ok secmod

src/crypto.ml

@@ -207,6 +207,7 @@ module RsaPublicKey = struct
 
   let to_octets = Binary_format_rsa.pub_to_octets
   let of_octets = Binary_format_rsa.pub_of_octets
+  let to_b32 t = B32.encode (to_octets t)
 
   let jsont =
     let of_b32 s =
@@ -214,7 +215,6 @@ module RsaPublicKey = struct
       let+ v = of_octets s in
       v
     in
-    let to_b32 t = B32.encode (to_octets t) in
     Jsont.of_of_string ~kind:"RsaPublicKey" of_b32 ~enc:to_b32
 
   let caqti : t Caqti_type.t =
@@ -252,7 +252,7 @@ module RsaSignature : sig
   type t
 
   val jsont : t Jsont.t
-  val sign : key:RsaPrivateKey.t -> string -> string
+  val sign : key:RsaPrivateKey.t -> string -> t
 end = struct
   type t = string
 

src/devices.ml

@@ -22,5 +22,5 @@ let keys =
   let finally _key = () in
   Vif.Device.v ~name:"keys" ~finally [ Vif.Device.value db_connection ]
   @@ fun (module Conn : Pg.CONN) (_env : env) ->
-  let sm : (module Keys.S) = (module Keys.Make (Conn)) in
+  let keys : (module Keys.S) = (module Keys.Make (Conn)) in
-  sm
+  keys

src/keys.ml

@@ -1,31 +1,34 @@
+open Syntax
+open Crypto
+
 (* TODO better error type *)
 type 'a result = ('a, string) Result.t
 
 module type S = Mod_intf.KEYS
 
 module Make (Conn : Pg.CONN) = struct
+  module Sm_eddsa = Secmod_eddsa.Make ()
+  module Sm_rsa = Secmod_rsa.Make ()
+
   let conn = (module Conn : Pg.CONN)
 
-  open Syntax
+  (* - *)
-  open Crypto
-
   let master_pub = Config.Exchange.master_public_key
-  let secmod_rsa_pub = Secmod_rsa.sm_pub
+  let secmod_eddsa_pub = Sm_eddsa.sm_pub
-  let secmod_eddsa_pub = Secmod_eddsa.sm_pub
+  let secmod_rsa_pub = Sm_rsa.sm_pub
 
-  (* TODO error
+  (* TODO
-     should be a "key not found", either:
+     error "key not found", either:
        - we tried to sign with a key that is not ours
        - key was revoked
-       - bad keyring state
+       - bad keyring state *)
-     *)
   let sign pub s =
-    match Secmod_eddsa.sign ~pub s with
+    match Sm_eddsa.sign pub s with
     | Error e -> Fmt.failwith "sign failure: %s." e
     | Ok v -> v
 
   let sign_denom pub s =
-    match Secmod_rsa.sign ~pub s with
+    match Sm_rsa.sign pub s with
     | Error e -> Fmt.failwith "sign_denom failure: %s." e
     | Ok v -> v
 
@@ -33,6 +36,8 @@ module Make (Conn : Pg.CONN) = struct
   let find_signkey pub = Pg.find_signkey conn pub |> unwrap_err_caqti
   let find_denomination h_pub = Pg.find_denom conn h_pub |> unwrap_err_caqti
 
+  (* TODO
+     check if database is coherent with secmod *)
   let signkeys () : Signkey.t list result =
     let now = Timestamp.of_ptime @@ Ptime_clock.now () in
     Pg.get_active_signkeys conn ~now |> unwrap_err_caqti
@@ -49,7 +54,7 @@ module Make (Conn : Pg.CONN) = struct
       let exchange_pub = pub in
       let anchor_time = stamp_start in
       let duration = Timestamp.diff stamp_start stamp_expire in
-      signf Secmod_eddsa.sign_secmod { exchange_pub; anchor_time; duration }
+      signf Sm_eddsa.sign_secmod { exchange_pub; anchor_time; duration }
     in
     Api.FutureSignKey.
       { key= pub; stamp_start; stamp_expire; stamp_end; signkey_secmod_sig }
@@ -96,7 +101,7 @@ module Make (Conn : Pg.CONN) = struct
       let duration_withdraw =
         Timestamp.diff stamp_start stamp_expire_withdraw
       in
-      signf Secmod_rsa.sign_secmod
+      signf Sm_rsa.sign_secmod
         { h_denom_pub; h_section_name; anchor_time; duration_withdraw }
     in
     FutureDenom.
@@ -116,6 +121,7 @@ module Make (Conn : Pg.CONN) = struct
       }
 
   let future_signkeys () =
+    let l : Sm_eddsa.info list = Sm_eddsa.keys () in
     let+ l =
       list_map
         (fun (pub, t1, t2) ->
@@ -131,7 +137,7 @@ module Make (Conn : Pg.CONN) = struct
                     "secmod/database stamp_start mismatch for signkey `%s`"
                     (EddsaPublicKey.to_b32 pub)
               | true -> Ok None))
-        (Secmod_eddsa.keys ())
+        l
     in
     List.filter_map Fun.id l
 
@@ -163,7 +169,7 @@ module Make (Conn : Pg.CONN) = struct
                     "secmod/database stamp_start mismatch for denomination `%s`"
                     section_name
               | true -> Ok None))
-        (Secmod_rsa.keys ())
+        (Sm_rsa.keys ())
     in
     List.filter_map Fun.id l
 
@@ -223,7 +229,7 @@ module Make (Conn : Pg.CONN) = struct
       }
 
   let certify_future_signkey pub master_sig =
-    Secmod_eddsa.keys () |> List.find_opt (fun (pub', _t1, _t2) -> pub' = pub)
+    Sm_eddsa.keys () |> List.find_opt (fun (pub', _t1, _t2) -> pub' = pub)
     |> function
     | None -> Error "future signkey not found"
     | Some (pub, t1, t2) ->
@@ -240,7 +246,7 @@ module Make (Conn : Pg.CONN) = struct
         Ok ()
 
   let certify_future_denomination h_pub master_sig =
-    Secmod_rsa.keys ()
+    Sm_rsa.keys ()
     |> List.find_opt (fun (_section_name, pub, _t1, _t2) ->
         let h_pub' = Hash.DenominationHash.hash (RsaPublicKey.to_octets pub) in
         h_pub' = h_pub)
@@ -272,7 +278,7 @@ module Make (Conn : Pg.CONN) = struct
   let revoke_signkey pub revoked_sig =
     let* opt = find_signkey pub in
     let* _sk = Option.to_result ~none:"signkey not found" opt in
-    let* () = Secmod_eddsa.revoke pub in
+    let* () = Sm_eddsa.revoke pub in
     let+ () =
       Pg.insert_signkey_revocation conn pub revoked_sig |> unwrap_err_caqti
     in
@@ -282,7 +288,7 @@ module Make (Conn : Pg.CONN) = struct
     let* opt = find_denomination h_pub in
     let* dn = Option.to_result ~none:"denomination not found" opt in
     let pub = dn.pub in
-    let* () = Secmod_rsa.revoke pub in
+    let* () = Sm_rsa.revoke pub in
     let+ () =
       Pg.insert_denomination_revocation conn h_pub revoked_sig
       |> unwrap_err_caqti

src/mod_intf.mli

@@ -1,13 +1,13 @@
+open Crypto
+
 type 'a result = ('a, string) Result.t
 
 module type KEYS = sig
-  open Crypto
-
   val master_pub : eddsa_pub
   val secmod_rsa_pub : eddsa_pub
   val secmod_eddsa_pub : eddsa_pub
   val sign : eddsa_pub -> string -> eddsa_sig
-  val sign_denom : rsa_pub -> string -> string
+  val sign_denom : rsa_pub -> string -> rsa_sig
   val find_signkey : eddsa_pub -> Signkey.t option result
   val find_denomination : denom_hash -> Denomination.t option result
   val signkeys : unit -> Signkey.t list result

src/secmod_eddsa.ml

@@ -1,3 +1,8 @@
+let src = Logs.Src.create "mte.secmod_eddsa"
+
+module Log = (val Logs.src_log src : Logs.LOG)
+
+(* - *)
 open Syntax
 open Crypto
 open Time
@@ -18,6 +23,7 @@ type t = {
 
 (* -- util -- *)
 
+(* TODO time *)
 let time_abs_of_string s =
   int_of_string_opt s |> Option.map (fun n -> Absolute.of_s (Int64.of_int n))
 
@@ -48,33 +54,43 @@ let key_fpath k =
 (* -- IO -- *)
 
 let read_key fpath =
+  Log.debug (fun m -> m "reading key file `%a`" Fpath.pp fpath);
   let* data = Bos.OS.File.read fpath |> unwrap_err_msg in
   EddsaPrivateKey.of_octets data
 
 let write_eddsa fpath priv =
+  Log.debug (fun m -> m "writing key file `%a`" Fpath.pp fpath);
   let data = EddsaPrivateKey.to_octets priv in
   Bos.OS.File.write fpath data |> unwrap_err_msg
 
 let write_key k = write_eddsa (key_fpath k) k.priv
 
-let delete_key_file k =
+let delete_file fpath =
-  let+ () =
+  Log.debug (fun m -> m "(disabled) delete key file `%a`" Fpath.pp fpath);
-    Bos.OS.File.delete ~must_exist:true (key_fpath k) |> unwrap_err_msg
+  (* TODO just to be safe~~
-  in
+  let+ () = Bos.OS.File.delete ~must_exist:true fpath |> unwrap_err_msg in
-  ()
+*)
+  Ok ()
 
 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
+  if b then Log.info (fun m -> m "created directory `%a`" Fpath.pp dir);
-    Logs.info (fun m -> m "secmod_eddsa: created directory `%a`" Fpath.pp dir);
   let+ l =
-    Bos.OS.Dir.contents ~dotfiles:false ~rel:true dir |> unwrap_err_msg
+    Bos.OS.Dir.contents ~dotfiles:false ~rel:false dir |> unwrap_err_msg
   in
   l
 
 (* -- *)
 
+let gen_key t1 t2 =
+  let priv, pub = EddsaPrivateKey.generate () in
+  Log.debug (fun m ->
+      m "generated key (%s-%s):@,`%s`" (time_abs_to_string t1)
+        (time_abs_to_string t2)
+        (EddsaPublicKey.to_b32 pub));
+  { priv; pub; t1; t2 }
+
 let sort_keys l = List.sort (fun a b -> Absolute.compare a.t2 b.t2) l
 
 let split_in_periodes ~start ~end_ =
@@ -91,25 +107,22 @@ let split_in_periodes ~start ~end_ =
   in
   go acc start end_
 
+(* TODO do not exceed lookahead (probably more important...) *)
+(* try to not generate keys with validity start in the past *)
 let gen_additional_keys_until_lookahead ~now l =
-  (* TODO do not exceed lookahead (probably more important...) *)
-  (* try to not generate keys with validity start in the past *)
   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
+  if Absolute.compare start end_ >= 0 then []
-  let new_keys =
+  else
-    List.map
+    let periodes = split_in_periodes ~start ~end_ in
-      (fun (t1, t2) ->
+    let new_keys = List.map (fun (t1, t2) -> gen_key t1 t2) periodes in
-        let priv, pub = EddsaPrivateKey.generate () in
+    new_keys
-        { priv; pub; t1; t2 })
-      periodes
-  in
-  new_keys
 
+(* TODO config *)
 let sm_key_fpath =
   Result.get_ok
   @@
@@ -149,6 +162,8 @@ let init () =
     | Some t -> Ok t
     | None ->
         let sm_key_priv, sm_pub = EddsaPrivateKey.generate () in
+        Log.debug (fun m ->
+            m "generated secmod key: `%s`" (EddsaPublicKey.to_b32 sm_pub));
         let* () = write_eddsa sm_key_fpath sm_key_priv in
         let ht = Hashtbl.create 0xff in
         Ok { sm_key_priv; sm_pub; ht }
@@ -160,54 +175,59 @@ let init () =
   let+ () = list_iter write_key new_keys in
   t
 
-(* --- *)
+type info = eddsa_pub * Time.Absolute.t * Time.Absolute.t
 
-let t =
+module Make () = struct
-  match init () with
+  type pub = EddsaPublicKey.t
-  | Error e -> Fmt.failwith "secmod_eddsa initialization failure: %s." e
+  type info = EddsaPublicKey.t * Time.Absolute.t * Time.Absolute.t
-  | Ok t -> t
 
-let find pub =
+  let t =
-  Hashtbl.find_opt t.ht pub |> Option.to_result ~none:"key not found"
+    match init () with
+    | Error e -> Fmt.failwith "secmod_eddsa initialization failure: %s." e
+    | Ok t -> t
 
-let add t1 t2 =
+  let find pub =
-  let priv, pub = EddsaPrivateKey.generate () in
+    Hashtbl.find_opt t.ht pub |> Option.to_result ~none:"key not found"
-  let k = { priv; pub; t1; t2 } in
-  Hashtbl.replace t.ht k.pub k;
-  ()
 
-let delete pub =
+  let add t1 t2 =
-  let* k = find pub in
+    let k = gen_key t1 t2 in
-  Hashtbl.remove t.ht k.pub; delete_key_file k
+    Hashtbl.replace t.ht k.pub k;
+    ()
 
-let delete_outdated ~now =
+  let delete pub =
-  Hashtbl.to_seq_values t.ht
+    let* k = find pub in
-  |> List.of_seq
+    Hashtbl.remove t.ht k.pub;
-  |> List.filter (fun k -> Absolute.compare now k.t2 >= 0)
+    delete_file (key_fpath k)
-  |> List.map (fun k -> k.pub)
-  |> list_iter delete
 
-(* ---- *)
+  let _delete_outdated ~now =
+    Hashtbl.to_seq_values t.ht
+    |> List.of_seq
+    |> List.filter (fun k -> Absolute.compare now k.t2 >= 0)
+    |> List.map (fun k -> k.pub)
+    |> list_iter delete
 
-let sm_pub = t.sm_pub
+  (* ---- *)
 
-let keys () =
+  let sm_pub = t.sm_pub
-  Hashtbl.to_seq_values t.ht
-  |> List.of_seq
-  |> List.map (fun { priv= _; pub; t1; t2 } -> (pub, t1, t2))
 
-let sign_secmod s = EddsaSignature.sign ~key:t.sm_key_priv s
+  let keys () =
+    Hashtbl.to_seq_values t.ht
+    |> List.of_seq
+    |> List.map (fun { priv= _; pub; t1; t2 } -> (pub, t1, t2))
 
-let sign ~pub s =
+  let sign_secmod s = EddsaSignature.sign ~key:t.sm_key_priv s
-  let+ k = find pub in
-  let data = EddsaSignature.sign ~key:k.priv s in
-  data
 
-(* delete and replace *)
+  let sign pub s =
-let revoke pub =
+    let+ k = find pub in
-  let* k = find pub in
+    let data = EddsaSignature.sign ~key:k.priv s in
-  let* () = delete pub in
+    data
-  add k.t1 k.t2; Ok ()
+
+  (* delete and replace *)
+  let revoke pub =
+    let* k = find pub in
+    let* () = delete pub in
+    add k.t1 k.t2; Ok ()
+end
 
 (* TODO
   - more checks

src/secmod_rsa.ml

@@ -1,4 +1,9 @@
 (* TODO refacto common parts with secmod_eddsa *)
+let src = Logs.Src.create "mte.secmod_rsa"
+
+module Log = (val Logs.src_log src : Logs.LOG)
+
+(* - *)
 open Syntax
 open Crypto
 open Time
@@ -50,14 +55,17 @@ let key_fpath k =
 (* -- IO -- *)
 
 let read_eddsa fpath =
+  Log.debug (fun m -> m "reading key file `%a`" Fpath.pp fpath);
   let* data = Bos.OS.File.read fpath |> unwrap_err_msg in
   EddsaPrivateKey.of_octets data
 
 let read_rsa fpath =
+  Log.debug (fun m -> m "reading key file `%a`" Fpath.pp fpath);
   let* data = Bos.OS.File.read fpath |> unwrap_err_msg in
   RsaPrivateKey.of_octets data
 
 let write_eddsa fpath priv =
+  Log.debug (fun m -> m "writing key file `%a`" Fpath.pp fpath);
   let data = EddsaPrivateKey.to_octets priv in
   Bos.OS.File.write fpath data |> unwrap_err_msg
 
@@ -67,24 +75,30 @@ let write_rsa fpath priv =
 
 let write_key k = write_rsa (key_fpath k) k.priv
 
-let delete_key_file k =
+let delete_file fpath =
-  let+ () =
+  Log.debug (fun m -> m "(disabled) delete key file `%a`" Fpath.pp fpath);
-    Bos.OS.File.delete ~must_exist:true (key_fpath k) |> unwrap_err_msg
+  (* TODO just to be safe~~
-  in
+  let+ () = Bos.OS.File.delete ~must_exist:true fpath |> unwrap_err_msg in
-  ()
+*)
+  Ok ()
 
 let get_key_dir_contents dir_fpath =
   let* b = Bos.OS.Dir.create ~mode:0o700 dir_fpath |> unwrap_err_msg in
-  if b then
+  if b then Log.info (fun m -> m "created directory `%a`" Fpath.pp dir_fpath);
-    Logs.info (fun m ->
-        m "secmod_rsa: created directory `%a`" Fpath.pp dir_fpath);
   let+ l =
-    Bos.OS.Dir.contents ~dotfiles:false ~rel:true dir_fpath |> unwrap_err_msg
+    Bos.OS.Dir.contents ~dotfiles:false ~rel:false dir_fpath |> unwrap_err_msg
   in
   l
 
 (* -- *)
 
+let gen_key section_name t1 t2 =
+  let priv, pub = RsaPrivateKey.generate ~bits:Cfg.rsa_keysize () in
+  Log.debug (fun m ->
+      m "generated key (%s-%s):@,`%s`" (time_abs_to_string t1)
+        (time_abs_to_string t2) (RsaPublicKey.to_b32 pub));
+  { section_name; priv; pub; t1; t2 }
+
 let sort_keys l = List.sort (fun a b -> Absolute.compare a.t2 b.t2) l
 
 let split_in_periodes ~start ~end_ =
@@ -110,15 +124,13 @@ let gen_additional_keys_until_lookahead ~now ~section_name l =
     | 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
+  if Absolute.compare start end_ >= 0 then []
-  let new_keys =
+  else
-    List.map
+    let periodes = split_in_periodes ~start ~end_ in
-      (fun (t1, t2) ->
+    let new_keys =
-        let priv, pub = RsaPrivateKey.generate ~bits:Cfg.rsa_keysize () in
+      List.map (fun (t1, t2) -> gen_key section_name t1 t2) periodes
-        { section_name; priv; pub; t1; t2 })
+    in
-      periodes
+    new_keys
-  in
-  new_keys
 
 let sm_key_fpath =
   Result.get_ok
@@ -165,6 +177,8 @@ let init () =
     | Some t -> Ok t
     | None ->
         let sm_key_priv, sm_pub = EddsaPrivateKey.generate () in
+        Log.debug (fun m ->
+            m "generated secmod key: `%s`" (EddsaPublicKey.to_b32 sm_pub));
         let* () = write_eddsa sm_key_fpath sm_key_priv in
         let ht = Hashtbl.create 0xff in
         Ok { sm_key_priv; sm_pub; ht }
@@ -183,55 +197,58 @@ let init () =
   let new_keys = List.concat new_keys_l in
   let () = List.iter (fun k -> Hashtbl.replace t.ht k.pub k) new_keys in
   let+ () = list_iter write_key new_keys in
-
   t
 
-(* --- *)
+type info = string * rsa_pub * Time.Absolute.t * Time.Absolute.t
 
-let t =
+module Make () = struct
-  match init () with
+  type pub = RsaPublicKey.t
-  | Error e -> Fmt.failwith "secmod_rsa initialization failure: %s." e
+  type info = string * RsaPublicKey.t * Time.Absolute.t * Time.Absolute.t
-  | Ok t -> t
 
-let find pub =
+  (* --- *)
-  Hashtbl.find_opt t.ht pub |> Option.to_result ~none:"key not found"
+  let t =
+    match init () with
+    | Error e -> Fmt.failwith "secmod_rsa initialization failure: %s." e
+    | Ok t -> t
 
-let delete pub =
+  let find pub =
-  let* k = find pub in
+    Hashtbl.find_opt t.ht pub |> Option.to_result ~none:"key not found"
-  Hashtbl.remove t.ht k.pub; delete_key_file k
 
-let delete_outdated ~now =
+  let delete pub =
-  Hashtbl.to_seq_values t.ht
+    let* k = find pub in
-  |> List.of_seq
+    Hashtbl.remove t.ht k.pub;
-  |> List.filter (fun k -> Absolute.compare now k.t2 >= 0)
+    delete_file (key_fpath k)
-  |> List.map (fun k -> k.pub)
-  |> list_iter delete
 
-let add section_name t1 t2 =
+  let _delete_outdated ~now =
-  let priv, pub = RsaPrivateKey.generate ~bits:Cfg.rsa_keysize () in
+    Hashtbl.to_seq_values t.ht
-  let k = { section_name; priv; pub; t1; t2 } in
+    |> List.of_seq
-  Hashtbl.replace t.ht k.pub k;
+    |> List.filter (fun k -> Absolute.compare now k.t2 >= 0)
-  ()
+    |> List.map (fun k -> k.pub)
+    |> list_iter delete
 
-(* ---- *)
+  let add section_name t1 t2 =
+    let k = gen_key section_name t1 t2 in
+    Hashtbl.replace t.ht k.pub k;
+    ()
 
-let sm_pub = t.sm_pub
+  let sm_pub = t.sm_pub
 
-let keys () =
+  let keys () =
-  Hashtbl.to_seq_values t.ht
+    Hashtbl.to_seq_values t.ht
-  |> List.of_seq
+    |> List.of_seq
-  |> List.map (fun { section_name; priv= _; pub; t1; t2 } ->
+    |> List.map (fun { section_name; priv= _; pub; t1; t2 } ->
-      (section_name, pub, t1, t2))
+        (section_name, pub, t1, t2))
 
-let sign_secmod s = EddsaSignature.sign ~key:t.sm_key_priv s
+  let sign_secmod s = EddsaSignature.sign ~key:t.sm_key_priv s
 
-let sign ~pub s =
+  let sign pub s =
-  let+ k = find pub in
+    let+ k = find pub in
-  let data = RsaSignature.sign ~key:k.priv s in
+    let data = RsaSignature.sign ~key:k.priv s in
-  data
+    data
 
-let revoke pub =
+  let revoke pub =
-  let* k = find pub in
+    let* k = find pub in
-  let* () = delete pub in
+    let* () = delete pub in
-  add k.section_name k.t1 k.t2;
+    add k.section_name k.t1 k.t2;
-  Ok ()
+    Ok ()
+end

src/util.ml

@@ -48,10 +48,8 @@ module Log_reporter = struct
     in
     { report }
 
-  (* TODO logs
-     - vif shouldn't use/set the default reporter
-     - Log.err all `Internal_server_error response *)
   let setup () =
+    (*Logs.Src.set_level Secmod_rsa.src (Some Logs.Debug);*)
     let level = Some Logs.Info in
     Logs.set_level ~all:false level;
     Fmt_tty.setup_std_outputs ~style_renderer:`Ansi_tty ~utf_8:true ();