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

ok secmod

Browse source
This commit is contained in:
swrup 2026-02-21 18:43:47 +01:00
parent 7f440077ed
commit ededffb26b
7 changed files with 183 additions and 142 deletions
Download patch file Download diff file Expand all files Collapse all files

4
src/crypto.ml
View file

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

4
src/devices.ml
View file

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

44
src/keys.ml
View file

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

6
src/mod_intf.mli
View file

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

86
src/secmod_eddsa.ml
View file

@ -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
if Absolute.compare start end_ >= 0 then []
else
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
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 =
module Make () = struct
type pub = EddsaPublicKey.t
type info = EddsaPublicKey.t * Time.Absolute.t * Time.Absolute.t
let t =
match init () with
| Error e -> Fmt.failwith "secmod_eddsa initialization failure: %s." e
| Ok t -> t
let find pub =
let find pub =
Hashtbl.find_opt t.ht pub |> Option.to_result ~none:"key not found"
let add t1 t2 =
let priv, pub = EddsaPrivateKey.generate () in
let k = { priv; pub; t1; t2 } in
let add t1 t2 =
let k = gen_key t1 t2 in
Hashtbl.replace t.ht k.pub k;
()
let delete pub =
let delete pub =
let* k = find pub in
Hashtbl.remove t.ht k.pub; delete_key_file k
Hashtbl.remove t.ht k.pub;
delete_file (key_fpath k)
let delete_outdated ~now =
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 sm_pub = t.sm_pub
let keys () =
let keys () =
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 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 data = EddsaSignature.sign ~key:k.priv s in
data
(* delete and replace *)
let revoke pub =
(* 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

79
src/secmod_rsa.ml
View file

@ -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,13 +124,11 @@ 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
if Absolute.compare start end_ >= 0 then []
else
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
List.map (fun (t1, t2) -> gen_key section_name t1 t2) periodes
in
new_keys
@ -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
type pub = RsaPublicKey.t
type info = string * RsaPublicKey.t * Time.Absolute.t * Time.Absolute.t
(* --- *)
let t =
match init () with
| Error e -> Fmt.failwith "secmod_rsa initialization failure: %s." e
| Ok t -> t
let find pub =
let find pub =
Hashtbl.find_opt t.ht pub |> Option.to_result ~none:"key not found"
let delete pub =
let delete pub =
let* k = find pub in
Hashtbl.remove t.ht k.pub; delete_key_file k
Hashtbl.remove t.ht k.pub;
delete_file (key_fpath k)
let delete_outdated ~now =
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 priv, pub = RsaPrivateKey.generate ~bits:Cfg.rsa_keysize () in
let k = { section_name; priv; pub; t1; t2 } in
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
|> 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 sign pub s =
let+ k = find pub in
let data = RsaSignature.sign ~key:k.priv s in
data
let revoke pub =
let revoke pub =
let* k = find pub in
let* () = delete pub in
add k.section_name k.t1 k.t2;
Ok ()
end

4
src/util.ml
View file

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