rm util.ml + clean up

src/config.ml

@@ -222,10 +222,6 @@ module Exchange_secmod_rsa = struct
 
   let lookahead_sign = get "lookahead_sign" |> duration
   let overlap_duration = get "overlap_duration" |> duration
-
-  (* 8.3 filenames for FAT *)
-  let key_dir = "rsa" |> spath
-  let sm_priv_key = "sm_rsa" |> spath
 end
 
 module Exchange_secmod_eddsa = struct
@@ -236,8 +232,6 @@ module Exchange_secmod_eddsa = struct
   let lookahead_sign = get "lookahead_sign" |> duration
   let overlap_duration = get "overlap_duration" |> duration
   let duration = get "duration" |> duration
-  let key_dir = "eddsa" |> spath
-  let sm_priv_key = "sm_eddsa" |> spath
 end
 
 (* -- *)

src/global.ml

@@ -2,15 +2,15 @@
    [connect_pool] with parameter [?post_connect] for preflight *)
 let db_conn =
   let f Env.{ sw; stack; tcp; dns; fs= _ } =
-    Logs.info (fun m -> m "Connecting to database ...");
+    Logs.info (fun m -> m "Connecting to database");
     let db_uri = Config.Exchangedb_postgres.config in
     match Caqti_mnet.connect ~sw stack tcp dns db_uri with
     | Error err ->
         Fmt.failwith "Database connection failure: %a." Caqti_error.pp err
     | Ok conn ->
-        Logs.info (fun m -> m "... connection done.");
+        Logs.info (fun m -> m "Database connection done");
         let () = Pg.preflight conn in
-        Logs.info (fun m -> m "Preflight done.");
+        Logs.info (fun m -> m "Database connection preflight done");
         conn
   in
   let finally (module Conn : Pg.CONN) = Conn.disconnect () in

src/log_reporter.ml

@@ -0,0 +1,60 @@
+let detail_tag : string Logs.Tag.def =
+  Logs.Tag.def "Detail tag" ~doc:"" Fmt.string
+
+let detail s = Logs.Tag.(empty |> add detail_tag s)
+let time_anchor = Mirage_ptime.now () |> Ptime.to_span
+
+let color_of_log_level = function
+  | Logs.App -> `White
+  | Error -> `Red
+  | Warning -> `Yellow
+  | Info -> `Blue
+  | Debug -> `Magenta
+
+let reporter : Logs.reporter =
+  let open Fmt in
+  let pp_timestamp = styled `Faint (styled (`Fg `White) (fmt "%09.04f")) in
+  let pp_header ppf v =
+    let color = color_of_log_level (fst v) in
+    let pp = styled (`Fg color) Logs.pp_header in
+    pf ppf "%a" pp v
+  in
+  let pp_src_name =
+    let pp = using Logs.Src.name (styled `Cyan (fmt "%s: ")) in
+    fun ppf v -> if not @@ Logs.Src.equal Logs.default v then pp ppf v
+  in
+  let pp_detail = option (styled `Green (fmt " (%s)")) in
+  let report src lvl ~over k msgf =
+    let ppf =
+      match lvl with
+      | Logs.App -> stdout
+      | Error | Warning | Info | Debug -> stderr
+    in
+    let k _ppf = over (); k () in
+    let with_detail h tags k user_fmt =
+      let detail = Option.bind tags (Logs.Tag.find detail_tag) in
+      let timestamp =
+        Ptime.sub_span (Mirage_ptime.now ()) time_anchor
+        |> Option.map Ptime.to_float_s
+        |> Option.value ~default:0.
+      in
+      let k ppf = kpf k ppf "%a@." pp_detail detail in
+      let k ppf = kpf k ppf user_fmt in
+      kpf k ppf "%a %a %a" pp_timestamp timestamp pp_header (lvl, h) pp_src_name
+        src
+    in
+    msgf @@ fun ?header ?tags fmt -> with_detail header tags k fmt
+  in
+  { report }
+
+let set_level_secmods lvl =
+  let secmod_srcs = [ Secmod_rsa.src; Secmod_eddsa.src ] in
+  List.iter (fun src -> Logs.Src.set_level src lvl) secmod_srcs;
+  ()
+
+let setup level =
+  (*     set_level_secmods level; *)
+  Logs.set_level ~all:false level;
+  Logs.Src.set_level Logs.default level;
+  Logs.set_reporter reporter;
+  ()

src/mte.ml

@@ -73,7 +73,7 @@ module RNG = Mirage_crypto_rng.Fortuna
 
 let () =
   let ( let@ ) finally fn = Fun.protect ~finally fn in
-  Util.Log_reporter.setup ();
+  Log_reporter.setup (Some Logs.Info);
   let rng =
     let rng () = Mirage_crypto_rng_mkernel.initialize (module RNG) in
     Mkernel.map rng Mkernel.[]
@@ -98,6 +98,5 @@ let () =
   let env = Env.{ sw; stack; tcp; dns; fs } in
   let devices = Vifu.Devices.[ Global.db_conn; Global.keys ] in
   let cfg = Vifu.Config.v Config.Exchange.port in
-  Logs.info (fun m ->
+  Logs.info (fun m -> m "Starting MTE server");
-      m ~tags:(Util.Log_reporter.detail "...") "Starting MTE server");
   Vifu.run ~cfg ~devices tcp routes env

src/secmod_eddsa.ml

@@ -21,7 +21,14 @@ open Crypto
 open Time
 module Sfn = Mfat.Sfn
 module Spath = Mfat.Spath
-module Cfg = Config.Exchange_secmod_eddsa
+
+module Cfg = struct
+  include Config.Exchange_secmod_eddsa
+
+  (* 8.3 filenames for FAT *)
+  let key_dir = Config.spath "/EDDSA"
+  let sm_key = Config.spath "/SM_EDDSA"
+end
 
 type key = {
   priv: EddsaPrivateKey.t;
@@ -127,16 +134,13 @@ let load fs =
     else Fat.mkdir fs Cfg.key_dir |> unwrap_msg
   in
   let* l = Fat.ls fs Cfg.key_dir |> unwrap_msg in
-  let l = List.map (fun entry -> entry.Fat.name) l in
+  let l = List.map (fun entry -> Spath.add Cfg.key_dir entry.Fat.name) l in
-  let l = List.map (Spath.add Cfg.key_dir) l in
+  let l = List.filter (fun spath -> not @@ Spath.equal spath Cfg.sm_key) l in
-  let l =
-    List.filter (fun spath -> not @@ Spath.equal spath Cfg.sm_priv_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_priv_key in
+      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 })
@@ -152,7 +156,7 @@ let init fs =
             m "generated secmod key: `%s`" (EddsaPublicKey.to_b32 sm_pub));
         let ht = Hashtbl.create 0xff in
         let t = { fs; sm_priv; sm_pub; ht } in
-        let* () = write_eddsa fs Cfg.sm_priv_key t.sm_priv in
+        let* () = write_eddsa fs Cfg.sm_key t.sm_priv in
         Ok t
   in
   let now = TimeAbsolute.of_ptime (Mirage_ptime.now ()) in

src/secmod_rsa.ml

@@ -9,35 +9,36 @@ open Time
 module Sfn = Mfat.Sfn
 module Spath = Mfat.Spath
 
+module Coin_config = struct
+  type t = {
+    name: string;
+    duration_withdraw: TimeRelative.t;
+    rsa_keysize: int;
+  }
+
+  let of_coin (coin : Config.Coin.t) =
+    {
+      name= coin.section_name;
+      duration_withdraw= coin.duration_withdraw;
+      rsa_keysize= coin.rsa_keysize;
+    }
+end
+
 module Cfg = struct
-  open Config
+  include Config.Exchange_secmod_rsa
-  include Exchange_secmod_rsa
 
-  let sections = Coin.all_coins |> List.map (fun coin -> coin.Coin.section_name)
+  let key_dir = Config.spath "/RSA"
+  let sm_key = Config.spath "/SM_RSA"
+  let coin_config_list = List.map Coin_config.of_coin Config.Coin.all_coins
 
-  (* helper functions to get config value from section_name: *)
+  let get_coin_config ~section_name =
-
+    coin_config_list
-  let duration_withdraw =
+    |> List.find_opt (fun (cfg : Coin_config.t) ->
-    let duration_withdraw_assoc =
+        String.equal cfg.name section_name)
-      Coin.all_coins
+    |> function
-      |> List.map (fun coin -> (coin.Coin.section_name, coin.duration_withdraw))
+    | None ->
-    in
+        Fmt.failwith "secmod_rsa failure: section `%s` not found" section_name
-    fun ~section_name ->
+    | Some cfg -> cfg
-      match List.assoc_opt section_name duration_withdraw_assoc with
-      | None ->
-          Fmt.failwith "section_name `%s` not found in config" section_name
-      | Some v -> v
-
-  let rsa_keysize =
-    let rsa_keysize_assoc =
-      Coin.all_coins
-      |> List.map (fun coin -> (coin.Coin.section_name, coin.rsa_keysize))
-    in
-    fun ~section_name ->
-      match List.assoc_opt section_name rsa_keysize_assoc with
-      | None ->
-          Fmt.failwith "section_name `%s` not found in config" section_name
-      | Some v -> v
 end
 
 type key = {
@@ -107,32 +108,32 @@ let delete_file fs spath =
 
 (* -- *)
 
-let gen_key ~section_name t1 t2 =
+let gen_key cfg t1 t2 =
-  let bits = Cfg.rsa_keysize ~section_name in
+  let priv, pub = RsaPrivateKey.generate ~bits:cfg.Coin_config.rsa_keysize () in
-  let priv, pub = RsaPrivateKey.generate ~bits () in
   let h_pub = DenominationHash.hash_of_rsa pub in
-  let k = { section_name; priv; pub; h_pub; t1; t2 } in
+  let k = { section_name= cfg.name; priv; pub; h_pub; t1; t2 } in
   Log.debug (fun m ->
-      m "generated key %s `%s`" section_name (DenominationHash.to_b32 k.h_pub));
+      m "generated key %s `%s`" cfg.Coin_config.name
+        (DenominationHash.to_b32 k.h_pub));
   k
 
 let sort_keys l = List.sort (fun a b -> TimeAbsolute.compare a.t2 b.t2) l
 
-let split_in_periodes ~start ~end_ ~duration_withdraw =
+let split_in_periodes (cfg : Coin_config.t) ~start ~end_ =
   assert (start < end_);
   (* no overlap on first periode *)
   let t1 = start in
-  let t2 = TimeAbsolute.add start duration_withdraw in
+  let t2 = TimeAbsolute.add start cfg.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
+    let t2 = TimeAbsolute.add start cfg.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 ~now ~section_name l =
+let gen_additional_keys_until_lookahead cfg ~now l =
   let start =
     match List.rev (sort_keys l) with
     | [] -> now
@@ -141,11 +142,8 @@ let gen_additional_keys_until_lookahead ~now ~section_name l =
   let end_ = TimeAbsolute.add now Cfg.lookahead_sign in
   if TimeAbsolute.compare start end_ >= 0 then []
   else
-    let duration_withdraw = Cfg.duration_withdraw ~section_name in
+    let periodes = split_in_periodes cfg ~start ~end_ in
-    let periodes = split_in_periodes ~start ~end_ ~duration_withdraw in
+    let new_keys = List.map (fun (t1, t2) -> gen_key cfg t1 t2) periodes in
-    let new_keys =
-      List.map (fun (t1, t2) -> gen_key ~section_name t1 t2) periodes
-    in
     new_keys
 
 let load fs =
@@ -154,16 +152,13 @@ let load fs =
     else Fat.mkdir fs Cfg.key_dir |> unwrap_msg
   in
   let* l = Fat.ls fs Cfg.key_dir |> unwrap_msg in
-  let l = List.map (fun entry -> entry.Fat.name) l in
+  let l = List.map (fun entry -> Spath.add Cfg.key_dir entry.Fat.name) l in
-  let l = List.map (Spath.add Cfg.key_dir) l in
+  let l = List.filter (fun spath -> not @@ Spath.equal spath Cfg.sm_key) l in
-  let l =
-    List.filter (fun spath -> not @@ Spath.equal spath Cfg.sm_priv_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_priv_key in
+      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 })
@@ -178,19 +173,16 @@ let init fs =
         let sm_priv, sm_pub = EddsaPrivateKey.generate () in
         Log.debug (fun m ->
             m "generated secmod key: `%s`" (EddsaPublicKey.to_b32 sm_pub));
-        let* () = write_eddsa fs Cfg.sm_priv_key sm_priv in
+        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 =
-    List.map
+    Cfg.coin_config_list
-      (fun section_name ->
+    |> List.map (fun (cfg : Coin_config.t) ->
-        let keys =
+        let keys = List.filter (fun k -> k.section_name = cfg.name) all_keys in
-          List.filter (fun k -> k.section_name = section_name) all_keys
+        gen_additional_keys_until_lookahead cfg ~now keys)
-        in
-        gen_additional_keys_until_lookahead ~now ~section_name keys)
-      Cfg.sections
   in
   let new_keys = List.concat new_keys_l in
   List.iter (fun k -> Hashtbl.replace t.ht k.h_pub k) new_keys;
@@ -218,8 +210,8 @@ module Make (Fs : Fat.FS) = struct
     |> List.map (fun (h_pub, _k) -> h_pub)
     |> list_iter delete
 
-  let add section_name t1 t2 =
+  let add cfg t1 t2 =
-    let k = gen_key ~section_name t1 t2 in
+    let k = gen_key cfg t1 t2 in
     let+ () = write_key t.fs k in
     Hashtbl.replace t.ht k.h_pub k;
     ()
@@ -237,7 +229,8 @@ module Make (Fs : Fat.FS) = struct
         m "revoke `%s`" (DenominationHash.to_octets h_pub |> B32.encode));
     let* k = find h_pub in
     let* () = delete h_pub in
-    let* () = add k.section_name k.t1 k.t2 in
+    let cfg = Cfg.get_coin_config ~section_name:k.section_name in
+    let* () = add cfg k.t1 k.t2 in
     Ok ()
 
   let conv =

src/util.ml

@@ -1,63 +0,0 @@
-module Log_reporter = struct
-  let detail_tag : string Logs.Tag.def =
-    Logs.Tag.def "Detail tag" ~doc:"" Fmt.string
-
-  let detail s = Logs.Tag.(empty |> add detail_tag s)
-  let time_anchor = Mirage_ptime.now () |> Ptime.to_span
-
-  let color_of_log_level = function
-    | Logs.App -> `White
-    | Error -> `Red
-    | Warning -> `Yellow
-    | Info -> `Blue
-    | Debug -> `Magenta
-
-  let reporter : Logs.reporter =
-    let open Fmt in
-    let pp_timestamp = styled `Faint (styled (`Fg `White) (fmt "%04.02f")) in
-    let pp_header ppf v =
-      let color = color_of_log_level (fst v) in
-      let pp = styled (`Fg color) Logs.pp_header in
-      pf ppf "%a" pp v
-    in
-    let pp_src_name =
-      let pp = using Logs.Src.name (styled `Cyan (fmt "%s: ")) in
-      fun ppf v -> if not @@ Logs.Src.equal Logs.default v then pp ppf v
-    in
-    let pp_detail = option (styled `Green (fmt " (%s)")) in
-    let report src lvl ~over k msgf =
-      let ppf =
-        match lvl with
-        | Logs.App -> stdout
-        | Error | Warning | Info | Debug -> stderr
-      in
-      let k _ppf = over (); k () in
-      let with_detail h tags k user_fmt =
-        let detail = Option.bind tags (Logs.Tag.find detail_tag) in
-        let timestamp =
-          Ptime.sub_span (Mirage_ptime.now ()) time_anchor
-          |> Option.map Ptime.to_float_s
-          |> Option.value ~default:0.
-        in
-        let k ppf = kpf k ppf "%a@." pp_detail detail in
-        let k ppf = kpf k ppf user_fmt in
-        kpf k ppf "%a %a %a" pp_timestamp timestamp pp_header (lvl, h)
-          pp_src_name src
-      in
-      msgf @@ fun ?header ?tags fmt -> with_detail header tags k fmt
-    in
-    { report }
-
-  let set_level_secmods lvl =
-    let secmod_srcs = [ Secmod_rsa.src; Secmod_eddsa.src ] in
-    List.iter (fun src -> Logs.Src.set_level src lvl) secmod_srcs;
-    ()
-
-  let setup () =
-    set_level_secmods (Some Logs.Debug);
-    let level = Some Logs.Debug in
-    Logs.set_level ~all:false level;
-    Logs.Src.set_level Logs.default level;
-    Logs.set_reporter reporter;
-    ()
-end