swrup/mte
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

rename handler modules

Browse source
This commit is contained in:
swrup 2025-12-15 17:06:35 +01:00
parent f0254c6f5d
commit f69f393abb
3 changed files with 1 additions and 1 deletions
Download patch file Download diff file Expand all files Collapse all files

728
src/management.ml
View file

@ -1,728 +0,0 @@
open Syntax
open Api
module Keys_get = struct
let mk_future_denom ~sm_key_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= _;
} :
Denom_data.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_key_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_data.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 =
let future_signkeys =
Secmod.get_signkeys sm
|> List.filter (fun k -> Option.is_none k.Signkey_data.master_sig)
|> List.map (fun signkey ->
let sm_signkey_priv = Secmod.get_sm_key_priv sm in
mk_future_signkey ~sm_signkey_priv signkey)
in
let future_denoms =
Secmod.get_denoms sm
|> List.filter (fun k -> Option.is_none k.Denom_data.master_sig)
|> List.map (fun denom ->
let sm_key_priv = Secmod.get_sm_key_priv sm in
mk_future_denom ~sm_key_priv denom)
in
let master_pub = Config.Exchange.master_public_key in
let denom_secmod_public_key = Secmod.get_sm_key_pub sm in
let signkey_secmod_public_key = Secmod.get_sm_key_pub sm 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 =
Logs.info (fun m -> m "GET /management/keys/");
let sm = Vif.Server.device Devices.secmod server in
let res =
let v = mk_future_keys_response ~sm 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 DenomSignature.{ h_denom_pub; master_sig } =
let denom_hash = HashCode.to_denomination_hash h_denom_pub in
let* denom =
Secmod.get_denoms sm
|> List.find_opt (fun (denom : Denom_data.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 SignKeySignature.{ key; master_sig } =
let* signkey =
Secmod.get_signkeys sm
|> List.find_opt (fun (signkey : Signkey_data.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 MasterSignatures.{ denom_sigs; signkey_sigs } =
let* () = list_iter (verify_denom_signature ~sm) denom_sigs in
let* () = list_iter (verify_signkey_signature ~sm) signkey_sigs in
Ok ()
(* TODO move to test *)
let check_master_signatures_update ~db_conn ~sm =
Secmod.get_denoms sm
|> list_iter (fun denom ->
let error = Error "update_master_signatures sanity check failure" in
let* opt =
Pg.lookup_denomination_key db_conn denom.Denom_data.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 do_ ~db_conn ~sm MasterSignatures.{ denom_sigs; signkey_sigs } =
let* () =
signkey_sigs
|> List.map (fun SignKeySignature.{ key; master_sig } ->
(key, master_sig))
|> Secmod.add_signkey_master_signatures db_conn sm
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.add_denom_master_signatures db_conn sm
in
let* () = check_master_signatures_update ~db_conn ~sm in
Ok ()
let jsont = MasterSignatures.jsont
let f req server _env =
Logs.info (fun m -> m "POST /management/keys/");
let db_conn = Vif.Server.device Devices.db_connection server in
let sm = Vif.Server.device Devices.secmod server in
let res =
let* v = Vif.Request.of_json req |> unwrap_err_msg in
let* () = verify ~sm v in
let* () = do_ ~db_conn ~sm 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 do_ ~db_conn ~sm h_denom_pub DenomRevocationSignature.{ master_sig } =
let* () = Secmod.revoke_denomination sm h_denom_pub master_sig in
let+ () =
Pg.insert_denomination_revocation db_conn h_denom_pub master_sig
|> unwrap_err_caqti
in
()
let jsont = DenomRevocationSignature.jsont
let f req h_denom_pub server _env =
Logs.info (fun m -> m "POST /management/denominations/$H_DENOM_PUB/revoke/");
let db_conn = Vif.Server.device Devices.db_connection server in
let sm = Vif.Server.device Devices.secmod 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 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 do_ ~db_conn ~sm exchange_pub SignkeyRevocationSignature.{ master_sig } =
let* () = Secmod.revoke_signkey sm exchange_pub master_sig in
let+ () =
Pg.insert_signkey_revocation db_conn exchange_pub master_sig
|> unwrap_err_caqti
in
()
let jsont = SignkeyRevocationSignature.jsont
let f req exchange_pub server _env =
Logs.info (fun m -> m "POST /management/signkeys/$EXCHANGE_PUB/revoke/");
let db_conn = Vif.Server.device Devices.db_connection server in
let sm = Vif.Server.device Devices.secmod 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 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;
} =
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
+ protection against replay attack that I don't understand *)
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 jsont = AuditorSetupMessage.jsont
let f req server _env =
Logs.info (fun m -> m "POST /management/auditors/");
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 =
Logs.info (fun m -> m "POST /management/auditors/$AUDITOR_PUB/revoke/");
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.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 jsont = WireFeeSetupMessage.jsont
let f req server _env =
Logs.info (fun m -> m "POST /management/wire-fee/");
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;
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;
purse_account_limit;
}
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 =
Logs.info (fun m -> m "POST /management/global-fees/");
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 ->
(* TODO wire *)
let last_change = Ptime_clock.now () |> Option.some in
let v =
ExchangeWireAccount.
{
payto_uri= v.payto_uri;
conversion_url= None;
debit_restrictions= [];
credit_restrictions= [];
master_sig= v.master_sig_wire;
bank_label= v.bank_label;
priority= v.priority;
}
in
let+ () = Pg.insert_wire db_conn ~last_change v |> unwrap_err_caqti in
()
let jsont = WireSetupMessage.jsont
let f req server _env =
Logs.info (fun m -> m "POST /management/wire/");
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 =
Logs.info (fun m -> m "POST /management/wire/disable/");
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
{
wtid;
date;
amount;
h_section= Hash_64_cstr.hash debit_account_section;
h_payto= FullPaytoHash.hash credit_payto_uri;
}
let do_ ~db_conn v =
let+ () = Pg.insert_drain_profit db_conn v |> unwrap_err_caqti in
()
let jsont = DrainProfitsMessage.jsont
let f req server _env =
Logs.info (fun m -> m "POST /management/drain/");
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
{
change_date;
officer_pub;
h_officer_name= Bin_type.Hash_64_cstr.hash officer_name;
is_active;
}
let do_ ~db_conn v =
let+ _last_change = Pg.insert_aml_officer db_conn v |> unwrap_err_caqti in
()
let jsont = AmlOfficerSetup.jsont
let f req server _env =
Logs.info (fun m -> m "POST /management/aml-officers/");
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_pub;
start_date;
end_date;
wad_frequency;
wad_fee;
h_url= Bin_type.Hash_64_cstr.hash partner_base_url;
}
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 =
Logs.info (fun m -> m "POST /management/partners/");
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