(** Response types and helper functions.

    This module provides the canonical HTTP response type used throughout HCS.
    It works with both HTTP/1.1 and HTTP/2 protocols. *)

(** {1 Pre-built Responses}

    Pre-built responses for zero-allocation hot paths. Create once at startup,
    respond many times without allocation. *)
module Prebuilt = struct
  type t = {
    status : H1.Status.t;
    headers : H1.Headers.t;
    body : Bigstringaf.t;
    cached_h1_response : H1.Response.t Atomic.t;
    cached_second : int Atomic.t;
  }

  let create ~status ?(headers = []) body_str =
    let body =
      Bigstringaf.of_string ~off:0 ~len:(String.length body_str) body_str
    in
    let body_len = Bigstringaf.length body in
    let all_headers = ("content-length", string_of_int body_len) :: headers in
    let h1_headers = H1.Headers.of_list all_headers in
    let now = int_of_float (Unix.gettimeofday ()) in
    let headers_with_date =
      H1.Headers.add h1_headers "date" (Date_cache.get ())
    in
    let cached_resp = H1.Response.create ~headers:headers_with_date status in
    {
      status;
      headers = h1_headers;
      body;
      cached_h1_response = Atomic.make cached_resp;
      cached_second = Atomic.make now;
    }

  let create_bigstring ~status ?(headers = []) body =
    let body_len = Bigstringaf.length body in
    let all_headers = ("content-length", string_of_int body_len) :: headers in
    let h1_headers = H1.Headers.of_list all_headers in
    let now = int_of_float (Unix.gettimeofday ()) in
    let headers_with_date =
      H1.Headers.add h1_headers "date" (Date_cache.get ())
    in
    let cached_resp = H1.Response.create ~headers:headers_with_date status in
    {
      status;
      headers = h1_headers;
      body;
      cached_h1_response = Atomic.make cached_resp;
      cached_second = Atomic.make now;
    }

  let[@inline] get_cached_h1_response t =
    let now = int_of_float (Unix.gettimeofday ()) in
    let last = Atomic.get t.cached_second in
    if now <> last then begin
      let headers = H1.Headers.add t.headers "date" (Date_cache.get ()) in
      let resp = H1.Response.create ~headers t.status in
      Atomic.set t.cached_h1_response resp;
      Atomic.set t.cached_second now
    end;
    Atomic.get t.cached_h1_response

  let[@inline] respond_h1 reqd t =
    let response = get_cached_h1_response t in
    H1.Reqd.respond_with_bigstring reqd response t.body

  let[@inline] respond_h2 reqd t =
    let result = ref [] in
    H1.Headers.iter
      ~f:(fun name value -> result := (name, value) :: !result)
      t.headers;
    let h2_headers = H2.Headers.of_list (List.rev !result) in
    let h2_status = (t.status :> H2.Status.t) in
    let response = H2.Response.create ~headers:h2_headers h2_status in
    H2.Reqd.respond_with_bigstring reqd response t.body
end

(** {1 Types} *)

type body =
  | Empty
  | String of string
  | Cstruct of Cstruct.t
  | Bigstring of Bigstringaf.t
  | Stream of { content_length : int64 option; next : unit -> Cstruct.t option }
  | Prebuilt_body of Prebuilt.t

type t = { status : H1.Status.t; headers : (string * string) list; body : body }

(** {1 Basic Constructors} *)

let make ?(status = `OK) ?(headers = []) body_str : t =
  { status; headers; body = String body_str }

let empty ?(status = `No_content) ?(headers = []) () : t =
  { status; headers; body = Empty }

(** {1 Status shortcuts - 2xx Success} *)

let ok ?(headers = []) body : t = { status = `OK; headers; body = String body }

let created ?(headers = []) ?location body : t =
  let headers =
    match location with
    | Some loc -> ("Location", loc) :: headers
    | None -> headers
  in
  { status = `Created; headers; body = String body }

let accepted ?(headers = []) body : t =
  { status = `Accepted; headers; body = String body }

let no_content ?(headers = []) () : t =
  { status = `No_content; headers; body = Empty }

(** {1 Status shortcuts - 3xx Redirection} *)

let redirect ?(permanent = false) ?(headers = []) location : t =
  let status = if permanent then `Moved_permanently else `Found in
  { status; headers = ("Location", location) :: headers; body = Empty }

let moved_permanently ?(headers = []) location : t =
  redirect ~permanent:true ~headers location

let found ?(headers = []) location : t =
  redirect ~permanent:false ~headers location

let see_other ?(headers = []) location : t =
  {
    status = `See_other;
    headers = ("Location", location) :: headers;
    body = Empty;
  }

let temporary_redirect ?(headers = []) location : t =
  {
    status = `Temporary_redirect;
    headers = ("Location", location) :: headers;
    body = Empty;
  }

let not_modified ?(headers = []) () : t =
  { status = `Not_modified; headers; body = Empty }

(** {1 Status shortcuts - 4xx Client Errors} *)

let bad_request ?(headers = []) ?(body = "Bad Request") () : t =
  { status = `Bad_request; headers; body = String body }

let unauthorized ?(headers = []) ?www_authenticate () : t =
  let headers =
    match www_authenticate with
    | Some auth -> ("WWW-Authenticate", auth) :: headers
    | None -> headers
  in
  { status = `Unauthorized; headers; body = String "Unauthorized" }

let forbidden ?(headers = []) ?(body = "Forbidden") () : t =
  { status = `Forbidden; headers; body = String body }

let not_found ?(headers = []) ?(body = "Not Found") () : t =
  { status = `Not_found; headers; body = String body }

let method_not_allowed ?(headers = []) ~allowed () : t =
  let allow_header =
    String.concat ", " (List.map H1.Method.to_string allowed)
  in
  {
    status = `Method_not_allowed;
    headers = ("Allow", allow_header) :: headers;
    body = String "Method Not Allowed";
  }

let conflict ?(headers = []) ?(body = "Conflict") () : t =
  { status = `Conflict; headers; body = String body }

let gone ?(headers = []) ?(body = "Gone") () : t =
  { status = `Gone; headers; body = String body }

let unprocessable_entity ?(headers = []) ?(body = "Unprocessable Entity") () : t
    =
  { status = `Code 422; headers; body = String body }

let too_many_requests ?(headers = []) ?retry_after () : t =
  let headers =
    match retry_after with
    | Some secs -> ("Retry-After", string_of_int secs) :: headers
    | None -> headers
  in
  { status = `Code 429; headers; body = String "Too Many Requests" }

(** {1 Status shortcuts - 5xx Server Errors} *)

let internal_error ?(headers = []) ?(body = "Internal Server Error") () : t =
  { status = `Internal_server_error; headers; body = String body }

let not_implemented ?(headers = []) ?(body = "Not Implemented") () : t =
  { status = `Not_implemented; headers; body = String body }

let bad_gateway ?(headers = []) ?(body = "Bad Gateway") () : t =
  { status = `Bad_gateway; headers; body = String body }

let service_unavailable ?(headers = []) ?retry_after () : t =
  let headers =
    match retry_after with
    | Some secs -> ("Retry-After", string_of_int secs) :: headers
    | None -> headers
  in
  {
    status = `Service_unavailable;
    headers;
    body = String "Service Unavailable";
  }

let gateway_timeout ?(headers = []) ?(body = "Gateway Timeout") () : t =
  { status = `Gateway_timeout; headers; body = String body }

(** {1 Content-Type helpers} *)

let text ?(status = `OK) body : t =
  {
    status;
    headers = [ ("Content-Type", "text/plain; charset=utf-8") ];
    body = String body;
  }

let html ?(status = `OK) body : t =
  {
    status;
    headers = [ ("Content-Type", "text/html; charset=utf-8") ];
    body = String body;
  }

let json ?(status = `OK) body : t =
  {
    status;
    headers = [ ("Content-Type", "application/json; charset=utf-8") ];
    body = String body;
  }

let xml ?(status = `OK) body : t =
  {
    status;
    headers = [ ("Content-Type", "application/xml; charset=utf-8") ];
    body = String body;
  }

(** {1 Streaming and special responses} *)

let stream ?(status = `OK) ?(headers = []) ?content_length next : t =
  { status; headers; body = Stream { content_length; next } }

let bigstring ?(status = `OK) ?(headers = []) bstr : t =
  { status; headers; body = Bigstring bstr }

let cstruct ?(status = `OK) ?(headers = []) cs : t =
  { status; headers; body = Cstruct cs }

let prebuilt p : t =
  { status = p.Prebuilt.status; headers = []; body = Prebuilt_body p }

(** {1 Response modifiers} *)

let with_header name value (resp : t) : t =
  { resp with headers = (name, value) :: resp.headers }

let with_headers headers (resp : t) : t =
  { resp with headers = headers @ resp.headers }

let with_body body_str (resp : t) : t = { resp with body = String body_str }
let with_body_raw body (resp : t) : t = { resp with body }
let with_status status (resp : t) : t = { resp with status }

let with_content_type content_type resp =
  with_header "Content-Type" content_type resp

let with_cache_control directive resp =
  with_header "Cache-Control" directive resp

let with_no_cache resp =
  resp
  |> with_header "Cache-Control" "no-store, no-cache, must-revalidate"
  |> with_header "Pragma" "no-cache"

let with_cors ?(origin = "*") ?(methods = "GET, POST, PUT, DELETE, OPTIONS")
    ?(headers = "Content-Type, Authorization") resp =
  resp
  |> with_header "Access-Control-Allow-Origin" origin
  |> with_header "Access-Control-Allow-Methods" methods
  |> with_header "Access-Control-Allow-Headers" headers

(** {1 Cookie helpers} *)

let with_cookie ?(path = "/") ?(http_only = true) ?(secure = false)
    ?(same_site = "Lax") ?max_age name value resp =
  let buf = Buffer.create 128 in
  Buffer.add_string buf name;
  Buffer.add_char buf '=';
  Buffer.add_string buf value;
  Buffer.add_string buf "; Path=";
  Buffer.add_string buf path;
  if http_only then Buffer.add_string buf "; HttpOnly";
  if secure then Buffer.add_string buf "; Secure";
  Buffer.add_string buf "; SameSite=";
  Buffer.add_string buf same_site;
  (match max_age with
  | None -> ()
  | Some age ->
      Buffer.add_string buf "; Max-Age=";
      Buffer.add_string buf (string_of_int age));
  with_header "Set-Cookie" (Buffer.contents buf) resp

let clear_cookie ?(path = "/") name resp =
  with_cookie ~path ~max_age:0 name "" resp