let 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 "&lt;"
      | '>' -> add buffer "&gt;"
      | '"' -> add buffer "&quot;"
      | '\'' -> add buffer "&#39;"
      | 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 " " arguments
let 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;
                   ])))