From 1c0167f401307d9012341eff9945a4f5f9206fdc Mon Sep 17 00:00:00 2001 From: swrup Date: Wed, 1 Apr 2026 03:30:27 +0200 Subject: [PATCH] refacto secmod --- GNUmakefile | 30 ++-- src/config.ml | 8 +- src/keys.ml | 151 ++++++++++--------- src/pg.ml | 2 +- src/secmod_eddsa.ml | 293 ++++++++++++++++-------------------- src/secmod_rsa.ml | 354 ++++++++++++++++++++------------------------ 6 files changed, 388 insertions(+), 450 deletions(-) diff --git a/GNUmakefile b/GNUmakefile index 3052f8ae..785b6343 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -1,19 +1,21 @@ -vendor_list := \ +storage=assets/secmod.fat +service=tap0 + +vendors_list := \ mkernel zarith bstr mnet mirage-crypto-rng-mkernel gmp digestif \ kdf utcp flux h1 httpcats mhttp multipart_form-miou prettym tls \ x509 vifu cachet mfat caqti \ base32 cohttp mirage-mtime mirage-ptime -secmod_fat=assets/secmod.fat -tap_device=tap0 - check-kvm: $(if $(wildcard /dev/kvm),,$(error KVM support not enabled)) -pins: +pin-deps: #opam pin --no-action --yes "git+https://github.com/robur-coop/mcrunch.git#682ed63c03e3be5664f96c469a260e1d9e9df011" opam pin --no-action --yes "git+https://github.com/mirage/Zarith.git#zarith-1.14" - opam pin --no-action --yes "git+https://github.com/robur-coop/vif.git#e8b3053476162d119dee8cefe38511d679d3ad55" + opam pin --no-action --yes add mhttp "git+https://github.com/robur-coop/mhttp.git#b2e55ae693b07ad3ef87c26c37c8f5d14c2e205c" + opam pin --no-action --yes add vif "git+https://github.com/swrup/vif.git#1b16040ba06c6af82019f02811e781e81084d269" + opam pin --no-action --yes add vifu "git+https://github.com/swrup/vif.git#1b16040ba06c6af82019f02811e781e81084d269" opam pin --no-action --yes "git+https://github.com/robur-coop/mfat.git#5b1204d914e853f0139c6d2776511f530b753550" opam pin --no-action --yes "git+https://github.com/swrup/mirage-mtime.git#6a6bb4dd25624a3c43e6417dcdf73f3c689946a7" opam pin --no-action --yes add caqti "git+https://github.com/swrup/ocaml-caqti.git#186650581efd9d247ced982cdefd74256905e3b0" @@ -22,18 +24,18 @@ pins: opam pin --no-action --yes add caqti-driver-pgx "git+https://github.com/swrup/ocaml-caqti.git#186650581efd9d247ced982cdefd74256905e3b0" opam pin --no-action --yes "git+https://github.com/robur-coop/mnet.git#7e07437cda26f8efd3da0c4d14d76293d8fcbc78" -installs: +install-deps: # opam install --yes mcrunch opam install --yes dune utop merlin ocp-browser ocamlformat opam install --yes crunch opam install --yes sqlite3 # needed for caqti even if not used opam install --yes caqti-driver-pgx - opam install --yes $(vendor_list) + opam install --yes $(vendors_list) .PHONY: vendors vendors: @mkdir -p vendors - @for v in $(vendor_list); do \ + @for v in $(vendors_list); do \ [ -d vendors/$$v ] || opam source $$v --dir vendors/$$v ; \ done @@ -45,16 +47,18 @@ clean: assets: @cp default/assets ./ -secmod.fat: +fat-image: @mkdir -p assets - mfat make --sectors=2048 $(secmod_fat) + mfat make --sectors=2048 $(storage) + +init: clean pin-deps install-deps vendors assets fat-image manifest: @dune exec src/mte.exe > src/manifest.json -build: +build: manifest @dune build @all @dune build --workspace dune-workspace.solo5 src/mte.exe run: build - @solo5-hvt --block:storage=$(secmod_fat) --net:service=$(tap_device) -- ./_build/solo5/src/mte.exe + @solo5-hvt --block:storage=$(storage) --net:service=$(service) -- ./_build/solo5/src/mte.exe diff --git a/src/config.ml b/src/config.ml index 6a5a48f3..8e65832d 100644 --- a/src/config.ml +++ b/src/config.ml @@ -193,8 +193,8 @@ module Exchange_secmod_rsa = struct let section = "taler-exchange-secmod-" ^ "rsa" in get config_data ~section ~field - let lookahead_sign = get "lookahead_sign" |> duration - let overlap_duration = get "overlap_duration" |> duration + let lookahead = get "lookahead_sign" |> duration + let overlap = get "overlap_duration" |> duration end module Exchange_secmod_eddsa = struct @@ -202,8 +202,8 @@ module Exchange_secmod_eddsa = struct let section = "taler-exchange-secmod-" ^ "eddsa" in get config_data ~section ~field - let lookahead_sign = get "lookahead_sign" |> duration - let overlap_duration = get "overlap_duration" |> duration + let lookahead = get "lookahead_sign" |> duration + let overlap = get "overlap_duration" |> duration let duration = get "duration" |> duration end diff --git a/src/keys.ml b/src/keys.ml index b4452fc7..282d6668 100644 --- a/src/keys.ml +++ b/src/keys.ml @@ -28,57 +28,61 @@ module type S = sig end module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct - module Sm_eddsa = Secmod_eddsa.Make (Fs) - module Sm_rsa = Secmod_rsa.Make (Fs) - let conn = (module Conn : Pg.CONN) - let sign = Sm_eddsa.sign - let sign_denom = Sm_rsa.sign + 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_denom conn h_pub + let find_denomination h_pub = Pg.find_denomination conn h_pub + (* - *) - let warn_key_state = - let first = ref true in + (* TODO *) + let last_change = ref Timestamp.never + let denominations_last_change () = !last_change + + (* - *) + + let warn_once msg = + let b = ref true in fun () -> - if !first then ( - Logs.warn (fun m -> - m - "some keys found in database are missing from secmod, (unclean \ - database/secmod state?)"); - first := false; - ()) + if !b then begin + b := false; + Logs.warn (fun m -> m "%s" msg) + end - let signkeys () : Signkey.t list Result.t = + 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 @@ Sm_eddsa.find_key sk.Signkey.pub) + (fun sk -> + Option.is_none (Secmod_eddsa.find_key sm_eddsa sk.Signkey.pub)) l in - match missing_l with - | [] -> l - | _ -> - warn_key_state (); - Logs.debug (fun m -> m "found %d active signkey(s)" (List.length l)); - l + 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 @@ Sm_rsa.find_key dn.Denomination.h_pub) + (fun dn -> + Option.is_none @@ Secmod_rsa.find_key sm_rsa dn.Denomination.h_pub) l in - match missing_l with - | [] -> l - | _ -> - warn_key_state (); - Logs.debug (fun m -> - m "found %d active denomination(s)" (List.length l)); - l + 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); @@ -94,7 +98,9 @@ module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct let exchange_pub = pub in let anchor_time = stamp_start in let duration = Timestamp.diff stamp_start stamp_expire in - signf Sm_eddsa.sign_secmod { exchange_pub; anchor_time; duration } + 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 } @@ -133,7 +139,8 @@ module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct let denom_pub = DenominationKey.Rsa rsa_denomination_key in let denom_secmod_sig = let open Signatures.DenominationKeyAnnouncement in - signf Sm_rsa.sign_secmod + signf + (Secmod_rsa.sign_secmod sm_rsa) { h_denom_pub= h_pub; h_section_name= Hash.H64_cstring.hash section_name; @@ -158,14 +165,14 @@ module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct } let find_future_signkey pub = - match Sm_eddsa.find_key pub with + 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 Sm_rsa.find_key h_pub with + 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 @@ -178,7 +185,7 @@ module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct let sk_ht = Hashtbl.create 0xff in List.iter (fun sk -> Hashtbl.replace sk_ht sk.Signkey.pub ()) sk_db_l; let future_signkeys = - Sm_eddsa.keys () + Secmod_eddsa.keys sm_eddsa |> List.filter (fun (pub, _) -> not @@ Hashtbl.mem sk_ht pub) |> List.map make_future_sk in @@ -186,7 +193,7 @@ module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct 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 = - Sm_rsa.keys () + Secmod_rsa.keys sm_rsa |> List.filter (fun (h_pub, _) -> not @@ Hashtbl.mem dn_ht h_pub) |> List.map make_future_dn in @@ -194,45 +201,41 @@ module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct 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= Sm_rsa.sm_pub; - signkey_secmod_public_key= Sm_eddsa.sm_pub; + denom_secmod_public_key; + signkey_secmod_public_key; } - let sk_of_future_sk future_sk master_sig = - let Api.FutureSignKey. - { key; stamp_start; stamp_expire; stamp_end; signkey_secmod_sig= _ } = - future_sk - in + 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 future_dn h_pub master_sig = - let 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= _; - } = - future_dn - in - let rsa_pub = - match denom_pub with - | Rsa Api.RsaDenominationKey.{ age_mask= _; rsa_pub } -> rsa_pub - in + 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; @@ -263,12 +266,8 @@ module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct Denomination.verify_denomination_key_validity ~key:Config.master_public_key dn - (* MIOU *) - let last_change = ref Timestamp.never - let denominations_last_change () = !last_change - let certify_future_signkey Api.SignKeySignature.{ key= pub; master_sig } = - match Sm_eddsa.find_key pub with + match Secmod_eddsa.find_key sm_eddsa pub with | None -> Error (`Not_found "future eddsa key") | Some (pub, (t1, t2)) -> (* rebuild it *) @@ -280,7 +279,7 @@ module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct let certify_future_denomination Api.DenomSignature.{ h_denom_pub= h_pub; master_sig } = - match Sm_rsa.find_key h_pub with + 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 @@ -291,21 +290,21 @@ module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct () let revoke_signkey pub revoked_sig = - let* opt = find_signkey pub in + let* opt = Pg.find_signkey conn pub in match opt with | None -> Fmt.error_msg "signkey not found" | Some _sk -> - let* () = Sm_eddsa.revoke pub in + 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 = find_denomination h_pub in + let* opt = Pg.find_denomination conn h_pub in match opt with | None -> Fmt.error_msg "denomination not found" | Some dn -> - let* () = Sm_rsa.revoke dn.h_pub in + 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); diff --git a/src/pg.ml b/src/pg.ml index 719b5f31..7d73c88a 100644 --- a/src/pg.ml +++ b/src/pg.ml @@ -63,7 +63,7 @@ let insert_signkey = in fun conn v -> exec conn req v -let find_denom = +let find_denomination = let req = (denom_hash ->? denom) "SELECT denom_pub, (coin).*, valid_from, expire_withdraw, \ diff --git a/src/secmod_eddsa.ml b/src/secmod_eddsa.ml index c48a97ee..dcf2232a 100644 --- a/src/secmod_eddsa.ml +++ b/src/secmod_eddsa.ml @@ -18,7 +18,7 @@ module Cfg = struct include Config.Exchange_secmod_eddsa let key_dir = "/EDDSA" - let sm_key = "/SM_EDDSA" + let sm_key_path = "/SM_EDDSA" end type key = { @@ -35,177 +35,146 @@ type t = { ht: (Eddsa.pub, key) Hashtbl.t; } -(* todo: this should be encoded in little-endian *) -let key_bin = - let open Bin in - record (fun t1 t2 priv -> - let pub = Eddsa.pub_of_priv priv in - { t1; t2; priv; pub }) - |+ field TimeAbsolute.bin (fun t -> t.t1) - |+ field TimeAbsolute.bin (fun t -> t.t2) - |+ field Eddsa.priv_bin (fun t -> t.priv) - |> sealr +open struct + (* todo: this should be encoded in little-endian *) + let key_bin = + let open Bin in + record (fun t1 t2 priv -> + let pub = Eddsa.pub_of_priv priv in + { t1; t2; priv; pub }) + |+ field TimeAbsolute.bin (fun t -> t.t1) + |+ field TimeAbsolute.bin (fun t -> t.t2) + |+ field Eddsa.priv_bin (fun t -> t.priv) + |> sealr -(* for sm_key only *) -let read_eddsa fs spath = - Log.debug (fun m -> m "reading key file `%s`" spath); - let* data = Fat.read fs spath in - let* priv = Eddsa.priv_of_octets data |> Result.map_error (fun e -> `Msg e) in - let pub = Eddsa.pub_of_priv priv in - Ok (priv, pub) + let read_sm_key fs spath = + let* s = Fat.read fs spath in + Bbin.decode Eddsa.priv_bin s -let write_eddsa fs spath priv = - Log.debug (fun m -> m "writing key file `%s`" spath); - let data = Eddsa.priv_to_octets priv in - Fat.write fs spath data + let write_sm_key fs spath t = + let* s = Bbin.encode Eddsa.priv_bin t in + Fat.write fs spath s -let key_spath k = - let sfn = String.sub (Eddsa.pub_to_crockford k.pub) 0 8 in - Fat.Path.add Cfg.key_dir sfn - -let read_key fs spath = - Log.debug (fun m -> m "reading key file `%s`" spath); - let* s = Fat.read fs spath in - let+ k = Bbin.decode key_bin s in - k - -let write_key fs k = - let spath = key_spath k in - Log.debug (fun m -> m "writing key file `%s`" spath); - let* s = Bbin.encode key_bin k in - Fat.write fs spath s - -let delete_file fs spath = - Log.debug (fun m -> m "delete key file `%s`" spath); - let+ () = Fat.remove fs spath in - () - -let gen_key t1 t2 = - let priv, pub = Eddsa.generate () in - let k = { priv; pub; t1; t2 } in - Log.debug (fun m -> m "generated key `%a`" Eddsa.pp_pub pub); - k - -let sort_keys l = List.sort (fun a b -> TimeAbsolute.compare a.t2 b.t2) l - -let split_in_periodes ~start ~end_ = - assert (start < end_); - (* no overlap on first periode *) - let t1 = start in - let t2 = TimeAbsolute.add start Cfg.duration in - let acc = [ (t1, t2) ] in - let start = t2 in - let rec go acc start end_ = - let t1 = TimeAbsolute.sub start Cfg.overlap_duration in - let t2 = TimeAbsolute.add start Cfg.duration in - if t2 > end_ then acc else go ((t1, t2) :: acc) t2 end_ - in - go acc start end_ - -(* try to not generate keys with validity start in the past *) -let gen_additional_keys_until_lookahead ~now l = - let start = - match List.rev (sort_keys l) with - | [] -> now - | hd :: _ -> TimeAbsolute.sub hd.t2 Cfg.overlap_duration - in - let end_ = TimeAbsolute.add now Cfg.lookahead_sign in - if TimeAbsolute.compare start end_ >= 0 then [] - else - let periodes = split_in_periodes ~start ~end_ in - let new_keys = List.map (fun (t1, t2) -> gen_key t1 t2) periodes in - new_keys - -let load fs = - let* () = - if Fat.exists fs Cfg.key_dir then Ok () else Fat.mkdir fs Cfg.key_dir - in - let* l = Fat.ls fs Cfg.key_dir in - let l = List.map (fun entry -> Fat.Path.add Cfg.key_dir entry.Fat.name) l in - let l = List.filter (fun spath -> not @@ String.equal spath Cfg.sm_key) l in - let* keys = list_map (read_key fs) l in - match keys with - | [] -> Ok None - | _l -> - let* sm_priv, sm_pub = read_eddsa fs Cfg.sm_key in - let ht = Hashtbl.create 0xff in - let () = List.iter (fun k -> Hashtbl.replace ht k.pub k) keys in - Ok (Some { fs; sm_priv; sm_pub; ht }) - -let init fs = - let* opt = load fs in - let* t = - match opt with - | Some t -> Ok t - | None -> - let sm_priv, sm_pub = Eddsa.generate () in - Log.debug (fun m -> m "generated secmod key: `%a`" Eddsa.pp_pub sm_pub); - let ht = Hashtbl.create 0xff in - let t = { fs; sm_priv; sm_pub; ht } in - let* () = write_eddsa fs Cfg.sm_key t.sm_priv in - Ok t - in - let now = TimeAbsolute.of_ptime (Mirage_ptime.now ()) in - let keys = List.of_seq @@ Hashtbl.to_seq_values t.ht in - let new_keys = gen_additional_keys_until_lookahead ~now keys in - List.iter (fun k -> Hashtbl.replace t.ht k.pub k) new_keys; - let+ () = list_iter (write_key fs) new_keys in - t - -module Make (Fs : Fat.FS) = struct - let t = - match init Fs.t with - | Error e -> - Fmt.failwith "secmod_eddsa initialization failure: %a." Result.pp_err e - | Ok t -> t - - let find_exn pub = - Log.debug (fun m -> m "find_exn: `%a`" Eddsa.pp_pub pub); - match Hashtbl.find_opt t.ht pub with - | Some v -> v - | None -> - (* XXX ERR - either: - - we tried to sign with a key that is not ours - - key was revoked bywhile we were holding on it - - broken keyring state *) - Fmt.failwith "secmod_eddsa operation on unknown key" - - let add t1 t2 = - let k = gen_key t1 t2 in - Hashtbl.replace t.ht k.pub k; - let+ () = write_key t.fs k in + let delete_file fs spath = + Log.debug (fun m -> m "delete key file `%s`" spath); + let+ () = Fat.remove fs spath in () - let delete pub = - let k = find_exn pub in - Hashtbl.remove t.ht k.pub; - delete_file t.fs (key_spath k) + let key_spath k = + let sfn = String.sub (Eddsa.pub_to_crockford k.pub) 0 8 in + Fat.Path.add Cfg.key_dir sfn - let _delete_outdated ~now = - Hashtbl.to_seq_values t.ht - |> List.of_seq - |> List.filter (fun k -> TimeAbsolute.compare now k.t2 >= 0) - |> List.map (fun k -> k.pub) - |> list_iter delete + let read_key fs spath = + Log.debug (fun m -> m "reading key file `%s`" spath); + let* s = Fat.read fs spath in + let+ k = Bbin.decode key_bin s in + k + + let write_key fs k = + let spath = key_spath k in + Log.debug (fun m -> m "writing key file `%s`" spath); + let* s = Bbin.encode key_bin k in + Fat.write fs spath s (* ---- *) - let sm_pub = t.sm_pub - let sign_secmod s = Eddsa.sign ~key:t.sm_priv s + let epochs t0 tmax overlap duration = + let rec go t acc = + match t >= tmax with + | true -> acc + | false -> + let t1 = TimeAbsolute.sub t overlap in + let t2 = TimeAbsolute.add t duration in + let acc = (t1, t2) :: acc in + go t2 acc + in + go t0 [] - let sign pub s = - let k = find_exn pub in - Eddsa.sign ~key:k.priv s + let gen_key t1 t2 = + let priv, pub = Eddsa.generate () in + let k = { priv; pub; t1; t2 } in + Log.debug (fun m -> m "generated key `%a`" Eddsa.pp_pub pub); + k - (* delete and replace *) - let revoke pub = - let k = find_exn pub in - let* () = delete pub in - let* () = add k.t1 k.t2 in - Ok () + let load fs = + let open Fat in + let open Cfg in + let* () = if exists fs key_dir then Ok () else mkdir fs key_dir in + let* l = ls fs key_dir in + let l = List.map (fun entry -> Path.add key_dir entry.name) l in + let* keys = list_map (read_key fs) l in + match keys with + | [] -> Ok None + | _l -> + let* sm_priv = read_sm_key fs sm_key_path in + let sm_pub = Eddsa.pub_of_priv sm_priv in + let ht = Hashtbl.create 0xff in + let () = List.iter (fun k -> Hashtbl.replace ht k.pub k) keys in + Ok (Some { fs; sm_priv; sm_pub; ht }) - let conv = fun { priv= _; pub; t1; t2 } -> (pub, (t1, t2)) - let keys () = Hashtbl.to_seq_values t.ht |> List.of_seq |> List.map conv - let find_key pub = Hashtbl.find_opt t.ht pub |> Option.map conv + let create fs = + let* opt = load fs in + let* t = + match opt with + | Some t -> Ok t + | None -> + let sm_priv, sm_pub = Eddsa.generate () in + Log.debug (fun m -> + m "generated secmod key: `%a`" Eddsa.pp_pub sm_pub); + let ht = Hashtbl.create 0xff in + let t = { fs; sm_priv; sm_pub; ht } in + let* () = write_sm_key fs Cfg.sm_key_path sm_priv in + Ok t + in + let now = TimeAbsolute.of_ptime (Mirage_ptime.now ()) in + let keys = Hashtbl.to_seq_values t.ht |> List.of_seq in + let new_keys = + let t0 = + List.fold_left (fun acc k -> TimeAbsolute.max acc k.t2) now keys + in + let tmax = TimeAbsolute.add t0 Cfg.lookahead in + let l = epochs t0 tmax Cfg.overlap Cfg.duration in + List.map (fun (t1, t2) -> gen_key t1 t2) l + in + List.iter (fun k -> Hashtbl.replace t.ht k.pub k) new_keys; + let+ () = list_iter (write_key fs) new_keys in + t end + +(* ### *) + +let create fs = + match create fs with + | Error e -> + Fmt.failwith "secmod_eddsa initialization failure: %a." Result.pp_err e + | Ok t -> t + +(* XXX ERR + either: + - we tried to sign with a key that is not ours + - key was revoked bywhile we were holding on it + - broken keyring state *) +let find_exn t pub = + Log.debug (fun m -> m "find_exn: `%a`" Eddsa.pp_pub pub); + match Hashtbl.find_opt t.ht pub with + | None -> Fmt.failwith "secmod_eddsa operation on unknown key" + | Some v -> v + +let sm_pub t = t.sm_pub +let conv = fun { priv= _; pub; t1; t2 } -> (pub, (t1, t2)) +let keys t = Hashtbl.to_seq_values t.ht |> List.of_seq |> List.map conv +let find_key t pub = Hashtbl.find_opt t.ht pub |> Option.map conv +let sign_secmod t s = Eddsa.sign ~key:t.sm_priv s + +let sign t pub s = + let k = find_exn t pub in + Eddsa.sign ~key:k.priv s + +let revoke t pub = + let k = find_exn t pub in + Hashtbl.remove t.ht pub; + let* () = delete_file t.fs (key_spath k) in + let k = gen_key k.t1 k.t2 in + Hashtbl.replace t.ht k.pub k; + let+ () = write_key t.fs k in + () diff --git a/src/secmod_rsa.ml b/src/secmod_rsa.ml index 31e75a75..f25bfb4c 100644 --- a/src/secmod_rsa.ml +++ b/src/secmod_rsa.ml @@ -12,7 +12,7 @@ module Cfg = struct include Config.Exchange_secmod_rsa let key_dir = "/RSA" - let sm_key = "/SM_RSA" + let sm_key_path = "/SM_RSA" end type key = { @@ -31,208 +31,174 @@ type t = { ht: (DenominationHash.t, key) Hashtbl.t; } -let find_exn h_pub section_name = - Coin.all_coins - |> Iarray.find_opt (fun coin -> - String.equal section_name coin.Coin.section_name) - |> function - | Some coin -> coin - | None -> - Fmt.failwith - "Secmod_rsa denomination key loading failure on key `%a`: unknown \ - section_name [%s]" - DenominationHash.pp h_pub section_name - -(* ? enforce all to be of the same size instead *) -(* we use Bin.cstring + b32 binary encoding because - rsa keysize is not known and then we have to escape '\x00' *) -let rsa_private_key_bin = - let decode_exn o = - Rsa.priv_of_crockford o |> function Error e -> invalid_arg e | Ok v -> v - in - let encode o = Rsa.priv_to_crockford o in - Bin.map Bin.cstring decode_exn encode - -let key_bin = - let open Bin in - record (fun t1 t2 section_name priv -> - let pub = Rsa.pub_of_priv priv in - let h_pub = DenominationHash.hash pub in - let coin = find_exn h_pub section_name in - { coin; t1; t2; priv; pub; h_pub }) - |+ field TimeAbsolute.bin (fun t -> t.t1) - |+ field TimeAbsolute.bin (fun t -> t.t2) - |+ field cstring (fun t -> t.coin.section_name) - |+ field rsa_private_key_bin (fun t -> t.priv) - |> sealr - -let key_spath k = - let sfn = String.sub (DenominationHash.to_crockford k.h_pub) 0 8 in - Fat.Path.add Cfg.key_dir sfn - -let read_eddsa fs spath = - Log.debug (fun m -> m "reading key file `%s`" spath); - let* data = Fat.read fs spath in - let* priv = Eddsa.priv_of_octets data |> Result.map_error (fun e -> `Msg e) in - let pub = Eddsa.pub_of_priv priv in - Ok (priv, pub) - -let write_eddsa fs spath priv = - Log.debug (fun m -> m "writing key file `%s`" spath); - let data = Eddsa.priv_to_octets priv in - Fat.write fs spath data - -let read_key fs spath = - Log.debug (fun m -> m "reading key file `%s`" spath); - let* s = Fat.read fs spath in - let+ k = Bbin.decode key_bin s in - k - -let write_key fs k = - let spath = key_spath k in - Log.debug (fun m -> m "writing key file `%s`" spath); - let* s = Bbin.encode key_bin k in - Fat.write fs spath s - -let delete_file fs spath = - Log.debug (fun m -> m "delete key file `%s`" spath); - let+ () = Fat.remove fs spath in - () - -(* -- *) - -let gen_key coin t1 t2 = - let bits = coin.Coin.rsa_keysize in - let priv, pub = Rsa.generate ~bits () in - let h_pub = DenominationHash.hash pub in - let k = { coin; priv; pub; h_pub; t1; t2 } in - Log.debug (fun m -> - m "generated key for coin [%s]: `%a`" coin.section_name - DenominationHash.pp k.h_pub); - k - -let sort_keys l = List.sort (fun a b -> TimeAbsolute.compare a.t2 b.t2) l - -let split_in_periodes coin ~start ~end_ = - assert (start < end_); - let duration_withdraw = coin.Coin.duration_withdraw in - (* no overlap on first periode *) - let t1 = start in - let t2 = TimeAbsolute.add start duration_withdraw in - let acc = [ (t1, t2) ] in - let start = t2 in - let rec go acc start end_ = - let t1 = TimeAbsolute.sub start Cfg.overlap_duration in - let t2 = TimeAbsolute.add start duration_withdraw in - if t2 > end_ then acc else go ((t1, t2) :: acc) t2 end_ - in - go acc start end_ - -let gen_additional_keys_until_lookahead coin ~now l = - let start = - match List.rev (sort_keys l) with - | [] -> now - | hd :: _ -> TimeAbsolute.sub hd.t2 Cfg.overlap_duration - in - let end_ = TimeAbsolute.add now Cfg.lookahead_sign in - if TimeAbsolute.compare start end_ >= 0 then [] - else - let periodes = split_in_periodes coin ~start ~end_ in - let new_keys = List.map (fun (t1, t2) -> gen_key coin t1 t2) periodes in - new_keys - -let load fs = - let* () = - if Fat.exists fs Cfg.key_dir then Ok () else Fat.mkdir fs Cfg.key_dir - in - let* l = Fat.ls fs Cfg.key_dir in - let l = List.map (fun entry -> Fat.Path.add Cfg.key_dir entry.Fat.name) l in - let l = List.filter (fun spath -> not @@ String.equal Cfg.sm_key spath) l in - let* keys = list_map (read_key fs) l in - match keys with - | [] -> Ok None - | _l -> - let* sm_priv, sm_pub = read_eddsa fs Cfg.sm_key in - let ht = Hashtbl.create 0xff in - let () = List.iter (fun k -> Hashtbl.replace ht k.h_pub k) keys in - Ok (Some { fs; sm_priv; sm_pub; ht }) - -let init fs = - let* opt = load fs in - let now = TimeAbsolute.of_ptime (Mirage_ptime.now ()) in - let* t = - match opt with - | Some t -> Ok t - | None -> - let sm_priv, sm_pub = Eddsa.generate () in - Log.debug (fun m -> m "generated secmod key: `%a`" Eddsa.pp_pub sm_pub); - let* () = write_eddsa fs Cfg.sm_key sm_priv in - let ht = Hashtbl.create 0xff in - Ok { fs; sm_priv; sm_pub; ht } - in - let all_keys = List.of_seq @@ Hashtbl.to_seq_values t.ht in - let new_keys_l = +open struct + let find_coin_exn h_pub section_name = Coin.all_coins - |> Iarray.to_list - |> List.map (fun coin -> - let keys = - List.filter - (fun k -> String.equal coin.Coin.section_name k.coin.section_name) - all_keys - in - gen_additional_keys_until_lookahead coin ~now keys) - in - let new_keys = List.concat new_keys_l in - List.iter (fun k -> Hashtbl.replace t.ht k.h_pub k) new_keys; - let+ () = list_iter (write_key fs) new_keys in - t + |> Iarray.find_opt (fun coin -> + String.equal section_name coin.Coin.section_name) + |> function + | Some coin -> coin + | None -> + Fmt.failwith + "Secmod_rsa denomination key loading failure on key `%a`: unknown \ + section_name [%s]" + DenominationHash.pp h_pub section_name -module Make (Fs : Fat.FS) = struct - let t = - match init Fs.t with - | Error e -> - Fmt.failwith "secmod_rsa initialization failure: %a." Result.pp_err e - | Ok t -> t + (* ? enforce all to be of the same size instead *) + (* we use Bin.cstring + b32 binary encoding because + rsa keysize is not known and then we have to escape '\x00' *) + let rsa_private_key_bin = + let decode_exn o = + Rsa.priv_of_crockford o |> function Error e -> invalid_arg e | Ok v -> v + in + let encode o = Rsa.priv_to_crockford o in + Bin.map Bin.cstring decode_exn encode - let find_exn h_pub = - Log.debug (fun m -> m "find_exn: `%a`" DenominationHash.pp h_pub); - match Hashtbl.find_opt t.ht h_pub with - | Some v -> v - | None -> Fmt.failwith "secmod_rsa operation on unknown key" + let key_bin = + let open Bin in + record (fun t1 t2 section_name priv -> + let pub = Rsa.pub_of_priv priv in + let h_pub = DenominationHash.hash pub in + let coin = find_coin_exn h_pub section_name in + { coin; t1; t2; priv; pub; h_pub }) + |+ field TimeAbsolute.bin (fun t -> t.t1) + |+ field TimeAbsolute.bin (fun t -> t.t2) + |+ field cstring (fun t -> t.coin.section_name) + |+ field rsa_private_key_bin (fun t -> t.priv) + |> sealr - let delete h_pub = - let k = find_exn h_pub in - Hashtbl.remove t.ht h_pub; - delete_file t.fs (key_spath k) + let read_sm_key fs spath = + let* s = Fat.read fs spath in + Bbin.decode Eddsa.priv_bin s - let _delete_outdated ~now = - Hashtbl.to_seq t.ht - |> List.of_seq - |> List.filter (fun (_h_pub, k) -> TimeAbsolute.compare now k.t2 >= 0) - |> List.map (fun (h_pub, _k) -> h_pub) - |> list_iter delete + let write_sm_key fs spath t = + let* s = Bbin.encode Eddsa.priv_bin t in + Fat.write fs spath s - let add coin t1 t2 = - let k = gen_key coin t1 t2 in - let+ () = write_key t.fs k in - Hashtbl.replace t.ht k.h_pub k; + let delete_file fs spath = + Log.debug (fun m -> m "delete key file `%s`" spath); + let+ () = Fat.remove fs spath in () - let sm_pub = t.sm_pub - let sign_secmod s = Eddsa.sign ~key:t.sm_priv s + let key_spath k = + let sfn = String.sub (DenominationHash.to_crockford k.h_pub) 0 8 in + Fat.Path.add Cfg.key_dir sfn - let sign h_pub msg = - let k = find_exn h_pub in - Rsa.sign ~key:k.priv msg + let read_key fs spath = + Log.debug (fun m -> m "reading key file `%s`" spath); + let* s = Fat.read fs spath in + let+ k = Bbin.decode key_bin s in + k - let revoke h_pub = - Log.debug (fun m -> m "revoke `%a`" DenominationHash.pp h_pub); - let k = find_exn h_pub in - let* () = delete h_pub in - let* () = add k.coin k.t1 k.t2 in - Ok () + let write_key fs k = + let spath = key_spath k in + Log.debug (fun m -> m "writing key file `%s`" spath); + let* s = Bbin.encode key_bin k in + Fat.write fs spath s - let conv k = (k.h_pub, (k.coin, k.pub, k.t1)) - let keys () = Hashtbl.to_seq_values t.ht |> List.of_seq |> List.map conv - let find_key pub = Hashtbl.find_opt t.ht pub |> Option.map conv + (* ---- *) + + let epochs t0 tmax overlap duration = + let rec go t acc = + match t >= tmax with + | true -> acc + | false -> + let t1 = TimeAbsolute.sub t overlap in + let t2 = TimeAbsolute.add t duration in + let acc = (t1, t2) :: acc in + go t2 acc + in + go t0 [] + + let gen_key coin t1 t2 = + let bits = coin.Coin.rsa_keysize in + let priv, pub = Rsa.generate ~bits () in + let h_pub = DenominationHash.hash pub in + let k = { coin; priv; pub; h_pub; t1; t2 } in + Log.debug (fun m -> + m "generated key for coin [%s]: `%a`" coin.section_name + DenominationHash.pp k.h_pub); + k + + let load fs = + let open Fat in + let open Cfg in + let* () = if exists fs key_dir then Ok () else mkdir fs key_dir in + let* l = ls fs key_dir in + let l = List.map (fun entry -> Path.add key_dir entry.name) l in + let* keys = list_map (read_key fs) l in + match keys with + | [] -> Ok None + | _l -> + let* sm_priv = read_sm_key fs sm_key_path in + let sm_pub = Eddsa.pub_of_priv sm_priv in + let ht = Hashtbl.create 0xff in + List.iter (fun k -> Hashtbl.replace ht k.h_pub k) keys; + Ok (Some { fs; sm_priv; sm_pub; ht }) + + let create fs = + let* opt = load fs in + let now = TimeAbsolute.of_ptime (Mirage_ptime.now ()) in + let* t = + match opt with + | Some t -> Ok t + | None -> + let sm_priv, sm_pub = Eddsa.generate () in + Log.debug (fun m -> + m "generated secmod key: `%a`" Eddsa.pp_pub sm_pub); + let* () = write_sm_key fs Cfg.sm_key_path sm_priv in + let ht = Hashtbl.create 0xff in + Ok { fs; sm_priv; sm_pub; ht } + in + let keys = Hashtbl.to_seq_values t.ht |> List.of_seq in + let new_keys = + Coin.all_coins + |> Iarray.to_list + |> List.concat_map (fun coin -> + let t0 = + keys + |> List.filter (fun k -> + String.equal coin.Coin.section_name k.coin.section_name) + |> List.fold_left (fun acc k -> TimeAbsolute.max acc k.t2) now + in + let tmax = TimeAbsolute.add t0 Cfg.lookahead in + let l = epochs t0 tmax Cfg.overlap coin.duration_withdraw in + List.map (fun (t1, t2) -> gen_key coin t1 t2) l) + in + List.iter (fun k -> Hashtbl.replace t.ht k.h_pub k) new_keys; + let+ () = list_iter (write_key fs) new_keys in + t end + +(* ### *) + +let create fs = + match create fs with + | Error e -> + Fmt.failwith "secmod_rsa initialization failure: %a." Result.pp_err e + | Ok t -> t + +let find_exn t h_pub = + Log.debug (fun m -> m "find_exn: `%a`" DenominationHash.pp h_pub); + match Hashtbl.find_opt t.ht h_pub with + | None -> Fmt.failwith "secmod_rsa operation on unknown key" + | Some v -> v + +let sm_pub t = t.sm_pub +let conv k = (k.h_pub, (k.coin, k.pub, k.t1)) +let keys t = Hashtbl.to_seq_values t.ht |> List.of_seq |> List.map conv +let find_key t h_pub = Hashtbl.find_opt t.ht h_pub |> Option.map conv +let sign_secmod t s = Eddsa.sign ~key:t.sm_priv s + +let sign t h_pub s = + let k = find_exn t h_pub in + Rsa.sign ~key:k.priv s + +let revoke t h_pub = + let k = find_exn t h_pub in + Hashtbl.remove t.ht h_pub; + let* () = delete_file t.fs (key_spath k) in + let k = gen_key k.coin k.t1 k.t2 in + Hashtbl.replace t.ht k.h_pub k; + let+ () = write_key t.fs k in + ()