better response status

src/keys.ml

@@ -269,7 +269,7 @@ module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct
 
   let certify_future_signkey Api.SignKeySignature.{ key= pub; master_sig } =
     match Sm_eddsa.find_key pub with
-    | None -> Error `Not_found
+    | None -> Error (`Not_found "future eddsa key")
     | Some (pub, (t1, t2)) ->
         (* rebuild it *)
         let future_sk = make_future_sk (pub, (t1, t2)) in
@@ -281,7 +281,7 @@ module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct
   let certify_future_denomination
       Api.DenomSignature.{ h_denom_pub= h_pub; master_sig } =
     match Sm_rsa.find_key h_pub with
-    | None -> Error `Not_found
+    | None -> Error (`Not_found "future rsa denomination key")
     | Some (h_pub, (section_name, pub, t1)) ->
         let future_dn = make_future_dn (h_pub, (section_name, pub, t1)) in
         let dn = dn_of_future_dn future_dn h_pub master_sig in

src/mte_info.ml

@@ -18,8 +18,8 @@ let seed req _server _env =
 
 let config req _server _env =
   Logs.info (fun m -> m "GET /config");
-  let res = Api.encode Api.ExchangeVersionResponse.jsont config in
+  let jsont = Api.ExchangeVersionResponse.jsont in
-  Respond.result res req
+  Respond.ok req jsont config
 
 (* not implemented:
      - kyc
@@ -157,9 +157,10 @@ let jsont = ExchangeKeysResponse.jsont
 
 let keys req server _env =
   Logs.info (fun m -> m "GET /keys");
+  Respond.result req jsont
+  @@
   let db_conn = Vifu.Server.device Global.db_conn server in
   let keys = Vifu.Server.device Global.keys server in
-  let res =
   let* last_issue_date =
     match Vifu.Queries.get req "last_issue_date" with
     | [] -> Ok None
@@ -169,7 +170,4 @@ let keys req server _env =
             Fmt.error_msg "invalid `?last_issue_date` query param, not an int"
         | Some n -> Ok (Some (Timestamp.of_s n)))
   in
-    let* v = mk_keys ~db_conn keys ~last_issue_date in
+  mk_keys ~db_conn keys ~last_issue_date
-    Api.encode jsont v
-  in
-  Respond.result res req

src/mte_management.ml

@@ -3,23 +3,21 @@ open Api
 open Hash
 open Time
 
-(* todo request.ml? *)
-let request_of_json req =
-  Result.map_error (fun (`Msg e) -> `Json_decode e) (Vifu.Request.of_json req)
-
 module Keys_get = struct
   let jsont = FutureKeysResponse.jsont
 
   let f req server _env =
     Logs.info (fun m -> m "GET /management/keys/");
     let (module Keys : Keys.S) = Vifu.Server.device Global.keys server in
-    let res =
+    Respond.result req jsont
+    @@
     let* v = Keys.make_future_keys_response () in
-      Api.encode jsont v
+    Ok v
-    in
-    Respond.result res req
 end
 
+let request_of_json req =
+  Vifu.Request.of_json req |> Result.map_error (fun (`Msg e) -> `Json_decode e)
+
 module Keys_post = struct
   let verify (module Keys : Keys.S)
       MasterSignatures.{ denom_sigs; signkey_sigs } =
@@ -27,7 +25,8 @@ module Keys_post = struct
     let* () = list_iter Keys.verify_future_denomination denom_sigs in
     Ok ()
 
-  let do_ (module Keys : Keys.S) MasterSignatures.{ denom_sigs; signkey_sigs } =
+  let process (module Keys : Keys.S)
+      MasterSignatures.{ denom_sigs; signkey_sigs } =
     let* () = list_iter Keys.certify_future_signkey signkey_sigs in
     let* () = list_iter Keys.certify_future_denomination denom_sigs in
     Ok ()
@@ -36,14 +35,13 @@ module Keys_post = struct
 
   let f req server _env =
     Logs.info (fun m -> m "POST /management/keys/");
+    Respond.result_no_content req
+    @@
     let keys = Vifu.Server.device Global.keys server in
-    let res =
     let* v = request_of_json req in
     let* () = verify keys v in
-      let* () = do_ keys v in
+    let* () = process keys v in
     Ok ()
-    in
-    Respond.result_no_content res req
 end
 
 module Denom_revoke = struct
@@ -52,7 +50,7 @@ module Denom_revoke = struct
     let open Signatures.MasterDenominationKeyRevocation in
     verify Config.master_public_key master_sig { h_denom_pub }
 
-  let do_ (module Keys : Keys.S) h_denom_pub
+  let process (module Keys : Keys.S) h_denom_pub
       DenomRevocationSignature.{ master_sig } =
     let+ () = Keys.revoke_denomination h_denom_pub master_sig in
     ()
@@ -61,18 +59,16 @@ module Denom_revoke = struct
 
   let f req h_denom_pub server _env =
     Logs.info (fun m -> m "POST /management/denominations/$H_DENOM_PUB/revoke/");
+    Respond.result_no_content req
+    @@
     let keys = Vifu.Server.device Global.keys server in
-    let res =
     let* h_denom_pub =
-        DenominationHash.of_b32 h_denom_pub
+      DenominationHash.of_b32 h_denom_pub |> Result.map_error (fun e -> `Msg e)
-        |> Result.map_error (fun e -> `Msg e)
     in
     let* v = request_of_json req in
     let* () = verify keys h_denom_pub v in
-      let* () = do_ keys h_denom_pub v in
+    let* () = process keys h_denom_pub v in
     Ok ()
-    in
-    Respond.result_no_content res req
 end
 
 module Signkey_revoke = struct
@@ -81,7 +77,7 @@ module Signkey_revoke = struct
     let open Signatures.MasterSigningKeyRevocation in
     verify Config.master_public_key master_sig { exchange_pub }
 
-  let do_ (module Keys : Keys.S) exchange_pub
+  let process (module Keys : Keys.S) exchange_pub
       SignkeyRevocationSignature.{ master_sig } =
     let+ () = Keys.revoke_signkey exchange_pub master_sig in
     ()
@@ -90,17 +86,16 @@ module Signkey_revoke = struct
 
   let f req exchange_pub server _env =
     Logs.info (fun m -> m "POST /management/signkeys/$EXCHANGE_PUB/revoke/");
+    Respond.result_no_content req
+    @@
     let keys = Vifu.Server.device Global.keys server in
-    let res =
     let* exchange_pub =
       Eddsa.pub_of_b32 exchange_pub |> Result.map_error (fun e -> `Msg e)
     in
     let* v = request_of_json req in
     let* () = verify keys exchange_pub v in
-      let* () = do_ keys exchange_pub v in
+    let* () = process keys exchange_pub v in
     Ok ()
-    in
-    Respond.result_no_content res req
 end
 
 module Auditors = struct
@@ -121,7 +116,7 @@ module Auditors = struct
         h_auditor_url= H64_cstring.hash auditor_url;
       }
 
-  let do_ ~db_conn v =
+  let process ~db_conn v =
     let auditor_pub = v.AuditorSetupMessage.auditor_pub in
     let validity_start = v.AuditorSetupMessage.validity_start in
     let* opt = Pg.find_auditor db_conn auditor_pub in
@@ -143,15 +138,14 @@ module Auditors = struct
 
   let f req server _env =
     Logs.info (fun m -> m "POST /management/auditors/");
+    Respond.result_no_content req
+    @@
     let keys = Vifu.Server.device Global.keys server in
     let db_conn = Vifu.Server.device Global.db_conn server in
-    let res =
     let* v = request_of_json req in
     let* () = verify keys v in
-      let* () = do_ ~db_conn v in
+    let* () = process ~db_conn v in
     Ok ()
-    in
-    Respond.result_no_content res req
 end
 
 module Auditors_disable = struct
@@ -161,11 +155,11 @@ module Auditors_disable = struct
     verify Config.master_public_key master_sig
       { end_date= validity_end; auditor_pub }
 
-  let do_ ~db_conn auditor_pub
+  let process ~db_conn auditor_pub
       AuditorTeardownMessage.{ master_sig= _; validity_end } =
     let* opt = Pg.find_auditor db_conn auditor_pub in
     match opt with
-    | None -> Error `Not_found
+    | None -> Error (`Not_found "auditor pub key")
     | Some auditor -> (
         if Timestamp.compare validity_end auditor.last_change <= 0 then
           Error (`Conflict "replay detected on disable-auditor")
@@ -187,18 +181,17 @@ module Auditors_disable = struct
 
   let f req auditor_pub server _env =
     Logs.info (fun m -> m "POST /management/auditors/$AUDITOR_PUB/disable/");
+    Respond.result_no_content req
+    @@
     let keys = Vifu.Server.device Global.keys server in
     let db_conn = Vifu.Server.device Global.db_conn server in
-    let res =
     let* auditor_pub =
       Eddsa.pub_of_b32 auditor_pub |> Result.map_error (fun e -> `Msg e)
     in
     let* v = request_of_json req in
     let* () = verify keys auditor_pub v in
-      let* () = do_ ~db_conn auditor_pub v in
+    let* () = process ~db_conn auditor_pub v in
     Ok ()
-    in
-    Respond.result_no_content res req
 end
 
 module Wire_fee = struct
@@ -222,7 +215,7 @@ module Wire_fee = struct
         closing_fee;
       }
 
-  let do_ ~db_conn (v : WireFeeSetupMessage.t) =
+  let process ~db_conn (v : WireFeeSetupMessage.t) =
     let* wire_fees =
       Pg.get_wire_fees_by_time db_conn ~wire_method:v.wire_method
         ~start_date:v.fee_start ~end_date:v.fee_end
@@ -250,21 +243,20 @@ module Wire_fee = struct
 
   let f req server _env =
     Logs.info (fun m -> m "POST /management/wire-fee/");
+    Respond.result_no_content req
+    @@
     let keys = Vifu.Server.device Global.keys server in
     let db_conn = Vifu.Server.device Global.db_conn server in
-    let res =
     let* v = request_of_json req in
     let* () = verify keys v in
-      let* () = do_ ~db_conn v in
+    let* () = process ~db_conn v in
     Ok ()
-    in
-    Respond.result_no_content res req
 end
 
 module Global_fees = struct
   let verify v = GlobalFees.verify_global_fees ~key:Config.master_public_key v
 
-  let do_ ~db_conn v =
+  let process ~db_conn v =
     let* global_fees =
       let start_date = v.GlobalFees.start_date in
       let end_date = v.GlobalFees.end_date in
@@ -297,14 +289,13 @@ module Global_fees = struct
      and once set for a timeframe, it should not change. *)
   let f req server _env =
     Logs.info (fun m -> m "POST /management/global-fees/");
+    Respond.result_no_content req
+    @@
     let db_conn = Vifu.Server.device Global.db_conn server in
-    let res =
     let* v = request_of_json req in
     let* () = verify v in
-      let* () = do_ ~db_conn v in
+    let* () = process ~db_conn v in
     Ok ()
-    in
-    Respond.result_no_content res req
 end
 
 module Wire = struct
@@ -362,7 +353,7 @@ module Wire = struct
     in
     Ok ()
 
-  let do_ ~db_conn
+  let process ~db_conn
       WireSetupMessage.
         {
           payto_uri;
@@ -411,15 +402,14 @@ module Wire = struct
 
   let f req server _env =
     Logs.info (fun m -> m "POST /management/wire/");
+    Respond.result_no_content req
+    @@
     let keys = Vifu.Server.device Global.keys server in
     let db_conn = Vifu.Server.device Global.db_conn server in
-    let res =
     let* v = request_of_json req in
     let* () = verify keys v in
-      let* () = do_ ~db_conn v in
+    let* () = process ~db_conn v in
     Ok ()
-    in
-    Respond.result_no_content res req
 end
 
 module Wire_disable = struct
@@ -429,11 +419,11 @@ module Wire_disable = struct
     verify Config.master_public_key master_sig_del
       { end_date= validity_end; h_wire= FullPaytoHash.hash payto_uri }
 
-  let do_ ~db_conn
+  let process ~db_conn
       WireTeardownMessage.{ payto_uri; master_sig_del= _; validity_end } =
     let* opt = Pg.find_wire db_conn ~payto_uri in
     match opt with
-    | None -> Error `Not_found
+    | None -> Error (`Not_found "wire payto-uri")
     | Some (wire, _is_active, last_change) ->
         if Timestamp.compare validity_end last_change <= 0 then
           Error (`Conflict "replay detected on disable-wire")
@@ -449,15 +439,14 @@ module Wire_disable = struct
 
   let f req server _env =
     Logs.info (fun m -> m "POST /management/wire/disable/");
+    Respond.result_no_content req
+    @@
     let keys = Vifu.Server.device Global.keys server in
     let db_conn = Vifu.Server.device Global.db_conn server in
-    let res =
     let* v = request_of_json req in
     let* () = verify keys v in
-      let* () = do_ ~db_conn v in
+    let* () = process ~db_conn v in
     Ok ()
-    in
-    Respond.result_no_content res req
 end
 
 module Drain = struct
@@ -481,7 +470,7 @@ module Drain = struct
         h_payto= FullPaytoHash.hash credit_payto_uri;
       }
 
-  let do_ ~db_conn v =
+  let process ~db_conn v =
     let* opt = Pg.find_drain_profit db_conn v.DrainProfitsMessage.wtid in
     match opt with
     | Some _ ->
@@ -496,15 +485,14 @@ module Drain = struct
 
   let f req server _env =
     Logs.info (fun m -> m "POST /management/drain/");
+    Respond.result_no_content req
+    @@
     let keys = Vifu.Server.device Global.keys server in
     let db_conn = Vifu.Server.device Global.db_conn server in
-    let res =
     let* v = request_of_json req in
     let* () = verify keys v in
-      let* () = do_ ~db_conn v in
+    let* () = process ~db_conn v in
     Ok ()
-    in
-    Respond.result_no_content res req
 end
 
 module AmlOfficer = struct
@@ -528,7 +516,7 @@ module AmlOfficer = struct
         is_active;
       }
 
-  let do_ ~db_conn v =
+  let process ~db_conn v =
     let+ _last_change = Pg.insert_aml_officer db_conn v in
     ()
 
@@ -536,15 +524,14 @@ module AmlOfficer = struct
 
   let f req server _env =
     Logs.info (fun m -> m "POST /management/aml-officers/");
+    Respond.result_no_content req
+    @@
     let keys = Vifu.Server.device Global.keys server in
     let db_conn = Vifu.Server.device Global.db_conn server in
-    let res =
     let* v = request_of_json req in
     let* () = verify keys v in
-      let* () = do_ ~db_conn v in
+    let* () = process ~db_conn v in
     Ok ()
-    in
-    Respond.result_no_content res req
 end
 
 module Partners = struct
@@ -570,7 +557,7 @@ module Partners = struct
         h_url= H64_cstring.hash partner_base_url;
       }
 
-  let do_ ~db_conn v =
+  let process ~db_conn v =
     let+ () = Pg.insert_partner db_conn v in
     ()
 
@@ -578,13 +565,12 @@ module Partners = struct
 
   let f req server _env =
     Logs.info (fun m -> m "POST /management/partners/");
+    Respond.result_no_content req
+    @@
     let keys = Vifu.Server.device Global.keys server in
     let db_conn = Vifu.Server.device Global.db_conn server in
-    let res =
     let* v = request_of_json req in
     let* () = verify keys v in
-      let* () = do_ ~db_conn v in
+    let* () = process ~db_conn v in
     Ok ()
-    in
-    Respond.result_no_content res req
 end

src/respond.ml

@@ -1,53 +1,63 @@
-let encode_error_detail err =
+let bad_request _req =
-  match Api.encode Api.ErrorDetail.jsont err with
-  | Error e ->
-      Fmt.failwith "json encoding error on `ErrorDetail`: %a." Result.pp_err e
-  | Ok s -> s
-
-let respond_json req content status =
   let open Vifu.Response in
-  let open Syntax in
+  Logs.debug (fun m -> m "Bad request");
-  let* () = add ~field:"content-type" "application/json" in
+  respond `Bad_request
-  let* () = with_string req content in
-  respond status
 
-let mk_error_content ?hint _status =
+let no_content _req =
-  let open Api in
+  Logs.debug (fun m -> m "No content");
-  let code = -1 in
-  let err = ErrorDetail.make ?hint code in
-  encode_error_detail err
-
-let error err req =
-  let hint = Fmt.str "%a" Result.pp_err err in
-  Logs.err (fun m -> m "error: %s" hint);
-  let body = mk_error_content ~hint `Internal_server_error in
-  respond_json req body `Internal_server_error
-
-let bad_request ?hint req =
-  Logs.err (fun m -> m "bad request");
-  let body = mk_error_content ?hint `Bad_request in
-  respond_json req body `Bad_request
-
-let ok content req =
-  Logs.debug (fun m -> m "ok");
-  respond_json req content `OK
-
-let no_content () =
-  Logs.debug (fun m -> m "no content");
   let open Vifu.Response in
   let open Syntax in
   let* () = empty in
   respond `No_content
 
 let not_modified () =
-  Logs.debug (fun m -> m "not modified");
+  Logs.debug (fun m -> m "Not modified");
   let open Vifu.Response in
   let open Syntax in
   let* () = empty in
   respond `Not_modified
 
-let result res req =
+let respond_json req jsont status body =
-  match res with Error e -> error e req | Ok content -> ok content req
+  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 result_no_content res req =
+let ok req jsont body =
-  match res with Error e -> error e req | Ok () -> no_content ()
+  Logs.debug (fun m -> m "OK");
+  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 status_to_string = function
+  | `Bad_request -> "Bad request"
+  | `Forbidden -> "Forbidden"
+  | `Not_found -> "Not found"
+  | `Conflict -> "Conflict"
+  | `Internal_server_error -> "Internal server error"
+
+let error_detail hint =
+  let open Api in
+  let code = -1 in
+  ErrorDetail.make ~hint code
+
+let error req err =
+  let status = map_err_status err in
+  let hint = Result.err_to_string err in
+  let body = error_detail hint in
+  Logs.err (fun m -> m "%s: %s" (status_to_string status) hint);
+  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 req

src/result.ml

@@ -1,26 +1,24 @@
 include Stdlib.Result
 
 type err =
-  [ `Msg of string
+  [ `Json_decode of string
-  | `Json_decode of string
   | `Bin_decode of string
   | `Invalid_signature_eddsa
   | `Invalid_signature_rsa
   | (* - *)
-    `Not_found
+    `Not_found of string
   | `Conflict of string
   | (* - server errors - *)
-    `Server_err of string
+    `Caqti of string
-  | `Caqti of string
   | `Mfat of string
   | `Json_encode of string
   | `Bin_encode of string
+  | `Msg of string
   ]
 
 type 'a t = ('a, err) Stdlib.Result.t
 
 let err_to_string : err -> string = function
-  | `Msg s -> s
   | `Json_decode s -> Fmt.str "Json decode: %s" s
   | `Json_encode s -> Fmt.str "Json encode: %s" s
   | `Bin_decode s -> Fmt.str "Bin decode: %s" s
@@ -28,12 +26,12 @@ let err_to_string : err -> string = function
   | `Invalid_signature_eddsa -> Fmt.str "Invalid eddsa signature"
   | `Invalid_signature_rsa -> Fmt.str "Invalid rsa signature"
   (* - *)
-  | `Not_found -> Fmt.str "Not found"
+  | `Not_found s -> Fmt.str "Not found: %s" s
   | `Conflict s -> Fmt.str "Conflict: %s" s
   (* - *)
-  | `Server_err s -> Fmt.str "Server error: %s" s
   | `Caqti s -> Fmt.str "Caqti: %s" s
   | `Mfat s -> Fmt.str "mFAT: %s" s
+  | `Msg s -> s
 
 let pp_err = Fmt.of_to_string err_to_string
 let unwrap_err r = map_error err_to_string r