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,56 +28,60 @@ 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
-    | _ ->
-        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
-    | _ ->
-        warn_key_state ();
-        Logs.debug (fun m ->
-            m "found %d active denomination(s)" (List.length l));
     l
 
   let make_future_sk (pub, (start, expire)) =
@@ -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,25 +201,26 @@ 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= _;
           value;
@@ -226,13 +234,8 @@ module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct
           fee_refresh;
           fee_refund;
           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,8 +35,9 @@ 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 key_bin =
     let open Bin in
     record (fun t1 t2 priv ->
         let pub = Eddsa.pub_of_priv priv in
@@ -46,166 +47,134 @@ let key_bin =
     |+ 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 =
+    Log.debug (fun m -> m "delete key file `%s`" spath);
+    let+ () = Fat.remove fs spath in
+    ()
+
+  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 =
+  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 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 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 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 load fs =
-
+    let open Fat in
-let split_in_periodes ~start ~end_ =
+    let open Cfg in
-  assert (start < end_);
+    let* () = if exists fs key_dir then Ok () else mkdir fs key_dir in
-  (* no overlap on first periode *)
+    let* l = ls fs key_dir in
-  let t1 = start in
+    let l = List.map (fun entry -> Path.add key_dir entry.name) l 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* 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 init fs =
+  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);
+          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
+          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 = List.of_seq @@ Hashtbl.to_seq_values t.ht in
+    let keys = Hashtbl.to_seq_values t.ht |> List.of_seq in
-  let new_keys = gen_additional_keys_until_lookahead ~now keys 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
 
-module Make (Fs : Fat.FS) = struct
+(* ### *)
-  let t =
+
-    match init Fs.t with
+let create fs =
+  match create fs with
   | Error e ->
       Fmt.failwith "secmod_eddsa initialization failure: %a." Result.pp_err e
   | Ok t -> t
 
-  let find_exn pub =
+(* XXX ERR
-    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 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 add t1 t2 =
+let sm_pub t = t.sm_pub
-    let k = gen_key t1 t2 in
+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
   ()
-
-  let delete pub =
-    let k = find_exn pub in
-    Hashtbl.remove t.ht k.pub;
-    delete_file t.fs (key_spath k)
-
-  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 sm_pub = t.sm_pub
-  let sign_secmod s = Eddsa.sign ~key:t.sm_priv s
-
-  let sign pub s =
-    let k = find_exn pub in
-    Eddsa.sign ~key:k.priv s
-
-  (* 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 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
-end

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,7 +31,8 @@ type t = {
   ht: (DenominationHash.t, key) Hashtbl.t;
 }
 
-let find_exn h_pub section_name =
+open struct
+  let find_coin_exn h_pub section_name =
     Coin.all_coins
     |> Iarray.find_opt (fun coin ->
         String.equal section_name coin.Coin.section_name)
@@ -43,22 +44,22 @@ let find_exn h_pub section_name =
            section_name [%s]"
           DenominationHash.pp h_pub section_name
 
-(* ? enforce all to be of the same size instead *)
+  (* ? enforce all to be of the same size instead *)
-(* we use Bin.cstring + b32 binary encoding because
+  (* 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 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 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
+        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)
@@ -66,42 +67,50 @@ let key_bin =
     |+ field rsa_private_key_bin (fun t -> t.priv)
     |> sealr
 
-let key_spath k =
+  let read_sm_key fs spath =
+    let* s = Fat.read fs spath in
+    Bbin.decode Eddsa.priv_bin s
+
+  let write_sm_key fs spath t =
+    let* s = Bbin.encode Eddsa.priv_bin t 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 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 =
+  let read_key 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 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 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 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
@@ -111,53 +120,23 @@ let gen_key coin t1 t2 =
           DenominationHash.pp k.h_pub);
     k
 
-let sort_keys l = List.sort (fun a b -> TimeAbsolute.compare a.t2 b.t2) l
+  let load fs =
-
+    let open Fat in
-let split_in_periodes coin ~start ~end_ =
+    let open Cfg in
-  assert (start < end_);
+    let* () = if exists fs key_dir then Ok () else mkdir fs key_dir in
-  let duration_withdraw = coin.Coin.duration_withdraw in
+    let* l = ls fs key_dir in
-  (* no overlap on first periode *)
+    let l = List.map (fun entry -> Path.add key_dir entry.name) l in
-  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* 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.h_pub k) keys in
+        List.iter (fun k -> Hashtbl.replace ht k.h_pub k) keys;
         Ok (Some { fs; sm_priv; sm_pub; ht })
 
-let init fs =
+  let create fs =
     let* opt = load fs in
     let now = TimeAbsolute.of_ptime (Mirage_ptime.now ()) in
     let* t =
@@ -165,74 +144,61 @@ let init fs =
       | 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);
+          Log.debug (fun m ->
-        let* () = write_eddsa fs Cfg.sm_key sm_priv in
+              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 all_keys = List.of_seq @@ Hashtbl.to_seq_values t.ht in
+    let keys = Hashtbl.to_seq_values t.ht |> List.of_seq in
-  let new_keys_l =
+    let new_keys =
       Coin.all_coins
       |> Iarray.to_list
-    |> List.map (fun coin ->
+      |> List.concat_map (fun coin ->
-        let keys =
+          let t0 =
-          List.filter
+            keys
-            (fun k -> String.equal coin.Coin.section_name k.coin.section_name)
+            |> List.filter (fun k ->
-            all_keys
+                String.equal coin.Coin.section_name k.coin.section_name)
+            |> List.fold_left (fun acc k -> TimeAbsolute.max acc k.t2) now
           in
-        gen_additional_keys_until_lookahead coin ~now keys)
+          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
-  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
+end
 
-module Make (Fs : Fat.FS) = struct
+(* ### *)
-  let t =
+
-    match init Fs.t with
+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 h_pub =
+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
-    | Some v -> v
   | None -> Fmt.failwith "secmod_rsa operation on unknown key"
+  | Some v -> v
 
-  let delete h_pub =
+let sm_pub t = t.sm_pub
-    let k = find_exn h_pub in
+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;
-    delete_file t.fs (key_spath k)
+  let* () = delete_file t.fs (key_spath k) in
-
+  let k = gen_key k.coin k.t1 k.t2 in
-  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 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+ () = write_key t.fs k in
   ()
-
-  let sm_pub = t.sm_pub
-  let sign_secmod s = Eddsa.sign ~key:t.sm_priv s
-
-  let sign h_pub msg =
-    let k = find_exn h_pub in
-    Rsa.sign ~key:k.priv msg
-
-  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 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
-end