~

src/handler.ml

@@ -1,206 +0,0 @@
-module Respond_util = struct
-  let respond_with_plain_text_error ?status e req =
-    let open Vif.Response in
-    let open Syntax in
-    let status = Option.value ~default:`Bad_request status in
-    let* () = add ~field:"content-type" "text/plain; charset=utf-8" in
-    let* () = with_string req e in
-    respond status
-
-  let respond_with_ok_json content req =
-    let open Vif.Response in
-    let open Syntax in
-    let* () = add ~field:"content-type" "application/json" in
-    let* () = with_string req content in
-    respond `OK
-
-  let respond_with_res res req =
-    match res with
-    | Error err ->
-        Logs.err (fun m -> m "%s." err);
-        let err = Fmt.str "%s@." err in
-        respond_with_plain_text_error err req
-    | Ok content -> respond_with_ok_json content req
-end
-
-include Respond_util
-open Syntax
-open Api
-
-let management_keys_get req server _env =
-  let sm_signkey = Vif.Server.device Devices.secmod_signkey server in
-  let sm_denom = Vif.Server.device Devices.secmod_denom server in
-  let res =
-    let v = Management.mk_future_keys_response ~sm_signkey ~sm_denom in
-    let s = Api.encode_exn Api.FutureKeysResponse.jsont v in
-    Ok s
-  in
-  respond_with_res res req
-
-let management_keys_post_jsont = MasterSignatures.jsont
-
-let management_keys_post req server _env =
-  let open Management in
-  let db_conn = Vif.Server.device Devices.db_connection server in
-  let sm_signkey = Vif.Server.device Devices.secmod_signkey server in
-  let sm_denom = Vif.Server.device Devices.secmod_denom server in
-  let res =
-    let* master_signatures = Vif.Request.of_json req |> unwrap_err_msg in
-    let* () =
-      verify_master_signatures ~sm_signkey ~sm_denom master_signatures
-    in
-    let* () =
-      update_master_signatures ~db_conn ~sm_signkey ~sm_denom master_signatures
-    in
-    Ok ""
-  in
-  respond_with_res res req
-
-let management_denom_revoke_jsont = DenomRevocationSignature.jsont
-
-let management_denom_revoke req h_denom_pub server _env =
-  let open Management in
-  let db_conn = Vif.Server.device Devices.db_connection server in
-  let sm_denom = Vif.Server.device Devices.secmod_denom server in
-  let res =
-    let* h_denom_pub = HashCode.of_b32 h_denom_pub in
-    let h_denom_pub = HashCode.to_denomination_hash h_denom_pub in
-    let* v = Vif.Request.of_json req |> unwrap_err_msg in
-    let* () = verify_denom_revocation_sig h_denom_pub v in
-    let* () = update_denom_revocation ~db_conn ~sm_denom h_denom_pub v in
-    Ok ""
-  in
-  respond_with_res res req
-
-let management_signkey_revoke_jsont = SignkeyRevocationSignature.jsont
-
-let management_signkey_revoke req exchange_pub server _env =
-  let open Management in
-  let db_conn = Vif.Server.device Devices.db_connection server in
-  let sm_signkey = Vif.Server.device Devices.secmod_signkey server in
-  let res =
-    let* exchange_pub = Crypto.EddsaPublicKey.of_b32 exchange_pub in
-    let* v = Vif.Request.of_json req |> unwrap_err_msg in
-    let* () = verify_signkey_revocation_sig exchange_pub v in
-    let* () = update_signkey_revocation ~db_conn ~sm_signkey exchange_pub v in
-    Ok ""
-  in
-  respond_with_res res req
-
-let management_auditors_jsont = AuditorSetupMessage.jsont
-
-let management_auditors req server _env =
-  let open Management in
-  let db_conn = Vif.Server.device Devices.db_connection server in
-  let res =
-    let* v = Vif.Request.of_json req |> unwrap_err_msg in
-    let* () = verify_auditor_add_sig v in
-    let* () = update_auditor ~db_conn v in
-    Ok ""
-  in
-  respond_with_res res req
-
-let management_auditors_disable_jsont = AuditorTeardownMessage.jsont
-
-let management_auditors_disable req auditor_pub server _env =
-  let open Management in
-  let db_conn = Vif.Server.device Devices.db_connection server in
-  let res =
-    let* auditor_pub = Crypto.EddsaPublicKey.of_b32 auditor_pub in
-    let* v = Vif.Request.of_json req |> unwrap_err_msg in
-    let* () = verify_auditor_disable_sig auditor_pub v in
-    let* () = auditor_disable ~db_conn auditor_pub v in
-    Ok ""
-  in
-  respond_with_res res req
-
-let management_wire_fee_jsont = WireFeeSetupMessage.jsont
-
-let management_wire_fee req server _env =
-  let open Management in
-  let db_conn = Vif.Server.device Devices.db_connection server in
-  let res =
-    let* v = Vif.Request.of_json req |> unwrap_err_msg in
-    let* () = verify_wire_fee_setup_sig v in
-    let* () = update_wire_fee_setup ~db_conn v in
-    Ok ""
-  in
-  respond_with_res res req
-
-let management_global_fees_jsont = GlobalFees.jsont
-
-let management_global_fees req server _env =
-  let open Management in
-  let db_conn = Vif.Server.device Devices.db_connection server in
-  let res =
-    let* v = Vif.Request.of_json req |> unwrap_err_msg in
-    let* () = verify_global_fees v in
-    let* () = update_global_fees ~db_conn v in
-    Ok ""
-  in
-  respond_with_res res req
-
-let management_wire_jsont = WireSetupMessage.jsont
-
-let management_wire req server _env =
-  let open Management in
-  let db_conn = Vif.Server.device Devices.db_connection server in
-  let res =
-    let* v = Vif.Request.of_json req |> unwrap_err_msg in
-    let* () = verify_wire v in
-    let* () = update_wire ~db_conn v in
-    Ok ""
-  in
-  respond_with_res res req
-
-let management_wire_disable_jsont = WireTeardownMessage.jsont
-
-let management_wire_disable req server _env =
-  let open Management in
-  let db_conn = Vif.Server.device Devices.db_connection server in
-  let res =
-    let* v = Vif.Request.of_json req |> unwrap_err_msg in
-    let* () = verify_wire_disable v in
-    let* () = update_wire_disable ~db_conn v in
-    Ok ""
-  in
-  respond_with_res res req
-
-let management_drain_jsont = DrainProfitsMessage.jsont
-
-let management_drain req server _env =
-  let open Management in
-  let db_conn = Vif.Server.device Devices.db_connection server in
-  let res =
-    let* v = Vif.Request.of_json req |> unwrap_err_msg in
-    let* () = verify_drain v in
-    let* () = update_drain ~db_conn v in
-    Ok ""
-  in
-  respond_with_res res req
-
-let management_aml_officers_jsont = AmlOfficerSetup.jsont
-
-let management_aml_officers req server _env =
-  let open Management in
-  let db_conn = Vif.Server.device Devices.db_connection server in
-  let res =
-    let* v = Vif.Request.of_json req |> unwrap_err_msg in
-    let* () = verify_aml_officier v in
-    let* () = update_aml_officier ~db_conn v in
-    Ok ""
-  in
-  respond_with_res res req
-
-let management_partners_jsont = ExchangePartnerSetupRequest.jsont
-
-let management_partners req server _env =
-  let open Management in
-  let db_conn = Vif.Server.device Devices.db_connection server in
-  let res =
-    let* v = Vif.Request.of_json req |> unwrap_err_msg in
-    let* () = verify_partner v in
-    let* () = update_partner ~db_conn v in
-    Ok ""
-  in
-  respond_with_res res req

src/management.ml

@@ -1,6 +1,8 @@
+open Syntax
 open Api
 
-let mk_future_denom ~sm_denom_priv
+module Keys_get = struct
+  let mk_future_denom ~sm_denom_priv
       ({
          pub;
          priv= _;
@@ -27,7 +29,9 @@ let mk_future_denom ~sm_denom_priv
       let h_denom_pub = h_pub in
       let h_section_name = Bin_type.Hash_64_cstr.hash section_name in
       let anchor_time = stamp_start in
-    let duration_withdraw = Timestamp.diff stamp_start stamp_expire_withdraw in
+      let duration_withdraw =
+        Timestamp.diff stamp_start stamp_expire_withdraw
+      in
       sign ~key:sm_denom_priv
         { h_denom_pub; h_section_name; anchor_time; duration_withdraw }
     in
@@ -47,7 +51,7 @@ let mk_future_denom ~sm_denom_priv
         denom_secmod_sig;
       }
 
-let mk_future_signkey ~sm_signkey_priv
+  let mk_future_signkey ~sm_signkey_priv
       ({ pub; priv= _; stamp_start; stamp_expire; stamp_end; master_sig= _ } :
         Signkey.t) =
     let signkey_secmod_sig =
@@ -60,7 +64,7 @@ let mk_future_signkey ~sm_signkey_priv
     FutureSignKey.
       { key= pub; stamp_start; stamp_expire; stamp_end; signkey_secmod_sig }
 
-let mk_future_keys_response ~(sm_signkey : Secmod_signkey.t)
+  let mk_future_keys_response ~(sm_signkey : Secmod_signkey.t)
       ~(sm_denom : Secmod_denom.t) =
     let future_signkeys =
       Secmod_signkey.get_signkeys sm_signkey
@@ -80,7 +84,9 @@ let mk_future_keys_response ~(sm_signkey : Secmod_signkey.t)
     in
     let master_pub = Config.Exchange.master_public_key in
     let denom_secmod_public_key = (Secmod_denom.get_sm_key sm_denom).pub in
-  let signkey_secmod_public_key = (Secmod_signkey.get_sm_key sm_signkey).pub in
+    let signkey_secmod_public_key =
+      (Secmod_signkey.get_sm_key sm_signkey).pub
+    in
     FutureKeysResponse.
       {
         future_denoms;
@@ -90,15 +96,27 @@ let mk_future_keys_response ~(sm_signkey : Secmod_signkey.t)
         signkey_secmod_public_key;
       }
 
-(* - ** - *)
+  let jsont = FutureKeysResponse.jsont
-open Syntax
 
-let verify_denom_signature ~sm_denom DenomSignature.{ h_denom_pub; master_sig }
+  let f req server _env =
-    =
+    let sm_signkey = Vif.Server.device Devices.secmod_signkey server in
+    let sm_denom = Vif.Server.device Devices.secmod_denom server in
+    let res =
+      let v = mk_future_keys_response ~sm_signkey ~sm_denom in
+      let s = Api.encode_exn jsont v in
+      Ok s
+    in
+    Respond_util.respond_with_res res req
+end
+
+module Keys_post = struct
+  let verify_denom_signature ~sm_denom
+      DenomSignature.{ h_denom_pub; master_sig } =
     let denom_hash = HashCode.to_denomination_hash h_denom_pub in
     let* denom =
       Secmod_denom.get_denoms sm_denom
-    |> List.find_opt (fun (denom : Denomination.t) -> denom.h_pub = denom_hash)
+      |> List.find_opt (fun (denom : Denomination.t) ->
+          denom.h_pub = denom_hash)
       |> function
       | None ->
           Fmt.error
@@ -123,7 +141,8 @@ let verify_denom_signature ~sm_denom DenomSignature.{ h_denom_pub; master_sig }
     in
     verify ~key:Config.master_public_key master_sig r
 
-let verify_signkey_signature ~sm_signkey SignKeySignature.{ key; master_sig } =
+  let verify_signkey_signature ~sm_signkey SignKeySignature.{ key; master_sig }
+      =
     let* signkey =
       Secmod_signkey.get_signkeys sm_signkey
       |> List.find_opt (fun (signkey : Signkey.t) -> signkey.pub = key)
@@ -145,16 +164,14 @@ let verify_signkey_signature ~sm_signkey SignKeySignature.{ key; master_sig } =
     in
     verify ~key:Config.master_public_key master_sig r
 
-let verify_master_signatures ~sm_signkey ~sm_denom
+  let verify ~sm_signkey ~sm_denom MasterSignatures.{ denom_sigs; signkey_sigs }
-    MasterSignatures.{ denom_sigs; signkey_sigs } =
+      =
     let* () = list_iter (verify_denom_signature ~sm_denom) denom_sigs in
     let* () = list_iter (verify_signkey_signature ~sm_signkey) signkey_sigs in
     Ok ()
 
-(* --- *)
+  (* TODO move to test *)
-
+  let check_master_signatures_update ~db_conn ~sm_denom =
-(* TODO move to test *)
-let check_master_signatures_update ~db_conn ~sm_denom =
     Secmod_denom.get_denoms sm_denom
     |> list_iter (fun denom ->
         let error = Error "update_master_signatures sanity check failure" in
@@ -183,11 +200,12 @@ let check_master_signatures_update ~db_conn ~sm_denom =
         let* () = check (age_mask = denom.age_mask) in
         Ok ())
 
-let update_master_signatures ~db_conn ~sm_signkey ~sm_denom
+  let do_ ~db_conn ~sm_signkey ~sm_denom
       MasterSignatures.{ denom_sigs; signkey_sigs } =
     let* () =
       signkey_sigs
-    |> List.map (fun SignKeySignature.{ key; master_sig } -> (key, master_sig))
+      |> List.map (fun SignKeySignature.{ key; master_sig } ->
+          (key, master_sig))
       |> Secmod_signkey.add_master_signatures db_conn sm_signkey
     in
     let* () =
@@ -200,38 +218,94 @@ let update_master_signatures ~db_conn ~sm_signkey ~sm_denom
     let* () = check_master_signatures_update ~db_conn ~sm_denom in
     Ok ()
 
-let verify_denom_revocation_sig h_denom_pub
+  let jsont = MasterSignatures.jsont
-    DenomRevocationSignature.{ master_sig } =
+
+  let f req server _env =
+    let db_conn = Vif.Server.device Devices.db_connection server in
+    let sm_signkey = Vif.Server.device Devices.secmod_signkey server in
+    let sm_denom = Vif.Server.device Devices.secmod_denom server in
+    let res =
+      let* v = Vif.Request.of_json req |> unwrap_err_msg in
+      let* () = verify ~sm_signkey ~sm_denom v in
+      let* () = do_ ~db_conn ~sm_signkey ~sm_denom v in
+      Ok ""
+    in
+    Respond_util.respond_with_res res req
+end
+
+module Denom_revoke = struct
+  let verify h_denom_pub DenomRevocationSignature.{ master_sig } =
     let open Bin_sig.MasterDenominationKeyRevocation in
     verify ~key:Config.Exchange.master_public_key master_sig { h_denom_pub }
 
-let update_denom_revocation ~db_conn ~sm_denom h_denom_pub
+  let do_ ~db_conn ~sm_denom h_denom_pub DenomRevocationSignature.{ master_sig }
-    DenomRevocationSignature.{ master_sig } =
+      =
-  let* () = Secmod_denom.revoke_denomination sm_denom h_denom_pub master_sig in
     let* () =
+      Secmod_denom.revoke_denomination sm_denom h_denom_pub master_sig
+    in
+    let+ () =
       Pg.insert_denomination_revocation db_conn h_denom_pub master_sig
       |> unwrap_err_caqti
     in
-  Ok ()
+    ()
 
-let verify_signkey_revocation_sig exchange_pub
+  let jsont = DenomRevocationSignature.jsont
-    SignkeyRevocationSignature.{ master_sig } =
+
+  let f req h_denom_pub server _env =
+    let db_conn = Vif.Server.device Devices.db_connection server in
+    let sm_denom = Vif.Server.device Devices.secmod_denom server in
+    let res =
+      let* h_denom_pub = HashCode.of_b32 h_denom_pub in
+      let h_denom_pub = HashCode.to_denomination_hash h_denom_pub in
+      let* v = Vif.Request.of_json req |> unwrap_err_msg in
+      let* () = verify h_denom_pub v in
+      let* () = do_ ~db_conn ~sm_denom h_denom_pub v in
+      Ok ""
+    in
+    Respond_util.respond_with_res res req
+end
+
+module Signkey_revoke = struct
+  let verify exchange_pub SignkeyRevocationSignature.{ master_sig } =
     let open Bin_sig.MasterSigningKeyRevocation in
     verify ~key:Config.Exchange.master_public_key master_sig { exchange_pub }
 
-let update_signkey_revocation ~db_conn ~sm_signkey exchange_pub
+  let do_ ~db_conn ~sm_signkey exchange_pub
       SignkeyRevocationSignature.{ master_sig } =
-  let* () = Secmod_signkey.revoke_signkey sm_signkey exchange_pub master_sig in
     let* () =
+      Secmod_signkey.revoke_signkey sm_signkey exchange_pub master_sig
+    in
+    let+ () =
       Pg.insert_signkey_revocation db_conn exchange_pub master_sig
       |> unwrap_err_caqti
     in
-  Ok ()
+    ()
 
-let verify_auditor_add_sig
+  let jsont = SignkeyRevocationSignature.jsont
+
+  let f req exchange_pub server _env =
+    let db_conn = Vif.Server.device Devices.db_connection server in
+    let sm_signkey = Vif.Server.device Devices.secmod_signkey server in
+    let res =
+      let* exchange_pub = Crypto.EddsaPublicKey.of_b32 exchange_pub in
+      let* v = Vif.Request.of_json req |> unwrap_err_msg in
+      let* () = verify exchange_pub v in
+      let* () = do_ ~db_conn ~sm_signkey exchange_pub v in
+      Ok ""
+    in
+    Respond_util.respond_with_res res req
+end
+
+module Auditors = struct
+  let verify
       AuditorSetupMessage.
-      { auditor_url; auditor_name= _; auditor_pub; master_sig; validity_start }
+        {
-    =
+          auditor_url;
+          auditor_name= _;
+          auditor_pub;
+          master_sig;
+          validity_start;
+        } =
     let open Bin_sig.MasterAddAuditor in
     verify ~key:Config.Exchange.master_public_key master_sig
       {
@@ -240,10 +314,10 @@ let verify_auditor_add_sig
         h_auditor_url= Bin_type.Hash_64_cstr.hash auditor_url;
       }
 
-(* TODO timestamps last_change +/- checks *)
+  (* TODO timestamps last_change +/- checks *)
-(* todo: there is something about use of monotonic time
+  (* todo: there is something about use of monotonic time
    + protection against replay attack that I don't understand *)
-let update_auditor ~db_conn v =
+  let do_ ~db_conn v =
     let auditor_pub = v.AuditorSetupMessage.auditor_pub in
     let validity_start = v.AuditorSetupMessage.validity_start in
     let* last_date_opt =
@@ -260,13 +334,26 @@ let update_auditor ~db_conn v =
           let+ () = Pg.update_auditor db_conn v |> unwrap_err_caqti in
           ()
 
-let verify_auditor_disable_sig auditor_pub
+  let jsont = AuditorSetupMessage.jsont
-    AuditorTeardownMessage.{ master_sig; validity_end } =
+
+  let f req server _env =
+    let db_conn = Vif.Server.device Devices.db_connection server in
+    let res =
+      let* v = Vif.Request.of_json req |> unwrap_err_msg in
+      let* () = verify v in
+      let* () = do_ ~db_conn v in
+      Ok ""
+    in
+    Respond_util.respond_with_res res req
+end
+
+module Auditors_disable = struct
+  let verify auditor_pub AuditorTeardownMessage.{ master_sig; validity_end } =
     let open Bin_sig.MasterDelAuditor in
     verify ~key:Config.Exchange.master_public_key master_sig
       { end_date= validity_end; auditor_pub }
 
-let auditor_disable ~db_conn auditor_pub
+  let do_ ~db_conn auditor_pub
       AuditorTeardownMessage.{ master_sig= _; validity_end } =
     let* last_date_opt =
       Pg.lookup_auditor_timestamp db_conn auditor_pub |> unwrap_err_caqti
@@ -283,7 +370,22 @@ let auditor_disable ~db_conn auditor_pub
           in
           ()
 
-let verify_wire_fee_setup_sig
+  let jsont = AuditorTeardownMessage.jsont
+
+  let f req auditor_pub server _env =
+    let db_conn = Vif.Server.device Devices.db_connection server in
+    let res =
+      let* auditor_pub = Crypto.EddsaPublicKey.of_b32 auditor_pub in
+      let* v = Vif.Request.of_json req |> unwrap_err_msg in
+      let* () = verify auditor_pub v in
+      let* () = do_ ~db_conn auditor_pub v in
+      Ok ""
+    in
+    Respond_util.respond_with_res res req
+end
+
+module Wire_fee = struct
+  let verify
       WireFeeSetupMessage.
         {
           wire_method;
@@ -303,7 +405,7 @@ let verify_wire_fee_setup_sig
         closing_fee;
       }
 
-let update_wire_fee_setup ~db_conn
+  let do_ ~db_conn
       WireFeeSetupMessage.
         {
           wire_method;
@@ -328,7 +430,21 @@ let update_wire_fee_setup ~db_conn
         in
         ()
 
-let verify_global_fees
+  let jsont = WireFeeSetupMessage.jsont
+
+  let f req server _env =
+    let db_conn = Vif.Server.device Devices.db_connection server in
+    let res =
+      let* v = Vif.Request.of_json req |> unwrap_err_msg in
+      let* () = verify v in
+      let* () = do_ ~db_conn v in
+      Ok ""
+    in
+    Respond_util.respond_with_res res req
+end
+
+module Global_fees = struct
+  let verify
       GlobalFees.
         {
           start_date;
@@ -364,7 +480,7 @@ let verify_global_fees
         purse_account_limit;
       }
 
-let update_global_fees ~db_conn v =
+  let do_ ~db_conn v =
     let* global_fees_opt =
       let start_date = v.GlobalFees.start_date in
       let end_date = v.GlobalFees.end_date in
@@ -377,7 +493,21 @@ let update_global_fees ~db_conn v =
         let+ () = Pg.insert_global_fee db_conn v |> unwrap_err_caqti in
         ()
 
-let verify_wire
+  let jsont = GlobalFees.jsont
+
+  let f req server _env =
+    let db_conn = Vif.Server.device Devices.db_connection server in
+    let res =
+      let* v = Vif.Request.of_json req |> unwrap_err_msg in
+      let* () = verify v in
+      let* () = do_ ~db_conn v in
+      Ok ""
+    in
+    Respond_util.respond_with_res res req
+end
+
+module Wire = struct
+  let verify
       WireSetupMessage.
         {
           payto_uri;
@@ -415,7 +545,7 @@ let verify_wire
     in
     Ok ()
 
-let update_wire ~db_conn v =
+  let do_ ~db_conn v =
     let* last_change_opt =
       let payto_uri = v.WireSetupMessage.payto_uri in
       Pg.lookup_wire_timestamp db_conn ~payto_uri |> unwrap_err_caqti
@@ -426,13 +556,26 @@ let update_wire ~db_conn v =
         let+ () = Pg.insert_wire db_conn v |> unwrap_err_caqti in
         ()
 
-let verify_wire_disable
+  let jsont = WireSetupMessage.jsont
-    WireTeardownMessage.{ payto_uri; master_sig_del; validity_end } =
+
+  let f req server _env =
+    let db_conn = Vif.Server.device Devices.db_connection server in
+    let res =
+      let* v = Vif.Request.of_json req |> unwrap_err_msg in
+      let* () = verify v in
+      let* () = do_ ~db_conn v in
+      Ok ""
+    in
+    Respond_util.respond_with_res res req
+end
+
+module Wire_disable = struct
+  let verify WireTeardownMessage.{ payto_uri; master_sig_del; validity_end } =
     let open Bin_sig.MasterDelWire in
     verify ~key:Config.Exchange.master_public_key master_sig_del
       { end_date= validity_end; h_wire= Bin_type.FullPaytoHash.hash payto_uri }
 
-let update_wire_disable ~db_conn
+  let do_ ~db_conn
       WireTeardownMessage.{ payto_uri; master_sig_del= _; validity_end } =
     let* last_change_opt =
       Pg.lookup_wire_timestamp db_conn ~payto_uri |> unwrap_err_caqti
@@ -445,7 +588,21 @@ let update_wire_disable ~db_conn
         in
         ()
 
-let verify_drain
+  let jsont = WireTeardownMessage.jsont
+
+  let f req server _env =
+    let db_conn = Vif.Server.device Devices.db_connection server in
+    let res =
+      let* v = Vif.Request.of_json req |> unwrap_err_msg in
+      let* () = verify v in
+      let* () = do_ ~db_conn v in
+      Ok ""
+    in
+    Respond_util.respond_with_res res req
+end
+
+module Drain = struct
+  let verify
       DrainProfitsMessage.
         {
           debit_account_section;
@@ -466,11 +623,25 @@ let verify_drain
         h_payto= FullPaytoHash.hash credit_payto_uri;
       }
 
-let update_drain ~db_conn v =
+  let do_ ~db_conn v =
     let+ () = Pg.insert_drain_profit db_conn v |> unwrap_err_caqti in
     ()
 
-let verify_aml_officier
+  let jsont = DrainProfitsMessage.jsont
+
+  let f req server _env =
+    let db_conn = Vif.Server.device Devices.db_connection server in
+    let res =
+      let* v = Vif.Request.of_json req |> unwrap_err_msg in
+      let* () = verify v in
+      let* () = do_ ~db_conn v in
+      Ok ""
+    in
+    Respond_util.respond_with_res res req
+end
+
+module AmlOfficer = struct
+  let verify
       AmlOfficerSetup.
         {
           officer_pub;
@@ -490,13 +661,25 @@ let verify_aml_officier
         is_active;
       }
 
-let update_aml_officier ~db_conn v =
+  let do_ ~db_conn v =
     let+ _last_change = Pg.insert_aml_officer db_conn v |> unwrap_err_caqti in
     ()
 
-[@@@ocaml.warning "-27"]
+  let jsont = AmlOfficerSetup.jsont
 
-let verify_partner
+  let f req server _env =
+    let db_conn = Vif.Server.device Devices.db_connection server in
+    let res =
+      let* v = Vif.Request.of_json req |> unwrap_err_msg in
+      let* () = verify v in
+      let* () = do_ ~db_conn v in
+      Ok ""
+    in
+    Respond_util.respond_with_res res req
+end
+
+module Partners = struct
+  let verify
       ExchangePartnerSetupRequest.
         {
           partner_base_url;
@@ -518,6 +701,19 @@ let verify_partner
         h_url= Bin_type.Hash_64_cstr.hash partner_base_url;
       }
 
-let update_partner ~db_conn v =
+  let do_ ~db_conn v =
     let+ () = Pg.insert_partner db_conn v |> unwrap_err_caqti in
     ()
+
+  let jsont = ExchangePartnerSetupRequest.jsont
+
+  let f req server _env =
+    let db_conn = Vif.Server.device Devices.db_connection server in
+    let res =
+      let* v = Vif.Request.of_json req |> unwrap_err_msg in
+      let* () = verify v in
+      let* () = do_ ~db_conn v in
+      Ok ""
+    in
+    Respond_util.respond_with_res res req
+end

src/mte.ml

@@ -26,42 +26,37 @@ let routes =
   let open Vif.Type in
   let get_ path = get (path /?? nil) in
   let post path jsont = post (json_encoding jsont) (path /?? nil) in
+  let static =
     let v s = rel / s in
-  let open Handler in
     [
       get_ rel --> hello;
       get_ (v "terms") --> Static.terms;
       get_ (v "privacy") --> Static.privacy;
-    get_ (v "management" / "keys") --> management_keys_get;
-    post (v "management" / "keys") management_keys_post_jsont
-    --> management_keys_post;
-    post
-      (v "management" / "denominations" /% string `Path / "revoke")
-      management_denom_revoke_jsont
-    --> management_denom_revoke;
-    post
-      (v "management" / "signkeys" /% string `Path / "revoke")
-      management_signkey_revoke_jsont
-    --> management_signkey_revoke;
-    post (v "management" / "auditors") management_auditors_jsont
-    --> management_auditors;
-    post
-      (v "management" / "auditors" /% string `Path / "disable")
-      management_auditors_disable_jsont
-    --> management_auditors_disable;
-    post (v "management" / "wire-fee") management_wire_fee_jsont
-    --> management_wire_fee;
-    post (v "management" / "global-fees") management_global_fees_jsont
-    --> management_global_fees;
-    post (v "management" / "wire") management_wire_jsont --> management_wire;
-    post (v "management" / "wire" / "disable") management_wire_disable_jsont
-    --> management_wire_disable;
-    post (v "management" / "drain") management_drain_jsont --> management_drain;
-    post (v "management" / "aml-officers") management_aml_officers_jsont
-    --> management_aml_officers;
-    post (v "management" / "partners") management_partners_jsont
-    --> management_partners;
     ]
+  in
+  let management =
+    let open Management in
+    let v s = rel / "management" / s in
+    [
+      get_ (v "keys") --> Keys_get.f;
+      post (v "keys") Keys_post.jsont --> Keys_post.f;
+      post (v "denominations" /% string `Path / "revoke") Denom_revoke.jsont
+      --> Denom_revoke.f;
+      post (v "signkeys" /% string `Path / "revoke") Signkey_revoke.jsont
+      --> Signkey_revoke.f;
+      post (v "auditors") Auditors.jsont --> Auditors.f;
+      post (v "auditors" /% string `Path / "disable") Auditors_disable.jsont
+      --> Auditors_disable.f;
+      post (v "wire-fee") Wire_fee.jsont --> Wire_fee.f;
+      post (v "global-fees") Global_fees.jsont --> Global_fees.f;
+      post (v "wire") Wire.jsont --> Wire.f;
+      post (v "wire" / "disable") Wire_disable.jsont --> Wire_disable.f;
+      post (v "drain") Drain.jsont --> Drain.f;
+      post (v "aml-officers") AmlOfficer.jsont --> AmlOfficer.f;
+      post (v "partners") Partners.jsont --> Partners.f;
+    ]
+  in
+  static @ management
 
 let () =
   Util.Log_reporter.setup ();

src/pg.ml

@@ -13,6 +13,7 @@ module type CONN = Caqti_miou.CONNECTION
 
 open Crypto
 open Bin_type
+open Api
 
 module Caqti_type = struct
   include Caqti_type
@@ -205,7 +206,7 @@ let insert_auditor =
        is_active, last_change) VALUES ($1, $2, $3, true, $4)"
   in
   fun (module Conn : CONN)
-    Api.AuditorSetupMessage.
+    AuditorSetupMessage.
       { auditor_url; auditor_name; auditor_pub; master_sig= _; validity_start }
   ->
     Conn.exec insert_auditor
@@ -218,7 +219,7 @@ let update_auditor =
        last_change=$5 WHERE auditor_pub=$1"
   in
   fun (module Conn : CONN)
-    Api.AuditorSetupMessage.
+    AuditorSetupMessage.
       { auditor_url; auditor_name; auditor_pub; master_sig= _; validity_start }
   ->
     Conn.exec update_auditor
@@ -285,7 +286,7 @@ let insert_global_fee =
        $12)"
   in
   fun (module Conn : CONN)
-    Api.GlobalFees.
+    GlobalFees.
       {
         start_date;
         end_date;
@@ -330,7 +331,7 @@ let insert_wire =
        ($1,$2,$3::TEXT::JSONB,$4::TEXT::JSONB,$5,true,$6,$7,$8)"
   in
   fun (module Conn : CONN)
-    Api.WireSetupMessage.
+    WireSetupMessage.
       {
         payto_uri;
         master_sig_wire;
@@ -368,7 +369,7 @@ let update_wire =
        bank_label=$8, priority=$9 WHERE payto_uri=$1"
   in
   fun (module Conn : CONN)
-    Api.WireSetupMessage.
+    WireSetupMessage.
       {
         payto_uri;
         master_sig_wire;
@@ -417,7 +418,7 @@ let insert_drain_profit =
        trigger_date, amount, master_sig) VALUES ($1, $2, $3, $4, ($5,$6), $7)"
   in
   fun (module Conn : CONN)
-    Api.DrainProfitsMessage.
+    DrainProfitsMessage.
       {
         debit_account_section;
         credit_payto_uri;
@@ -438,7 +439,7 @@ let insert_aml_officer =
        $4, $5, $6)"
   in
   fun (module Conn : CONN)
-    Api.AmlOfficerSetup.
+    AmlOfficerSetup.
       {
         officer_pub;
         officer_name;
@@ -461,7 +462,7 @@ let insert_partner =
        $3, $4, ($5,$6), $7, $8) ON CONFLICT DO NOTHING"
   in
   fun (module Conn : CONN)
-    Api.ExchangePartnerSetupRequest.
+    ExchangePartnerSetupRequest.
       {
         partner_base_url;
         partner_pub;

src/respond_util.ml

@@ -0,0 +1,22 @@
+let respond_with_plain_text_error ?status e req =
+  let open Vif.Response in
+  let open Syntax in
+  let status = Option.value ~default:`Bad_request status in
+  let* () = add ~field:"content-type" "text/plain; charset=utf-8" in
+  let* () = with_string req e in
+  respond status
+
+let respond_with_ok_json content req =
+  let open Vif.Response in
+  let open Syntax in
+  let* () = add ~field:"content-type" "application/json" in
+  let* () = with_string req content in
+  respond `OK
+
+let respond_with_res res req =
+  match res with
+  | Error err ->
+      Logs.err (fun m -> m "%s." err);
+      let err = Fmt.str "%s@." err in
+      respond_with_plain_text_error err req
+  | Ok content -> respond_with_ok_json content req