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

~

Browse source
This commit is contained in:
swrup 2025-12-11 09:54:40 +01:00
parent 625c194fff
commit 5dec579179
5 changed files with 727 additions and 719 deletions
Download patch file Download diff file Expand all files Collapse all files

206
src/handler.ml
View file

@ -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

1134
src/management.ml
View file

File diff suppressed because it is too large Load diff

67
src/mte.ml
View file

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

17
src/pg.ml
View file

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

22
src/respond_util.ml Normal file
View file

@ -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