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

rm keys.ml; use pool device

Browse source
This commit is contained in:
swrup 2026-04-03 13:59:59 +02:00 • committed by Swrup
parent 1c0167f401
commit 8a9f188db3
7 changed files with 462 additions and 467 deletions
Download patch file Download diff file Expand all files Collapse all files

1
src/dune
View file

@ -15,7 +15,6 @@
mte_management mte_management
secmod_eddsa secmod_eddsa
secmod_rsa secmod_rsa
keys
log_reporter) log_reporter)
(link_flags :standard -cclib "-z solo5-abi=hvt") (link_flags :standard -cclib "-z solo5-abi=hvt")
(libraries (libraries

312
src/keys.ml
View file

@ -1,312 +0,0 @@
open Syntax
module DenominationHash = Hash.DenominationHash
open Time
module type S = sig
val sign : Eddsa.pub -> string -> Eddsa.sig_
val sign_denom : DenominationHash.t -> string -> Rsa.sig_
val find_signkey : Eddsa.pub -> Signkey.t option Result.t
val find_denomination : DenominationHash.t -> Denomination.t option Result.t
val signkeys : unit -> Signkey.t list Result.t
val denominations : unit -> Denomination.t list Result.t
val denominations_last_change : unit -> Timestamp.t
(* future keys *)
val make_future_keys_response : unit -> Api.FutureKeysResponse.t Result.t
val verify_future_signkey : Api.SignKeySignature.t -> unit Result.t
val verify_future_denomination : Api.DenomSignature.t -> unit Result.t
val certify_future_signkey : Api.SignKeySignature.t -> unit Result.t
val certify_future_denomination : Api.DenomSignature.t -> unit Result.t
val revoke_signkey :
Eddsa.pub -> Signatures.MasterSigningKeyRevocation.t -> unit Result.t
val revoke_denomination :
DenominationHash.t ->
Signatures.MasterDenominationKeyRevocation.t ->
unit Result.t
end
module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct
let conn = (module Conn : Pg.CONN)
let sm_eddsa = Secmod_eddsa.create Fs.t
let sm_rsa = Secmod_rsa.create Fs.t
(* - *)
let sign = Secmod_eddsa.sign sm_eddsa
let sign_denom = Secmod_rsa.sign sm_rsa
(* - *)
let find_signkey pub = Pg.find_signkey conn pub
let find_denomination h_pub = Pg.find_denomination conn h_pub
(* - *)
(* TODO *)
let last_change = ref Timestamp.never
let denominations_last_change () = !last_change
(* - *)
let warn_once msg =
let b = ref true in
fun () ->
if !b then begin
b := false;
Logs.warn (fun m -> m "%s" msg)
end
let warn_keyring_state_mismatch =
warn_once
"keyring state mismatch: database and secmod have different active keys \
data"
let signkeys =
fun () : Signkey.t list Result.t ->
let now = Timestamp.of_ptime @@ Mirage_ptime.now () in
let+ l = Pg.get_signkeys conn ~now in
let missing_l, l =
List.partition
(fun sk ->
Option.is_none (Secmod_eddsa.find_key sm_eddsa sk.Signkey.pub))
l
in
if missing_l <> [] then warn_keyring_state_mismatch ();
l
let denominations () =
let+ l = Pg.get_denominations conn () in
let missing_l, l =
List.partition
(fun dn ->
Option.is_none @@ Secmod_rsa.find_key sm_rsa dn.Denomination.h_pub)
l
in
if missing_l <> [] then warn_keyring_state_mismatch ();
l
let make_future_sk (pub, (start, expire)) =
Logs.debug (fun m -> m "make_future_sk: `%a`" Eddsa.pp_pub pub);
let open Time in
let stamp_start = Timestamp.of_absolute start in
let stamp_expire = Timestamp.of_absolute expire in
let stamp_end =
Timestamp.of_absolute
@@ TimeAbsolute.add start Config.Exchange.signkey_legal_duration
in
let signkey_secmod_sig =
let open Signatures.SigningKeyAnnouncement in
let exchange_pub = pub in
let anchor_time = stamp_start in
let duration = Timestamp.diff stamp_start stamp_expire in
signf
(Secmod_eddsa.sign_secmod sm_eddsa)
{ exchange_pub; anchor_time; duration }
in
Api.FutureSignKey.
{ key= pub; stamp_start; stamp_expire; stamp_end; signkey_secmod_sig }
let make_future_dn (h_pub, (coin, pub, start)) =
let {
Config.Coin.section_name;
value;
duration_withdraw;
duration_spend;
duration_legal;
fee_withdraw;
fee_deposit;
fee_refresh;
fee_refund;
_;
} =
coin
in
Logs.debug (fun m -> m "make_future_dn: `%a`" DenominationHash.pp h_pub);
let open Time in
let stamp_start = Timestamp.of_absolute start in
let stamp_expire_withdraw =
Timestamp.of_absolute @@ TimeAbsolute.add start duration_withdraw
in
let stamp_expire_deposit =
Timestamp.of_absolute @@ TimeAbsolute.add start duration_spend
in
let stamp_expire_legal =
Timestamp.of_absolute @@ TimeAbsolute.add start duration_legal
in
let open Api in
let rsa_denomination_key =
RsaDenominationKey.{ age_mask= 0; rsa_pub= pub }
in
let denom_pub = DenominationKey.Rsa rsa_denomination_key in
let denom_secmod_sig =
let open Signatures.DenominationKeyAnnouncement in
signf
(Secmod_rsa.sign_secmod sm_rsa)
{
h_denom_pub= h_pub;
h_section_name= Hash.H64_cstring.hash section_name;
anchor_time= stamp_start;
duration_withdraw= Timestamp.diff stamp_start stamp_expire_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 find_future_signkey pub =
match Secmod_eddsa.find_key sm_eddsa pub with
| None -> Fmt.error_msg "future signkey not found"
| Some (pub, (t1, t2)) ->
let fsk = make_future_sk (pub, (t1, t2)) in
Ok fsk
let find_future_denomination h_pub =
match Secmod_rsa.find_key sm_rsa h_pub with
| None -> Fmt.error_msg "future denomination not found"
| Some v ->
let future_dn = make_future_dn v in
Ok future_dn
let make_future_keys_response () =
let now = Timestamp.of_ptime @@ Mirage_ptime.now () in
(* get keys from database to filter out keys already certified *)
let* sk_db_l = Pg.get_signkeys conn ~now in
let sk_ht = Hashtbl.create 0xff in
List.iter (fun sk -> Hashtbl.replace sk_ht sk.Signkey.pub ()) sk_db_l;
let future_signkeys =
Secmod_eddsa.keys sm_eddsa
|> List.filter (fun (pub, _) -> not @@ Hashtbl.mem sk_ht pub)
|> List.map make_future_sk
in
let* dn_db_l = Pg.get_denominations conn () in
let dn_ht = Hashtbl.create 0xff in
List.iter (fun dn -> Hashtbl.replace dn_ht dn.Denomination.h_pub ()) dn_db_l;
let future_denoms =
Secmod_rsa.keys sm_rsa
|> List.filter (fun (h_pub, _) -> not @@ Hashtbl.mem dn_ht h_pub)
|> List.map make_future_dn
in
Logs.info (fun m ->
m "%d future signkey(s) and %d future denomination(s) to certify"
(List.length future_signkeys)
(List.length future_denoms));
let signkey_secmod_public_key = Secmod_eddsa.sm_pub sm_eddsa in
let denom_secmod_public_key = Secmod_rsa.sm_pub sm_rsa in
Ok
Api.FutureKeysResponse.
{
future_denoms;
future_signkeys;
master_pub= Config.Exchange.master_public_key;
denom_secmod_public_key;
signkey_secmod_public_key;
}
let sk_of_future_sk
Api.FutureSignKey.
{ key; stamp_start; stamp_expire; stamp_end; signkey_secmod_sig= _ }
master_sig =
Signkey.{ pub= key; stamp_start; stamp_expire; stamp_end; master_sig }
let dn_of_future_dn
Api.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= _;
} h_pub master_sig =
let (Rsa Api.RsaDenominationKey.{ age_mask= _; rsa_pub }) = denom_pub in
Denomination.
{
pub= rsa_pub;
value;
stamp_start;
stamp_expire_withdraw;
stamp_expire_deposit;
stamp_expire_legal;
fee_withdraw;
fee_deposit;
fee_refresh;
fee_refund;
age_mask= 0;
h_pub;
master_sig;
}
let verify_future_signkey Api.SignKeySignature.{ key; master_sig } =
let* fsk = find_future_signkey key in
let sk = sk_of_future_sk fsk master_sig in
Signkey.verify_exchange_signing_key_validity ~key:Config.master_public_key
sk
let verify_future_denomination Api.DenomSignature.{ h_denom_pub; master_sig }
=
let* fdn = find_future_denomination h_denom_pub in
let dn = dn_of_future_dn fdn h_denom_pub master_sig in
Denomination.verify_denomination_key_validity ~key:Config.master_public_key
dn
let certify_future_signkey Api.SignKeySignature.{ key= pub; master_sig } =
match Secmod_eddsa.find_key sm_eddsa pub with
| None -> Error (`Not_found "future eddsa key")
| Some (pub, (t1, t2)) ->
(* rebuild it *)
let future_sk = make_future_sk (pub, (t1, t2)) in
let sk = sk_of_future_sk future_sk master_sig in
let+ () = Pg.insert_signkey conn sk in
Logs.info (fun m -> m "certified signkey `%a`" Eddsa.pp_pub sk.pub);
()
let certify_future_denomination
Api.DenomSignature.{ h_denom_pub= h_pub; master_sig } =
match Secmod_rsa.find_key sm_rsa h_pub with
| None -> Error (`Not_found "future rsa denomination key")
| Some (h_pub, (section_name, pub, t1)) ->
let future_dn = make_future_dn (h_pub, (section_name, pub, t1)) in
let dn = dn_of_future_dn future_dn h_pub master_sig in
let+ () = Pg.insert_denom conn dn in
Logs.info (fun m ->
m "certified denomination `%a`" DenominationHash.pp dn.h_pub);
()
let revoke_signkey pub revoked_sig =
let* opt = Pg.find_signkey conn pub in
match opt with
| None -> Fmt.error_msg "signkey not found"
| Some _sk ->
let* () = Secmod_eddsa.revoke sm_eddsa pub in
let+ () = Pg.insert_signkey_revocation conn pub revoked_sig in
Logs.info (fun m -> m "revoked signkey `%a`" Eddsa.pp_pub pub);
()
let revoke_denomination h_pub revoked_sig =
let* opt = Pg.find_denomination conn h_pub in
match opt with
| None -> Fmt.error_msg "denomination not found"
| Some dn ->
let* () = Secmod_rsa.revoke sm_rsa dn.h_pub in
let+ () = Pg.insert_denomination_revocation conn dn.h_pub revoked_sig in
Logs.info (fun m ->
m "revoked denomination `%a`" DenominationHash.pp h_pub);
()
end

4
src/mte.ml
View file

@ -98,7 +98,9 @@ let () =
(* -- *) (* -- *)
let fs = Fat.create storage in let fs = Fat.create storage in
let cfg = Vifu.Config.v Config.Exchange.port in let cfg = Vifu.Config.v Config.Exchange.port in
let devices = Vifu.Devices.[ Mte_device.db_conn; Mte_device.keys ] in let devices =
Vifu.Devices.[ Mte_device.sm_eddsa; Mte_device.sm_rsa; Mte_device.pool ]
in
let handlers = [ Mte_handler.not_implemented_route ] in let handlers = [ Mte_handler.not_implemented_route ] in
let env = { Env.sw; stack; tcp; dns; fs } in let env = { Env.sw; stack; tcp; dns; fs } in
Logs.info (fun m -> m "Starting MTE server"); Logs.info (fun m -> m "Starting MTE server");

39
src/mte_device.ml
View file

@ -1,29 +1,24 @@
(* IMPROVE: use caqti pool let sm_eddsa =
[connect_pool] with parameter [?post_connect] for preflight *) let f (env : Env.t) = Secmod_eddsa.create env.fs in
let db_conn = let finally _ = () in
Vifu.Device.v ~name:"secmod-eddsa" ~finally [] f
let sm_rsa =
let f (env : Env.t) = Secmod_rsa.create env.fs in
let finally _ = () in
Vifu.Device.v ~name:"secmod-rsa" ~finally [] f
let pool : (Env.t, Pg.pool) Vifu.Device.device =
let f { Env.sw; stack; tcp; dns; fs= _ } = let f { Env.sw; stack; tcp; dns; fs= _ } =
Logs.info (fun m -> m "Connecting to database"); Logs.info (fun m -> m "Connecting to database");
let db_uri = Config.Exchangedb_postgres.config in let db_uri = Config.Exchangedb_postgres.config in
match Caqti_mnet.connect ~sw stack tcp dns db_uri with let post_connect conn = Pg.preflight conn in
match Caqti_mnet.connect_pool ~post_connect ~sw stack tcp dns db_uri with
| Error err -> | Error err ->
Fmt.failwith "Database connection failure: %a." Caqti_error.pp err Fmt.failwith "Database connection failure: %a." Caqti_error.pp err
| Ok conn -> | Ok pool ->
Logs.info (fun m -> m "Database connection done"); Logs.info (fun m -> m "Database connection done");
let () = Pg.preflight conn in pool
Logs.info (fun m -> m "Database connection preflight done");
conn
in in
let finally (module Conn : Pg.CONN) = Conn.disconnect () in let finally pool = Caqti_mnet.Pool.drain pool in
Vifu.Device.v ~name:"db_conn" ~finally [] f Vifu.Device.v ~name:"pool" ~finally [] f
let keys =
let f (module Conn : Pg.CONN) (env : Env.t) =
let (module Fs : Fat.FS) =
(module struct
let t = env.fs
end)
in
(module Keys.Make (Conn) (Fs) : Keys.S)
in
let finally _keys = () in
Vifu.Device.v ~name:"keys" ~finally [ Vifu.Device.value db_conn ] f

74
src/mte_info.ml
View file

@ -31,7 +31,48 @@ let config req _server _env =
aml_spa_dialect= None; aml_spa_dialect= None;
} }
let mk_keys ~db_conn (module Keys : Keys.S) ~last_issue_date = (* --- *)
(* TODO *)
let last_change = ref Timestamp.never
let get_denominations_last_change () = !last_change
let warn_once msg =
let b = ref true in
fun () ->
if !b then begin
b := false;
Logs.warn (fun m -> m "%s" msg)
end
let warn_keyring_state_mismatch =
warn_once
"keyring state mismatch: database and secmod have different active keys \
data"
let get_signkeys sm_eddsa pool =
let now = Timestamp.of_ptime @@ Mirage_ptime.now () in
let+ l = Pg.use_pool pool @@ fun conn -> Pg.get_signkeys conn ~now in
let missing_l, l =
List.partition
(fun sk -> Option.is_none (Secmod_eddsa.find_key sm_eddsa sk.Signkey.pub))
l
in
if missing_l <> [] then warn_keyring_state_mismatch ();
l
let get_denominations sm_rsa pool =
let+ l = Pg.use_pool pool @@ fun conn -> Pg.get_denominations conn () in
let missing_l, l =
List.partition
(fun dn ->
Option.is_none @@ Secmod_rsa.find_key sm_rsa dn.Denomination.h_pub)
l
in
if missing_l <> [] then warn_keyring_state_mismatch ();
l
let mk_keys sm_eddsa sm_rsa pool last_issue_date =
let version = Libtool_version.mte_protocol_version in let version = Libtool_version.mte_protocol_version in
let base_url = Config.base_url in let base_url = Config.base_url in
let currency = Config.currency in let currency = Config.currency in
@ -45,11 +86,15 @@ let mk_keys ~db_conn (module Keys : Keys.S) ~last_issue_date =
let stefan_lin = Config.stefan_lin in let stefan_lin = Config.stefan_lin in
(* type of the asset. "fiat", "crypto", "regional" or "stock". *) (* type of the asset. "fiat", "crypto", "regional" or "stock". *)
let asset_type = "fiat" in let asset_type = "fiat" in
let* accounts = Pg.get_wire_accounts db_conn () in let* accounts =
Pg.use_pool pool @@ fun conn -> Pg.get_wire_accounts conn ()
in
let* wire_fees = let* wire_fees =
(* wire_methods? *) (* wire_methods? *)
let wire_method = "x-taler-bank" in let wire_method = "x-taler-bank" in
let+ wire_fees = Pg.get_wire_fees db_conn ~wire_method in let+ wire_fees =
Pg.use_pool pool @@ fun conn -> Pg.get_wire_fees conn ~wire_method
in
String_map.singleton wire_method wire_fees String_map.singleton wire_method wire_fees
in in
let wads = [] in let wads = [] in
@ -61,8 +106,8 @@ let mk_keys ~db_conn (module Keys : Keys.S) ~last_issue_date =
let hard_limits = [] in let hard_limits = [] in
let zero_limits = [] in let zero_limits = [] in
let* denom_l = Keys.denominations () in let* denom_l = get_denominations sm_rsa pool in
let list_issue_date = Keys.denominations_last_change () in let list_issue_date = get_denominations_last_change () in
let denom_l = let denom_l =
(* if `?last_issue_date` query param does not exactly match the `stamp_start` (* if `?last_issue_date` query param does not exactly match the `stamp_start`
of one of the denomination keys, all keys are returned *) of one of the denomination keys, all keys are returned *)
@ -86,7 +131,7 @@ let mk_keys ~db_conn (module Keys : Keys.S) ~last_issue_date =
in in
let denominations = Denomination.make_denom_group_sorted denom_l in let denominations = Denomination.make_denom_group_sorted denom_l in
let* signkeys = Keys.signkeys () in let* signkeys = get_signkeys sm_eddsa pool in
(* the eddsa pub key used to sign exchange_sig *) (* the eddsa pub key used to sign exchange_sig *)
let* exchange_pub = let* exchange_pub =
@ -103,7 +148,8 @@ let mk_keys ~db_conn (module Keys : Keys.S) ~last_issue_date =
(* ! depends on denominations order *) (* ! depends on denominations order *)
let exchange_sig = let exchange_sig =
let open Signatures.ExchangeKeySet in let open Signatures.ExchangeKeySet in
signf (Keys.sign exchange_pub) signf
(Secmod_eddsa.sign sm_eddsa exchange_pub)
R. R.
{ {
list_issue_date; list_issue_date;
@ -112,10 +158,13 @@ let mk_keys ~db_conn (module Keys : Keys.S) ~last_issue_date =
in in
let recoup = (* /recoup *) [] in let recoup = (* /recoup *) [] in
let* global_fees = Pg.get_global_fees db_conn ~start_date:Timestamp.zero in let* global_fees =
Pg.use_pool pool @@ fun conn ->
Pg.get_global_fees conn ~start_date:Timestamp.zero
in
let* auditors = let* auditors =
(* /auditors/$AUDITOR_PUB/$H_DENOM_PUB *) (* /auditors/$AUDITOR_PUB/$H_DENOM_PUB *)
Pg.get_auditor_keys db_conn Pg.use_pool pool @@ fun conn -> Pg.get_auditor_keys conn
in in
let extensions = None in let extensions = None in
let extensions_sig = None in let extensions_sig = None in
@ -162,8 +211,9 @@ let keys req server _env =
Logs.info (fun m -> m "GET /keys"); Logs.info (fun m -> m "GET /keys");
Respond.result req jsont Respond.result req jsont
@@ @@
let db_conn = Vifu.Server.device Mte_device.db_conn server in let sm_eddsa = Vifu.Server.device Mte_device.sm_eddsa server in
let keys = Vifu.Server.device Mte_device.keys server in let sm_rsa = Vifu.Server.device Mte_device.sm_rsa server in
let pool = Vifu.Server.device Mte_device.pool server in
let* last_issue_date = let* last_issue_date =
match Vifu.Queries.get req "last_issue_date" with match Vifu.Queries.get req "last_issue_date" with
| [] -> Ok None | [] -> Ok None
@ -173,4 +223,4 @@ let keys req server _env =
Fmt.error_msg "invalid `?last_issue_date` query param, not an int" Fmt.error_msg "invalid `?last_issue_date` query param, not an int"
| Some n -> Ok (Some (Timestamp.of_s n))) | Some n -> Ok (Some (Timestamp.of_s n)))
in in
mk_keys ~db_conn keys ~last_issue_date mk_keys sm_eddsa sm_rsa pool last_issue_date

476
src/mte_management.ml
View file

@ -3,32 +3,282 @@ open Api
open Hash open Hash
open Time open Time
let request_of_json req =
Vifu.Request.of_json req |> Result.map_error (fun (`Msg e) -> `Json_decode e)
module Future_keys = struct
let make_future_sk sm_eddsa (pub, (start, expire)) =
Logs.debug (fun m -> m "make_future_sk: `%a`" Eddsa.pp_pub pub);
let open Time in
let stamp_start = Timestamp.of_absolute start in
let stamp_expire = Timestamp.of_absolute expire in
let stamp_end =
Timestamp.of_absolute
@@ TimeAbsolute.add start Config.Exchange.signkey_legal_duration
in
let signkey_secmod_sig =
let open Signatures.SigningKeyAnnouncement in
let exchange_pub = pub in
let anchor_time = stamp_start in
let duration = Timestamp.diff stamp_start stamp_expire in
signf
(Secmod_eddsa.sign_secmod sm_eddsa)
{ exchange_pub; anchor_time; duration }
in
Api.FutureSignKey.
{ key= pub; stamp_start; stamp_expire; stamp_end; signkey_secmod_sig }
let make_future_dn sm_rsa (h_pub, (coin, pub, start)) =
let {
Config.Coin.section_name;
value;
duration_withdraw;
duration_spend;
duration_legal;
fee_withdraw;
fee_deposit;
fee_refresh;
fee_refund;
_;
} =
coin
in
Logs.debug (fun m -> m "make_future_dn: `%a`" DenominationHash.pp h_pub);
let open Time in
let stamp_start = Timestamp.of_absolute start in
let stamp_expire_withdraw =
Timestamp.of_absolute @@ TimeAbsolute.add start duration_withdraw
in
let stamp_expire_deposit =
Timestamp.of_absolute @@ TimeAbsolute.add start duration_spend
in
let stamp_expire_legal =
Timestamp.of_absolute @@ TimeAbsolute.add start duration_legal
in
let open Api in
let rsa_denomination_key =
RsaDenominationKey.{ age_mask= 0; rsa_pub= pub }
in
let denom_pub = DenominationKey.Rsa rsa_denomination_key in
let denom_secmod_sig =
let open Signatures.DenominationKeyAnnouncement in
signf
(Secmod_rsa.sign_secmod sm_rsa)
{
h_denom_pub= h_pub;
h_section_name= Hash.H64_cstring.hash section_name;
anchor_time= stamp_start;
duration_withdraw= Timestamp.diff stamp_start stamp_expire_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 make_future_keys_response sm_eddsa sm_rsa pool =
let now = Timestamp.of_ptime @@ Mirage_ptime.now () in
(* get keys from database to filter out keys already certified *)
let* sk_db_l = Pg.use_pool pool @@ fun conn -> Pg.get_signkeys conn ~now in
let sk_ht = Hashtbl.create 0xff in
List.iter (fun sk -> Hashtbl.replace sk_ht sk.Signkey.pub ()) sk_db_l;
let future_signkeys =
Secmod_eddsa.keys sm_eddsa
|> List.filter (fun (pub, _) -> not @@ Hashtbl.mem sk_ht pub)
|> List.map (make_future_sk sm_eddsa)
in
let* dn_db_l =
Pg.use_pool pool @@ fun conn -> Pg.get_denominations conn ()
in
let dn_ht = Hashtbl.create 0xff in
List.iter (fun dn -> Hashtbl.replace dn_ht dn.Denomination.h_pub ()) dn_db_l;
let future_denoms =
Secmod_rsa.keys sm_rsa
|> List.filter (fun (h_pub, _) -> not @@ Hashtbl.mem dn_ht h_pub)
|> List.map (make_future_dn sm_rsa)
in
Logs.info (fun m ->
m "%d future signkey(s) and %d future denomination(s) to certify"
(List.length future_signkeys)
(List.length future_denoms));
let signkey_secmod_public_key = Secmod_eddsa.sm_pub sm_eddsa in
let denom_secmod_public_key = Secmod_rsa.sm_pub sm_rsa in
Ok
Api.FutureKeysResponse.
{
future_denoms;
future_signkeys;
master_pub= Config.Exchange.master_public_key;
denom_secmod_public_key;
signkey_secmod_public_key;
}
let find_future_signkey sm_eddsa pub =
match Secmod_eddsa.find_key sm_eddsa pub with
| None -> Fmt.error_msg "future signkey not found"
| Some (pub, (t1, t2)) ->
let fsk = make_future_sk sm_eddsa (pub, (t1, t2)) in
Ok fsk
let find_future_denomination sm_rsa h_pub =
match Secmod_rsa.find_key sm_rsa h_pub with
| None -> Fmt.error_msg "future denomination not found"
| Some v ->
let future_dn = make_future_dn sm_rsa v in
Ok future_dn
let sk_of_future_sk
Api.FutureSignKey.
{ key; stamp_start; stamp_expire; stamp_end; signkey_secmod_sig= _ }
master_sig =
Signkey.{ pub= key; stamp_start; stamp_expire; stamp_end; master_sig }
let dn_of_future_dn
Api.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= _;
} h_pub master_sig =
let (Rsa Api.RsaDenominationKey.{ age_mask= _; rsa_pub }) = denom_pub in
Denomination.
{
pub= rsa_pub;
value;
stamp_start;
stamp_expire_withdraw;
stamp_expire_deposit;
stamp_expire_legal;
fee_withdraw;
fee_deposit;
fee_refresh;
fee_refund;
age_mask= 0;
h_pub;
master_sig;
}
let verify_future_signkey sm_eddsa Api.SignKeySignature.{ key; master_sig } =
let* fsk = find_future_signkey sm_eddsa key in
let sk = sk_of_future_sk fsk master_sig in
Signkey.verify_exchange_signing_key_validity ~key:Config.master_public_key
sk
let verify_future_denomination sm_rsa
Api.DenomSignature.{ h_denom_pub; master_sig } =
let* fdn = find_future_denomination sm_rsa h_denom_pub in
let dn = dn_of_future_dn fdn h_denom_pub master_sig in
Denomination.verify_denomination_key_validity ~key:Config.master_public_key
dn
let certify_future_signkey sm_eddsa pool
Api.SignKeySignature.{ key= pub; master_sig } =
match Secmod_eddsa.find_key sm_eddsa pub with
| None -> Error (`Not_found "future eddsa key")
| Some (pub, (t1, t2)) ->
(* rebuild it *)
let future_sk = make_future_sk sm_eddsa (pub, (t1, t2)) in
let sk = sk_of_future_sk future_sk master_sig in
let+ () = Pg.use_pool pool @@ fun conn -> Pg.insert_signkey conn sk in
Logs.info (fun m -> m "certified signkey `%a`" Eddsa.pp_pub sk.pub);
()
let certify_future_denomination sm_rsa pool
Api.DenomSignature.{ h_denom_pub= h_pub; master_sig } =
match Secmod_rsa.find_key sm_rsa h_pub with
| None -> Error (`Not_found "future rsa denomination key")
| Some (h_pub, (section_name, pub, t1)) ->
let future_dn =
make_future_dn sm_rsa (h_pub, (section_name, pub, t1))
in
let dn = dn_of_future_dn future_dn h_pub master_sig in
let+ () = Pg.use_pool pool @@ fun conn -> Pg.insert_denom conn dn in
Logs.info (fun m ->
m "certified denomination `%a`" DenominationHash.pp dn.h_pub);
()
let revoke_signkey sm_eddsa pool pub revoked_sig =
let* opt = Pg.use_pool pool @@ fun conn -> Pg.find_signkey conn pub in
match opt with
| None -> Fmt.error_msg "signkey not found"
| Some _sk ->
let* () = Secmod_eddsa.revoke sm_eddsa pub in
let+ () =
Pg.use_pool pool @@ fun conn ->
Pg.insert_signkey_revocation conn pub revoked_sig
in
Logs.info (fun m -> m "revoked signkey `%a`" Eddsa.pp_pub pub);
()
let revoke_denomination sm_rsa pool h_pub revoked_sig =
let* opt =
Pg.use_pool pool @@ fun conn -> Pg.find_denomination conn h_pub
in
match opt with
| None -> Fmt.error_msg "denomination not found"
| Some dn ->
let* () = Secmod_rsa.revoke sm_rsa dn.h_pub in
let+ () =
Pg.use_pool pool @@ fun conn ->
Pg.insert_denomination_revocation conn dn.h_pub revoked_sig
in
Logs.info (fun m ->
m "revoked denomination `%a`" DenominationHash.pp h_pub);
()
end
module Keys_get = struct module Keys_get = struct
let jsont = FutureKeysResponse.jsont let jsont = FutureKeysResponse.jsont
let f req server _env = let f req server _env =
Logs.info (fun m -> m "GET /management/keys/"); Logs.info (fun m -> m "GET /management/keys/");
let (module Keys : Keys.S) = Vifu.Server.device Mte_device.keys server in let sm_eddsa = Vifu.Server.device Mte_device.sm_eddsa server in
let sm_rsa = Vifu.Server.device Mte_device.sm_rsa server in
let pool = Vifu.Server.device Mte_device.pool server in
Respond.result req jsont Respond.result req jsont
@@ @@
let* v = Keys.make_future_keys_response () in let* v = Future_keys.make_future_keys_response sm_eddsa sm_rsa pool in
Ok v Ok v
end end
let request_of_json req =
Vifu.Request.of_json req |> Result.map_error (fun (`Msg e) -> `Json_decode e)
module Keys_post = struct module Keys_post = struct
let verify (module Keys : Keys.S) let verify sm_eddsa sm_rsa MasterSignatures.{ denom_sigs; signkey_sigs } =
MasterSignatures.{ denom_sigs; signkey_sigs } = let* () =
let* () = list_iter Keys.verify_future_signkey signkey_sigs in list_iter (Future_keys.verify_future_signkey sm_eddsa) signkey_sigs
let* () = list_iter Keys.verify_future_denomination denom_sigs in in
let* () =
list_iter (Future_keys.verify_future_denomination sm_rsa) denom_sigs
in
Ok () Ok ()
let process (module Keys : Keys.S) let process sm_eddsa sm_rsa pool MasterSignatures.{ denom_sigs; signkey_sigs }
MasterSignatures.{ denom_sigs; signkey_sigs } = =
let* () = list_iter Keys.certify_future_signkey signkey_sigs in let* () =
let* () = list_iter Keys.certify_future_denomination denom_sigs in list_iter (Future_keys.certify_future_signkey sm_eddsa pool) signkey_sigs
in
let* () =
list_iter (Future_keys.certify_future_denomination sm_rsa pool) denom_sigs
in
Ok () Ok ()
let jsont = MasterSignatures.jsont let jsont = MasterSignatures.jsont
@ -37,22 +287,24 @@ module Keys_post = struct
Logs.info (fun m -> m "POST /management/keys/"); Logs.info (fun m -> m "POST /management/keys/");
Respond.result_no_content req Respond.result_no_content req
@@ @@
let keys = Vifu.Server.device Mte_device.keys server in let sm_eddsa = Vifu.Server.device Mte_device.sm_eddsa server in
let sm_rsa = Vifu.Server.device Mte_device.sm_rsa server in
let pool = Vifu.Server.device Mte_device.pool server in
let* v = request_of_json req in let* v = request_of_json req in
let* () = verify keys v in let* () = verify sm_eddsa sm_rsa v in
let* () = process keys v in let* () = process sm_eddsa sm_rsa pool v in
Ok () Ok ()
end end
module Denom_revoke = struct module Denom_revoke = struct
let verify (module Keys : Keys.S) h_denom_pub let verify h_denom_pub DenomRevocationSignature.{ master_sig } =
DenomRevocationSignature.{ master_sig } =
let open Signatures.MasterDenominationKeyRevocation in let open Signatures.MasterDenominationKeyRevocation in
verify Config.master_public_key master_sig { h_denom_pub } verify Config.master_public_key master_sig { h_denom_pub }
let process (module Keys : Keys.S) h_denom_pub let process sm_rsa pool h_denom_pub DenomRevocationSignature.{ master_sig } =
DenomRevocationSignature.{ master_sig } = let+ () =
let+ () = Keys.revoke_denomination h_denom_pub master_sig in Future_keys.revoke_denomination sm_rsa pool h_denom_pub master_sig
in
() ()
let jsont = DenomRevocationSignature.jsont let jsont = DenomRevocationSignature.jsont
@ -61,26 +313,28 @@ module Denom_revoke = struct
Logs.info (fun m -> m "POST /management/denominations/$H_DENOM_PUB/revoke/"); Logs.info (fun m -> m "POST /management/denominations/$H_DENOM_PUB/revoke/");
Respond.result_no_content req Respond.result_no_content req
@@ @@
let keys = Vifu.Server.device Mte_device.keys server in let sm_rsa = Vifu.Server.device Mte_device.sm_rsa server in
let pool = Vifu.Server.device Mte_device.pool server in
let* h_denom_pub = let* h_denom_pub =
DenominationHash.of_crockford h_denom_pub DenominationHash.of_crockford h_denom_pub
|> Result.map_error (fun e -> `Msg e) |> Result.map_error (fun e -> `Msg e)
in in
let* v = request_of_json req in let* v = request_of_json req in
let* () = verify keys h_denom_pub v in let* () = verify h_denom_pub v in
let* () = process keys h_denom_pub v in let* () = process sm_rsa pool h_denom_pub v in
Ok () Ok ()
end end
module Signkey_revoke = struct module Signkey_revoke = struct
let verify (module Keys : Keys.S) exchange_pub let verify exchange_pub SignkeyRevocationSignature.{ master_sig } =
SignkeyRevocationSignature.{ master_sig } =
let open Signatures.MasterSigningKeyRevocation in let open Signatures.MasterSigningKeyRevocation in
verify Config.master_public_key master_sig { exchange_pub } verify Config.master_public_key master_sig { exchange_pub }
let process (module Keys : Keys.S) exchange_pub let process sm_eddsa pool exchange_pub
SignkeyRevocationSignature.{ master_sig } = SignkeyRevocationSignature.{ master_sig } =
let+ () = Keys.revoke_signkey exchange_pub master_sig in let+ () =
Future_keys.revoke_signkey sm_eddsa pool exchange_pub master_sig
in
() ()
let jsont = SignkeyRevocationSignature.jsont let jsont = SignkeyRevocationSignature.jsont
@ -89,18 +343,19 @@ module Signkey_revoke = struct
Logs.info (fun m -> m "POST /management/signkeys/$EXCHANGE_PUB/revoke/"); Logs.info (fun m -> m "POST /management/signkeys/$EXCHANGE_PUB/revoke/");
Respond.result_no_content req Respond.result_no_content req
@@ @@
let keys = Vifu.Server.device Mte_device.keys server in let sm_eddsa = Vifu.Server.device Mte_device.sm_eddsa server in
let pool = Vifu.Server.device Mte_device.pool server in
let* exchange_pub = let* exchange_pub =
Eddsa.pub_of_crockford exchange_pub |> Result.map_error (fun e -> `Msg e) Eddsa.pub_of_crockford exchange_pub |> Result.map_error (fun e -> `Msg e)
in in
let* v = request_of_json req in let* v = request_of_json req in
let* () = verify keys exchange_pub v in let* () = verify exchange_pub v in
let* () = process keys exchange_pub v in let* () = process sm_eddsa pool exchange_pub v in
Ok () Ok ()
end end
module Auditors = struct module Auditors = struct
let verify (module Keys : Keys.S) let verify
AuditorSetupMessage. AuditorSetupMessage.
{ {
auditor_url; auditor_url;
@ -117,21 +372,27 @@ module Auditors = struct
h_auditor_url= H64_cstring.hash auditor_url; h_auditor_url= H64_cstring.hash auditor_url;
} }
let process ~db_conn v = let process pool v =
let auditor_pub = v.AuditorSetupMessage.auditor_pub in let auditor_pub = v.AuditorSetupMessage.auditor_pub in
let validity_start = v.AuditorSetupMessage.validity_start in let validity_start = v.AuditorSetupMessage.validity_start in
let* opt = Pg.find_auditor db_conn auditor_pub in let* opt =
Pg.use_pool pool @@ fun conn -> Pg.find_auditor conn auditor_pub
in
match opt with match opt with
| None -> | None ->
let auditor = Pg_type.Auditor.of_setup_message v in let auditor = Pg_type.Auditor.of_setup_message v in
let+ () = Pg.update_auditor db_conn auditor in let+ () =
Pg.use_pool pool @@ fun conn -> Pg.update_auditor conn auditor
in
Logs.info (fun m -> m "enabled auditor"); Logs.info (fun m -> m "enabled auditor");
() ()
| Some auditor -> | Some auditor ->
if Timestamp.compare validity_start auditor.last_change <= 0 then if Timestamp.compare validity_start auditor.last_change <= 0 then
Error (`Conflict "replay detected on enable-auditor") Error (`Conflict "replay detected on enable-auditor")
else else
let+ () = Pg.update_auditor db_conn auditor in let+ () =
Pg.use_pool pool @@ fun conn -> Pg.update_auditor conn auditor
in
Logs.info (fun m -> m "updated auditor"); Logs.info (fun m -> m "updated auditor");
() ()
@ -141,24 +402,24 @@ module Auditors = struct
Logs.info (fun m -> m "POST /management/auditors/"); Logs.info (fun m -> m "POST /management/auditors/");
Respond.result_no_content req Respond.result_no_content req
@@ @@
let keys = Vifu.Server.device Mte_device.keys server in let pool = Vifu.Server.device Mte_device.pool server in
let db_conn = Vifu.Server.device Mte_device.db_conn server in
let* v = request_of_json req in let* v = request_of_json req in
let* () = verify keys v in let* () = verify v in
let* () = process ~db_conn v in let* () = process pool v in
Ok () Ok ()
end end
module Auditors_disable = struct module Auditors_disable = struct
let verify (module Keys : Keys.S) auditor_pub let verify auditor_pub AuditorTeardownMessage.{ master_sig; validity_end } =
AuditorTeardownMessage.{ master_sig; validity_end } =
let open Signatures.MasterDelAuditor in let open Signatures.MasterDelAuditor in
verify Config.master_public_key master_sig verify Config.master_public_key master_sig
{ end_date= validity_end; auditor_pub } { end_date= validity_end; auditor_pub }
let process ~db_conn auditor_pub let process pool auditor_pub
AuditorTeardownMessage.{ master_sig= _; validity_end } = AuditorTeardownMessage.{ master_sig= _; validity_end } =
let* opt = Pg.find_auditor db_conn auditor_pub in let* opt =
Pg.use_pool pool @@ fun conn -> Pg.find_auditor conn auditor_pub
in
match opt with match opt with
| None -> Error (`Not_found "auditor pub key") | None -> Error (`Not_found "auditor pub key")
| Some auditor -> ( | Some auditor -> (
@ -173,7 +434,9 @@ module Auditors_disable = struct
let auditor = let auditor =
{ auditor with last_change= validity_end; is_active= false } { auditor with last_change= validity_end; is_active= false }
in in
let+ () = Pg.update_auditor db_conn auditor in let+ () =
Pg.use_pool pool @@ fun conn -> Pg.update_auditor conn auditor
in
Logs.info (fun m -> Logs.info (fun m ->
m "revoked auditor `%a`" Eddsa.pp_pub auditor_pub); m "revoked auditor `%a`" Eddsa.pp_pub auditor_pub);
()) ())
@ -184,19 +447,18 @@ module Auditors_disable = struct
Logs.info (fun m -> m "POST /management/auditors/$AUDITOR_PUB/disable/"); Logs.info (fun m -> m "POST /management/auditors/$AUDITOR_PUB/disable/");
Respond.result_no_content req Respond.result_no_content req
@@ @@
let keys = Vifu.Server.device Mte_device.keys server in let pool = Vifu.Server.device Mte_device.pool server in
let db_conn = Vifu.Server.device Mte_device.db_conn server in
let* auditor_pub = let* auditor_pub =
Eddsa.pub_of_crockford auditor_pub |> Result.map_error (fun e -> `Msg e) Eddsa.pub_of_crockford auditor_pub |> Result.map_error (fun e -> `Msg e)
in in
let* v = request_of_json req in let* v = request_of_json req in
let* () = verify keys auditor_pub v in let* () = verify auditor_pub v in
let* () = process ~db_conn auditor_pub v in let* () = process pool auditor_pub v in
Ok () Ok ()
end end
module Wire_fee = struct module Wire_fee = struct
let verify (module Keys : Keys.S) let verify
WireFeeSetupMessage. WireFeeSetupMessage.
{ {
wire_method; wire_method;
@ -216,14 +478,15 @@ module Wire_fee = struct
closing_fee; closing_fee;
} }
let process ~db_conn (v : WireFeeSetupMessage.t) = let process pool (v : WireFeeSetupMessage.t) =
let* wire_fees = let* wire_fees =
Pg.get_wire_fees_by_time db_conn ~wire_method:v.wire_method Pg.use_pool pool @@ fun conn ->
Pg.get_wire_fees_by_time conn ~wire_method:v.wire_method
~start_date:v.fee_start ~end_date:v.fee_end ~start_date:v.fee_start ~end_date:v.fee_end
in in
match wire_fees with match wire_fees with
| [] -> | [] ->
let+ () = Pg.insert_wire_fee db_conn v in let+ () = Pg.use_pool pool @@ fun conn -> Pg.insert_wire_fee conn v in
Logs.info (fun m -> m "added wire fee"); Logs.info (fun m -> m "added wire fee");
() ()
| [ vv ] -> ( | [ vv ] -> (
@ -246,26 +509,28 @@ module Wire_fee = struct
Logs.info (fun m -> m "POST /management/wire-fee/"); Logs.info (fun m -> m "POST /management/wire-fee/");
Respond.result_no_content req Respond.result_no_content req
@@ @@
let keys = Vifu.Server.device Mte_device.keys server in let pool = Vifu.Server.device Mte_device.pool server in
let db_conn = Vifu.Server.device Mte_device.db_conn server in
let* v = request_of_json req in let* v = request_of_json req in
let* () = verify keys v in let* () = verify v in
let* () = process ~db_conn v in let* () = process pool v in
Ok () Ok ()
end end
module Global_fees = struct module Global_fees = struct
let verify v = GlobalFees.verify_global_fees ~key:Config.master_public_key v let verify v = GlobalFees.verify_global_fees ~key:Config.master_public_key v
let process ~db_conn v = let process pool v =
let* global_fees = let* global_fees =
let start_date = v.GlobalFees.start_date in let start_date = v.GlobalFees.start_date in
let end_date = v.GlobalFees.end_date in let end_date = v.GlobalFees.end_date in
Pg.get_global_fees_by_time db_conn ~start_date ~end_date Pg.use_pool pool @@ fun conn ->
Pg.get_global_fees_by_time conn ~start_date ~end_date
in in
match global_fees with match global_fees with
| [] -> | [] ->
let+ () = Pg.insert_global_fees db_conn v in let+ () =
Pg.use_pool pool @@ fun conn -> Pg.insert_global_fees conn v
in
Logs.info (fun m -> m "added global fees"); Logs.info (fun m -> m "added global fees");
() ()
| [ vv ] -> ( | [ vv ] -> (
@ -292,15 +557,15 @@ module Global_fees = struct
Logs.info (fun m -> m "POST /management/global-fees/"); Logs.info (fun m -> m "POST /management/global-fees/");
Respond.result_no_content req Respond.result_no_content req
@@ @@
let db_conn = Vifu.Server.device Mte_device.db_conn server in let pool = Vifu.Server.device Mte_device.pool server in
let* v = request_of_json req in let* v = request_of_json req in
let* () = verify v in let* () = verify v in
let* () = process ~db_conn v in let* () = process pool v in
Ok () Ok ()
end end
module Wire = struct module Wire = struct
let verify (module Keys : Keys.S) let verify
WireSetupMessage. WireSetupMessage.
{ {
payto_uri; payto_uri;
@ -354,7 +619,7 @@ module Wire = struct
in in
Ok () Ok ()
let process ~db_conn let process pool
WireSetupMessage. WireSetupMessage.
{ {
payto_uri; payto_uri;
@ -367,7 +632,7 @@ module Wire = struct
bank_label; bank_label;
priority; priority;
} = } =
let* opt = Pg.find_wire db_conn ~payto_uri in let* opt = Pg.use_pool pool @@ fun conn -> Pg.find_wire conn ~payto_uri in
match opt with match opt with
| None -> | None ->
let wire = let wire =
@ -383,8 +648,8 @@ module Wire = struct
} }
in in
let+ () = let+ () =
Pg.update_wire db_conn ~is_active:true ~last_change:validity_start Pg.use_pool pool @@ fun conn ->
wire Pg.update_wire conn ~is_active:true ~last_change:validity_start wire
in in
Logs.info (fun m -> m "added wire method"); Logs.info (fun m -> m "added wire method");
() ()
@ -393,8 +658,8 @@ module Wire = struct
Error (`Conflict "replay detected on enable-wire") Error (`Conflict "replay detected on enable-wire")
else else
let+ () = let+ () =
Pg.update_wire db_conn ~is_active:true ~last_change:validity_start Pg.use_pool pool @@ fun conn ->
wire Pg.update_wire conn ~is_active:true ~last_change:validity_start wire
in in
Logs.info (fun m -> m "updated wire method"); Logs.info (fun m -> m "updated wire method");
() ()
@ -405,24 +670,22 @@ module Wire = struct
Logs.info (fun m -> m "POST /management/wire/"); Logs.info (fun m -> m "POST /management/wire/");
Respond.result_no_content req Respond.result_no_content req
@@ @@
let keys = Vifu.Server.device Mte_device.keys server in let pool = Vifu.Server.device Mte_device.pool server in
let db_conn = Vifu.Server.device Mte_device.db_conn server in
let* v = request_of_json req in let* v = request_of_json req in
let* () = verify keys v in let* () = verify v in
let* () = process ~db_conn v in let* () = process pool v in
Ok () Ok ()
end end
module Wire_disable = struct module Wire_disable = struct
let verify (module Keys : Keys.S) let verify WireTeardownMessage.{ payto_uri; master_sig_del; validity_end } =
WireTeardownMessage.{ payto_uri; master_sig_del; validity_end } =
let open Signatures.MasterDelWire in let open Signatures.MasterDelWire in
verify Config.master_public_key master_sig_del verify Config.master_public_key master_sig_del
{ end_date= validity_end; h_wire= FullPaytoHash.hash payto_uri } { end_date= validity_end; h_wire= FullPaytoHash.hash payto_uri }
let process ~db_conn let process pool
WireTeardownMessage.{ payto_uri; master_sig_del= _; validity_end } = WireTeardownMessage.{ payto_uri; master_sig_del= _; validity_end } =
let* opt = Pg.find_wire db_conn ~payto_uri in let* opt = Pg.use_pool pool @@ fun conn -> Pg.find_wire conn ~payto_uri in
match opt with match opt with
| None -> Error (`Not_found "wire payto-uri") | None -> Error (`Not_found "wire payto-uri")
| Some (wire, _is_active, last_change) -> | Some (wire, _is_active, last_change) ->
@ -430,8 +693,8 @@ module Wire_disable = struct
Error (`Conflict "replay detected on disable-wire") Error (`Conflict "replay detected on disable-wire")
else else
let+ () = let+ () =
Pg.update_wire db_conn ~is_active:false ~last_change:validity_end Pg.use_pool pool @@ fun conn ->
wire Pg.update_wire conn ~is_active:false ~last_change:validity_end wire
in in
Logs.info (fun m -> m "disabled wire method"); Logs.info (fun m -> m "disabled wire method");
() ()
@ -442,16 +705,15 @@ module Wire_disable = struct
Logs.info (fun m -> m "POST /management/wire/disable/"); Logs.info (fun m -> m "POST /management/wire/disable/");
Respond.result_no_content req Respond.result_no_content req
@@ @@
let keys = Vifu.Server.device Mte_device.keys server in let pool = Vifu.Server.device Mte_device.pool server in
let db_conn = Vifu.Server.device Mte_device.db_conn server in
let* v = request_of_json req in let* v = request_of_json req in
let* () = verify keys v in let* () = verify v in
let* () = process ~db_conn v in let* () = process pool v in
Ok () Ok ()
end end
module Drain = struct module Drain = struct
let verify (module Keys : Keys.S) let verify
DrainProfitsMessage. DrainProfitsMessage.
{ {
debit_account_section; debit_account_section;
@ -471,14 +733,19 @@ module Drain = struct
h_payto= FullPaytoHash.hash credit_payto_uri; h_payto= FullPaytoHash.hash credit_payto_uri;
} }
let process ~db_conn v = let process pool v =
let* opt = Pg.find_drain_profit db_conn v.DrainProfitsMessage.wtid in let* opt =
Pg.use_pool pool @@ fun conn ->
Pg.find_drain_profit conn v.DrainProfitsMessage.wtid
in
match opt with match opt with
| Some _ -> | Some _ ->
Logs.info (fun m -> m "drain profit message already added to database"); Logs.info (fun m -> m "drain profit message already added to database");
Ok () Ok ()
| None -> | None ->
let+ () = Pg.insert_drain_profit db_conn v in let+ () =
Pg.use_pool pool @@ fun conn -> Pg.insert_drain_profit conn v
in
Logs.info (fun m -> m "added drain profit message to database"); Logs.info (fun m -> m "added drain profit message to database");
() ()
@ -488,16 +755,15 @@ module Drain = struct
Logs.info (fun m -> m "POST /management/drain/"); Logs.info (fun m -> m "POST /management/drain/");
Respond.result_no_content req Respond.result_no_content req
@@ @@
let keys = Vifu.Server.device Mte_device.keys server in let pool = Vifu.Server.device Mte_device.pool server in
let db_conn = Vifu.Server.device Mte_device.db_conn server in
let* v = request_of_json req in let* v = request_of_json req in
let* () = verify keys v in let* () = verify v in
let* () = process ~db_conn v in let* () = process pool v in
Ok () Ok ()
end end
module AmlOfficer = struct module AmlOfficer = struct
let verify (module Keys : Keys.S) let verify
AmlOfficerSetup. AmlOfficerSetup.
{ {
officer_pub; officer_pub;
@ -517,8 +783,10 @@ module AmlOfficer = struct
is_active; is_active;
} }
let process ~db_conn v = let process pool v =
let+ _last_change = Pg.insert_aml_officer db_conn v in let+ _last_change =
Pg.use_pool pool @@ fun conn -> Pg.insert_aml_officer conn v
in
() ()
let jsont = AmlOfficerSetup.jsont let jsont = AmlOfficerSetup.jsont
@ -527,16 +795,15 @@ module AmlOfficer = struct
Logs.info (fun m -> m "POST /management/aml-officers/"); Logs.info (fun m -> m "POST /management/aml-officers/");
Respond.result_no_content req Respond.result_no_content req
@@ @@
let keys = Vifu.Server.device Mte_device.keys server in let pool = Vifu.Server.device Mte_device.pool server in
let db_conn = Vifu.Server.device Mte_device.db_conn server in
let* v = request_of_json req in let* v = request_of_json req in
let* () = verify keys v in let* () = verify v in
let* () = process ~db_conn v in let* () = process pool v in
Ok () Ok ()
end end
module Partners = struct module Partners = struct
let verify (module Keys : Keys.S) let verify
ExchangePartnerSetupRequest. ExchangePartnerSetupRequest.
{ {
partner_base_url; partner_base_url;
@ -558,8 +825,8 @@ module Partners = struct
h_url= H64_cstring.hash partner_base_url; h_url= H64_cstring.hash partner_base_url;
} }
let process ~db_conn v = let process pool v =
let+ () = Pg.insert_partner db_conn v in let+ () = Pg.use_pool pool @@ fun conn -> Pg.insert_partner conn v in
() ()
let jsont = ExchangePartnerSetupRequest.jsont let jsont = ExchangePartnerSetupRequest.jsont
@ -568,10 +835,9 @@ module Partners = struct
Logs.info (fun m -> m "POST /management/partners/"); Logs.info (fun m -> m "POST /management/partners/");
Respond.result_no_content req Respond.result_no_content req
@@ @@
let keys = Vifu.Server.device Mte_device.keys server in let pool = Vifu.Server.device Mte_device.pool server in
let db_conn = Vifu.Server.device Mte_device.db_conn server in
let* v = request_of_json req in let* v = request_of_json req in
let* () = verify keys v in let* () = verify v in
let* () = process ~db_conn v in let* () = process pool v in
Ok () Ok ()
end end

23
src/pg.ml
View file

@ -1,17 +1,17 @@
(* TODO
transaction
GNU Taler use of db-events? it seems caqti/pgx does not support it *)
module type CONN = Caqti_miou.CONNECTION module type CONN = Caqti_miou.CONNECTION
type conn = (module CONN)
type pool = (conn, Caqti_error.t) Caqti_mnet.Pool.t
let map_err r = let map_err r =
Result.map_error (Fmt.kstr (fun e -> `Caqti e) "%a" Caqti_error.pp) r Result.map_error (Fmt.kstr (fun e -> `Caqti e) "%a" Caqti_error.pp) r
let exec (module Conn : CONN) req v = Conn.exec req v |> map_err let exec (module Conn : CONN) req v = Conn.exec req v
let find (module Conn : CONN) req v = Conn.find req v |> map_err let find (module Conn : CONN) req v = Conn.find req v
let find_opt (module Conn : CONN) req v = Conn.find_opt req v |> map_err let find_opt (module Conn : CONN) req v = Conn.find_opt req v
let collect_list (module Conn : CONN) req v = Conn.collect_list req v |> map_err let collect_list (module Conn : CONN) req v = Conn.collect_list req v
let disconnect (module Conn : CONN) () = Conn.disconnect () let disconnect (module Conn : CONN) () = Conn.disconnect ()
let use_pool pool fn = Caqti_mnet.Pool.use fn pool |> map_err
open Caqti_request.Infix open Caqti_request.Infix
open Caqti_type open Caqti_type
@ -30,12 +30,7 @@ let preflight =
"SET search_path TO exchange;"; "SET search_path TO exchange;";
] ]
in in
fun conn -> fun conn -> Syntax.list_iter (fun p -> exec conn p ()) l
let r = Syntax.list_iter (fun p -> exec conn p ()) l in
match r with
| Error err ->
Fmt.failwith "Database preflight failure: %a." Result.pp_err err
| Ok () -> ()
let find_signkey = let find_signkey =
let req = let req =