From 8a9f188db3128268ec4dd807193f7b50160b8d00 Mon Sep 17 00:00:00 2001 From: swrup Date: Fri, 3 Apr 2026 13:59:59 +0200 Subject: [PATCH] rm keys.ml; use pool device --- src/dune | 1 - src/keys.ml | 312 --------------------------- src/mte.ml | 4 +- src/mte_device.ml | 39 ++-- src/mte_info.ml | 74 +++++-- src/mte_management.ml | 476 ++++++++++++++++++++++++++++++++---------- src/pg.ml | 23 +- 7 files changed, 462 insertions(+), 467 deletions(-) delete mode 100644 src/keys.ml diff --git a/src/dune b/src/dune index 9ceb5f38..0f55dd10 100644 --- a/src/dune +++ b/src/dune @@ -15,7 +15,6 @@ mte_management secmod_eddsa secmod_rsa - keys log_reporter) (link_flags :standard -cclib "-z solo5-abi=hvt") (libraries diff --git a/src/keys.ml b/src/keys.ml deleted file mode 100644 index 282d6668..00000000 --- a/src/keys.ml +++ /dev/null @@ -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 diff --git a/src/mte.ml b/src/mte.ml index 0be96e25..c498cc2d 100644 --- a/src/mte.ml +++ b/src/mte.ml @@ -98,7 +98,9 @@ let () = (* -- *) let fs = Fat.create storage 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 env = { Env.sw; stack; tcp; dns; fs } in Logs.info (fun m -> m "Starting MTE server"); diff --git a/src/mte_device.ml b/src/mte_device.ml index 98da2f65..1a4b1045 100644 --- a/src/mte_device.ml +++ b/src/mte_device.ml @@ -1,29 +1,24 @@ -(* IMPROVE: use caqti pool - [connect_pool] with parameter [?post_connect] for preflight *) -let db_conn = +let sm_eddsa = + let f (env : Env.t) = Secmod_eddsa.create env.fs in + 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= _ } = Logs.info (fun m -> m "Connecting to database"); 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 -> Fmt.failwith "Database connection failure: %a." Caqti_error.pp err - | Ok conn -> + | Ok pool -> Logs.info (fun m -> m "Database connection done"); - let () = Pg.preflight conn in - Logs.info (fun m -> m "Database connection preflight done"); - conn + pool in - let finally (module Conn : Pg.CONN) = Conn.disconnect () in - Vifu.Device.v ~name:"db_conn" ~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 + let finally pool = Caqti_mnet.Pool.drain pool in + Vifu.Device.v ~name:"pool" ~finally [] f diff --git a/src/mte_info.ml b/src/mte_info.ml index 7327f906..44d5425c 100644 --- a/src/mte_info.ml +++ b/src/mte_info.ml @@ -31,7 +31,48 @@ let config req _server _env = 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 base_url = Config.base_url 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 (* type of the asset. "fiat", "crypto", "regional" or "stock". *) 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 = (* wire_methods? *) 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 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 zero_limits = [] in - let* denom_l = Keys.denominations () in - let list_issue_date = Keys.denominations_last_change () in + let* denom_l = get_denominations sm_rsa pool in + let list_issue_date = get_denominations_last_change () in let denom_l = (* if `?last_issue_date` query param does not exactly match the `stamp_start` 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 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 *) let* exchange_pub = @@ -103,7 +148,8 @@ let mk_keys ~db_conn (module Keys : Keys.S) ~last_issue_date = (* ! depends on denominations order *) let exchange_sig = let open Signatures.ExchangeKeySet in - signf (Keys.sign exchange_pub) + signf + (Secmod_eddsa.sign sm_eddsa exchange_pub) R. { list_issue_date; @@ -112,10 +158,13 @@ let mk_keys ~db_conn (module Keys : Keys.S) ~last_issue_date = 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 = (* /auditors/$AUDITOR_PUB/$H_DENOM_PUB *) - Pg.get_auditor_keys db_conn + Pg.use_pool pool @@ fun conn -> Pg.get_auditor_keys conn in let extensions = None in let extensions_sig = None in @@ -162,8 +211,9 @@ let keys req server _env = Logs.info (fun m -> m "GET /keys"); Respond.result req jsont @@ - let db_conn = Vifu.Server.device Mte_device.db_conn server in - 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* last_issue_date = match Vifu.Queries.get req "last_issue_date" with | [] -> Ok None @@ -173,4 +223,4 @@ let keys req server _env = Fmt.error_msg "invalid `?last_issue_date` query param, not an int" | Some n -> Ok (Some (Timestamp.of_s n))) in - mk_keys ~db_conn keys ~last_issue_date + mk_keys sm_eddsa sm_rsa pool last_issue_date diff --git a/src/mte_management.ml b/src/mte_management.ml index 587399ac..c4350ee3 100644 --- a/src/mte_management.ml +++ b/src/mte_management.ml @@ -3,32 +3,282 @@ open Api open Hash 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 let jsont = FutureKeysResponse.jsont let f req server _env = 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 @@ - let* v = Keys.make_future_keys_response () in + let* v = Future_keys.make_future_keys_response sm_eddsa sm_rsa pool in Ok v end -let request_of_json req = - Vifu.Request.of_json req |> Result.map_error (fun (`Msg e) -> `Json_decode e) - module Keys_post = struct - let verify (module Keys : Keys.S) - MasterSignatures.{ denom_sigs; signkey_sigs } = - let* () = list_iter Keys.verify_future_signkey signkey_sigs in - let* () = list_iter Keys.verify_future_denomination denom_sigs in + let verify sm_eddsa sm_rsa MasterSignatures.{ denom_sigs; signkey_sigs } = + let* () = + list_iter (Future_keys.verify_future_signkey sm_eddsa) signkey_sigs + in + let* () = + list_iter (Future_keys.verify_future_denomination sm_rsa) denom_sigs + in Ok () - let process (module Keys : Keys.S) - MasterSignatures.{ denom_sigs; signkey_sigs } = - let* () = list_iter Keys.certify_future_signkey signkey_sigs in - let* () = list_iter Keys.certify_future_denomination denom_sigs in + let process sm_eddsa sm_rsa pool MasterSignatures.{ denom_sigs; signkey_sigs } + = + let* () = + 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 () let jsont = MasterSignatures.jsont @@ -37,22 +287,24 @@ module Keys_post = struct Logs.info (fun m -> m "POST /management/keys/"); 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* () = verify keys v in - let* () = process keys v in + let* () = verify sm_eddsa sm_rsa v in + let* () = process sm_eddsa sm_rsa pool v in Ok () end module Denom_revoke = struct - let verify (module Keys : Keys.S) h_denom_pub - DenomRevocationSignature.{ master_sig } = + let verify h_denom_pub DenomRevocationSignature.{ master_sig } = let open Signatures.MasterDenominationKeyRevocation in verify Config.master_public_key master_sig { h_denom_pub } - let process (module Keys : Keys.S) h_denom_pub - DenomRevocationSignature.{ master_sig } = - let+ () = Keys.revoke_denomination h_denom_pub master_sig in + let process sm_rsa pool h_denom_pub DenomRevocationSignature.{ master_sig } = + let+ () = + Future_keys.revoke_denomination sm_rsa pool h_denom_pub master_sig + in () let jsont = DenomRevocationSignature.jsont @@ -61,26 +313,28 @@ module Denom_revoke = struct Logs.info (fun m -> m "POST /management/denominations/$H_DENOM_PUB/revoke/"); 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 = DenominationHash.of_crockford h_denom_pub |> Result.map_error (fun e -> `Msg e) in let* v = request_of_json req in - let* () = verify keys h_denom_pub v in - let* () = process keys h_denom_pub v in + let* () = verify h_denom_pub v in + let* () = process sm_rsa pool h_denom_pub v in Ok () end module Signkey_revoke = struct - let verify (module Keys : Keys.S) exchange_pub - SignkeyRevocationSignature.{ master_sig } = + let verify exchange_pub SignkeyRevocationSignature.{ master_sig } = let open Signatures.MasterSigningKeyRevocation in 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 } = - 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 @@ -89,18 +343,19 @@ module Signkey_revoke = struct Logs.info (fun m -> m "POST /management/signkeys/$EXCHANGE_PUB/revoke/"); 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 = Eddsa.pub_of_crockford exchange_pub |> Result.map_error (fun e -> `Msg e) in let* v = request_of_json req in - let* () = verify keys exchange_pub v in - let* () = process keys exchange_pub v in + let* () = verify exchange_pub v in + let* () = process sm_eddsa pool exchange_pub v in Ok () end module Auditors = struct - let verify (module Keys : Keys.S) + let verify AuditorSetupMessage. { auditor_url; @@ -117,21 +372,27 @@ module Auditors = struct 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 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 | None -> 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"); () | Some auditor -> if Timestamp.compare validity_start auditor.last_change <= 0 then Error (`Conflict "replay detected on enable-auditor") 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"); () @@ -141,24 +402,24 @@ module Auditors = struct Logs.info (fun m -> m "POST /management/auditors/"); Respond.result_no_content req @@ - let keys = Vifu.Server.device Mte_device.keys server in - 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* () = verify keys v in - let* () = process ~db_conn v in + let* () = verify v in + let* () = process pool v in Ok () end module Auditors_disable = struct - let verify (module Keys : Keys.S) auditor_pub - AuditorTeardownMessage.{ master_sig; validity_end } = + let verify auditor_pub AuditorTeardownMessage.{ master_sig; validity_end } = let open Signatures.MasterDelAuditor in verify Config.master_public_key master_sig { end_date= validity_end; auditor_pub } - let process ~db_conn auditor_pub + let process pool auditor_pub 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 | None -> Error (`Not_found "auditor pub key") | Some auditor -> ( @@ -173,7 +434,9 @@ module Auditors_disable = struct let auditor = { auditor with last_change= validity_end; is_active= false } 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 "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/"); Respond.result_no_content req @@ - let keys = Vifu.Server.device Mte_device.keys server in - let db_conn = Vifu.Server.device Mte_device.db_conn server in + let pool = Vifu.Server.device Mte_device.pool server in let* auditor_pub = Eddsa.pub_of_crockford auditor_pub |> Result.map_error (fun e -> `Msg e) in let* v = request_of_json req in - let* () = verify keys auditor_pub v in - let* () = process ~db_conn auditor_pub v in + let* () = verify auditor_pub v in + let* () = process pool auditor_pub v in Ok () end module Wire_fee = struct - let verify (module Keys : Keys.S) + let verify WireFeeSetupMessage. { wire_method; @@ -216,14 +478,15 @@ module Wire_fee = struct closing_fee; } - let process ~db_conn (v : WireFeeSetupMessage.t) = + let process pool (v : WireFeeSetupMessage.t) = 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 in 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"); () | [ vv ] -> ( @@ -246,26 +509,28 @@ module Wire_fee = struct Logs.info (fun m -> m "POST /management/wire-fee/"); Respond.result_no_content req @@ - let keys = Vifu.Server.device Mte_device.keys server in - 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* () = verify keys v in - let* () = process ~db_conn v in + let* () = verify v in + let* () = process pool v in Ok () end module Global_fees = struct 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 start_date = v.GlobalFees.start_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 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"); () | [ vv ] -> ( @@ -292,15 +557,15 @@ module Global_fees = struct Logs.info (fun m -> m "POST /management/global-fees/"); 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* () = verify v in - let* () = process ~db_conn v in + let* () = process pool v in Ok () end module Wire = struct - let verify (module Keys : Keys.S) + let verify WireSetupMessage. { payto_uri; @@ -354,7 +619,7 @@ module Wire = struct in Ok () - let process ~db_conn + let process pool WireSetupMessage. { payto_uri; @@ -367,7 +632,7 @@ module Wire = struct bank_label; 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 | None -> let wire = @@ -383,8 +648,8 @@ module Wire = struct } in let+ () = - Pg.update_wire db_conn ~is_active:true ~last_change:validity_start - wire + Pg.use_pool pool @@ fun conn -> + Pg.update_wire conn ~is_active:true ~last_change:validity_start wire in Logs.info (fun m -> m "added wire method"); () @@ -393,8 +658,8 @@ module Wire = struct Error (`Conflict "replay detected on enable-wire") else let+ () = - Pg.update_wire db_conn ~is_active:true ~last_change:validity_start - wire + Pg.use_pool pool @@ fun conn -> + Pg.update_wire conn ~is_active:true ~last_change:validity_start wire in Logs.info (fun m -> m "updated wire method"); () @@ -405,24 +670,22 @@ module Wire = struct Logs.info (fun m -> m "POST /management/wire/"); Respond.result_no_content req @@ - let keys = Vifu.Server.device Mte_device.keys server in - 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* () = verify keys v in - let* () = process ~db_conn v in + let* () = verify v in + let* () = process pool v in Ok () end module Wire_disable = struct - let verify (module Keys : Keys.S) - WireTeardownMessage.{ payto_uri; master_sig_del; validity_end } = + let verify WireTeardownMessage.{ payto_uri; master_sig_del; validity_end } = let open Signatures.MasterDelWire in verify Config.master_public_key master_sig_del { 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 } = - 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 | None -> Error (`Not_found "wire payto-uri") | Some (wire, _is_active, last_change) -> @@ -430,8 +693,8 @@ module Wire_disable = struct Error (`Conflict "replay detected on disable-wire") else let+ () = - Pg.update_wire db_conn ~is_active:false ~last_change:validity_end - wire + Pg.use_pool pool @@ fun conn -> + Pg.update_wire conn ~is_active:false ~last_change:validity_end wire in 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/"); Respond.result_no_content req @@ - let keys = Vifu.Server.device Mte_device.keys server in - 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* () = verify keys v in - let* () = process ~db_conn v in + let* () = verify v in + let* () = process pool v in Ok () end module Drain = struct - let verify (module Keys : Keys.S) + let verify DrainProfitsMessage. { debit_account_section; @@ -471,14 +733,19 @@ module Drain = struct h_payto= FullPaytoHash.hash credit_payto_uri; } - let process ~db_conn v = - let* opt = Pg.find_drain_profit db_conn v.DrainProfitsMessage.wtid in + let process pool v = + let* opt = + Pg.use_pool pool @@ fun conn -> + Pg.find_drain_profit conn v.DrainProfitsMessage.wtid + in match opt with | Some _ -> Logs.info (fun m -> m "drain profit message already added to database"); Ok () | 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"); () @@ -488,16 +755,15 @@ module Drain = struct Logs.info (fun m -> m "POST /management/drain/"); Respond.result_no_content req @@ - let keys = Vifu.Server.device Mte_device.keys server in - 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* () = verify keys v in - let* () = process ~db_conn v in + let* () = verify v in + let* () = process pool v in Ok () end module AmlOfficer = struct - let verify (module Keys : Keys.S) + let verify AmlOfficerSetup. { officer_pub; @@ -517,8 +783,10 @@ module AmlOfficer = struct is_active; } - let process ~db_conn v = - let+ _last_change = Pg.insert_aml_officer db_conn v in + let process pool v = + let+ _last_change = + Pg.use_pool pool @@ fun conn -> Pg.insert_aml_officer conn v + in () let jsont = AmlOfficerSetup.jsont @@ -527,16 +795,15 @@ module AmlOfficer = struct Logs.info (fun m -> m "POST /management/aml-officers/"); Respond.result_no_content req @@ - let keys = Vifu.Server.device Mte_device.keys server in - 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* () = verify keys v in - let* () = process ~db_conn v in + let* () = verify v in + let* () = process pool v in Ok () end module Partners = struct - let verify (module Keys : Keys.S) + let verify ExchangePartnerSetupRequest. { partner_base_url; @@ -558,8 +825,8 @@ module Partners = struct h_url= H64_cstring.hash partner_base_url; } - let process ~db_conn v = - let+ () = Pg.insert_partner db_conn v in + let process pool v = + let+ () = Pg.use_pool pool @@ fun conn -> Pg.insert_partner conn v in () let jsont = ExchangePartnerSetupRequest.jsont @@ -568,10 +835,9 @@ module Partners = struct Logs.info (fun m -> m "POST /management/partners/"); Respond.result_no_content req @@ - let keys = Vifu.Server.device Mte_device.keys server in - 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* () = verify keys v in - let* () = process ~db_conn v in + let* () = verify v in + let* () = process pool v in Ok () end diff --git a/src/pg.ml b/src/pg.ml index 7d73c88a..c4331ed3 100644 --- a/src/pg.ml +++ b/src/pg.ml @@ -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 +type conn = (module CONN) +type pool = (conn, Caqti_error.t) Caqti_mnet.Pool.t + let map_err 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 find (module Conn : CONN) req v = Conn.find req v |> map_err -let find_opt (module Conn : CONN) req v = Conn.find_opt req v |> map_err -let collect_list (module Conn : CONN) req v = Conn.collect_list 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 +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 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_type @@ -30,12 +30,7 @@ let preflight = "SET search_path TO exchange;"; ] in - fun conn -> - 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 () -> () + fun conn -> Syntax.list_iter (fun p -> exec conn p ()) l let find_signkey = let req =