Something went wrong. Try again.
An adversarial testing framework for OCaml HTTP/1.1 clients and servers
Something went wrong. Try again.
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707open Model
type request = { method_ : string; target : string; headers : (string * string) list; body : string;}
type state = { attempts : (string, int) Hashtbl.t; requests : (string, int * float * request) Hashtbl.t; clock_offsets_ms : (string, int) Hashtbl.t; mutex : Mutex.t;}
let max_request_body = 16 * 1024 * 1024let max_request_fields = 1000let max_request_buffer = max_request_body + (1024 * 1024)
let split_request_line line = match String.split_on_char ' ' line |> List.filter (fun s -> s <> "") with | method_ :: target :: _ -> (method_, target) | _ -> invalid_arg ("invalid request line: " ^ line)
let split_field line = match String.index_opt line ':' with | None -> invalid_arg ("invalid request field: " ^ 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 (name, value)
let header_values = Spec_field_sequence.values
let base64 text = let alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" in let length = String.length text in String.init ((length + 2) / 3 * 4) (fun index -> let group = index / 4 * 3 and column = index mod 4 in if (column = 2 && group + 1 >= length) || (column = 3 && group + 2 >= length) then '=' else let a = Char.code text.[group] in let b = if group + 1 < length then Char.code text.[group + 1] else 0 in let c = if group + 2 < length then Char.code text.[group + 2] else 0 in let value = match column with | 0 -> a lsr 2 | 1 -> ((a land 0x03) lsl 4) lor (b lsr 4) | 2 -> ((b land 0x0f) lsl 2) lor (c lsr 6) | _ -> c land 0x3f in alphabet.[value])
let validate_basic request username password = match header_values "authorization" request.headers with | [ authorization ] -> String.equal authorization ("Basic " ^ base64 (username ^ ":" ^ password)) | _ -> false
let split_auth_params text = let length = String.length text in let rec scan index quoted escaped start acc = if index = length then List.rev (String.sub text start (length - start) :: acc) else match (text.[index], quoted, escaped) with | _, true, true -> scan (index + 1) true false start acc | '\\', true, false -> scan (index + 1) true true start acc | '"', _, false -> scan (index + 1) (not quoted) false start acc | ',', false, false -> scan (index + 1) false false (index + 1) (String.sub text start (index - start) :: acc) | _ -> scan (index + 1) quoted false start acc in if length = 0 then [] else scan 0 false false 0 []
let unquote value = let value = String.trim value in let length = String.length value in if length >= 2 && value.[0] = '"' && value.[length - 1] = '"' then ( let buffer = Buffer.create (length - 2) in let rec copy index = if index < length - 1 then if value.[index] = '\\' && index + 1 < length - 1 then ( Buffer.add_char buffer value.[index + 1]; copy (index + 2)) else ( Buffer.add_char buffer value.[index]; copy (index + 1)) in copy 1; Buffer.contents buffer) else value
let digest_params authorization = let prefix = "Digest " in if not (String.starts_with ~prefix authorization) then None else let text = String.sub authorization (String.length prefix) (String.length authorization - String.length prefix) in let params = Hashtbl.create 16 in let add part = match String.index_opt part '=' with | None -> () | Some index -> let name = String.sub part 0 index |> String.trim |> String.lowercase_ascii in let value = String.sub part (index + 1) (String.length part - index - 1) |> unquote in Hashtbl.replace params name value in List.iter add (split_auth_params text); Some params
let digest_hex algorithm text = match algorithm with | Conformance.Md5 | Md5_sess -> Digestif.MD5.(digest_string text |> to_hex) | Sha256 | Sha256_sess -> Digestif.SHA256.(digest_string text |> to_hex)
let digest_algorithm_name = function | Conformance.Md5 -> "MD5" | Md5_sess -> "MD5-SESS" | Sha256 -> "SHA-256" | Sha256_sess -> "SHA-256-SESS"
let digest_session_algorithm = function | Conformance.Md5_sess | Sha256_sess -> true | Md5 | Sha256 -> false
let digest_qop_name = function | Conformance.Auth -> "auth" | Auth_int -> "auth-int"
let valid_nonce_count value = String.length value = 8 && String.for_all (function '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true | _ -> false) value
let validate_digest request (validation : Conformance.digest_validation) = match header_values "authorization" request.headers with | [ authorization ] -> ( match digest_params authorization with | None -> false | Some params -> ( let get name = Hashtbl.find_opt params name in let algorithm = digest_algorithm_name validation.algorithm in let same name expected = match get name with | Some actual -> String.equal actual expected | None -> false in let uri = get "uri" and response = get "response" in let algorithm_matches = match get "algorithm" with | None -> validation.algorithm = Md5 | Some actual -> String.equal (String.uppercase_ascii actual) algorithm in if (not (same "username" validation.username)) || (not (same "realm" validation.realm)) || (not (same "nonce" validation.nonce)) || not algorithm_matches then false else match (uri, response) with | Some uri, Some response -> let initial_ha1 = digest_hex validation.algorithm (validation.username ^ ":" ^ validation.realm ^ ":" ^ validation.password) in let expected_qop = digest_qop_name validation.qop in let expected = match (get "qop", get "nc", get "cnonce") with | Some qop, Some nc, Some cnonce when String.equal (String.lowercase_ascii qop) expected_qop && valid_nonce_count nc -> let ha1 = if digest_session_algorithm validation.algorithm then digest_hex validation.algorithm (String.concat ":" [ initial_ha1; validation.nonce; cnonce ]) else initial_ha1 in let a2 = match validation.qop with | Auth -> request.method_ ^ ":" ^ uri | Auth_int -> String.concat ":" [ request.method_; uri; digest_hex validation.algorithm request.body; ] in let ha2 = digest_hex validation.algorithm a2 in digest_hex validation.algorithm (String.concat ":" [ ha1; validation.nonce; nc; cnonce; qop; ha2 ]) | _ -> "" in String.equal uri request.target && String.equal (String.lowercase_ascii response) expected | _ -> false)) | _ -> false
let read_chunked_body reader = let body = Buffer.create 256 in let rec chunks () = let line = Eio.Buf_read.line reader in let size_text = match String.index_opt line ';' with | None -> line | Some index -> String.sub line 0 index in let size = int_of_string ("0x" ^ String.trim size_text) in if size < 0 || Buffer.length body + size > max_request_body then invalid_arg "workflow request body is too large"; if size = 0 then let rec trailers count = if count > max_request_fields then invalid_arg "too many request trailers" else if Eio.Buf_read.line reader <> "" then trailers (count + 1) in trailers 0 else ( Buffer.add_string body (Eio.Buf_read.take size reader); if Eio.Buf_read.line reader <> "" then invalid_arg "invalid chunk data terminator"; chunks ()) in chunks (); Buffer.contents body
let read_body reader headers = match header_values "transfer-encoding" headers with | _ :: _ as values -> ( let combined = String.concat "," values |> String.lowercase_ascii in let codings = String.split_on_char ',' combined |> List.map String.trim |> List.filter (fun value -> value <> "") in match List.rev codings with | "chunked" :: _ -> read_chunked_body reader | _ -> invalid_arg "unsupported workflow request transfer coding") | [] -> ( match header_values "content-length" headers with | [] -> "" | [ value ] -> let length = int_of_string value in if length < 0 || length > max_request_body then invalid_arg "workflow request body is too large"; Eio.Buf_read.take length reader | _ -> invalid_arg "multiple Content-Length request fields")
let read_request reader = let first = Eio.Buf_read.line reader in if first = "" then invalid_arg "empty request line"; let method_, target = split_request_line first in let rec fields count acc = if count > max_request_fields then invalid_arg "too many request fields" else match Eio.Buf_read.line reader with | "" -> List.rev acc | line -> fields (count + 1) (split_field line :: acc) in let headers = fields 0 [] in { method_; target; headers; body = read_body reader headers }
let strip_query target = match String.index_opt target '?' with | None -> target | Some i -> String.sub target 0 i
let normal_response ?(content_type = "text/plain; charset=utf-8") status body = Printf.sprintf "HTTP/1.1 %s\r\n\ Content-Type: %s\r\n\ Content-Length: %d\r\n\ Connection: close\r\n\ \r\n\ %s" status content_type (String.length body) body
let encode_json ?format schema value = match Json.encode ?format schema value with | Ok json -> json | Error message -> invalid_arg ("cannot encode JSON: " ^ message)
let manifest_json cases = encode_json ~format:Jsont.Indent Json.manifest cases ^ "\n"
let manifest_jsonl cases = cases |> List.map (encode_json Json.case) |> String.concat "\n" |> fun s -> s ^ "\n"
let field_manifest_json () = encode_json ~format:Jsont.Indent Conformance_json.field_manifest Conformance.field_cases ^ "\n"
let structured_field_manifest_json () = encode_json ~format:Jsont.Indent Conformance_json.structured_field_manifest Conformance.structured_field_cases ^ "\n"
let workflow_manifest_json () = encode_json ~format:Jsont.Indent Conformance_json.workflow_manifest Conformance.workflow_cases ^ "\n"
let cache_manifest_json () = encode_json ~format:Jsont.Indent Conformance_json.cache_manifest Conformance.cache_cases ^ "\n"
let index cases = Printf.sprintf "httnope %s\n\ %d raw response cases\n\ %d typed-field cases\n\ %d Structured Field cases\n\ %d user-agent cases\n\ %d cache cases\n\n\ GET /manifest.json\n\ GET /manifest.jsonl\n\ GET /typed-fields.json\n\ GET /structured-fields.json\n\ GET /user-agent.json\n\ GET /cache.json\n\ <METHOD> /case/<id>\n\ GET /workflow/cookie/<id>/<step>\n\ POST /workflow/advance/<case-id>/<milliseconds>\n\ GET /probe\n" Corpus.version (List.length cases) (List.length Conformance.field_cases) (List.length Conformance.structured_field_cases) (List.length Conformance.workflow_cases) (List.length Conformance.cache_cases)
let write_step ~clock ~delay_scale ~reader flow = function | Write s -> Eio.Flow.copy_string s flow | Write_fragments parts -> List.iter (fun part -> Eio.Flow.copy_string part flow; Eio.Fiber.yield ()) parts | Write_bytes s -> String.iter (fun c -> Eio.Flow.copy_string (String.make 1 c) flow; Eio.Fiber.yield ()) s | Pause_ms milliseconds -> Eio.Time.sleep clock (Float.of_int milliseconds /. 1000. *. delay_scale) | Read_request -> ignore (read_request reader)
let method_matches expected actual = String.equal (string_of_method expected) (String.uppercase_ascii actual)
let serve_case ~clock ~delay_scale ~reader flow (request : request) (case : case) = if not (method_matches case.method_ request.method_) then Eio.Flow.copy_string (normal_response "405 Method Not Allowed" (Printf.sprintf "case %s requires %s\n" case.id (string_of_method case.method_))) flow else List.iter (write_step ~clock ~delay_scale ~reader flow) case.script
let reason_phrase = function | 100 -> "Continue" | 102 -> "Processing" | 103 -> "Early Hints" | 200 -> "OK" | 201 -> "Created" | 204 -> "No Content" | 301 -> "Moved Permanently" | 302 -> "Found" | 303 -> "See Other" | 304 -> "Not Modified" | 307 -> "Temporary Redirect" | 308 -> "Permanent Redirect" | 401 -> "Unauthorized" | 408 -> "Request Timeout" | 412 -> "Precondition Failed" | 421 -> "Misdirected Request" | 425 -> "Too Early" | 429 -> "Too Many Requests" | 500 -> "Internal Server Error" | 502 -> "Bad Gateway" | 503 -> "Service Unavailable" | 504 -> "Gateway Timeout" | status when status >= 100 && status <= 599 -> "Httnope" | status -> invalid_arg (Printf.sprintf "unsupported workflow status %d" status)
let record_request state path now request = Mutex.protect state.mutex (fun () -> let attempt = Option.value ~default:0 (Hashtbl.find_opt state.attempts path) + 1 in let interval = Hashtbl.find_opt state.requests path |> Option.map (fun (_, previous, _) -> now -. previous) in Hashtbl.replace state.attempts path attempt; Hashtbl.replace state.requests path (attempt, now, request); (attempt, interval))
let response_for_attempt responses attempt = match List.nth_opt responses (attempt - 1) with | Some response -> response | None -> List.hd (List.rev responses)
let alternate_origin request = match header_values "host" request.headers with | host :: _ -> if String.starts_with ~prefix:"localhost" (String.lowercase_ascii host) then "http://127.0.0.1" ^ String.sub host 9 (String.length host - 9) else let port = match String.rindex_opt host ':' with | Some index -> String.sub host index (String.length host - index) | None -> "" in "http://localhost" ^ port | [] -> invalid_arg "workflow request has no Host field"
let expand_header request (name, value) = let marker = "${ALT_ORIGIN}" in let value = if String.starts_with ~prefix:marker value then alternate_origin request ^ String.sub value (String.length marker) (String.length value - String.length marker) else value in (name, value)
let add_headers buffer request headers = List.iter (fun header -> let name, value = expand_header request header in Buffer.add_string buffer name; Buffer.add_string buffer ": "; Buffer.add_string buffer value; Buffer.add_string buffer "\r\n") headers
let reset_workflow state case_id = match Conformance.workflow_endpoint_paths case_id with | None -> false | Some paths -> Mutex.protect state.mutex (fun () -> List.iter (fun path -> Hashtbl.remove state.attempts path; Hashtbl.remove state.requests path) paths; Hashtbl.remove state.clock_offsets_ms case_id); true
let advance_workflow_clock state case_id milliseconds = match Conformance.workflow_endpoint_paths case_id with | None -> false | Some _ -> Mutex.protect state.mutex (fun () -> let previous = Option.value ~default:0 (Hashtbl.find_opt state.clock_offsets_ms case_id) in Hashtbl.replace state.clock_offsets_ms case_id (previous + milliseconds)); true
let workflow_now state ~clock case_id = let offset_ms = Mutex.protect state.mutex (fun () -> Option.value ~default:0 (Hashtbl.find_opt state.clock_offsets_ms case_id)) in Eio.Time.now clock +. (Float.of_int offset_ms /. 1000.)
let parse_clock_advance target = let prefix = "/workflow/advance/" in if not (String.starts_with ~prefix target) then None else match String.rindex_opt target '/' with | Some slash when slash >= String.length prefix -> let case_id = String.sub target (String.length prefix) (slash - String.length prefix) in let milliseconds = String.sub target (slash + 1) (String.length target - slash - 1) |> int_of_string_opt in Option.map (fun milliseconds -> (case_id, milliseconds)) milliseconds | None | Some _ -> None
let workflow_response state ~now request (endpoint : Conformance.endpoint) = let attempt, interval = record_request state endpoint.path now request in let selected = response_for_attempt endpoint.responses attempt in let body = match selected.body with | Fixed body -> body | Echo_header name -> String.concat "\n" (header_values name request.headers) | Echo_request names -> Conformance.request_trace ~attempt ~method_:request.method_ ~target:request.target ~body:request.body ~headers:request.headers ~names | Echo_stored_request (path, names) -> ( match Mutex.protect state.mutex (fun () -> Hashtbl.find_opt state.requests path) with | Some (attempt, _, stored) -> Conformance.request_trace ~attempt ~method_:stored.method_ ~target:stored.target ~body:stored.body ~headers:stored.headers ~names | None -> "missing=" ^ path) | Check_attempt_delay seconds -> ( match interval with | Some elapsed when elapsed >= Float.of_int seconds -> "delay-ok" | Some elapsed -> Printf.sprintf "delay-too-short=%.6f" elapsed | None -> "delay-missing-previous-attempt") | Validate_basic (username, password) -> if validate_basic request username password then "auth-ok" else "auth-invalid" | Validate_digest validation -> if validate_digest request validation then "auth-ok" else "auth-invalid" in let buffer = Buffer.create (String.length body + 256) in List.iter (fun (status, headers) -> Buffer.add_string buffer (Printf.sprintf "HTTP/1.1 %d %s\r\n" status (reason_phrase status)); add_headers buffer request headers; Buffer.add_string buffer "\r\n") selected.informational; Buffer.add_string buffer (Printf.sprintf "HTTP/1.1 %d %s\r\n" selected.status (reason_phrase selected.status)); add_headers buffer request selected.headers; if selected.status <> 204 && selected.status <> 304 then ( Buffer.add_string buffer "Content-Type: text/plain\r\n"; Buffer.add_string buffer (Printf.sprintf "Content-Length: %d\r\n" (String.length body))); Buffer.add_string buffer "Connection: close\r\n\r\n"; if not (String.equal request.method_ "HEAD") then Buffer.add_string buffer body; Buffer.contents buffer
let route ~cases ~state ~clock ~delay_scale ~reader flow request = let target = strip_query request.target in if String.equal target "/" then Eio.Flow.copy_string (normal_response "200 OK" (index cases)) flow else if String.equal target "/healthz" then Eio.Flow.copy_string (normal_response "200 OK" "ok\n") flow else if String.equal target "/manifest.json" then Eio.Flow.copy_string (normal_response ~content_type:"application/json" "200 OK" (manifest_json cases)) flow else if String.equal target "/manifest.jsonl" then Eio.Flow.copy_string (normal_response ~content_type:"application/x-ndjson" "200 OK" (manifest_jsonl cases)) flow else if String.equal target "/typed-fields.json" then Eio.Flow.copy_string (normal_response ~content_type:"application/json" "200 OK" (field_manifest_json ())) flow else if String.equal target "/structured-fields.json" then Eio.Flow.copy_string (normal_response ~content_type:"application/json" "200 OK" (structured_field_manifest_json ())) flow else if String.equal target "/user-agent.json" then Eio.Flow.copy_string (normal_response ~content_type:"application/json" "200 OK" (workflow_manifest_json ())) flow else if String.equal target "/cache.json" then Eio.Flow.copy_string (normal_response ~content_type:"application/json" "200 OK" (cache_manifest_json ())) flow else if String.equal target "/probe" then Eio.Flow.copy_string "HTTP/1.1 201 Created\r\nContent-Length: 4\r\n\r\nnext" flow else if String.starts_with ~prefix:"/workflow/reset/" target then let prefix = "/workflow/reset/" in let case_id = String.sub target (String.length prefix) (String.length target - String.length prefix) in if reset_workflow state case_id then Eio.Flow.copy_string "HTTP/1.1 200 OK\r\n\ Cache-Control: no-store\r\n\ Content-Length: 6\r\n\ Connection: close\r\n\ \r\n\ reset\n" flow else Eio.Flow.copy_string (normal_response "404 Not Found" ("unknown workflow: " ^ case_id ^ "\n")) flow else if String.starts_with ~prefix:"/workflow/advance/" target then if not (String.equal request.method_ "POST") then Eio.Flow.copy_string (normal_response "405 Method Not Allowed" "") flow else match parse_clock_advance target with | Some (case_id, milliseconds) when milliseconds >= 0 -> if advance_workflow_clock state case_id milliseconds then Eio.Flow.copy_string (normal_response "200 OK" (Printf.sprintf "advanced=%d\n" milliseconds)) flow else Eio.Flow.copy_string (normal_response "404 Not Found" ("unknown workflow: " ^ case_id ^ "\n")) flow | Some _ | None -> Eio.Flow.copy_string (normal_response "400 Bad Request" "invalid clock advance\n") flow else let prefix = "/case/" in match Conformance.find_endpoint_case target with | Some (case_id, endpoint) -> Eio.Flow.copy_string (workflow_response state ~now:(workflow_now state ~clock case_id) request endpoint) flow | None -> if String.length target > String.length prefix && String.equal prefix (String.sub target 0 (String.length prefix)) then let id = String.sub target (String.length prefix) (String.length target - String.length prefix) in match List.find_opt (fun (case : Model.case) -> String.equal case.id id) cases with | Some case -> serve_case ~clock ~delay_scale ~reader flow request case | None -> Eio.Flow.copy_string (normal_response "404 Not Found" ("unknown case: " ^ id ^ "\n")) flow else Eio.Flow.copy_string (normal_response "404 Not Found" "not found\n") flow
let handle ~cases ~state ~clock ~delay_scale flow _client_addr = let reader = Eio.Buf_read.of_flow ~max_size:max_request_buffer flow in let request = read_request reader in route ~cases ~state ~clock ~delay_scale ~reader flow request
let run ~sw ~net ~clock ~addr ?(cases = Corpus.all) ?(delay_scale = 1.0) ?on_listening ?(on_error = fun _exn -> ()) () = if delay_scale < 0. then invalid_arg "delay_scale must not be negative"; let state = { attempts = Hashtbl.create 128; requests = Hashtbl.create 128; clock_offsets_ms = Hashtbl.create 32; mutex = Mutex.create (); } in let socket = Eio.Net.listen ~sw ~backlog:128 ~reuse_addr:true net addr in Option.iter (fun f -> f (Eio.Net.listening_addr socket)) on_listening; Eio.Net.run_server socket ~on_error (handle ~cases ~state ~clock ~delay_scale)