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

fix secmod + FAT

Browse source
This commit is contained in:
swrup 2026-03-19 07:31:12 +01:00
parent 67e09d38b6
commit 4e40ceb08d
10 changed files with 170 additions and 206 deletions
Download patch file Download diff file Expand all files Collapse all files

14
src/config.ml
View file

@ -211,6 +211,10 @@ module Coin = struct
let all_coins = List.map parse_coin coin_sections
end
let spath s =
let open Fat.Spath in
match of_string s with Error (`Msg e) -> fail "%s" e | Ok v -> v
module Exchange_secmod_rsa = struct
let get field =
let section = "taler-exchange-secmod-" ^ "rsa" in
@ -218,8 +222,10 @@ module Exchange_secmod_rsa = struct
let lookahead_sign = get "lookahead_sign" |> duration
let overlap_duration = get "overlap_duration" |> duration
let key_dir = get "key_dir"
let sm_priv_key = get "sm_priv_key"
(* 8.3 filenames for FAT *)
let key_dir = "rsa" |> spath
let sm_priv_key = "sm_rsa" |> spath
end
module Exchange_secmod_eddsa = struct
@ -230,8 +236,8 @@ 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 = get "key_dir"
let sm_priv_key = get "sm_priv_key"
let key_dir = "eddsa" |> spath
let sm_priv_key = "sm_eddsa" |> spath
end
(* -- *)

17
src/crypto.ml
View file

@ -238,6 +238,23 @@ module RsaPrivateKey = struct
let of_octets = Binary_format_rsa.priv_of_octets
let to_octets = Binary_format_rsa.priv_to_octets
(* we use Bin.cstring because size of key (~bits) can change depending on section_name
we also have to b32 encode/decode our octets because of null-char
enforce all to be of the same size instead? *)
let bin =
let of_octets_exn s =
let res =
let* s = B32.decode s in
of_octets s
in
match res with
| Error e -> Fmt.failwith "RsaPrivateKey.bin decoding failure: %s." e
| Ok t -> t
in
let to_octets t = to_octets t |> B32.encode in
Bin.map Bin.cstring of_octets_exn to_octets
let jsont =
let of_b32 s =
let* s = B32.decode s in

4
src/fat.ml
View file

@ -5,10 +5,12 @@ module Fat = Mfat.Make (struct
let write = atomic_write
end)
module Sfn = Mfat.Sfn
module Spath = Mfat.Spath
include Fat
type entry = Mfat.entry = {
name: string;
name: Sfn.t;
is_dir: bool;
size: int32;
}

158
src/secmod_eddsa.ml
View file

@ -4,6 +4,9 @@
schedule tasks
sign: check timestamps before signing *)
(* IMPROVE
Bin encode/decode
- catch failure
- should use little-endian
list_issue_date: save timestamp of key generation
key validity period:
more checks + do not exceed lookahead
@ -16,6 +19,8 @@ module Log = (val Logs.src_log src : Logs.LOG)
open Syntax
open Crypto
open Time
module Sfn = Mfat.Sfn
module Spath = Mfat.Spath
module Cfg = Config.Exchange_secmod_eddsa
type key = {
@ -27,81 +32,64 @@ type key = {
type t = {
fs: Fat.t;
sm_key_priv: EddsaPrivateKey.t;
sm_priv: EddsaPrivateKey.t;
sm_pub: EddsaPublicKey.t;
ht: (EddsaPublicKey.t, key) Hashtbl.t;
}
let parse_filename =
let scan_filename s =
Scanf.sscanf_opt s "%Lu-%Lu" (fun t1 t2 ->
(TimeAbsolute.of_s t1, TimeAbsolute.of_s t2))
in
fun fpath -> scan_filename (Fpath.filename fpath)
(* todo: this should be encoded in little-endian *)
let key_bin =
let open Bin in
record (fun t1 t2 priv ->
let pub = EddsaPrivateKey.pub_of_priv priv in
{ t1; t2; priv; pub })
|+ field TimeAbsolute.bin (fun t -> t.t1)
|+ field TimeAbsolute.bin (fun t -> t.t2)
|+ field EddsaPrivateKey.bin (fun t -> t.priv)
|> sealr
let pp_filename =
let to_int64 abs =
abs |> Timestamp.of_absolute |> Timestamp.to_s |> function
| None ->
(* (= `never`) this should not happen given resonable config value *)
Fmt.failwith "encountered timestamp with value `never`"
| Some i -> i
in
fun ppf (t1, t2) -> Fmt.pf ppf "%Lu-%Lu" (to_int64 t1) (to_int64 t2)
(* for sm_key only *)
let read_eddsa fs spath =
Log.debug (fun m -> m "reading key file `%a`" Spath.pp spath);
let* data = Fat.read fs spath |> unwrap_msg in
let* priv = EddsaPrivateKey.of_octets data in
let pub = EddsaPrivateKey.pub_of_priv priv in
Ok (priv, pub)
let key_fpath k =
let fname = Fmt.str "%a" pp_filename (k.t1, k.t2) in
Fpath.(v Cfg.key_dir / fname)
(* -- IO -- *)
let read_key fs fpath =
Log.debug (fun m -> m "reading key file `%a`" Fpath.pp fpath);
let fpath = Fpath.to_string fpath in
let* data = Fat.read fs fpath |> unwrap_msg in
EddsaPrivateKey.of_octets data
let write_eddsa fs fpath priv =
Log.debug (fun m -> m "writing key file `%a`" Fpath.pp fpath);
let write_eddsa fs spath priv =
Log.debug (fun m -> m "writing key file `%a`" Spath.pp spath);
let data = EddsaPrivateKey.to_octets priv in
let fpath = Fpath.to_string fpath in
Fat.write fs fpath data |> unwrap_msg
Fat.write fs spath data |> unwrap_msg
let write_key fs k = write_eddsa fs (key_fpath k) k.priv
let key_spath k =
let sfn_res = String.sub (EddsaPublicKey.to_b32 k.pub) 0 8 |> Sfn.of_string in
match sfn_res with
| Error _ -> failwith "not possible"
| Ok sfn -> Spath.(Cfg.key_dir / sfn)
let delete_file fs fpath =
(* check fpath just to be safe *)
let () =
let root = Fpath.v Cfg.key_dir in
if not @@ Fpath.is_rooted ~root fpath then
Fmt.failwith
"delete_file failure: file `%a` is not contained in secmod directory"
Fpath.pp fpath
in
Log.debug (fun m -> m "delete key file `%a`" Fpath.pp fpath);
let fpath = Fpath.to_string fpath in
let+ () = Fat.remove fs fpath |> unwrap_msg in
let read_key fs spath =
Log.debug (fun m -> m "reading key file `%a`" Spath.pp spath);
let* data = Fat.read fs spath |> unwrap_msg in
(* todo: catch failure *)
let k = Bin.decode key_bin data (ref 0) in
Ok k
let write_key fs k =
let spath = key_spath k in
Log.debug (fun m -> m "writing key file `%a`" Spath.pp spath);
let data = Bin.to_string key_bin k in
Fat.write fs spath data |> unwrap_msg
let delete_file fs spath =
Log.debug (fun m -> m "delete key file `%a`" Spath.pp spath);
let+ () = Fat.remove fs spath |> unwrap_msg in
()
let get_key_dir_contents fs dir =
let* dir = Fpath.of_string dir |> unwrap_msg in
let dir = Fpath.to_string dir in
let* () = Fat.mkdir fs dir |> unwrap_msg in
Log.info (fun m -> m "created directory `%s`" dir);
let+ l = Fat.ls fs dir |> unwrap_msg in
(* List.map Fpath.normalize l *)
let l = List.map (fun entry -> entry.Fat.name) l in
let l = List.map Fpath.v l in
l
(* -- *)
let gen_key t1 t2 =
let priv, pub = EddsaPrivateKey.generate () in
Log.debug (fun m ->
m "generated key (%a):@,`%s`" pp_filename (t1, t2)
(EddsaPublicKey.to_b32 pub));
{ priv; pub; t1; t2 }
let k = { priv; pub; t1; t2 } in
Log.debug (fun m -> m "generated key `%s`" (EddsaPublicKey.to_b32 pub));
k
let sort_keys l = List.sort (fun a b -> TimeAbsolute.compare a.t2 b.t2) l
@ -133,34 +121,25 @@ let gen_additional_keys_until_lookahead ~now l =
let new_keys = List.map (fun (t1, t2) -> gen_key t1 t2) periodes in
new_keys
let sm_key_fpath =
Result.get_ok
@@
let+ fpath = Fpath.of_string Cfg.sm_priv_key |> unwrap_msg in
Fpath.normalize fpath
(* we load sm_key separately
we don't accept non-key files in key_dir *)
let load_key fs fpath =
match parse_filename fpath with
| None -> Fmt.error "invalid file `%a`" Fpath.pp fpath
| Some (t1, t2) ->
let+ priv = read_key fs fpath in
let pub = EddsaPrivateKey.pub_of_priv priv in
{ priv; pub; t1; t2 }
let load fs =
let* l = get_key_dir_contents fs Cfg.key_dir in
let l = List.filter (fun fpath -> not @@ Fpath.equal fpath sm_key_fpath) l in
let* keys = list_map (load_key fs) l in
let* () =
if Fat.exists fs Cfg.key_dir then Ok ()
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* keys = list_map (read_key fs) l in
match keys with
| [] -> Ok None
| _l ->
let* sm_key_priv = read_key fs sm_key_fpath in
let sm_pub = EddsaPrivateKey.pub_of_priv sm_key_priv in
let* sm_priv, sm_pub = read_eddsa fs Cfg.sm_priv_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_key_priv; sm_pub; ht })
Ok (Some { fs; sm_priv; sm_pub; ht })
let init fs =
let* opt = load fs in
@ -168,12 +147,13 @@ let init fs =
match opt with
| Some t -> Ok t
| None ->
let sm_key_priv, sm_pub = EddsaPrivateKey.generate () in
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 sm_key_fpath sm_key_priv in
let ht = Hashtbl.create 0xff in
Ok { fs; sm_key_priv; sm_pub; ht }
let t = { fs; sm_priv; sm_pub; ht } in
let* () = write_eddsa fs Cfg.sm_priv_key t.sm_priv in
Ok t
in
let now = TimeAbsolute.of_ptime (Mirage_ptime.now ()) in
let keys = List.of_seq @@ Hashtbl.to_seq_values t.ht in
@ -200,7 +180,7 @@ module Make (Fs : Fat.FS) = struct
let delete pub =
let* k = find pub in
Hashtbl.remove t.ht k.pub;
delete_file t.fs (key_fpath k)
delete_file t.fs (key_spath k)
let _delete_outdated ~now =
Hashtbl.to_seq_values t.ht
@ -212,7 +192,7 @@ module Make (Fs : Fat.FS) = struct
(* ---- *)
let sm_pub = t.sm_pub
let sign_secmod s = EddsaSignature.sign ~key:t.sm_key_priv s
let sign_secmod s = EddsaSignature.sign ~key:t.sm_priv s
let sign pub s =
let+ k = find pub in

167
src/secmod_rsa.ml
View file

@ -6,6 +6,8 @@ module Log = (val Logs.src_log src : Logs.LOG)
open Syntax
open Crypto
open Time
module Sfn = Mfat.Sfn
module Spath = Mfat.Spath
module Cfg = struct
open Config
@ -49,93 +51,70 @@ type key = {
type t = {
fs: Fat.t;
sm_key_priv: EddsaPrivateKey.t;
sm_priv: EddsaPrivateKey.t;
sm_pub: EddsaPublicKey.t;
ht: (DenominationHash.t, key) Hashtbl.t;
}
let parse_filename =
let scan_filename s =
Scanf.sscanf_opt s "%Lu-%Lu" (fun t1 t2 ->
(TimeAbsolute.of_s t1, TimeAbsolute.of_s t2))
let key_bin =
let open Bin in
record (fun t1 t2 section_name priv ->
let pub = RsaPrivateKey.pub_of_priv priv in
let h_pub = DenominationHash.hash_of_rsa pub in
{ section_name; t1; t2; priv; pub; h_pub })
|+ field TimeAbsolute.bin (fun t -> t.t1)
|+ field TimeAbsolute.bin (fun t -> t.t2)
|+ field cstring (fun t -> t.section_name)
|+ field RsaPrivateKey.bin (fun t -> t.priv)
|> sealr
let key_spath k =
let sfn_res =
String.sub (DenominationHash.to_b32 k.h_pub) 0 8 |> Sfn.of_string
in
fun fpath -> scan_filename (Fpath.filename fpath)
match sfn_res with
| Error _ -> failwith "not possible"
| Ok sfn -> Spath.(Cfg.key_dir / sfn)
let pp_filename =
let to_int64 abs =
abs |> Timestamp.of_absolute |> Timestamp.to_s |> function
| None ->
(* (= `never`) this should not happen given resonable config value *)
Fmt.failwith "encountered timestamp with value `never`"
| Some i -> i
in
fun ppf (t1, t2) -> Fmt.pf ppf "%Lu-%Lu" (to_int64 t1) (to_int64 t2)
let read_eddsa fs spath =
Log.debug (fun m -> m "reading key file `%a`" Spath.pp spath);
let* data = Fat.read fs spath |> unwrap_msg in
let* priv = EddsaPrivateKey.of_octets data in
let pub = EddsaPrivateKey.pub_of_priv priv in
Ok (priv, pub)
let key_fpath k =
let fname = Fmt.str "%a" pp_filename (k.t1, k.t2) in
Fpath.(v Cfg.key_dir / k.section_name / fname)
(* -- IO -- *)
let read_eddsa fs fpath =
Log.debug (fun m -> m "reading key file `%a`" Fpath.pp fpath);
let fpath = Fpath.to_string fpath in
let* data = Fat.read fs fpath |> unwrap_msg in
EddsaPrivateKey.of_octets data
let read_rsa fs fpath =
Log.debug (fun m -> m "reading key file `%a`" Fpath.pp fpath);
let fpath = Fpath.to_string fpath in
let* data = Fat.read fs fpath |> unwrap_msg in
RsaPrivateKey.of_octets data
let write_eddsa fs fpath priv =
Log.debug (fun m -> m "writing key file `%a`" Fpath.pp fpath);
let write_eddsa fs spath priv =
Log.debug (fun m -> m "writing key file `%a`" Spath.pp spath);
let data = EddsaPrivateKey.to_octets priv in
let fpath = Fpath.to_string fpath in
Fat.write fs fpath data |> unwrap_msg
Fat.write fs spath data |> unwrap_msg
let write_rsa fs fpath priv =
let data = RsaPrivateKey.to_octets priv in
let fpath = Fpath.to_string fpath in
Fat.write fs fpath data |> unwrap_msg
let read_key fs spath =
Log.debug (fun m -> m "reading key file `%a`" Spath.pp spath);
let* data = Fat.read fs spath |> unwrap_msg in
let k = Bin.decode key_bin data (ref 0) in
Ok k
let write_key fs k = write_rsa fs (key_fpath k) k.priv
let write_key fs k =
let spath = key_spath k in
Log.debug (fun m -> m "writing key file `%a`" Spath.pp spath);
let data = Bin.to_string key_bin k in
Fat.write fs spath data |> unwrap_msg
let delete_file fs fpath =
(* check fpath just to be safe *)
let () =
let root = Fpath.v Cfg.key_dir in
if not @@ Fpath.is_rooted ~root fpath then
Fmt.failwith
"delete_file failure: file `%a` is not contained in secmod directory"
Fpath.pp fpath
in
Log.debug (fun m -> m "delete key file `%a`" Fpath.pp fpath);
let fpath = Fpath.to_string fpath in
let+ () = Fat.remove fs fpath |> unwrap_msg in
let delete_file fs spath =
Log.debug (fun m -> m "delete key file `%a`" Spath.pp spath);
let+ () = Fat.remove fs spath |> unwrap_msg in
()
let get_key_dir_contents fs dir_fpath =
let dir_fpath = Fpath.to_string dir_fpath in
let* () = Fat.mkdir fs dir_fpath |> unwrap_msg in
Log.info (fun m -> m "created directory `%s`" dir_fpath);
let+ l = Fat.ls fs dir_fpath |> unwrap_msg in
(* List.map Fpath.normalize l *)
let l = List.map (fun entry -> entry.Fat.name) l in
let l = List.map Fpath.v l in
l
(* -- *)
let gen_key ~section_name t1 t2 =
let bits = Cfg.rsa_keysize ~section_name 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
Log.debug (fun m ->
m "generated key (%a):@,`%s`" pp_filename (t1, t2)
(DenominationHash.to_octets h_pub |> B32.encode));
{ section_name; priv; pub; h_pub; t1; t2 }
m "generated key %s `%s`" section_name (DenominationHash.to_b32 k.h_pub));
k
let sort_keys l = List.sort (fun a b -> TimeAbsolute.compare a.t2 b.t2) l
@ -154,8 +133,6 @@ let split_in_periodes ~start ~end_ ~duration_withdraw =
go acc start end_
let gen_additional_keys_until_lookahead ~now ~section_name l =
(* try to _not_ generate keys with validity start in the past
(probably not important) *)
let start =
match List.rev (sort_keys l) with
| [] -> now
@ -171,41 +148,25 @@ let gen_additional_keys_until_lookahead ~now ~section_name l =
in
new_keys
let sm_key_fpath =
Result.get_ok
@@
let+ fpath = Fpath.of_string Cfg.sm_priv_key |> unwrap_msg in
Fpath.normalize fpath
(* we load sm_key separately
we don't accept non-key files in key_dir *)
let load_key fs ~section_name fpath =
match parse_filename fpath with
| None -> Fmt.error "invalid file `%a`" Fpath.pp fpath
| Some (t1, t2) ->
let+ priv = read_rsa fs fpath in
let pub = RsaPrivateKey.pub_of_priv priv in
let h_pub = DenominationHash.hash_of_rsa pub in
{ section_name; priv; pub; h_pub; t1; t2 }
let load_section fs section_name =
let section_fpath = Fpath.(v Cfg.key_dir / section_name) in
let* l = get_key_dir_contents fs section_fpath in
let l = List.filter (fun fpath -> not @@ Fpath.equal fpath sm_key_fpath) l in
let* keys = list_map (load_key fs ~section_name) l in
Ok keys
let load fs =
let* keys_l = list_map (load_section fs) Cfg.sections in
let keys = List.concat keys_l in
let* () =
if Fat.exists fs Cfg.key_dir then Ok ()
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* keys = list_map (read_key fs) l in
match keys with
| [] -> Ok None
| _l ->
let* sm_key_priv = read_eddsa fs sm_key_fpath in
let sm_pub = EddsaPrivateKey.pub_of_priv sm_key_priv in
let* sm_priv, sm_pub = read_eddsa fs Cfg.sm_priv_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_key_priv; sm_pub; ht })
Ok (Some { fs; sm_priv; sm_pub; ht })
let init fs =
let* opt = load fs in
@ -214,12 +175,12 @@ let init fs =
match opt with
| Some t -> Ok t
| None ->
let sm_key_priv, sm_pub = EddsaPrivateKey.generate () in
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 sm_key_fpath sm_key_priv in
let* () = write_eddsa fs Cfg.sm_priv_key sm_priv in
let ht = Hashtbl.create 0xff in
Ok { fs; sm_key_priv; sm_pub; ht }
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 =
@ -248,7 +209,7 @@ module Make (Fs : Fat.FS) = struct
let delete h_pub =
let* k = find h_pub in
Hashtbl.remove t.ht h_pub;
delete_file t.fs (key_fpath k)
delete_file t.fs (key_spath k)
let _delete_outdated ~now =
Hashtbl.to_seq t.ht
@ -264,7 +225,7 @@ module Make (Fs : Fat.FS) = struct
()
let sm_pub = t.sm_pub
let sign_secmod s = EddsaSignature.sign ~key:t.sm_key_priv s
let sign_secmod s = EddsaSignature.sign ~key:t.sm_priv s
let sign h_pub msg =
let+ k = find h_pub in

1
src/time.ml
View file

@ -92,6 +92,7 @@ module TimeAbsolute = struct
if Int64.unsigned_div v 1_000_000L <> s then never else v
let of_ptime v = v |> Ptime.to_float_s |> Int64.of_float |> of_s
let bin = Bin.beint64
let pp ppf t = if t = never then Fmt.pf ppf "never" else Fmt.pf ppf "%Lu" t
end

1
src/time.mli
View file

@ -32,6 +32,7 @@ module TimeAbsolute : sig
val sub : t -> TimeRelative.t -> t
val of_s : int64 -> t
val of_ptime : Ptime.t -> t
val bin : t Bin.t
(* TODO rename pp_dump *)
val pp : Format.formatter -> t -> unit

4
src/util.ml
View file

@ -54,8 +54,8 @@ module Log_reporter = struct
()
let setup () =
(*set_level_secmods (Some Logs.Debug);*)
let level = Some Logs.Info in
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;