src/crypto.ml

@@ -119,6 +119,7 @@ module EddsaPrivateKey = struct
 
   type t = priv
 
+  let generate = generate
   let pub_of_priv = pub_of_priv
   let to_octets t = priv_to_octets t
 
@@ -251,9 +252,14 @@ module RsaSignature : sig
   type t
 
   val jsont : t Jsont.t
+  val sign : key:RsaPrivateKey.t -> string -> string
 end = struct
   type t = string
 
+  (* TODO crypto
+     this is a placeholder signature algorithm *)
+  let sign ~key s = Mirage_crypto_pk.Rsa.PKCS1.sig_encode ~key s
+
   let jsont =
     let of_b32 s = B32.decode s in
     let to_b32 t = B32.encode t in

src/secmod_eddsa.ml

@@ -1,22 +1,18 @@
 open Syntax
 open Crypto
 open Time
-open Mirage_crypto_ec
 module Cfg = Config.Exchange_secmod_eddsa
 
-type priv = Ed25519.priv
-type pub = Ed25519.pub
-
 type key = {
-  priv: priv;
-  pub: pub;
+  priv: EddsaPrivateKey.t;
+  pub: EddsaPublicKey.t;
   t1: Absolute.t;
   t2: Absolute.t;
 }
 
 type t = {
-  sm_key_priv: priv;
-  sm_key_pub: pub;
+  sm_key_priv: EddsaPrivateKey.t;
+  sm_key_pub: EddsaPublicKey.t;
   mutable keys: key list;
 }
 
@@ -108,7 +104,7 @@ let gen_additional_keys_until_lookahead ~now l =
   let new_keys =
     List.map
       (fun (t1, t2) ->
-        let priv, pub = Mirage_crypto_ec.Ed25519.generate () in
+        let priv, pub = EddsaPrivateKey.generate () in
         { priv; pub; t1; t2 })
       periodes
   in
@@ -150,7 +146,7 @@ let init () =
     match opt with
     | Some t -> Ok t
     | None ->
-        let sm_key_priv, sm_key_pub = Mirage_crypto_ec.Ed25519.generate () in
+        let sm_key_priv, sm_key_pub = EddsaPrivateKey.generate () in
         let* () = write_eddsa sm_key_fpath sm_key_priv in
         Ok { sm_key_priv; sm_key_pub; keys= [] }
   in

src/secmod_rsa.ml

@@ -0,0 +1,199 @@
+(* TODO refacto common parts with secmod_eddsa *)
+open Syntax
+open Crypto
+open Time
+module Cfg = Config.Exchange_secmod_rsa
+
+type key = {
+  priv: RsaPrivateKey.t;
+  pub: RsaPublicKey.t;
+  t1: Absolute.t;
+  t2: Absolute.t;
+}
+
+type t = {
+  sm_key_priv: EddsaPrivateKey.t;
+  sm_key_pub: EddsaPublicKey.t;
+  mutable keys: key list;
+}
+
+(* -- util -- *)
+
+let time_abs_of_string s =
+  int_of_string_opt s |> Option.map (fun n -> Absolute.of_s (Int64.of_int n))
+
+let t1_t2_of_fpath fpath =
+  let fname = Fpath.filename fpath in
+  match String.split_on_char '-' fname with
+  | [] -> Fmt.failwith "not possible"
+  | [ t1; t2 ] -> (
+      match (time_abs_of_string t1, time_abs_of_string t2) with
+      | None, _ | _, None -> None
+      | Some t1, Some t2 -> Some (t1, t2))
+  | _ -> None
+
+let time_abs_to_string abs =
+  abs
+  |> Timestamp.of_absolute
+  |> Timestamp.to_s
+  |> Option.get
+  |> Int64.to_int
+  |> string_of_int
+
+let key_fpath k =
+  let t1 = time_abs_to_string k.t1 in
+  let t2 = time_abs_to_string k.t2 in
+  let fname = Fmt.str "%s-%s" t1 t2 in
+  Fpath.(v Cfg.key_dir / fname)
+
+(* -- IO -- *)
+
+let read_eddsa fpath =
+  let* data = Bos.OS.File.read fpath |> unwrap_err_msg in
+  EddsaPrivateKey.of_octets data
+
+let read_rsa fpath =
+  let* data = Bos.OS.File.read fpath |> unwrap_err_msg in
+  RsaPrivateKey.of_octets data
+
+let write_eddsa fpath priv =
+  let data = EddsaPrivateKey.to_octets priv in
+  Bos.OS.File.write fpath data |> unwrap_err_msg
+
+let write_rsa fpath priv =
+  let data = RsaPrivateKey.to_octets priv in
+  Bos.OS.File.write fpath data |> unwrap_err_msg
+
+let write_key k = write_rsa (key_fpath k) k.priv
+
+let delete_key_file k =
+  let+ () =
+    Bos.OS.File.delete ~must_exist:true (key_fpath k) |> unwrap_err_msg
+  in
+  ()
+
+let get_key_dir_contents dir =
+  let* dir = Fpath.of_string dir |> unwrap_err_msg in
+  let* b = Bos.OS.Dir.create ~mode:0o700 dir |> unwrap_err_msg in
+  if b then
+    Logs.info (fun m -> m "secmod_rsa: created directory `%a`" Fpath.pp dir);
+  let+ l =
+    Bos.OS.Dir.contents ~dotfiles:false ~rel:true dir |> unwrap_err_msg
+  in
+  l
+
+(* -- *)
+
+let sort_keys l = List.sort (fun a b -> Absolute.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 = Absolute.add start Cfg.duration in
+  let acc = [ (t1, t2) ] in
+  let start = t2 in
+  let rec go acc start end_ =
+    let t1 = Absolute.sub start Cfg.overlap_duration in
+    let t2 = Absolute.add start Cfg.duration in
+    if t2 > end_ then acc else go ((t1, t2) :: acc) t2 end_
+  in
+  go acc start end_
+
+let gen_additional_keys_until_lookahead ~now l =
+  (* try to _not_ generate keys with validity start in the past
+     (probably not important) *)
+  let start =
+    match List.rev (sort_keys l) with
+    | [] -> now
+    | hd :: _ -> Absolute.sub hd.t2 Cfg.overlap_duration
+  in
+  let end_ = Absolute.add now Cfg.lookahead_sign in
+  let periodes = split_in_periodes ~start ~end_ in
+  let new_keys =
+    List.map
+      (fun (t1, t2) ->
+        (* TODO ~bits is in coin's config *)
+        let priv, pub = RsaPrivateKey.generate ~bits:2048 () in
+        { priv; pub; t1; t2 })
+      periodes
+  in
+  new_keys
+
+let sm_key_fpath =
+  Result.get_ok
+  @@
+  let+ fpath = Fpath.of_string Cfg.sm_priv_key |> unwrap_err_msg in
+  Fpath.normalize fpath
+
+(* we load sm_key separately
+   we don't accept non-key files in key_dir *)
+let load_key fpath =
+  match Fpath.equal (Fpath.normalize fpath) sm_key_fpath with
+  | true -> Ok None
+  | false -> (
+      match t1_t2_of_fpath fpath with
+      | None -> Fmt.error "invalid file `%a`" Fpath.pp fpath
+      | Some (t1, t2) ->
+          let* priv = read_rsa fpath in
+          let pub = RsaPrivateKey.pub_of_priv priv in
+          Ok (Some { priv; pub; t1; t2 }))
+
+let load () =
+  let* l = get_key_dir_contents Cfg.key_dir in
+  let* l = list_map load_key l in
+  let keys = List.filter_map Fun.id l in
+  match keys with
+  | [] -> Ok None
+  | _l ->
+      let* sm_key_priv = read_eddsa sm_key_fpath in
+      let sm_key_pub = EddsaPrivateKey.pub_of_priv sm_key_priv in
+      Ok (Some { sm_key_priv; sm_key_pub; keys })
+
+let init () =
+  let* opt = load () in
+  let* t =
+    match opt with
+    | Some t -> Ok t
+    | None ->
+        let sm_key_priv, sm_key_pub = EddsaPrivateKey.generate () in
+        let* () = write_eddsa sm_key_fpath sm_key_priv in
+        Ok { sm_key_priv; sm_key_pub; keys= [] }
+  in
+  let now = Absolute.of_ptime (Ptime_clock.now ()) in
+  let new_keys = gen_additional_keys_until_lookahead ~now t.keys in
+  let+ () = list_iter write_key new_keys in
+  let keys = sort_keys (t.keys @ new_keys) in
+  { t with keys }
+
+(* --- *)
+
+let t =
+  match init () with
+  | Error e -> Fmt.failwith "secmod_rsa initialization failure: %s." e
+  | Ok t -> t
+
+let sm_key_pub = t.sm_key_pub
+let keys () = List.map (fun { priv= _; pub; t1; t2 } -> (pub, t1, t2)) t.keys
+let sign_with_sm_key s = EddsaSignature.sign ~key:t.sm_key_priv s
+
+let find_key pub =
+  List.find_opt (fun k -> k.pub = pub) t.keys
+  |> Option.to_result ~none:"key not found"
+
+let sign ~pub s =
+  let+ k = find_key pub in
+  let data = RsaSignature.sign ~key:k.priv s in
+  data
+
+let delete_key pub =
+  let* k = find_key pub in
+  let l = List.filter (fun k -> k.pub <> pub) t.keys in
+  t.keys <- l;
+  delete_key_file k
+
+let delete_outdated ~now =
+  t.keys
+  |> List.filter (fun k -> Absolute.compare now k.t2 >= 0)
+  |> List.map (fun k -> k.pub)
+  |> list_iter delete_key