Something went wrong. Try again.
An adversarial testing framework for OCaml HTTP/1.1 clients and servers
Something went wrong. Try again.
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232open Server_profile
let lower = String.lowercase_asciilet header_values = Spec_field_sequence.values
let split_header line = match String.index_opt line ':' with | None -> Error (Printf.sprintf "malformed response field %S" line) | Some index -> let name = String.sub line 0 index in let value = String.sub line (index + 1) (String.length line - index - 1) |> String.trim in Ok (name, value)
let status_code line = match String.split_on_char ' ' line with | version :: code :: _ when String.starts_with ~prefix:"HTTP/" version -> ( match int_of_string_opt code with | Some code when code >= 100 && code <= 999 -> Ok code | _ -> Error (Printf.sprintf "invalid response status %S" line)) | _ -> Error (Printf.sprintf "invalid response status line %S" line)
let read_headers reader = let rec loop headers = match Eio.Buf_read.line reader with | "" -> Ok (List.rev headers) | line -> ( match split_header line with | Ok header -> loop (header :: headers) | Error _ as error -> error) in loop []
let chunk_size line = let value = match String.index_opt line ';' with | None -> line | Some index -> String.sub line 0 index in try let size = Int64.of_string ("0x" ^ value) in if size < 0L || size > Int64.of_int max_int then Error "chunk size overflow" else Ok (Int64.to_int size) with Failure _ -> Error (Printf.sprintf "invalid chunk size %S" line)
let read_chunked reader = let body = Buffer.create 128 in let rec chunks () = let line = Eio.Buf_read.line reader in match chunk_size line with | Error _ as error -> error | Ok 0 -> trailers () | Ok size -> Buffer.add_string body (Eio.Buf_read.take size reader); if Eio.Buf_read.line reader <> "" then Error "missing chunk-data CRLF" else chunks () and trailers () = match Eio.Buf_read.line reader with | "" -> Ok (Buffer.contents body) | _ -> trailers () in chunks ()
let content_length headers = match header_values "content-length" headers with | [] -> Ok None | first :: rest when List.for_all (String.equal first) rest -> ( match int_of_string_opt first with | Some length when length >= 0 -> Ok (Some length) | _ -> Error (Printf.sprintf "invalid response Content-Length %S" first)) | _ -> Error "conflicting response Content-Length fields"
let has_chunked headers = header_values "transfer-encoding" headers |> List.concat_map (String.split_on_char ',') |> List.map (fun value -> String.trim value |> lower) |> List.exists (String.equal "chunked")
let bodyless ~head status = head || (status >= 100 && status < 200) || List.mem status [ 204; 205; 304 ]
let read_response ~head reader = let line = Eio.Buf_read.line reader in match status_code line with | Error _ as error -> error | Ok status -> ( match read_headers reader with | Error _ as error -> error | Ok headers -> ( if bodyless ~head status then Ok { status; headers; body = "" } else if has_chunked headers then Result.map (fun body -> { status; headers; body }) (read_chunked reader) else match content_length headers with | Error _ as error -> error | Ok (Some length) -> Ok { status; headers; body = Eio.Buf_read.take length reader } | Ok None -> Ok { status; headers; body = "" }))
let run_script ~clock flow script = List.iter (function | Write bytes -> Eio.Flow.copy_string bytes flow | Write_fragments parts -> List.iter (fun part -> Eio.Flow.copy_string part flow; Eio.Fiber.yield ()) parts | Write_bytes bytes -> String.iter (fun character -> Eio.Flow.copy_string (String.make 1 character) flow; Eio.Fiber.yield ()) bytes | Pause_ms milliseconds -> Eio.Time.sleep clock (Float.of_int milliseconds /. 1000.) | Shutdown_send -> Eio.Flow.shutdown flow `Send) script
let exchange ~net ~clock ~addr ~timeout ~head ~response_count script = match Eio.Time.with_timeout clock timeout (fun () -> Ok (try Eio.Switch.run @@ fun sw -> let flow = Eio.Net.connect ~sw net addr in let reader = Eio.Buf_read.of_flow ~max_size:(4 * 1024 * 1024) flow in run_script ~clock flow script; let rec responses remaining seen = if remaining = 0 then Responses (List.rev seen) else match read_response ~head reader with | Ok response -> responses (remaining - 1) (response :: seen) | Error message -> Protocol_error message | exception End_of_file -> if seen = [] then Closed else Responses (List.rev seen) in responses response_count [] with | Eio.Io (Eio.Net.E (Connection_reset _), _) as exn -> Reset (Printexc.to_string exn) | Eio.Io _ as exn -> Reset (Printexc.to_string exn) | exn -> Connect_error (Printexc.to_string exn))) with | Ok outcome -> outcome | Error `Timeout -> Timeout
let control_request ~net ~clock ~addr meth path = let wire = Printf.sprintf "%s %s HTTP/1.1\r\n\ Host: localhost\r\n\ Content-Length: 0\r\n\ Connection: close\r\n\ \r\n" meth path in match exchange ~net ~clock ~addr ~timeout:1. ~head:false ~response_count:1 [ Write wire ] with | Responses [ response ] when response.status = 200 -> Ok response.body | Responses [ response ] -> Error (Printf.sprintf "%s returned %d" path response.status) | outcome -> Error (match outcome with | Closed -> path ^ " closed" | Reset message -> path ^ " reset: " ^ message | Timeout -> path ^ " timed out" | Protocol_error message -> path ^ " protocol error: " ^ message | Connect_error message -> path ^ " connect error: " ^ message | Responses responses -> Printf.sprintf "%s returned %d responses" path (List.length responses))
let reset_token ~net ~clock ~addr token = control_request ~net ~clock ~addr "POST" (Server_fixture.prefix ^ "/reset/" ^ token) |> Result.map (fun _ -> ())
let probe_token ~net ~clock ~addr token = match control_request ~net ~clock ~addr "GET" (Server_fixture.prefix ^ "/count/" ^ token) with | Error message -> (None, Some message) | Ok body -> ( match int_of_string_opt (String.trim body) with | Some count -> (Some count, None) | None -> (None, Some (Printf.sprintf "count for %s is %S" token body)))
let run_case ~net ~clock ~addr ?(timeout = 1.) case = let reset_errors = List.filter_map (fun token -> match reset_token ~net ~clock ~addr token with | Ok () -> None | Error message -> Some message) case.probe_tokens in let started = Eio.Time.now clock in let wire = exchange ~net ~clock ~addr ~timeout ~head:case.head_response ~response_count:case.response_count case.script in let effects, probe_errors = List.fold_left (fun (effects, errors) token -> let count, error = probe_token ~net ~clock ~addr token in ( (token, count) :: effects, match error with None -> errors | Some error -> error :: errors )) ([], reset_errors) case.probe_tokens in { case_id = case.id; elapsed_ms = (Eio.Time.now clock -. started) *. 1000.; wire; effects = List.rev effects; probe_errors = List.rev probe_errors; }
let run ~net ~clock ~addr ?timeout cases = List.map (run_case ~net ~clock ~addr ?timeout) cases