Something went wrong. Try again.
An adversarial testing framework for OCaml HTTP/1.1 clients and servers
Something went wrong. Try again.
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475let add = Buffer.add_string
let hex bytes = let digits = "0123456789abcdef" in let result = Bytes.create (String.length bytes * 2) in String.iteri (fun index character -> let value = Char.code character in Bytes.set result (index * 2) digits.[value lsr 4]; Bytes.set result ((index * 2) + 1) digits.[value land 0x0f]) bytes; Bytes.unsafe_to_string result
let text bytes = if String.is_valid_utf_8 bytes then bytes else "hex:" ^ hex bytes
let escape buffer value = String.iter (function | '&' -> add buffer "&" | '<' -> add buffer "<" | '>' -> add buffer ">" | '"' -> add buffer """ | '\'' -> add buffer "'" | character -> Buffer.add_char buffer character) (text value)
let process_status = function | Report.Exited code -> Printf.sprintf "exited %d" code | Report.Signaled signal -> Printf.sprintf "signal %d" signal | Report.Timed_out -> "timed out" | Report.Spawn_error message -> "spawn error: " ^ message
let server_process_status = function | Server_profile.Stopped_by_harness -> "stopped by harness" | Server_profile.Exited code -> Printf.sprintf "exited %d" code | Server_profile.Signaled signal -> Printf.sprintf "signal %d" signal | Server_profile.Timed_out -> "stop timed out" | Server_profile.Spawn_error message -> "spawn error: " ^ message | Server_profile.Readiness_error message -> "readiness error: " ^ message
let duration milliseconds = if milliseconds < 1000. then Printf.sprintf "%.0f ms" milliseconds else Printf.sprintf "%.2f s" (milliseconds /. 1000.)
let command = function [] -> "—" | arguments -> String.concat " " argumentslet requirement requirement = Model.string_of_requirement requirement
let references buffer references = List.iteri (fun index reference -> if index > 0 then add buffer " "; add buffer "<a href=\""; escape buffer (Provenance.url reference); add buffer "\">"; escape buffer (Provenance.label reference); add buffer "</a>") references
let stylesheet = {|:root{color-scheme:light dark;--bg:#f6f7f8;--panel:#fff;--text:#202124;--muted:#687078;--line:#dfe3e6;--good:#177245;--bad:#b3261e;--accent:#295ea7;--code:#f0f2f4}@media(prefers-color-scheme:dark){:root{--bg:#141618;--panel:#1d2023;--text:#e8eaed;--muted:#a9b0b7;--line:#363b40;--good:#70d6a3;--bad:#ff8983;--accent:#8ab4f8;--code:#272b2f}}*{box-sizing:border-box}body{margin:0;background:var(--bg);color:var(--text);font:14px/1.45 system-ui,-apple-system,BlinkMacSystemFont,"Segoe UI",sans-serif}main{max-width:1120px;margin:auto;padding:28px 20px 48px}header{display:flex;align-items:flex-start;justify-content:space-between;gap:18px;margin-bottom:18px}h1{font-size:22px;line-height:1.2;margin:0 0 5px}h2{font-size:15px;margin:24px 0 8px}h3{font-size:11px;text-transform:uppercase;letter-spacing:.04em;color:var(--muted);margin:0}.sub,.muted,small{color:var(--muted)}.state{border:1px solid currentColor;border-radius:999px;padding:4px 10px;font-weight:700;white-space:nowrap}.clean{color:var(--good)}.dirty{color:var(--bad)}.meta{display:flex;flex-wrap:wrap;gap:5px 16px;color:var(--muted);margin:0 0 16px}.stats{display:grid;grid-template-columns:repeat(auto-fit,minmax(105px,1fr));gap:8px}.stat{background:var(--panel);border:1px solid var(--line);border-radius:7px;padding:9px 11px}.stat b{display:block;font-size:20px;line-height:1.1}.stat span{color:var(--muted);font-size:12px}table{width:100%;border-collapse:collapse;background:var(--panel);border:1px solid var(--line);font-size:13px}th,td{text-align:left;vertical-align:top;padding:8px 9px;border-bottom:1px solid var(--line)}th{color:var(--muted);font-size:11px;text-transform:uppercase;letter-spacing:.04em}tr:last-child td{border-bottom:0}td:first-child{width:37%}code,pre{font:12px/1.45 ui-monospace,SFMono-Regular,Consolas,monospace}code{background:var(--code);border-radius:3px;padding:1px 4px;overflow-wrap:anywhere}.case-title{display:block;margin-top:3px}.req{display:inline-block;text-transform:uppercase;font-size:10px;font-weight:700;color:var(--muted)}a{color:var(--accent);text-decoration:none}a:hover{text-decoration:underline}.refs{white-space:nowrap}.observed{display:block;color:var(--muted);margin-top:3px}details{background:var(--panel);border:1px solid var(--line);border-radius:7px;padding:8px 11px;margin-top:8px}summary{cursor:pointer;font-weight:600}dl{display:grid;grid-template-columns:max-content 1fr;gap:4px 12px;margin:10px 0}dt{color:var(--muted)}dd{margin:0;overflow-wrap:anywhere}pre{background:var(--code);padding:9px;border-radius:5px;white-space:pre-wrap;overflow-wrap:anywhere;max-height:300px;overflow:auto}.detail-row>td{width:auto;padding:0 9px 9px}.case-detail{margin:0}.description{margin:8px 0 3px}.rationale{color:var(--muted);margin:0 0 9px}.trace-grid{display:grid;grid-template-columns:repeat(3,minmax(0,1fr));gap:8px}.trace-grid pre{margin:4px 0 0;max-height:360px}.empty{padding:15px;background:var(--panel);border:1px solid var(--line);border-radius:7px;color:var(--muted)}footer{color:var(--muted);font-size:11px;margin-top:22px}@media(max-width:680px){main{padding:18px 10px 36px}header{display:block}.state{display:inline-block;margin-top:10px}th:nth-child(2),td:nth-child(2){display:none}td:first-child{width:46%}.trace-grid{grid-template-columns:1fr}}|}
let page_start buffer ~title ~kind ~label ~clean = add buffer "<!doctype html><html lang=\"en\"><head><meta charset=\"utf-8\">"; add buffer "<meta name=\"viewport\" content=\"width=device-width,initial-scale=1\">"; add buffer "<title>"; escape buffer title; add buffer "</title><style>"; add buffer stylesheet; add buffer "</style></head><body><main><header><div><h1>"; escape buffer title; add buffer "</h1><div class=\"sub\">"; escape buffer kind; add buffer " · "; escape buffer label; add buffer "</div></div><span class=\"state "; add buffer (if clean then "clean\">PASS" else "dirty\">FAIL"); add buffer "</span></header>"
let page_end buffer = add buffer "<footer>Generated by httnope from a typed v1 execution \ report.</footer></main></body></html>"; Buffer.contents buffer
let meta buffer values = add buffer "<div class=\"meta\">"; List.iter (fun (name, value) -> add buffer "<span>"; escape buffer name; add buffer ": <b>"; escape buffer value; add buffer "</b></span>") values; add buffer "</div>"
let stats buffer values = add buffer "<div class=\"stats\">"; List.iter (fun (label, value) -> add buffer "<div class=\"stat\"><b>"; escape buffer value; add buffer "</b><span>"; escape buffer label; add buffer "</span></div>") values; add buffer "</div>"
let section_start buffer title = add buffer "<h2>"; escape buffer title; add buffer "</h2>"
let table_start buffer = add buffer "<table><thead><tr><th>Case</th><th>Requirement</th><th>Result</th><th>References</th></tr></thead><tbody>"
let table_end buffer = add buffer "</tbody></table>"
let case_row buffer ~id ~title ~requirement:requirement_ ~reason ~observed ~reference_list = add buffer "<tr><td><code>"; escape buffer id; add buffer "</code><span class=\"case-title\">"; escape buffer title; add buffer "</span></td><td><span class=\"req\">"; escape buffer (requirement requirement_); add buffer "</span></td><td>"; escape buffer reason; if observed <> "" then begin add buffer "<span class=\"observed\">"; escape buffer observed; add buffer "</span>" end; add buffer "</td><td class=\"refs\">"; references buffer reference_list; add buffer "</td></tr>"
let diagnostic_panel buffer title contents = add buffer "<section><h3>"; escape buffer title; add buffer "</h3><pre>"; escape buffer contents; add buffer "</pre></section>"
let failure_detail buffer (detail : Html_detail.t) = add buffer "<tr class=\"detail-row\"><td colspan=\"4\"><details \ class=\"case-detail\"><summary>Show stimulus, expectation, and \ observation</summary><p class=\"description\">"; escape buffer detail.description; add buffer "</p><p class=\"rationale\">"; escape buffer detail.rationale; add buffer "</p><div class=\"trace-grid\">"; diagnostic_panel buffer "Stimulus" detail.stimulus; diagnostic_panel buffer "Expected" detail.expected; diagnostic_panel buffer "Observed" detail.observed; add buffer "</div></details></td></tr>"
let case_info_row buffer (case : Report.case_info) reason = case_row buffer ~id:case.case_id ~title:case.title ~requirement:case.requirement ~reason ~observed:"" ~reference_list:case.references
let conformance_case_row buffer (case : Conformance.case_info) reason = case_row buffer ~id:case.id ~title:case.title ~requirement:case.rule.strength ~reason ~observed:"" ~reference_list:case.references
let raw_observation (observation : Model.observation) = match observation.outcome with | Model.Observed_responses responses -> let statuses = List.map (fun (response : Model.observed_response) -> string_of_int response.status) responses in "response " ^ String.concat ", " statuses | Model.Observed_error message -> "error: " ^ message | Model.Observed_timeout None -> "timeout" | Model.Observed_timeout (Some message) -> "timeout: " ^ message | Model.Observed_crash message -> "crash: " ^ message
let conformance_observation (observation : Conformance.observation) = match observation.outcome with | Conformance.Observed_values values -> Printf.sprintf "%d value(s)" (List.length values) | Conformance.Observed_parsed _ -> "parsed" | Conformance.Observed_responses responses -> Printf.sprintf "%d structured response(s)" (List.length responses) | Conformance.Observed_rejected None -> "rejected" | Conformance.Observed_rejected (Some message) -> "rejected: " ^ message | Conformance.Observed_unsupported None -> "unsupported" | Conformance.Observed_unsupported (Some message) -> "unsupported: " ^ message | Conformance.Observed_error message -> "error: " ^ message | Conformance.Observed_timeout None -> "timeout" | Conformance.Observed_timeout (Some message) -> "timeout: " ^ message | Conformance.Observed_crash message -> "crash: " ^ message
let server_wire = function | Server_profile.Responses responses -> "response " ^ String.concat ", " (List.map (fun (response : Server_profile.response) -> string_of_int response.status) responses) | Server_profile.Closed -> "connection closed" | Server_profile.Reset message -> "connection reset: " ^ message | Server_profile.Timeout -> "timeout" | Server_profile.Protocol_error message -> "protocol error: " ^ message | Server_profile.Connect_error message -> "connect error: " ^ message
let server_observation (observation : Server_profile.observation) = let effects = observation.effects |> List.map (fun (token, count) -> token ^ "=" ^ match count with None -> "?" | Some count -> string_of_int count) |> String.concat ", " in server_wire observation.wire ^ if effects = "" then "" else "; " ^ effects
let process_details buffer ~command:arguments ~endpoint ~stderr ?(stdout = "") () = add buffer "<details><summary>Process details</summary><dl><dt>Command</dt><dd><code>"; escape buffer (command arguments); add buffer "</code></dd><dt>Endpoint</dt><dd>"; escape buffer endpoint; add buffer "</dd></dl>"; if stdout <> "" then begin add buffer "<b>stdout</b><pre>"; escape buffer stdout; add buffer "</pre>" end; if stderr <> "" then begin add buffer "<b>stderr</b><pre>"; escape buffer stderr; add buffer "</pre>" end; add buffer "</details>"
let empty buffer message = add buffer "<div class=\"empty\">"; escape buffer message; add buffer "</div>"
let invalid_observations buffer observations = if observations <> [] then begin section_start buffer (Printf.sprintf "Invalid observations (%d)" (List.length observations)); add buffer "<table><thead><tr><th>Input</th><th>Line</th><th>Case</th><th>Error</th></tr></thead><tbody>"; List.iter (fun (line, case_id, input, error) -> add buffer "<tr><td><code>"; escape buffer input; add buffer "</code></td><td>"; escape buffer (match line with None -> "—" | Some line -> string_of_int line); add buffer "</td><td><code>"; escape buffer (Option.value ~default:"—" case_id); add buffer "</code></td><td>"; escape buffer error; add buffer "</td></tr>") observations; table_end buffer end
let report (report : Report.t) = let buffer = Buffer.create 8192 in page_start buffer ~title:(report.client ^ " HTTP/1 report") ~kind:"response-client" ~label:report.corpus_version ~clean:(Report.is_clean report); meta buffer ([ ("process", process_status report.process_status); ("duration", duration report.duration_ms); ("origin", report.base_url); ] @ match report.selected_tags with | [] -> [] | tags -> [ ("selected tags", String.concat ", " tags) ]); let summary = report.summary in stats buffer [ ("cases", string_of_int summary.case_count); ("observed", string_of_int summary.observed); ("passed", string_of_int summary.passed); ("failed", string_of_int summary.failed); ("missing", string_of_int summary.missing); ("invalid", string_of_int summary.invalid); ("crashes", string_of_int summary.crashes); ]; process_details buffer ~command:report.command ~endpoint:report.base_url ~stderr:report.stderr (); section_start buffer (Printf.sprintf "Failures (%d)" summary.failed); if report.failures = [] then empty buffer "No conformance failures." else begin table_start buffer; List.iter (fun (failure : Report.failure) -> let case = failure.case in case_row buffer ~id:case.case_id ~title:case.title ~requirement:case.requirement ~reason:failure.reason ~observed:(raw_observation failure.observation) ~reference_list:case.references; failure_detail buffer (Html_detail.response_client ~corpus_version:report.corpus_version failure)) report.failures; table_end buffer end; if report.missing_cases <> [] then begin section_start buffer (Printf.sprintf "Missing (%d)" (List.length report.missing_cases)); table_start buffer; List.iter (fun case -> case_info_row buffer case "not observed") report.missing_cases; table_end buffer end; invalid_observations buffer (List.map (fun (invalid : Report.invalid_observation) -> (invalid.line, invalid.case_id, invalid.input, invalid.error)) report.invalid_observations); page_end buffer
let conformance_report (report : Conformance.report) = let buffer = Buffer.create 8192 in let profile = Conformance.string_of_profile report.profile in page_start buffer ~title:(report.client ^ " " ^ profile) ~kind:"independent profile" ~label:report.corpus_version ~clean:(Conformance.report_is_clean report); meta buffer ([ ("process", process_status report.process_status); ("duration", duration report.duration_ms); ("origin", report.base_url); ] @ match report.selected_tags with | [] -> [] | tags -> [ ("selected tags", String.concat ", " tags) ]); let summary = report.summary in stats buffer [ ("cases", string_of_int summary.case_count); ("observed", string_of_int summary.observed); ("supported", string_of_int summary.supported); ("passed", string_of_int summary.passed); ("failed", string_of_int summary.failed); ("unsupported", string_of_int summary.unsupported); ("missing", string_of_int summary.missing); ("invalid", string_of_int summary.invalid); ("crashes", string_of_int summary.crashes); ]; process_details buffer ~command:report.command ~endpoint:report.base_url ~stderr:report.stderr (); section_start buffer (Printf.sprintf "Failures (%d)" summary.failed); if report.failures = [] then empty buffer "No conformance failures." else begin table_start buffer; List.iter (fun (failure : Conformance.failure) -> let case = failure.case in case_row buffer ~id:case.id ~title:case.title ~requirement:case.rule.strength ~reason:failure.reason ~observed:(conformance_observation failure.observation) ~reference_list:case.references; failure_detail buffer (Html_detail.conformance ~corpus_version:report.corpus_version report.profile failure)) report.failures; table_end buffer end; if report.unsupported_cases <> [] then begin section_start buffer (Printf.sprintf "Unsupported (%d)" (List.length report.unsupported_cases)); table_start buffer; List.iter (fun case -> conformance_case_row buffer case "unsupported") report.unsupported_cases; table_end buffer end; if report.missing_cases <> [] then begin section_start buffer (Printf.sprintf "Missing (%d)" (List.length report.missing_cases)); table_start buffer; List.iter (fun case -> conformance_case_row buffer case "not observed") report.missing_cases; table_end buffer end; invalid_observations buffer (List.map (fun (invalid : Conformance.invalid_observation) -> (invalid.line, invalid.case_id, invalid.input, invalid.error)) report.invalid_observations); page_end buffer
let server_report (report : Server_profile.report) = let buffer = Buffer.create 8192 in page_start buffer ~title:(report.server ^ " HTTP/1 server report") ~kind:"request-server" ~label:report.corpus_version ~clean:(Server_profile.report_is_clean report); meta buffer ([ ("process", server_process_status report.process_status); ("duration", duration report.duration_ms); ("origin", report.origin); ] @ match report.selected_tags with | [] -> [] | tags -> [ ("selected tags", String.concat ", " tags) ]); let summary = report.summary in stats buffer [ ("cases", string_of_int summary.case_count); ("observed", string_of_int summary.observed); ("passed", string_of_int summary.passed); ("failed", string_of_int summary.failed); ("probe errors", string_of_int summary.probe_errors); ]; process_details buffer ~command:report.command ~endpoint:report.origin ~stdout:report.stdout ~stderr:report.stderr (); section_start buffer (Printf.sprintf "Failures (%d)" summary.failed); if report.failures = [] then empty buffer "No conformance failures." else begin table_start buffer; List.iter (fun (failure : Server_profile.failure) -> let case = failure.case in case_row buffer ~id:case.id ~title:case.title ~requirement:case.rule.strength ~reason:failure.reason ~observed:(server_observation failure.observation) ~reference_list:case.references; failure_detail buffer (Html_detail.request_server failure)) report.failures; table_end buffer end; page_end buffer
let of_json ?file json = match Json.decode ?file Server_profile_json.report json with | Ok report -> Ok (server_report report) | Error server_error -> ( match Json.decode ?file Conformance_json.report json with | Ok report -> Ok (conformance_report report) | Error conformance_error -> ( match Json.decode ?file Json.report json with | Ok raw -> Ok (report raw) | Error raw_error -> Error (String.concat "\n" [ "not a recognized httnope v1 execution report"; "request-server: " ^ server_error; "profile: " ^ conformance_error; "response-client: " ^ raw_error; ])))