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
secmod_eddsa
secmod_rsa
keys
log_reporter)
(link_flags :standard -cclib "-z solo5-abi=hvt")
(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 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");

39
src/mte_device.ml
View file

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

74
src/mte_info.ml
View file

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

476
src/mte_management.ml
View file

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

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