mte/src/respond.ml

let pp_status ppf status =
  match status with
  | #H2.Status.standard as status ->
      Fmt.pf ppf "HTTP [%d %s]" (H2.Status.to_code status)
        (H2.Status.default_reason_phrase status)
  | _ -> Fmt.pf ppf "HTTP [%d]" (H2.Status.to_code status)

let empty status =
  Logs.info (fun m -> m "%a" pp_status status);
  let open Vifu.Response in
  let open Syntax in
  let* () = empty in
  respond status

let bad_request () = empty `Bad_request
let no_content () = empty `No_content
let not_modified () = empty `Not_modified
let not_implemented () = empty `Not_implemented

let respond_json req jsont status body =
  Logs.info (fun m -> m "%a" pp_status status);
  let open Vifu.Response in
  let open Syntax in
  let* () = add ~field:"content-type" "application/json" in
  let* () = with_json req jsont body in
  respond status

let ok req jsont body = respond_json req jsont `OK body

let map_err_status err =
  match err with
  | `Json_decode _ | `Bin_decode _ -> `Bad_request
  | `Invalid_signature_eddsa | `Invalid_signature_rsa -> `Forbidden
  | `Not_found _ -> `Not_found
  | `Conflict _ -> `Conflict
  | `Caqti _s | `Mfat _s | `Json_encode _s | `Bin_encode _s | `Msg _s ->
      `Internal_server_error

let error req err =
  let status = map_err_status err in
  let hint = Result.err_to_string err in
  let log_lvl =
    if H2.Status.is_server_error status then Logs.Error else Logs.Warning
  in
  Logs.msg log_lvl (fun m -> m "%a %s" pp_status status hint);
  let body = Api.ErrorDetail.make ~hint (-1) in
  respond_json req Api.ErrorDetail.jsont status body

let result req jsont res =
  match res with Error e -> error req e | Ok body -> ok req jsont body

let result_no_content req res =
  match res with Error e -> error req e | Ok () -> no_content ()