swrup/mte
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

rm util.ml + clean up

Browse source
This commit is contained in:
swrup 2026-03-19 23:01:04 +01:00 • committed by Swrup
parent a23e59dfca
commit 439fdc6a30
7 changed files with 127 additions and 140 deletions
Download patch file Download diff file Expand all files Collapse all files

6
src/config.ml
View file

@ -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
(* -- *)

6
src/global.ml
View file

@ -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

60
src/log_reporter.ml Normal file
View file

@ -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;
()

5
src/mte.ml
View file

@ -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

20
src/secmod_eddsa.ml
View file

@ -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

107
src/secmod_rsa.ml
View file

@ -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 =

63
src/util.ml
View file

@ -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