diff --git a/src/config.ml b/src/config.ml index 438bbcc5..bfbd6dc1 100644 --- a/src/config.ml +++ b/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 (* -- *) diff --git a/src/global.ml b/src/global.ml index 04a76dfb..16e9d795 100644 --- a/src/global.ml +++ b/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 diff --git a/src/log_reporter.ml b/src/log_reporter.ml new file mode 100644 index 00000000..fa549ef3 --- /dev/null +++ b/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; + () diff --git a/src/mte.ml b/src/mte.ml index 0d54dbca..f2eb2d19 100644 --- a/src/mte.ml +++ b/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 -> - m ~tags:(Util.Log_reporter.detail "...") "Starting MTE server"); + Logs.info (fun m -> m "Starting MTE server"); Vifu.run ~cfg ~devices tcp routes env diff --git a/src/secmod_eddsa.ml b/src/secmod_eddsa.ml index e5163fcf..4a6576e0 100644 --- a/src/secmod_eddsa.ml +++ b/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 (Spath.add Cfg.key_dir) l in - let l = - List.filter (fun spath -> not @@ Spath.equal spath Cfg.sm_priv_key) l - in + let l = List.map (fun entry -> Spath.add Cfg.key_dir entry.Fat.name) l in + let l = List.filter (fun spath -> not @@ Spath.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_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 diff --git a/src/secmod_rsa.ml b/src/secmod_rsa.ml index 1383fa26..4c368dc8 100644 --- a/src/secmod_rsa.ml +++ b/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 Exchange_secmod_rsa + include Config.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 duration_withdraw = - let duration_withdraw_assoc = - Coin.all_coins - |> List.map (fun coin -> (coin.Coin.section_name, coin.duration_withdraw)) - in - fun ~section_name -> - 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 + let get_coin_config ~section_name = + coin_config_list + |> List.find_opt (fun (cfg : Coin_config.t) -> + String.equal cfg.name section_name) + |> function + | None -> + Fmt.failwith "secmod_rsa failure: section `%s` not found" section_name + | Some cfg -> cfg end type key = { @@ -107,32 +108,32 @@ let delete_file fs spath = (* -- *) -let gen_key ~section_name t1 t2 = - let bits = Cfg.rsa_keysize ~section_name in - let priv, pub = RsaPrivateKey.generate ~bits () in +let gen_key cfg t1 t2 = + let priv, pub = RsaPrivateKey.generate ~bits:cfg.Coin_config.rsa_keysize () 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 ~start ~end_ ~duration_withdraw in - let new_keys = - List.map (fun (t1, t2) -> gen_key ~section_name t1 t2) periodes - in + let periodes = split_in_periodes cfg ~start ~end_ in + let new_keys = List.map (fun (t1, t2) -> gen_key cfg 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 (Spath.add Cfg.key_dir) l in - let l = - List.filter (fun spath -> not @@ Spath.equal spath Cfg.sm_priv_key) l - in + let l = List.map (fun entry -> Spath.add Cfg.key_dir entry.Fat.name) l in + let l = List.filter (fun spath -> not @@ Spath.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_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 - (fun section_name -> - let keys = - List.filter (fun k -> k.section_name = section_name) all_keys - in - gen_additional_keys_until_lookahead ~now ~section_name keys) - Cfg.sections + Cfg.coin_config_list + |> List.map (fun (cfg : Coin_config.t) -> + let keys = List.filter (fun k -> k.section_name = cfg.name) all_keys in + gen_additional_keys_until_lookahead cfg ~now keys) 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 k = gen_key ~section_name t1 t2 in + let add cfg t1 t2 = + 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 = diff --git a/src/util.ml b/src/util.ml deleted file mode 100644 index c173cd9b..00000000 --- a/src/util.ml +++ /dev/null @@ -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