mte/unikernel/server.ml

let src = Logs.Src.create "unikernel server"

module Log = (val Logs.src_log src : Logs.LOG)
module Method = Mte.Method
module Headers = Mte.Headers
module Status = Mte.Status

let request_from_h1 ~scheme { H1.Request.meth; target; headers; _ } =
  let headers = Mte.Headers.of_list (H1.Headers.to_list headers) in
  Mte.{ meth; target; scheme; headers }

let request_from_h2 { H2.Request.meth; target; scheme; headers } =
  Mte.{ meth; target; scheme; headers }

let http_1_1_request_handler reqd =
  let request = H1.Reqd.request reqd in
  Log.debug (fun m ->
      m "(HTTP/1.1) request-handler: %S" request.H1.Request.target);
  Lwt.async @@ fun () ->
  Lwt.catch
    (fun () ->
      let open Syntax in
      let+ Mte.{ status; headers; content } =
        Mte.request_handler (request_from_h1 ~scheme:"http" request)
      in
      let status =
        match status with
        | #H1.Status.t as status -> status
        | _ -> Fmt.failwith "H2 status response on a H1 request"
      in
      let headers = H1.Headers.of_list (Headers.to_list headers) in
      let response = H1.Response.create ~headers status in
      H1.Reqd.respond_with_string reqd response content;
      ())
    (fun exn ->
      (* note: not sure what this does exactly, this is what is done in Dream *)
      H1.Reqd.report_exn reqd exn;
      Lwt.return_unit)

let http_2_0_request_handler reqd =
  let request = H2.Reqd.request reqd in
  Log.debug (fun m -> m "(H2) request-handler: %S" request.H2.Request.target);
  Lwt.async @@ fun () ->
  Lwt.catch
    (fun () ->
      let open Syntax in
      let+ Mte.{ status; headers; content } =
        Mte.request_handler (request_from_h2 request)
      in
      let response = H2.Response.create ~headers status in
      H2.Reqd.respond_with_string reqd response content;
      ())
    (fun exn ->
      H2.Reqd.report_exn reqd exn;
      Lwt.return_unit)

let alpn_request_handler : type reqd headers request response ro wo.
    reqd -> (reqd, headers, request, response, ro, wo) Alpn.protocol -> unit =
 fun reqd -> function
  | Alpn.HTTP_1_1 _ -> http_1_1_request_handler reqd
  | Alpn.H2 _ -> http_2_0_request_handler reqd

let headers_of_list : type reqd headers request response ro wo.
    (reqd, headers, request, response, ro, wo) Alpn.protocol ->
    (string * string) list ->
    headers =
 fun protocol lst ->
  match protocol with
  | Alpn.HTTP_1_1 _ -> H1.Headers.of_list lst
  | Alpn.H2 _ -> H2.Headers.of_list lst

let respond_with_string : type reqd headers request response ro wo.
    (reqd, headers, request, response, ro, wo) Alpn.protocol ->
    headers:headers ->
    respond:(headers -> wo) ->
    string ->
    unit =
 fun protocol ~headers ~respond str ->
  let body = respond headers in
  match protocol with
  | Alpn.HTTP_1_1 _ ->
      H1.Body.Writer.write_string body str;
      H1.Body.Writer.close body
  | Alpn.H2 _ ->
      H2.Body.Writer.write_string body str;
      H2.Body.Writer.close body

let alpn_error_handler : type reqd headers request response ro wo.
    _ ->
    (reqd, headers, request, response, ro, wo) Alpn.protocol ->
    ?request:_ ->
    _ ->
    (headers -> wo) ->
    unit =
 fun _edn protocol ?request:_ error respond ->
  let contents =
    match error with
    | `Bad_gateway -> {|Bad gateway.|}
    | `Bad_request -> {|Bad request.|}
    | `Exn (Paf.Flow err) | `Exn (Paf.Flow_write err) ->
        Fmt.str {|I/O error: %s.|} err
    | `Exn exn -> Fmt.str {|Unknown error: %S.|} (Printexc.to_string exn)
    | `Internal_server_error -> {|Internal server error.|}
  in
  let headers =
    headers_of_list protocol
      [
        ("content-type", "text/plain");
        ("content-length", string_of_int (String.length contents));
      ]
  in
  respond_with_string protocol ~respond ~headers contents

let http_1_1_error_handler edn ?request error respond =
  alpn_error_handler edn ?request Alpn.http_1_1
    (error :> Alpn.server_error)
    respond

let http_2_0_error_handler edn ?request error respond =
  alpn_error_handler edn ?request Alpn.h2 (error :> Alpn.server_error) respond