From 34a55dec6b153bb28b4c7a1260abee296b4ad95f Mon Sep 17 00:00:00 2001 From: swrup Date: Sat, 21 Feb 2026 18:43:47 +0100 Subject: [PATCH] JJ: Description from the destination commit: functorize secmod JJ: Description from source commit: ok secmod + logs --- src/crypto.ml | 4 +- src/devices.ml | 4 +- src/keys.ml | 44 ++++++++------- src/mod_intf.mli | 6 +- src/secmod_eddsa.ml | 132 +++++++++++++++++++++++++------------------- src/secmod_rsa.ml | 131 ++++++++++++++++++++++++------------------- src/util.ml | 4 +- 7 files changed, 183 insertions(+), 142 deletions(-) diff --git a/src/crypto.ml b/src/crypto.ml index dce8e925..4ce582f9 100644 --- a/src/crypto.ml +++ b/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 diff --git a/src/devices.ml b/src/devices.ml index 1d3c702b..15c6d389 100644 --- a/src/devices.ml +++ b/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 - sm + let keys : (module Keys.S) = (module Keys.Make (Conn)) in + keys diff --git a/src/keys.ml b/src/keys.ml index be6b003e..1088f526 100644 --- a/src/keys.ml +++ b/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 = Secmod_eddsa.sm_pub + let secmod_eddsa_pub = Sm_eddsa.sm_pub + let secmod_rsa_pub = Sm_rsa.sm_pub - (* TODO error - should be a "key not found", either: + (* TODO + 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 diff --git a/src/mod_intf.mli b/src/mod_intf.mli index cf0fb2f7..c0edfacd 100644 --- a/src/mod_intf.mli +++ b/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 diff --git a/src/secmod_eddsa.ml b/src/secmod_eddsa.ml index cd6a182b..f83ca224 100644 --- a/src/secmod_eddsa.ml +++ b/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+ () = - Bos.OS.File.delete ~must_exist:true (key_fpath k) |> unwrap_err_msg - in - () +let delete_file fpath = + Log.debug (fun m -> m "(disabled) delete key file `%a`" Fpath.pp fpath); + (* TODO just to be safe~~ + 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 - Logs.info (fun m -> m "secmod_eddsa: created directory `%a`" Fpath.pp dir); + if b then Log.info (fun m -> m "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 - let new_keys = - List.map - (fun (t1, t2) -> - let priv, pub = EddsaPrivateKey.generate () in - { priv; pub; t1; t2 }) - periodes - in - new_keys + if Absolute.compare start end_ >= 0 then [] + else + let periodes = split_in_periodes ~start ~end_ in + let new_keys = List.map (fun (t1, t2) -> gen_key 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 = - match init () with - | Error e -> Fmt.failwith "secmod_eddsa initialization failure: %s." e - | Ok t -> t +module Make () = struct + type pub = EddsaPublicKey.t + type info = EddsaPublicKey.t * Time.Absolute.t * Time.Absolute.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_eddsa initialization failure: %s." e + | Ok t -> t -let add t1 t2 = - let priv, pub = EddsaPrivateKey.generate () in - let k = { priv; pub; t1; t2 } in - Hashtbl.replace t.ht k.pub k; - () + let find pub = + Hashtbl.find_opt t.ht pub |> Option.to_result ~none:"key not found" -let delete pub = - let* k = find pub in - Hashtbl.remove t.ht k.pub; delete_key_file k + let add t1 t2 = + let k = gen_key t1 t2 in + Hashtbl.replace t.ht k.pub k; + () -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 delete pub = + let* k = find pub in + Hashtbl.remove t.ht k.pub; + delete_file (key_fpath k) -(* ---- *) + 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 () = - Hashtbl.to_seq_values t.ht - |> List.of_seq - |> List.map (fun { priv= _; pub; t1; t2 } -> (pub, t1, t2)) + let sm_pub = t.sm_pub -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+ k = find pub in - let data = EddsaSignature.sign ~key:k.priv s in - data + let sign_secmod s = EddsaSignature.sign ~key:t.sm_key_priv s -(* delete and replace *) -let revoke pub = - let* k = find pub in - let* () = delete pub in - add k.t1 k.t2; Ok () + let sign pub s = + let+ k = find pub in + let data = EddsaSignature.sign ~key:k.priv s in + data + + (* 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 diff --git a/src/secmod_rsa.ml b/src/secmod_rsa.ml index a9e1de62..50aa954f 100644 --- a/src/secmod_rsa.ml +++ b/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+ () = - Bos.OS.File.delete ~must_exist:true (key_fpath k) |> unwrap_err_msg - in - () +let delete_file fpath = + Log.debug (fun m -> m "(disabled) delete key file `%a`" Fpath.pp fpath); + (* TODO just to be safe~~ + 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 - Logs.info (fun m -> - m "secmod_rsa: created directory `%a`" Fpath.pp dir_fpath); + if b then Log.info (fun m -> m "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 - let new_keys = - List.map - (fun (t1, t2) -> - let priv, pub = RsaPrivateKey.generate ~bits:Cfg.rsa_keysize () in - { section_name; priv; pub; t1; t2 }) - periodes - in - new_keys + if Absolute.compare start end_ >= 0 then [] + else + let periodes = split_in_periodes ~start ~end_ in + let new_keys = + List.map (fun (t1, t2) -> gen_key section_name t1 t2) periodes + 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 = - match init () with - | Error e -> Fmt.failwith "secmod_rsa initialization failure: %s." e - | Ok t -> t +module Make () = struct + type pub = RsaPublicKey.t + type info = string * RsaPublicKey.t * Time.Absolute.t * Time.Absolute.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* k = find pub in - Hashtbl.remove t.ht k.pub; delete_key_file k + let find pub = + Hashtbl.find_opt t.ht pub |> Option.to_result ~none:"key not found" -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 delete pub = + let* k = find pub in + Hashtbl.remove t.ht k.pub; + delete_file (key_fpath k) -let add section_name t1 t2 = - let priv, pub = RsaPrivateKey.generate ~bits:Cfg.rsa_keysize () in - let k = { section_name; priv; pub; t1; t2 } in - Hashtbl.replace t.ht k.pub k; - () + 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 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 () = - Hashtbl.to_seq_values t.ht - |> List.of_seq - |> List.map (fun { section_name; priv= _; pub; t1; t2 } -> - (section_name, pub, t1, t2)) + let keys () = + Hashtbl.to_seq_values t.ht + |> List.of_seq + |> List.map (fun { section_name; priv= _; 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+ k = find pub in - let data = RsaSignature.sign ~key:k.priv s in - data + let sign pub s = + let+ k = find pub in + let data = RsaSignature.sign ~key:k.priv s in + data -let revoke pub = - let* k = find pub in - let* () = delete pub in - add k.section_name k.t1 k.t2; - Ok () + let revoke pub = + let* k = find pub in + let* () = delete pub in + add k.section_name k.t1 k.t2; + Ok () +end diff --git a/src/util.ml b/src/util.ml index c690a009..bf00cd53 100644 --- a/src/util.ml +++ b/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 ();