refacto secmod

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

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 lookahead = get "lookahead_sign" |> duration
-  let overlap_duration = get "overlap_duration" |> 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 lookahead = get "lookahead_sign" |> duration
-  let overlap_duration = get "overlap_duration" |> duration
+  let overlap = get "overlap_duration" |> duration
   let duration = get "duration" |> duration
 end
 

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 sm_eddsa = Secmod_eddsa.create Fs.t
-  let sign_denom = Sm_rsa.sign
+  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 =
+  (* TODO *)
-    let first = ref true in
+  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 (
+      if !b then begin
-        Logs.warn (fun m ->
+        b := false;
-            m
+        Logs.warn (fun m -> m "%s" msg)
-              "some keys found in database are missing from secmod, (unclean \
+      end
-               database/secmod state?)");
-        first := false;
-        ())
 
-  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
+    if missing_l <> [] then warn_keyring_state_mismatch ();
-    | [] -> l
+    l
-    | _ ->
-        warn_key_state ();
-        Logs.debug (fun m -> m "found %d active signkey(s)" (List.length l));
-        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
+    if missing_l <> [] then warn_keyring_state_mismatch ();
-    | [] -> l
+    l
-    | _ ->
-        warn_key_state ();
-        Logs.debug (fun m ->
-            m "found %d active denomination(s)" (List.length l));
-        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;
+          denom_secmod_public_key;
-          signkey_secmod_public_key= Sm_eddsa.sm_pub;
+          signkey_secmod_public_key;
         }
 
-  let sk_of_future_sk future_sk master_sig =
+  let sk_of_future_sk
-    let Api.FutureSignKey.
+      Api.FutureSignKey.
-          { key; stamp_start; stamp_expire; stamp_end; signkey_secmod_sig= _ } =
+        { key; stamp_start; stamp_expire; stamp_end; signkey_secmod_sig= _ }
-      future_sk
+      master_sig =
-    in
     Signkey.{ pub= key; stamp_start; stamp_expire; stamp_end; master_sig }
 
-  let dn_of_future_dn future_dn h_pub master_sig =
+  let dn_of_future_dn
-    let Api.FutureDenom.
+      Api.FutureDenom.
-          {
+        {
-            section_name= _;
+          section_name= _;
-            value;
+          value;
-            stamp_start;
+          stamp_start;
-            stamp_expire_withdraw;
+          stamp_expire_withdraw;
-            stamp_expire_deposit;
+          stamp_expire_deposit;
-            stamp_expire_legal;
+          stamp_expire_legal;
-            denom_pub;
+          denom_pub;
-            fee_withdraw;
+          fee_withdraw;
-            fee_deposit;
+          fee_deposit;
-            fee_refresh;
+          fee_refresh;
-            fee_refund;
+          fee_refund;
-            denom_secmod_sig= _;
+          denom_secmod_sig= _;
-          } =
+        } h_pub master_sig =
-      future_dn
+    let (Rsa Api.RsaDenominationKey.{ age_mask= _; rsa_pub }) = denom_pub in
-    in
-    let rsa_pub =
-      match denom_pub with
-      | Rsa Api.RsaDenominationKey.{ age_mask= _; rsa_pub } -> rsa_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);

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, \

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 *)
+open struct
-let key_bin =
+  (* todo: this should be encoded in little-endian *)
-  let open Bin in
+  let key_bin =
-  record (fun t1 t2 priv ->
+    let open Bin in
-      let pub = Eddsa.pub_of_priv priv in
+    record (fun t1 t2 priv ->
-      { t1; t2; priv; pub })
+        let pub = Eddsa.pub_of_priv priv in
-  |+ field TimeAbsolute.bin (fun t -> t.t1)
+        { t1; t2; priv; pub })
-  |+ field TimeAbsolute.bin (fun t -> t.t2)
+    |+ field TimeAbsolute.bin (fun t -> t.t1)
-  |+ field Eddsa.priv_bin (fun t -> t.priv)
+    |+ field TimeAbsolute.bin (fun t -> t.t2)
-  |> sealr
+    |+ field Eddsa.priv_bin (fun t -> t.priv)
+    |> sealr
 
-(* for sm_key only *)
+  let read_sm_key fs spath =
-let read_eddsa fs spath =
+    let* s = Fat.read fs spath in
-  Log.debug (fun m -> m "reading key file `%s`" spath);
+    Bbin.decode Eddsa.priv_bin s
-  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 =
+  let write_sm_key fs spath t =
-  Log.debug (fun m -> m "writing key file `%s`" spath);
+    let* s = Bbin.encode Eddsa.priv_bin t in
-  let data = Eddsa.priv_to_octets priv in
+    Fat.write fs spath s
-  Fat.write fs spath data
 
-let key_spath k =
+  let delete_file fs spath =
-  let sfn = String.sub (Eddsa.pub_to_crockford k.pub) 0 8 in
+    Log.debug (fun m -> m "delete key file `%s`" spath);
-  Fat.Path.add Cfg.key_dir sfn
+    let+ () = Fat.remove fs spath in
-
-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 pub =
+  let key_spath k =
-    let k = find_exn pub in
+    let sfn = String.sub (Eddsa.pub_to_crockford k.pub) 0 8 in
-    Hashtbl.remove t.ht k.pub;
+    Fat.Path.add Cfg.key_dir sfn
-    delete_file t.fs (key_spath k)
 
-  let _delete_outdated ~now =
+  let read_key fs spath =
-    Hashtbl.to_seq_values t.ht
+    Log.debug (fun m -> m "reading key file `%s`" spath);
-    |> List.of_seq
+    let* s = Fat.read fs spath in
-    |> List.filter (fun k -> TimeAbsolute.compare now k.t2 >= 0)
+    let+ k = Bbin.decode key_bin s in
-    |> List.map (fun k -> k.pub)
+    k
-    |> list_iter delete
+
+  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 epochs t0 tmax overlap duration =
-  let sign_secmod s = Eddsa.sign ~key:t.sm_priv s
+    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 gen_key t1 t2 =
-    let k = find_exn pub in
+    let priv, pub = Eddsa.generate () in
-    Eddsa.sign ~key:k.priv s
+    let k = { priv; pub; t1; t2 } in
+    Log.debug (fun m -> m "generated key `%a`" Eddsa.pp_pub pub);
+    k
 
-  (* delete and replace *)
+  let load fs =
-  let revoke pub =
+    let open Fat in
-    let k = find_exn pub in
+    let open Cfg in
-    let* () = delete pub in
+    let* () = if exists fs key_dir then Ok () else mkdir fs key_dir in
-    let* () = add k.t1 k.t2 in
+    let* l = ls fs key_dir in
-    Ok ()
+    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 create fs =
-  let keys () = Hashtbl.to_seq_values t.ht |> List.of_seq |> List.map conv
+    let* opt = load fs in
-  let find_key pub = Hashtbl.find_opt t.ht pub |> Option.map conv
+    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
+  ()

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 =
+open struct
-  Coin.all_coins
+  let find_coin_exn h_pub section_name =
-  |> 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 =
     Coin.all_coins
-    |> Iarray.to_list
+    |> Iarray.find_opt (fun coin ->
-    |> List.map (fun coin ->
+        String.equal section_name coin.Coin.section_name)
-        let keys =
+    |> function
-          List.filter
+    | Some coin -> coin
-            (fun k -> String.equal coin.Coin.section_name k.coin.section_name)
+    | None ->
-            all_keys
+        Fmt.failwith
-        in
+          "Secmod_rsa denomination key loading failure on key `%a`: unknown \
-        gen_additional_keys_until_lookahead coin ~now keys)
+           section_name [%s]"
-  in
+          DenominationHash.pp h_pub section_name
-  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
 
-module Make (Fs : Fat.FS) = struct
+  (* ? enforce all to be of the same size instead *)
-  let t =
+  (* we use Bin.cstring + b32 binary encoding because
-    match init Fs.t with
+     rsa keysize is not known and then we have to escape '\x00' *)
-    | Error e ->
+  let rsa_private_key_bin =
-        Fmt.failwith "secmod_rsa initialization failure: %a." Result.pp_err e
+    let decode_exn o =
-    | Ok t -> t
+      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 =
+  let key_bin =
-    Log.debug (fun m -> m "find_exn: `%a`" DenominationHash.pp h_pub);
+    let open Bin in
-    match Hashtbl.find_opt t.ht h_pub with
+    record (fun t1 t2 section_name priv ->
-    | Some v -> v
+        let pub = Rsa.pub_of_priv priv in
-    | None -> Fmt.failwith "secmod_rsa operation on unknown key"
+        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 read_sm_key fs spath =
-    let k = find_exn h_pub in
+    let* s = Fat.read fs spath in
-    Hashtbl.remove t.ht h_pub;
+    Bbin.decode Eddsa.priv_bin s
-    delete_file t.fs (key_spath k)
 
-  let _delete_outdated ~now =
+  let write_sm_key fs spath t =
-    Hashtbl.to_seq t.ht
+    let* s = Bbin.encode Eddsa.priv_bin t in
-    |> List.of_seq
+    Fat.write fs spath s
-    |> List.filter (fun (_h_pub, k) -> TimeAbsolute.compare now k.t2 >= 0)
-    |> List.map (fun (h_pub, _k) -> h_pub)
-    |> list_iter delete
 
-  let add coin t1 t2 =
+  let delete_file fs spath =
-    let k = gen_key coin t1 t2 in
+    Log.debug (fun m -> m "delete key file `%s`" spath);
-    let+ () = write_key t.fs k in
+    let+ () = Fat.remove fs spath in
-    Hashtbl.replace t.ht k.h_pub k;
     ()
 
-  let sm_pub = t.sm_pub
+  let key_spath k =
-  let sign_secmod s = Eddsa.sign ~key:t.sm_priv s
+    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 read_key fs spath =
-    let k = find_exn h_pub in
+    Log.debug (fun m -> m "reading key file `%s`" spath);
-    Rsa.sign ~key:k.priv msg
+    let* s = Fat.read fs spath in
+    let+ k = Bbin.decode key_bin s in
+    k
 
-  let revoke h_pub =
+  let write_key fs k =
-    Log.debug (fun m -> m "revoke `%a`" DenominationHash.pp h_pub);
+    let spath = key_spath k in
-    let k = find_exn h_pub in
+    Log.debug (fun m -> m "writing key file `%s`" spath);
-    let* () = delete h_pub in
+    let* s = Bbin.encode key_bin k in
-    let* () = add k.coin k.t1 k.t2 in
+    Fat.write fs spath s
-    Ok ()
 
-  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
+  ()