From 5dec579179dda4a37546b639a8b10118c90ef195 Mon Sep 17 00:00:00 2001 From: swrup Date: Thu, 11 Dec 2025 09:54:40 +0100 Subject: [PATCH] ~ --- src/handler.ml | 206 -------- src/management.ml | 1134 +++++++++++++++++++++++++------------------ src/mte.ml | 67 ++- src/pg.ml | 17 +- src/respond_util.ml | 22 + 5 files changed, 727 insertions(+), 719 deletions(-) delete mode 100644 src/handler.ml create mode 100644 src/respond_util.ml diff --git a/src/handler.ml b/src/handler.ml deleted file mode 100644 index 1ffc0378..00000000 --- a/src/handler.ml +++ /dev/null @@ -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 diff --git a/src/management.ml b/src/management.ml index 158bcd27..77ee9f3c 100644 --- a/src/management.ml +++ b/src/management.ml @@ -1,523 +1,719 @@ +open Syntax open Api -let mk_future_denom ~sm_denom_priv - ({ - pub; - priv= _; - section_name; - value; - stamp_start; - stamp_expire_withdraw; - stamp_expire_deposit; - stamp_expire_legal; - fee_withdraw; - fee_deposit; - fee_refresh; - fee_refund; - age_mask; - h_pub; - master_sig= _; - } : - Denomination.t) = - let denom_pub = - DenominationKey.of_rsa RsaDenominationKey.{ age_mask; rsa_pub= pub } - in - let denom_secmod_sig = - let open Bin_sig.DenominationKeyAnnouncement in - 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 - sign ~key:sm_denom_priv - { h_denom_pub; h_section_name; anchor_time; duration_withdraw } - in - FutureDenom. - { - section_name; - value; - stamp_start; - stamp_expire_withdraw; - stamp_expire_deposit; - stamp_expire_legal; - denom_pub; - fee_withdraw; - fee_deposit; - fee_refresh; - fee_refund; - denom_secmod_sig; - } +module Keys_get = struct + let mk_future_denom ~sm_denom_priv + ({ + pub; + priv= _; + section_name; + value; + stamp_start; + stamp_expire_withdraw; + stamp_expire_deposit; + stamp_expire_legal; + fee_withdraw; + fee_deposit; + fee_refresh; + fee_refund; + age_mask; + h_pub; + master_sig= _; + } : + Denomination.t) = + let denom_pub = + DenominationKey.of_rsa RsaDenominationKey.{ age_mask; rsa_pub= pub } + in + let denom_secmod_sig = + let open Bin_sig.DenominationKeyAnnouncement in + 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 + sign ~key:sm_denom_priv + { h_denom_pub; h_section_name; anchor_time; duration_withdraw } + in + FutureDenom. + { + section_name; + value; + stamp_start; + stamp_expire_withdraw; + stamp_expire_deposit; + stamp_expire_legal; + denom_pub; + fee_withdraw; + fee_deposit; + fee_refresh; + fee_refund; + denom_secmod_sig; + } -let mk_future_signkey ~sm_signkey_priv - ({ pub; priv= _; stamp_start; stamp_expire; stamp_end; master_sig= _ } : - Signkey.t) = - let signkey_secmod_sig = - let open Bin_sig.SigningKeyAnnouncement in - let exchange_pub = pub in - let anchor_time = stamp_start in - let duration = Timestamp.diff stamp_start stamp_expire in - sign ~key:sm_signkey_priv { exchange_pub; anchor_time; duration } - in - FutureSignKey. - { key= pub; stamp_start; stamp_expire; stamp_end; signkey_secmod_sig } + let mk_future_signkey ~sm_signkey_priv + ({ pub; priv= _; stamp_start; stamp_expire; stamp_end; master_sig= _ } : + Signkey.t) = + let signkey_secmod_sig = + let open Bin_sig.SigningKeyAnnouncement in + let exchange_pub = pub in + let anchor_time = stamp_start in + let duration = Timestamp.diff stamp_start stamp_expire in + sign ~key:sm_signkey_priv { exchange_pub; anchor_time; duration } + in + FutureSignKey. + { key= pub; stamp_start; stamp_expire; stamp_end; signkey_secmod_sig } -let mk_future_keys_response ~(sm_signkey : Secmod_signkey.t) - ~(sm_denom : Secmod_denom.t) = - let future_signkeys = - Secmod_signkey.get_signkeys sm_signkey - |> List.filter (fun k -> Option.is_none k.Signkey.master_sig) - |> List.map (fun signkey -> - let sm_signkey_priv = - (Secmod_signkey.get_sm_key sm_signkey).Signkey.priv + let mk_future_keys_response ~(sm_signkey : Secmod_signkey.t) + ~(sm_denom : Secmod_denom.t) = + let future_signkeys = + Secmod_signkey.get_signkeys sm_signkey + |> List.filter (fun k -> Option.is_none k.Signkey.master_sig) + |> List.map (fun signkey -> + let sm_signkey_priv = + (Secmod_signkey.get_sm_key sm_signkey).Signkey.priv + in + mk_future_signkey ~sm_signkey_priv signkey) + in + let future_denoms = + Secmod_denom.get_denoms sm_denom + |> List.filter (fun k -> Option.is_none k.Denomination.master_sig) + |> List.map (fun denom -> + let sm_denom_priv = (Secmod_denom.get_sm_key sm_denom).Signkey.priv in + mk_future_denom ~sm_denom_priv denom) + 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 + FutureKeysResponse. + { + future_denoms; + future_signkeys; + master_pub; + denom_secmod_public_key; + signkey_secmod_public_key; + } + + let jsont = FutureKeysResponse.jsont + + 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) + |> function + | None -> + Fmt.error + "404 not found, One of the keys for which a signature was provided \ + is unknown to the exchange." + | Some denom -> Ok denom + in + let open Bin_sig.DenominationKeyValidity in + let r : r = + { + master= Config.master_public_key; + start= denom.stamp_start; + expire_withdraw= denom.stamp_expire_withdraw; + expire_spend= denom.stamp_expire_deposit; + expire_legal= denom.stamp_expire_legal; + value= denom.value; + fee_withdraw= denom.fee_withdraw; + fee_deposit= denom.fee_deposit; + fee_refresh= denom.fee_refresh; + denom_hash; + } + in + verify ~key:Config.master_public_key master_sig r + + 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) + |> function + | None -> + Fmt.error + "404 not found, One of the keys for which a signature was provided \ + is unknown to the exchange." + | Some signkey -> Ok signkey + in + let open Bin_sig.ExchangeSigningKeyValidity in + let r : r = + { + start= signkey.stamp_start; + expire= signkey.stamp_expire; + end_= signkey.stamp_end; + signkey_pub= signkey.pub; + } + in + verify ~key:Config.master_public_key master_sig r + + let verify ~sm_signkey ~sm_denom 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 = + Secmod_denom.get_denoms sm_denom + |> list_iter (fun denom -> + let error = Error "update_master_signatures sanity check failure" in + let* opt = + Pg.lookup_denomination_key db_conn denom.Denomination.h_pub + |> unwrap_err_caqti in - mk_future_signkey ~sm_signkey_priv signkey) - in - let future_denoms = - Secmod_denom.get_denoms sm_denom - |> List.filter (fun k -> Option.is_none k.Denomination.master_sig) - |> List.map (fun denom -> - let sm_denom_priv = (Secmod_denom.get_sm_key sm_denom).Signkey.priv in - mk_future_denom ~sm_denom_priv denom) - 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 - FutureKeysResponse. - { - future_denoms; - future_signkeys; - master_pub; - denom_secmod_public_key; - signkey_secmod_public_key; - } + let* ( valid_from, + _expire_withdraw, + _expire_deposit, + _expire_legal, + coin, + _fee_withdraw, + _fee_deposit, + _fee_refresh, + fee_refund, + age_mask ) = + match opt with None -> error | Some v -> Ok v + in + let check = function false -> error | true -> Ok () in + let* () = + check (Timestamp.compare valid_from denom.stamp_start = Some 0) + in + let* () = check (coin = denom.value) in + let* () = check (fee_refund = denom.fee_refund) in + let* () = check (age_mask = denom.age_mask) in + Ok ()) -(* - ** - *) -open Syntax + 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)) + |> Secmod_signkey.add_master_signatures db_conn sm_signkey + in + let* () = + denom_sigs + |> List.map (fun DenomSignature.{ h_denom_pub; master_sig } -> + let h_denom_pub = HashCode.to_denomination_hash h_denom_pub in + (h_denom_pub, master_sig)) + |> Secmod_denom.add_master_signatures db_conn sm_denom + in + let* () = check_master_signatures_update ~db_conn ~sm_denom in + Ok () -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) - |> function - | None -> - Fmt.error - "404 not found, One of the keys for which a signature was provided \ - is unknown to the exchange." - | Some denom -> Ok denom - in - let open Bin_sig.DenominationKeyValidity in - let r : r = - { - master= Config.master_public_key; - start= denom.stamp_start; - expire_withdraw= denom.stamp_expire_withdraw; - expire_spend= denom.stamp_expire_deposit; - expire_legal= denom.stamp_expire_legal; - value= denom.value; - fee_withdraw= denom.fee_withdraw; - fee_deposit= denom.fee_deposit; - fee_refresh= denom.fee_refresh; - denom_hash; - } - in - verify ~key:Config.master_public_key master_sig r + let jsont = MasterSignatures.jsont -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) - |> function - | None -> - Fmt.error - "404 not found, One of the keys for which a signature was provided \ - is unknown to the exchange." - | Some signkey -> Ok signkey - in - let open Bin_sig.ExchangeSigningKeyValidity in - let r : r = - { - start= signkey.stamp_start; - expire= signkey.stamp_expire; - end_= signkey.stamp_end; - signkey_pub= signkey.pub; - } - in - verify ~key:Config.master_public_key master_sig r + 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 -let verify_master_signatures ~sm_signkey ~sm_denom - 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 () +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 do_ ~db_conn ~sm_denom h_denom_pub DenomRevocationSignature.{ master_sig } + = + 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 + () -(* 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 - let* opt = - Pg.lookup_denomination_key db_conn denom.Denomination.h_pub - |> unwrap_err_caqti - in - let* ( valid_from, - _expire_withdraw, - _expire_deposit, - _expire_legal, - coin, - _fee_withdraw, - _fee_deposit, - _fee_refresh, - fee_refund, - age_mask ) = - match opt with None -> error | Some v -> Ok v - in - let check = function false -> error | true -> Ok () in - let* () = - check (Timestamp.compare valid_from denom.stamp_start = Some 0) - in - let* () = check (coin = denom.value) in - let* () = check (fee_refund = denom.fee_refund) in - let* () = check (age_mask = denom.age_mask) in - Ok ()) + let jsont = DenomRevocationSignature.jsont -let update_master_signatures ~db_conn ~sm_signkey ~sm_denom - MasterSignatures.{ denom_sigs; signkey_sigs } = - let* () = - signkey_sigs - |> List.map (fun SignKeySignature.{ key; master_sig } -> (key, master_sig)) - |> Secmod_signkey.add_master_signatures db_conn sm_signkey - in - let* () = - denom_sigs - |> List.map (fun DenomSignature.{ h_denom_pub; master_sig } -> - let h_denom_pub = HashCode.to_denomination_hash h_denom_pub in - (h_denom_pub, master_sig)) - |> Secmod_denom.add_master_signatures db_conn sm_denom - in - let* () = check_master_signatures_update ~db_conn ~sm_denom in - Ok () + 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 -let verify_denom_revocation_sig h_denom_pub - DenomRevocationSignature.{ master_sig } = - let open Bin_sig.MasterDenominationKeyRevocation in - verify ~key:Config.Exchange.master_public_key master_sig { h_denom_pub } +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_denom_revocation ~db_conn ~sm_denom h_denom_pub - DenomRevocationSignature.{ master_sig } = - 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 do_ ~db_conn ~sm_signkey exchange_pub + SignkeyRevocationSignature.{ master_sig } = + 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 + () -let verify_signkey_revocation_sig exchange_pub - SignkeyRevocationSignature.{ master_sig } = - let open Bin_sig.MasterSigningKeyRevocation in - verify ~key:Config.Exchange.master_public_key master_sig { exchange_pub } + let jsont = SignkeyRevocationSignature.jsont -let update_signkey_revocation ~db_conn ~sm_signkey exchange_pub - SignkeyRevocationSignature.{ master_sig } = - 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 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 -let verify_auditor_add_sig - AuditorSetupMessage. - { 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 - { - start_date= validity_start; - auditor_pub; - h_auditor_url= Bin_type.Hash_64_cstr.hash auditor_url; - } +module Auditors = struct + let verify + AuditorSetupMessage. + { + 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 + { + start_date= validity_start; + auditor_pub; + h_auditor_url= Bin_type.Hash_64_cstr.hash auditor_url; + } -(* TODO timestamps last_change +/- checks *) -(* todo: there is something about use of monotonic time + (* TODO timestamps last_change +/- checks *) + (* 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 auditor_pub = v.AuditorSetupMessage.auditor_pub in - let validity_start = v.AuditorSetupMessage.validity_start in - let* last_date_opt = - Pg.lookup_auditor_timestamp db_conn auditor_pub |> unwrap_err_caqti - in - match last_date_opt with - | None -> - let+ () = Pg.insert_auditor db_conn v |> unwrap_err_caqti in - () - | Some last_date -> - let cmp = Timestamp.compare last_date validity_start |> Option.get in - if cmp > 0 then Error "more recent management auditor already present" - else - let+ () = Pg.update_auditor db_conn v |> unwrap_err_caqti in + 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 = + Pg.lookup_auditor_timestamp db_conn auditor_pub |> unwrap_err_caqti + in + match last_date_opt with + | None -> + let+ () = Pg.insert_auditor db_conn v |> unwrap_err_caqti in () + | Some last_date -> + let cmp = Timestamp.compare last_date validity_start |> Option.get in + if cmp > 0 then Error "more recent management auditor already present" + else + let+ () = Pg.update_auditor db_conn v |> unwrap_err_caqti in + () -let verify_auditor_disable_sig 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 jsont = AuditorSetupMessage.jsont -let auditor_disable ~db_conn auditor_pub - AuditorTeardownMessage.{ master_sig= _; validity_end } = - let* last_date_opt = - Pg.lookup_auditor_timestamp db_conn auditor_pub |> unwrap_err_caqti - in - match last_date_opt with - | None -> Error "auditor not found" - | Some last_date -> - let cmp = Timestamp.compare last_date validity_end |> Option.get in - if cmp > 0 then Error "more recent management auditor already present" - else + 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 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 + in + match last_date_opt with + | None -> Error "auditor not found" + | Some last_date -> + let cmp = Timestamp.compare last_date validity_end |> Option.get in + if cmp > 0 then Error "more recent management auditor already present" + else + let+ () = + Pg.disable_auditor db_conn ~auditor_pub ~change_date:validity_end + |> unwrap_err_caqti + in + () + + 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; + master_sig_wire; + fee_start; + fee_end; + closing_fee; + wire_fee; + } = + let open Bin_sig.MasterWireFee in + verify ~key:Config.Exchange.master_public_key master_sig_wire + { + h_wire_method= Bin_type.Hash_64_cstr.hash wire_method; + start_date= fee_start; + end_date= fee_end; + wire_fee; + closing_fee; + } + + let do_ ~db_conn + WireFeeSetupMessage. + { + wire_method; + master_sig_wire; + fee_start; + fee_end; + closing_fee; + wire_fee; + } = + let* wire_fee_opt = + Pg.lookup_wire_fee_by_time db_conn ~wire_method ~start_date:fee_start + ~end_date:fee_end + |> unwrap_err_caqti + in + match wire_fee_opt with + | Some (_wire_fee, _closing_fee) -> Error "wire-fee already setup" + | None -> let+ () = - Pg.disable_auditor db_conn ~auditor_pub ~change_date:validity_end + Pg.insert_wire_fee db_conn ~wire_method ~start_date:fee_start + ~end_date:fee_end ~wire_fee ~closing_fee ~master_sig:master_sig_wire |> unwrap_err_caqti in () -let verify_wire_fee_setup_sig - WireFeeSetupMessage. - { - wire_method; - master_sig_wire; - fee_start; - fee_end; - closing_fee; - wire_fee; - } = - let open Bin_sig.MasterWireFee in - verify ~key:Config.Exchange.master_public_key master_sig_wire - { - h_wire_method= Bin_type.Hash_64_cstr.hash wire_method; - start_date= fee_start; - end_date= fee_end; - wire_fee; - closing_fee; - } + let jsont = WireFeeSetupMessage.jsont -let update_wire_fee_setup ~db_conn - WireFeeSetupMessage. - { - wire_method; - master_sig_wire; - fee_start; - fee_end; - closing_fee; - wire_fee; - } = - let* wire_fee_opt = - Pg.lookup_wire_fee_by_time db_conn ~wire_method ~start_date:fee_start - ~end_date:fee_end - |> unwrap_err_caqti - in - match wire_fee_opt with - | Some (_wire_fee, _closing_fee) -> Error "wire-fee already setup" - | None -> - let+ () = - Pg.insert_wire_fee db_conn ~wire_method ~start_date:fee_start - ~end_date:fee_end ~wire_fee ~closing_fee ~master_sig:master_sig_wire - |> unwrap_err_caqti - in - () + 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 -let verify_global_fees - GlobalFees. +module Global_fees = struct + let verify + GlobalFees. + { + start_date; + end_date; + history_fee; + account_fee; + purse_fee; + history_expiration; + purse_account_limit; + purse_timeout; + master_sig; + } = + (* TODO what is kyc_timeout, kyc_fee ? *) + let dummy_amount = + Amount.make ~sign:None ~currency:"EUR" ~value:0_L ~fraction:0_l + |> Result.get_ok + in + let kyc_timeout = None in + let kyc_fee = dummy_amount in + (* * *) + let open Bin_sig.GlobalFees in + verify ~key:Config.Exchange.master_public_key master_sig { start_date; end_date; + purse_timeout; + kyc_timeout; + history_expiration; history_fee; + kyc_fee; account_fee; purse_fee; - history_expiration; purse_account_limit; - purse_timeout; - master_sig; - } = - (* TODO what is kyc_timeout, kyc_fee ? *) - let dummy_amount = - Amount.make ~sign:None ~currency:"EUR" ~value:0_L ~fraction:0_l - |> Result.get_ok - in - let kyc_timeout = None in - let kyc_fee = dummy_amount in - (* * *) - let open Bin_sig.GlobalFees in - verify ~key:Config.Exchange.master_public_key master_sig - { - start_date; - end_date; - purse_timeout; - kyc_timeout; - history_expiration; - history_fee; - kyc_fee; - account_fee; - purse_fee; - purse_account_limit; - } - -let update_global_fees ~db_conn v = - let* global_fees_opt = - let start_date = v.GlobalFees.start_date in - let end_date = v.GlobalFees.end_date in - Pg.lookup_global_fee_by_time db_conn ~start_date ~end_date - |> unwrap_err_caqti - in - match global_fees_opt with - | Some _ -> Error "global-fees already setup" - | None -> - let+ () = Pg.insert_global_fee db_conn v |> unwrap_err_caqti in - () - -let verify_wire - WireSetupMessage. - { - payto_uri; - master_sig_wire; - master_sig_add; - validity_start; - bank_label= _; - priority= _; - } = - (* TODO wire *) - let conversion_url = "" in - let credit_restrictions = "" in - let debit_restrictions = "" in - let open Bin_type in - let* () = - let open Bin_sig.MasterWireDetails in - verify ~key:Config.Exchange.master_public_key master_sig_wire - { - h_wire_details= FullPaytoHash.hash payto_uri; - h_conversion_url= Hash_64_cstr.hash conversion_url; - h_credit_restrictions= Hash_64_cstr.hash credit_restrictions; - h_debit_restrictions= Hash_64_cstr.hash debit_restrictions; } - in - let* () = - let open Bin_sig.MasterAddWire in - verify ~key:Config.Exchange.master_public_key master_sig_add + + 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 + Pg.lookup_global_fee_by_time db_conn ~start_date ~end_date + |> unwrap_err_caqti + in + match global_fees_opt with + | Some _ -> Error "global-fees already setup" + | None -> + let+ () = Pg.insert_global_fee db_conn v |> unwrap_err_caqti in + () + + 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; + master_sig_wire; + master_sig_add; + validity_start; + bank_label= _; + priority= _; + } = + (* TODO wire *) + let conversion_url = "" in + let credit_restrictions = "" in + let debit_restrictions = "" in + let open Bin_type in + let* () = + let open Bin_sig.MasterWireDetails in + verify ~key:Config.Exchange.master_public_key master_sig_wire + { + h_wire_details= FullPaytoHash.hash payto_uri; + h_conversion_url= Hash_64_cstr.hash conversion_url; + h_credit_restrictions= Hash_64_cstr.hash credit_restrictions; + h_debit_restrictions= Hash_64_cstr.hash debit_restrictions; + } + in + let* () = + let open Bin_sig.MasterAddWire in + verify ~key:Config.Exchange.master_public_key master_sig_add + { + start_date= validity_start; + h_wire= FullPaytoHash.hash payto_uri; + h_conversion_url= Hash_64_cstr.hash conversion_url; + h_credit_restrictions= Hash_64_cstr.hash credit_restrictions; + h_debit_restrictions= Hash_64_cstr.hash debit_restrictions; + } + in + Ok () + + 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 + in + match last_change_opt with + | Some _ -> Error "wire already setup" + | None -> + let+ () = Pg.insert_wire db_conn v |> unwrap_err_caqti in + () + + let jsont = WireSetupMessage.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_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 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 + in + match last_change_opt with + | None -> Error "wire not found" + | Some _ -> + let+ () = + Pg.disable_wire db_conn ~payto_uri ~validity_end |> unwrap_err_caqti + in + () + + 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; + credit_payto_uri; + wtid; + master_sig; + date; + amount; + } = + let open Bin_sig.MasterDrainProfit in + let open Bin_type in + verify ~key:Config.Exchange.master_public_key master_sig { - start_date= validity_start; - h_wire= FullPaytoHash.hash payto_uri; - h_conversion_url= Hash_64_cstr.hash conversion_url; - h_credit_restrictions= Hash_64_cstr.hash credit_restrictions; - h_debit_restrictions= Hash_64_cstr.hash debit_restrictions; - } - in - Ok () - -let update_wire ~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 - in - match last_change_opt with - | Some _ -> Error "wire already setup" - | None -> - let+ () = Pg.insert_wire db_conn v |> unwrap_err_caqti in - () - -let verify_wire_disable - 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 - WireTeardownMessage.{ payto_uri; master_sig_del= _; validity_end } = - let* last_change_opt = - Pg.lookup_wire_timestamp db_conn ~payto_uri |> unwrap_err_caqti - in - match last_change_opt with - | None -> Error "wire not found" - | Some _ -> - let+ () = - Pg.disable_wire db_conn ~payto_uri ~validity_end |> unwrap_err_caqti - in - () - -let verify_drain - DrainProfitsMessage. - { - debit_account_section; - credit_payto_uri; wtid; - master_sig; date; amount; - } = - let open Bin_sig.MasterDrainProfit in - let open Bin_type in - verify ~key:Config.Exchange.master_public_key master_sig - { - wtid; - date; - amount; - h_section= Hash_64_cstr.hash debit_account_section; - h_payto= FullPaytoHash.hash credit_payto_uri; - } + h_section= Hash_64_cstr.hash debit_account_section; + h_payto= FullPaytoHash.hash credit_payto_uri; + } -let update_drain ~db_conn v = - let+ () = Pg.insert_drain_profit db_conn v |> unwrap_err_caqti in - () + let do_ ~db_conn v = + let+ () = Pg.insert_drain_profit db_conn v |> unwrap_err_caqti in + () -let verify_aml_officier - AmlOfficerSetup. + 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; + officer_name; + is_active; + read_only= _; + master_sig; + change_date; + } = + let open Bin_sig.MasterAmlOfficerStatus in + let is_active = match is_active with true -> 1_l | false -> 0_l in + verify ~key:Config.Exchange.master_public_key master_sig { - officer_pub; - officer_name; - is_active; - read_only= _; - master_sig; change_date; - } = - let open Bin_sig.MasterAmlOfficerStatus in - let is_active = match is_active with true -> 1_l | false -> 0_l in - verify ~key:Config.Exchange.master_public_key master_sig - { - change_date; - officer_pub; - h_officer_name= Bin_type.Hash_64_cstr.hash officer_name; - is_active; - } + officer_pub; + h_officer_name= Bin_type.Hash_64_cstr.hash officer_name; + is_active; + } -let update_aml_officier ~db_conn v = - let+ _last_change = Pg.insert_aml_officer db_conn v |> unwrap_err_caqti in - () + 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 - ExchangePartnerSetupRequest. + 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; + partner_pub; + wad_frequency; + master_sig; + start_date; + end_date; + wad_fee; + } = + let open Bin_sig.PartnerConfiguration in + verify ~key:Config.Exchange.master_public_key master_sig { - partner_base_url; partner_pub; - wad_frequency; - master_sig; start_date; end_date; + wad_frequency; wad_fee; - } = - let open Bin_sig.PartnerConfiguration in - verify ~key:Config.Exchange.master_public_key master_sig - { - partner_pub; - start_date; - end_date; - wad_frequency; - wad_fee; - h_url= Bin_type.Hash_64_cstr.hash partner_base_url; - } + h_url= Bin_type.Hash_64_cstr.hash partner_base_url; + } -let update_partner ~db_conn v = - let+ () = Pg.insert_partner db_conn v |> unwrap_err_caqti in - () + 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 diff --git a/src/mte.ml b/src/mte.ml index 7a54c866..39a9d7bc 100644 --- a/src/mte.ml +++ b/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 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; - ] + let static = + let v s = rel / s in + [ + get_ rel --> hello; + get_ (v "terms") --> Static.terms; + get_ (v "privacy") --> Static.privacy; + ] + 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 (); diff --git a/src/pg.ml b/src/pg.ml index 7403b79e..acaba787 100644 --- a/src/pg.ml +++ b/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; diff --git a/src/respond_util.ml b/src/respond_util.ml new file mode 100644 index 00000000..3c4faf5d --- /dev/null +++ b/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