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

refacto secmod

Browse source
This commit is contained in:
swrup 2026-04-01 03:30:27 +02:00 • committed by Swrup
parent 10df5181a0
commit 1c0167f401
6 changed files with 388 additions and 450 deletions
Download patch file Download diff file Expand all files Collapse all files

30
GNUmakefile
View file

@ -1,19 +1,21 @@
vendor_list := \
storage=assets/secmod.fat
service=tap0
vendors_list := \
mkernel zarith bstr mnet mirage-crypto-rng-mkernel gmp digestif \
kdf utcp flux h1 httpcats mhttp multipart_form-miou prettym tls \
x509 vifu cachet mfat caqti \
base32 cohttp mirage-mtime mirage-ptime
secmod_fat=assets/secmod.fat
tap_device=tap0
check-kvm:
$(if $(wildcard /dev/kvm),,$(error KVM support not enabled))
pins:
pin-deps:
#opam pin --no-action --yes "git+https://github.com/robur-coop/mcrunch.git#682ed63c03e3be5664f96c469a260e1d9e9df011"
opam pin --no-action --yes "git+https://github.com/mirage/Zarith.git#zarith-1.14"
opam pin --no-action --yes "git+https://github.com/robur-coop/vif.git#e8b3053476162d119dee8cefe38511d679d3ad55"
opam pin --no-action --yes add mhttp "git+https://github.com/robur-coop/mhttp.git#b2e55ae693b07ad3ef87c26c37c8f5d14c2e205c"
opam pin --no-action --yes add vif "git+https://github.com/swrup/vif.git#1b16040ba06c6af82019f02811e781e81084d269"
opam pin --no-action --yes add vifu "git+https://github.com/swrup/vif.git#1b16040ba06c6af82019f02811e781e81084d269"
opam pin --no-action --yes "git+https://github.com/robur-coop/mfat.git#5b1204d914e853f0139c6d2776511f530b753550"
opam pin --no-action --yes "git+https://github.com/swrup/mirage-mtime.git#6a6bb4dd25624a3c43e6417dcdf73f3c689946a7"
opam pin --no-action --yes add caqti "git+https://github.com/swrup/ocaml-caqti.git#186650581efd9d247ced982cdefd74256905e3b0"
@ -22,18 +24,18 @@ pins:
opam pin --no-action --yes add caqti-driver-pgx "git+https://github.com/swrup/ocaml-caqti.git#186650581efd9d247ced982cdefd74256905e3b0"
opam pin --no-action --yes "git+https://github.com/robur-coop/mnet.git#7e07437cda26f8efd3da0c4d14d76293d8fcbc78"
installs:
install-deps:
# opam install --yes mcrunch
opam install --yes dune utop merlin ocp-browser ocamlformat
opam install --yes crunch
opam install --yes sqlite3 # needed for caqti even if not used
opam install --yes caqti-driver-pgx
opam install --yes $(vendor_list)
opam install --yes $(vendors_list)
.PHONY: vendors
vendors:
@mkdir -p vendors
@for v in $(vendor_list); do \
@for v in $(vendors_list); do \
[ -d vendors/$$v ] || opam source $$v --dir vendors/$$v ; \
done
@ -45,16 +47,18 @@ clean:
assets:
@cp default/assets ./
secmod.fat:
fat-image:
@mkdir -p assets
mfat make --sectors=2048 $(secmod_fat)
mfat make --sectors=2048 $(storage)
init: clean pin-deps install-deps vendors assets fat-image
manifest:
@dune exec src/mte.exe > src/manifest.json
build:
build: manifest
@dune build @all
@dune build --workspace dune-workspace.solo5 src/mte.exe
run: build
@solo5-hvt --block:storage=$(secmod_fat) --net:service=$(tap_device) -- ./_build/solo5/src/mte.exe
@solo5-hvt --block:storage=$(storage) --net:service=$(service) -- ./_build/solo5/src/mte.exe

8
src/config.ml
View file

@ -193,8 +193,8 @@ module Exchange_secmod_rsa = struct
let section = "taler-exchange-secmod-" ^ "rsa" in
get config_data ~section ~field
let lookahead_sign = get "lookahead_sign" |> duration
let overlap_duration = get "overlap_duration" |> duration
let lookahead = get "lookahead_sign" |> duration
let overlap = get "overlap_duration" |> duration
end
module Exchange_secmod_eddsa = struct
@ -202,8 +202,8 @@ module Exchange_secmod_eddsa = struct
let section = "taler-exchange-secmod-" ^ "eddsa" in
get config_data ~section ~field
let lookahead_sign = get "lookahead_sign" |> duration
let overlap_duration = get "overlap_duration" |> duration
let lookahead = get "lookahead_sign" |> duration
let overlap = get "overlap_duration" |> duration
let duration = get "duration" |> duration
end

151
src/keys.ml
View file

@ -28,57 +28,61 @@ module type S = sig
end
module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct
module Sm_eddsa = Secmod_eddsa.Make (Fs)
module Sm_rsa = Secmod_rsa.Make (Fs)
let conn = (module Conn : Pg.CONN)
let sign = Sm_eddsa.sign
let sign_denom = Sm_rsa.sign
let sm_eddsa = Secmod_eddsa.create Fs.t
let sm_rsa = Secmod_rsa.create Fs.t
(* - *)
let sign = Secmod_eddsa.sign sm_eddsa
let sign_denom = Secmod_rsa.sign sm_rsa
(* - *)
let find_signkey pub = Pg.find_signkey conn pub
let find_denomination h_pub = Pg.find_denom conn h_pub
let find_denomination h_pub = Pg.find_denomination conn h_pub
(* - *)
let warn_key_state =
let first = ref true in
(* TODO *)
let last_change = ref Timestamp.never
let denominations_last_change () = !last_change
(* - *)
let warn_once msg =
let b = ref true in
fun () ->
if !first then (
Logs.warn (fun m ->
m
"some keys found in database are missing from secmod, (unclean \
database/secmod state?)");
first := false;
())
if !b then begin
b := false;
Logs.warn (fun m -> m "%s" msg)
end
let signkeys () : Signkey.t list Result.t =
let warn_keyring_state_mismatch =
warn_once
"keyring state mismatch: database and secmod have different active keys \
data"
let signkeys =
fun () : Signkey.t list Result.t ->
let now = Timestamp.of_ptime @@ Mirage_ptime.now () in
let+ l = Pg.get_signkeys conn ~now in
let missing_l, l =
List.partition
(fun sk -> Option.is_none @@ Sm_eddsa.find_key sk.Signkey.pub)
(fun sk ->
Option.is_none (Secmod_eddsa.find_key sm_eddsa sk.Signkey.pub))
l
in
match missing_l with
| [] -> l
| _ ->
warn_key_state ();
Logs.debug (fun m -> m "found %d active signkey(s)" (List.length l));
l
if missing_l <> [] then warn_keyring_state_mismatch ();
l
let denominations () =
let+ l = Pg.get_denominations conn () in
let missing_l, l =
List.partition
(fun dn -> Option.is_none @@ Sm_rsa.find_key dn.Denomination.h_pub)
(fun dn ->
Option.is_none @@ Secmod_rsa.find_key sm_rsa dn.Denomination.h_pub)
l
in
match missing_l with
| [] -> l
| _ ->
warn_key_state ();
Logs.debug (fun m ->
m "found %d active denomination(s)" (List.length l));
l
if missing_l <> [] then warn_keyring_state_mismatch ();
l
let make_future_sk (pub, (start, expire)) =
Logs.debug (fun m -> m "make_future_sk: `%a`" Eddsa.pp_pub pub);
@ -94,7 +98,9 @@ module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct
let exchange_pub = pub in
let anchor_time = stamp_start in
let duration = Timestamp.diff stamp_start stamp_expire in
signf Sm_eddsa.sign_secmod { exchange_pub; anchor_time; duration }
signf
(Secmod_eddsa.sign_secmod sm_eddsa)
{ exchange_pub; anchor_time; duration }
in
Api.FutureSignKey.
{ key= pub; stamp_start; stamp_expire; stamp_end; signkey_secmod_sig }
@ -133,7 +139,8 @@ module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct
let denom_pub = DenominationKey.Rsa rsa_denomination_key in
let denom_secmod_sig =
let open Signatures.DenominationKeyAnnouncement in
signf Sm_rsa.sign_secmod
signf
(Secmod_rsa.sign_secmod sm_rsa)
{
h_denom_pub= h_pub;
h_section_name= Hash.H64_cstring.hash section_name;
@ -158,14 +165,14 @@ module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct
}
let find_future_signkey pub =
match Sm_eddsa.find_key pub with
match Secmod_eddsa.find_key sm_eddsa pub with
| None -> Fmt.error_msg "future signkey not found"
| Some (pub, (t1, t2)) ->
let fsk = make_future_sk (pub, (t1, t2)) in
Ok fsk
let find_future_denomination h_pub =
match Sm_rsa.find_key h_pub with
match Secmod_rsa.find_key sm_rsa h_pub with
| None -> Fmt.error_msg "future denomination not found"
| Some v ->
let future_dn = make_future_dn v in
@ -178,7 +185,7 @@ module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct
let sk_ht = Hashtbl.create 0xff in
List.iter (fun sk -> Hashtbl.replace sk_ht sk.Signkey.pub ()) sk_db_l;
let future_signkeys =
Sm_eddsa.keys ()
Secmod_eddsa.keys sm_eddsa
|> List.filter (fun (pub, _) -> not @@ Hashtbl.mem sk_ht pub)
|> List.map make_future_sk
in
@ -186,7 +193,7 @@ module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct
let dn_ht = Hashtbl.create 0xff in
List.iter (fun dn -> Hashtbl.replace dn_ht dn.Denomination.h_pub ()) dn_db_l;
let future_denoms =
Sm_rsa.keys ()
Secmod_rsa.keys sm_rsa
|> List.filter (fun (h_pub, _) -> not @@ Hashtbl.mem dn_ht h_pub)
|> List.map make_future_dn
in
@ -194,45 +201,41 @@ module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct
m "%d future signkey(s) and %d future denomination(s) to certify"
(List.length future_signkeys)
(List.length future_denoms));
let signkey_secmod_public_key = Secmod_eddsa.sm_pub sm_eddsa in
let denom_secmod_public_key = Secmod_rsa.sm_pub sm_rsa in
Ok
Api.FutureKeysResponse.
{
future_denoms;
future_signkeys;
master_pub= Config.Exchange.master_public_key;
denom_secmod_public_key= Sm_rsa.sm_pub;
signkey_secmod_public_key= Sm_eddsa.sm_pub;
denom_secmod_public_key;
signkey_secmod_public_key;
}
let sk_of_future_sk future_sk master_sig =
let Api.FutureSignKey.
{ key; stamp_start; stamp_expire; stamp_end; signkey_secmod_sig= _ } =
future_sk
in
let sk_of_future_sk
Api.FutureSignKey.
{ key; stamp_start; stamp_expire; stamp_end; signkey_secmod_sig= _ }
master_sig =
Signkey.{ pub= key; stamp_start; stamp_expire; stamp_end; master_sig }
let dn_of_future_dn future_dn h_pub master_sig =
let Api.FutureDenom.
{
section_name= _;
value;
stamp_start;
stamp_expire_withdraw;
stamp_expire_deposit;
stamp_expire_legal;
denom_pub;
fee_withdraw;
fee_deposit;
fee_refresh;
fee_refund;
denom_secmod_sig= _;
} =
future_dn
in
let rsa_pub =
match denom_pub with
| Rsa Api.RsaDenominationKey.{ age_mask= _; rsa_pub } -> rsa_pub
in
let dn_of_future_dn
Api.FutureDenom.
{
section_name= _;
value;
stamp_start;
stamp_expire_withdraw;
stamp_expire_deposit;
stamp_expire_legal;
denom_pub;
fee_withdraw;
fee_deposit;
fee_refresh;
fee_refund;
denom_secmod_sig= _;
} h_pub master_sig =
let (Rsa Api.RsaDenominationKey.{ age_mask= _; rsa_pub }) = denom_pub in
Denomination.
{
pub= rsa_pub;
@ -263,12 +266,8 @@ module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct
Denomination.verify_denomination_key_validity ~key:Config.master_public_key
dn
(* MIOU *)
let last_change = ref Timestamp.never
let denominations_last_change () = !last_change
let certify_future_signkey Api.SignKeySignature.{ key= pub; master_sig } =
match Sm_eddsa.find_key pub with
match Secmod_eddsa.find_key sm_eddsa pub with
| None -> Error (`Not_found "future eddsa key")
| Some (pub, (t1, t2)) ->
(* rebuild it *)
@ -280,7 +279,7 @@ module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct
let certify_future_denomination
Api.DenomSignature.{ h_denom_pub= h_pub; master_sig } =
match Sm_rsa.find_key h_pub with
match Secmod_rsa.find_key sm_rsa h_pub with
| None -> Error (`Not_found "future rsa denomination key")
| Some (h_pub, (section_name, pub, t1)) ->
let future_dn = make_future_dn (h_pub, (section_name, pub, t1)) in
@ -291,21 +290,21 @@ module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct
()
let revoke_signkey pub revoked_sig =
let* opt = find_signkey pub in
let* opt = Pg.find_signkey conn pub in
match opt with
| None -> Fmt.error_msg "signkey not found"
| Some _sk ->
let* () = Sm_eddsa.revoke pub in
let* () = Secmod_eddsa.revoke sm_eddsa pub in
let+ () = Pg.insert_signkey_revocation conn pub revoked_sig in
Logs.info (fun m -> m "revoked signkey `%a`" Eddsa.pp_pub pub);
()
let revoke_denomination h_pub revoked_sig =
let* opt = find_denomination h_pub in
let* opt = Pg.find_denomination conn h_pub in
match opt with
| None -> Fmt.error_msg "denomination not found"
| Some dn ->
let* () = Sm_rsa.revoke dn.h_pub in
let* () = Secmod_rsa.revoke sm_rsa dn.h_pub in
let+ () = Pg.insert_denomination_revocation conn dn.h_pub revoked_sig in
Logs.info (fun m ->
m "revoked denomination `%a`" DenominationHash.pp h_pub);

2
src/pg.ml
View file

@ -63,7 +63,7 @@ let insert_signkey =
in
fun conn v -> exec conn req v
let find_denom =
let find_denomination =
let req =
(denom_hash ->? denom)
"SELECT denom_pub, (coin).*, valid_from, expire_withdraw, \

293
src/secmod_eddsa.ml
View file

@ -18,7 +18,7 @@ module Cfg = struct
include Config.Exchange_secmod_eddsa
let key_dir = "/EDDSA"
let sm_key = "/SM_EDDSA"
let sm_key_path = "/SM_EDDSA"
end
type key = {
@ -35,177 +35,146 @@ type t = {
ht: (Eddsa.pub, key) Hashtbl.t;
}
(* todo: this should be encoded in little-endian *)
let key_bin =
let open Bin in
record (fun t1 t2 priv ->
let pub = Eddsa.pub_of_priv priv in
{ t1; t2; priv; pub })
|+ field TimeAbsolute.bin (fun t -> t.t1)
|+ field TimeAbsolute.bin (fun t -> t.t2)
|+ field Eddsa.priv_bin (fun t -> t.priv)
|> sealr
open struct
(* todo: this should be encoded in little-endian *)
let key_bin =
let open Bin in
record (fun t1 t2 priv ->
let pub = Eddsa.pub_of_priv priv in
{ t1; t2; priv; pub })
|+ field TimeAbsolute.bin (fun t -> t.t1)
|+ field TimeAbsolute.bin (fun t -> t.t2)
|+ field Eddsa.priv_bin (fun t -> t.priv)
|> sealr
(* for sm_key only *)
let read_eddsa fs spath =
Log.debug (fun m -> m "reading key file `%s`" spath);
let* data = Fat.read fs spath in
let* priv = Eddsa.priv_of_octets data |> Result.map_error (fun e -> `Msg e) in
let pub = Eddsa.pub_of_priv priv in
Ok (priv, pub)
let read_sm_key fs spath =
let* s = Fat.read fs spath in
Bbin.decode Eddsa.priv_bin s
let write_eddsa fs spath priv =
Log.debug (fun m -> m "writing key file `%s`" spath);
let data = Eddsa.priv_to_octets priv in
Fat.write fs spath data
let write_sm_key fs spath t =
let* s = Bbin.encode Eddsa.priv_bin t in
Fat.write fs spath s
let key_spath k =
let sfn = String.sub (Eddsa.pub_to_crockford k.pub) 0 8 in
Fat.Path.add Cfg.key_dir sfn
let read_key fs spath =
Log.debug (fun m -> m "reading key file `%s`" spath);
let* s = Fat.read fs spath in
let+ k = Bbin.decode key_bin s in
k
let write_key fs k =
let spath = key_spath k in
Log.debug (fun m -> m "writing key file `%s`" spath);
let* s = Bbin.encode key_bin k in
Fat.write fs spath s
let delete_file fs spath =
Log.debug (fun m -> m "delete key file `%s`" spath);
let+ () = Fat.remove fs spath in
()
let gen_key t1 t2 =
let priv, pub = Eddsa.generate () in
let k = { priv; pub; t1; t2 } in
Log.debug (fun m -> m "generated key `%a`" Eddsa.pp_pub pub);
k
let sort_keys l = List.sort (fun a b -> TimeAbsolute.compare a.t2 b.t2) l
let split_in_periodes ~start ~end_ =
assert (start < end_);
(* no overlap on first periode *)
let t1 = start in
let t2 = TimeAbsolute.add start Cfg.duration 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 Cfg.duration in
if t2 > end_ then acc else go ((t1, t2) :: acc) t2 end_
in
go acc start end_
(* try to not generate keys with validity start in the past *)
let gen_additional_keys_until_lookahead ~now l =
let start =
match List.rev (sort_keys l) with
| [] -> now
| hd :: _ -> TimeAbsolute.sub hd.t2 Cfg.overlap_duration
in
let end_ = TimeAbsolute.add now Cfg.lookahead_sign in
if TimeAbsolute.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
let load fs =
let* () =
if Fat.exists fs Cfg.key_dir then Ok () else Fat.mkdir fs Cfg.key_dir
in
let* l = Fat.ls fs Cfg.key_dir in
let l = List.map (fun entry -> Fat.Path.add Cfg.key_dir entry.Fat.name) l in
let l = List.filter (fun spath -> not @@ String.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_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 })
let init fs =
let* opt = load fs in
let* t =
match opt with
| Some t -> Ok t
| None ->
let sm_priv, sm_pub = Eddsa.generate () in
Log.debug (fun m -> m "generated secmod key: `%a`" Eddsa.pp_pub sm_pub);
let ht = Hashtbl.create 0xff in
let t = { fs; sm_priv; sm_pub; ht } in
let* () = write_eddsa fs Cfg.sm_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
let new_keys = gen_additional_keys_until_lookahead ~now keys in
List.iter (fun k -> Hashtbl.replace t.ht k.pub k) new_keys;
let+ () = list_iter (write_key fs) new_keys in
t
module Make (Fs : Fat.FS) = struct
let t =
match init Fs.t with
| Error e ->
Fmt.failwith "secmod_eddsa initialization failure: %a." Result.pp_err e
| Ok t -> t
let find_exn pub =
Log.debug (fun m -> m "find_exn: `%a`" Eddsa.pp_pub pub);
match Hashtbl.find_opt t.ht pub with
| Some v -> v
| None ->
(* XXX ERR
either:
- we tried to sign with a key that is not ours
- key was revoked bywhile we were holding on it
- broken keyring state *)
Fmt.failwith "secmod_eddsa operation on unknown key"
let add t1 t2 =
let k = gen_key t1 t2 in
Hashtbl.replace t.ht k.pub k;
let+ () = write_key t.fs k in
let delete_file fs spath =
Log.debug (fun m -> m "delete key file `%s`" spath);
let+ () = Fat.remove fs spath in
()
let delete pub =
let k = find_exn pub in
Hashtbl.remove t.ht k.pub;
delete_file t.fs (key_spath k)
let key_spath k =
let sfn = String.sub (Eddsa.pub_to_crockford k.pub) 0 8 in
Fat.Path.add Cfg.key_dir sfn
let _delete_outdated ~now =
Hashtbl.to_seq_values t.ht
|> List.of_seq
|> List.filter (fun k -> TimeAbsolute.compare now k.t2 >= 0)
|> List.map (fun k -> k.pub)
|> list_iter delete
let read_key fs spath =
Log.debug (fun m -> m "reading key file `%s`" spath);
let* s = Fat.read fs spath in
let+ k = Bbin.decode key_bin s in
k
let write_key fs k =
let spath = key_spath k in
Log.debug (fun m -> m "writing key file `%s`" spath);
let* s = Bbin.encode key_bin k in
Fat.write fs spath s
(* ---- *)
let sm_pub = t.sm_pub
let sign_secmod s = Eddsa.sign ~key:t.sm_priv s
let epochs t0 tmax overlap duration =
let rec go t acc =
match t >= tmax with
| true -> acc
| false ->
let t1 = TimeAbsolute.sub t overlap in
let t2 = TimeAbsolute.add t duration in
let acc = (t1, t2) :: acc in
go t2 acc
in
go t0 []
let sign pub s =
let k = find_exn pub in
Eddsa.sign ~key:k.priv s
let gen_key t1 t2 =
let priv, pub = Eddsa.generate () in
let k = { priv; pub; t1; t2 } in
Log.debug (fun m -> m "generated key `%a`" Eddsa.pp_pub pub);
k
(* delete and replace *)
let revoke pub =
let k = find_exn pub in
let* () = delete pub in
let* () = add k.t1 k.t2 in
Ok ()
let load fs =
let open Fat in
let open Cfg in
let* () = if exists fs key_dir then Ok () else mkdir fs key_dir in
let* l = ls fs key_dir in
let l = List.map (fun entry -> Path.add key_dir entry.name) l in
let* keys = list_map (read_key fs) l in
match keys with
| [] -> Ok None
| _l ->
let* sm_priv = read_sm_key fs sm_key_path in
let sm_pub = Eddsa.pub_of_priv sm_priv 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 })
let conv = fun { priv= _; pub; t1; t2 } -> (pub, (t1, t2))
let keys () = Hashtbl.to_seq_values t.ht |> List.of_seq |> List.map conv
let find_key pub = Hashtbl.find_opt t.ht pub |> Option.map conv
let create fs =
let* opt = load fs in
let* t =
match opt with
| Some t -> Ok t
| None ->
let sm_priv, sm_pub = Eddsa.generate () in
Log.debug (fun m ->
m "generated secmod key: `%a`" Eddsa.pp_pub sm_pub);
let ht = Hashtbl.create 0xff in
let t = { fs; sm_priv; sm_pub; ht } in
let* () = write_sm_key fs Cfg.sm_key_path sm_priv in
Ok t
in
let now = TimeAbsolute.of_ptime (Mirage_ptime.now ()) in
let keys = Hashtbl.to_seq_values t.ht |> List.of_seq in
let new_keys =
let t0 =
List.fold_left (fun acc k -> TimeAbsolute.max acc k.t2) now keys
in
let tmax = TimeAbsolute.add t0 Cfg.lookahead in
let l = epochs t0 tmax Cfg.overlap Cfg.duration in
List.map (fun (t1, t2) -> gen_key t1 t2) l
in
List.iter (fun k -> Hashtbl.replace t.ht k.pub k) new_keys;
let+ () = list_iter (write_key fs) new_keys in
t
end
(* ### *)
let create fs =
match create fs with
| Error e ->
Fmt.failwith "secmod_eddsa initialization failure: %a." Result.pp_err e
| Ok t -> t
(* XXX ERR
either:
- we tried to sign with a key that is not ours
- key was revoked bywhile we were holding on it
- broken keyring state *)
let find_exn t pub =
Log.debug (fun m -> m "find_exn: `%a`" Eddsa.pp_pub pub);
match Hashtbl.find_opt t.ht pub with
| None -> Fmt.failwith "secmod_eddsa operation on unknown key"
| Some v -> v
let sm_pub t = t.sm_pub
let conv = fun { priv= _; pub; t1; t2 } -> (pub, (t1, t2))
let keys t = Hashtbl.to_seq_values t.ht |> List.of_seq |> List.map conv
let find_key t pub = Hashtbl.find_opt t.ht pub |> Option.map conv
let sign_secmod t s = Eddsa.sign ~key:t.sm_priv s
let sign t pub s =
let k = find_exn t pub in
Eddsa.sign ~key:k.priv s
let revoke t pub =
let k = find_exn t pub in
Hashtbl.remove t.ht pub;
let* () = delete_file t.fs (key_spath k) in
let k = gen_key k.t1 k.t2 in
Hashtbl.replace t.ht k.pub k;
let+ () = write_key t.fs k in
()

354
src/secmod_rsa.ml
View file

@ -12,7 +12,7 @@ module Cfg = struct
include Config.Exchange_secmod_rsa
let key_dir = "/RSA"
let sm_key = "/SM_RSA"
let sm_key_path = "/SM_RSA"
end
type key = {
@ -31,208 +31,174 @@ type t = {
ht: (DenominationHash.t, key) Hashtbl.t;
}
let find_exn h_pub section_name =
Coin.all_coins
|> Iarray.find_opt (fun coin ->
String.equal section_name coin.Coin.section_name)
|> function
| Some coin -> coin
| None ->
Fmt.failwith
"Secmod_rsa denomination key loading failure on key `%a`: unknown \
section_name [%s]"
DenominationHash.pp h_pub section_name
(* ? enforce all to be of the same size instead *)
(* we use Bin.cstring + b32 binary encoding because
rsa keysize is not known and then we have to escape '\x00' *)
let rsa_private_key_bin =
let decode_exn o =
Rsa.priv_of_crockford o |> function Error e -> invalid_arg e | Ok v -> v
in
let encode o = Rsa.priv_to_crockford o in
Bin.map Bin.cstring decode_exn encode
let key_bin =
let open Bin in
record (fun t1 t2 section_name priv ->
let pub = Rsa.pub_of_priv priv in
let h_pub = DenominationHash.hash pub in
let coin = find_exn h_pub section_name in
{ coin; 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.coin.section_name)
|+ field rsa_private_key_bin (fun t -> t.priv)
|> sealr
let key_spath k =
let sfn = String.sub (DenominationHash.to_crockford k.h_pub) 0 8 in
Fat.Path.add Cfg.key_dir sfn
let read_eddsa fs spath =
Log.debug (fun m -> m "reading key file `%s`" spath);
let* data = Fat.read fs spath in
let* priv = Eddsa.priv_of_octets data |> Result.map_error (fun e -> `Msg e) in
let pub = Eddsa.pub_of_priv priv in
Ok (priv, pub)
let write_eddsa fs spath priv =
Log.debug (fun m -> m "writing key file `%s`" spath);
let data = Eddsa.priv_to_octets priv in
Fat.write fs spath data
let read_key fs spath =
Log.debug (fun m -> m "reading key file `%s`" spath);
let* s = Fat.read fs spath in
let+ k = Bbin.decode key_bin s in
k
let write_key fs k =
let spath = key_spath k in
Log.debug (fun m -> m "writing key file `%s`" spath);
let* s = Bbin.encode key_bin k in
Fat.write fs spath s
let delete_file fs spath =
Log.debug (fun m -> m "delete key file `%s`" spath);
let+ () = Fat.remove fs spath in
()
(* -- *)
let gen_key coin t1 t2 =
let bits = coin.Coin.rsa_keysize in
let priv, pub = Rsa.generate ~bits () in
let h_pub = DenominationHash.hash pub in
let k = { coin; priv; pub; h_pub; t1; t2 } in
Log.debug (fun m ->
m "generated key for coin [%s]: `%a`" coin.section_name
DenominationHash.pp k.h_pub);
k
let sort_keys l = List.sort (fun a b -> TimeAbsolute.compare a.t2 b.t2) l
let split_in_periodes coin ~start ~end_ =
assert (start < end_);
let duration_withdraw = coin.Coin.duration_withdraw in
(* no overlap on first periode *)
let t1 = start in
let t2 = TimeAbsolute.add start 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
if t2 > end_ then acc else go ((t1, t2) :: acc) t2 end_
in
go acc start end_
let gen_additional_keys_until_lookahead coin ~now l =
let start =
match List.rev (sort_keys l) with
| [] -> now
| hd :: _ -> TimeAbsolute.sub hd.t2 Cfg.overlap_duration
in
let end_ = TimeAbsolute.add now Cfg.lookahead_sign in
if TimeAbsolute.compare start end_ >= 0 then []
else
let periodes = split_in_periodes coin ~start ~end_ in
let new_keys = List.map (fun (t1, t2) -> gen_key coin t1 t2) periodes in
new_keys
let load fs =
let* () =
if Fat.exists fs Cfg.key_dir then Ok () else Fat.mkdir fs Cfg.key_dir
in
let* l = Fat.ls fs Cfg.key_dir in
let l = List.map (fun entry -> Fat.Path.add Cfg.key_dir entry.Fat.name) l in
let l = List.filter (fun spath -> not @@ String.equal Cfg.sm_key spath) 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_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 })
let init fs =
let* opt = load fs in
let now = TimeAbsolute.of_ptime (Mirage_ptime.now ()) in
let* t =
match opt with
| Some t -> Ok t
| None ->
let sm_priv, sm_pub = Eddsa.generate () in
Log.debug (fun m -> m "generated secmod key: `%a`" Eddsa.pp_pub sm_pub);
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 =
open struct
let find_coin_exn h_pub section_name =
Coin.all_coins
|> Iarray.to_list
|> List.map (fun coin ->
let keys =
List.filter
(fun k -> String.equal coin.Coin.section_name k.coin.section_name)
all_keys
in
gen_additional_keys_until_lookahead coin ~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;
let+ () = list_iter (write_key fs) new_keys in
t
|> Iarray.find_opt (fun coin ->
String.equal section_name coin.Coin.section_name)
|> function
| Some coin -> coin
| None ->
Fmt.failwith
"Secmod_rsa denomination key loading failure on key `%a`: unknown \
section_name [%s]"
DenominationHash.pp h_pub section_name
module Make (Fs : Fat.FS) = struct
let t =
match init Fs.t with
| Error e ->
Fmt.failwith "secmod_rsa initialization failure: %a." Result.pp_err e
| Ok t -> t
(* ? enforce all to be of the same size instead *)
(* we use Bin.cstring + b32 binary encoding because
rsa keysize is not known and then we have to escape '\x00' *)
let rsa_private_key_bin =
let decode_exn o =
Rsa.priv_of_crockford o |> function Error e -> invalid_arg e | Ok v -> v
in
let encode o = Rsa.priv_to_crockford o in
Bin.map Bin.cstring decode_exn encode
let find_exn h_pub =
Log.debug (fun m -> m "find_exn: `%a`" DenominationHash.pp h_pub);
match Hashtbl.find_opt t.ht h_pub with
| Some v -> v
| None -> Fmt.failwith "secmod_rsa operation on unknown key"
let key_bin =
let open Bin in
record (fun t1 t2 section_name priv ->
let pub = Rsa.pub_of_priv priv in
let h_pub = DenominationHash.hash pub in
let coin = find_coin_exn h_pub section_name in
{ coin; 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.coin.section_name)
|+ field rsa_private_key_bin (fun t -> t.priv)
|> sealr
let delete h_pub =
let k = find_exn h_pub in
Hashtbl.remove t.ht h_pub;
delete_file t.fs (key_spath k)
let read_sm_key fs spath =
let* s = Fat.read fs spath in
Bbin.decode Eddsa.priv_bin s
let _delete_outdated ~now =
Hashtbl.to_seq t.ht
|> List.of_seq
|> List.filter (fun (_h_pub, k) -> TimeAbsolute.compare now k.t2 >= 0)
|> List.map (fun (h_pub, _k) -> h_pub)
|> list_iter delete
let write_sm_key fs spath t =
let* s = Bbin.encode Eddsa.priv_bin t in
Fat.write fs spath s
let add coin t1 t2 =
let k = gen_key coin t1 t2 in
let+ () = write_key t.fs k in
Hashtbl.replace t.ht k.h_pub k;
let delete_file fs spath =
Log.debug (fun m -> m "delete key file `%s`" spath);
let+ () = Fat.remove fs spath in
()
let sm_pub = t.sm_pub
let sign_secmod s = Eddsa.sign ~key:t.sm_priv s
let key_spath k =
let sfn = String.sub (DenominationHash.to_crockford k.h_pub) 0 8 in
Fat.Path.add Cfg.key_dir sfn
let sign h_pub msg =
let k = find_exn h_pub in
Rsa.sign ~key:k.priv msg
let read_key fs spath =
Log.debug (fun m -> m "reading key file `%s`" spath);
let* s = Fat.read fs spath in
let+ k = Bbin.decode key_bin s in
k
let revoke h_pub =
Log.debug (fun m -> m "revoke `%a`" DenominationHash.pp h_pub);
let k = find_exn h_pub in
let* () = delete h_pub in
let* () = add k.coin k.t1 k.t2 in
Ok ()
let write_key fs k =
let spath = key_spath k in
Log.debug (fun m -> m "writing key file `%s`" spath);
let* s = Bbin.encode key_bin k in
Fat.write fs spath s
let conv k = (k.h_pub, (k.coin, k.pub, k.t1))
let keys () = Hashtbl.to_seq_values t.ht |> List.of_seq |> List.map conv
let find_key pub = Hashtbl.find_opt t.ht pub |> Option.map conv
(* ---- *)
let epochs t0 tmax overlap duration =
let rec go t acc =
match t >= tmax with
| true -> acc
| false ->
let t1 = TimeAbsolute.sub t overlap in
let t2 = TimeAbsolute.add t duration in
let acc = (t1, t2) :: acc in
go t2 acc
in
go t0 []
let gen_key coin t1 t2 =
let bits = coin.Coin.rsa_keysize in
let priv, pub = Rsa.generate ~bits () in
let h_pub = DenominationHash.hash pub in
let k = { coin; priv; pub; h_pub; t1; t2 } in
Log.debug (fun m ->
m "generated key for coin [%s]: `%a`" coin.section_name
DenominationHash.pp k.h_pub);
k
let load fs =
let open Fat in
let open Cfg in
let* () = if exists fs key_dir then Ok () else mkdir fs key_dir in
let* l = ls fs key_dir in
let l = List.map (fun entry -> Path.add key_dir entry.name) l in
let* keys = list_map (read_key fs) l in
match keys with
| [] -> Ok None
| _l ->
let* sm_priv = read_sm_key fs sm_key_path in
let sm_pub = Eddsa.pub_of_priv sm_priv in
let ht = Hashtbl.create 0xff in
List.iter (fun k -> Hashtbl.replace ht k.h_pub k) keys;
Ok (Some { fs; sm_priv; sm_pub; ht })
let create fs =
let* opt = load fs in
let now = TimeAbsolute.of_ptime (Mirage_ptime.now ()) in
let* t =
match opt with
| Some t -> Ok t
| None ->
let sm_priv, sm_pub = Eddsa.generate () in
Log.debug (fun m ->
m "generated secmod key: `%a`" Eddsa.pp_pub sm_pub);
let* () = write_sm_key fs Cfg.sm_key_path sm_priv in
let ht = Hashtbl.create 0xff in
Ok { fs; sm_priv; sm_pub; ht }
in
let keys = Hashtbl.to_seq_values t.ht |> List.of_seq in
let new_keys =
Coin.all_coins
|> Iarray.to_list
|> List.concat_map (fun coin ->
let t0 =
keys
|> List.filter (fun k ->
String.equal coin.Coin.section_name k.coin.section_name)
|> List.fold_left (fun acc k -> TimeAbsolute.max acc k.t2) now
in
let tmax = TimeAbsolute.add t0 Cfg.lookahead in
let l = epochs t0 tmax Cfg.overlap coin.duration_withdraw in
List.map (fun (t1, t2) -> gen_key coin t1 t2) l)
in
List.iter (fun k -> Hashtbl.replace t.ht k.h_pub k) new_keys;
let+ () = list_iter (write_key fs) new_keys in
t
end
(* ### *)
let create fs =
match create fs with
| Error e ->
Fmt.failwith "secmod_rsa initialization failure: %a." Result.pp_err e
| Ok t -> t
let find_exn t h_pub =
Log.debug (fun m -> m "find_exn: `%a`" DenominationHash.pp h_pub);
match Hashtbl.find_opt t.ht h_pub with
| None -> Fmt.failwith "secmod_rsa operation on unknown key"
| Some v -> v
let sm_pub t = t.sm_pub
let conv k = (k.h_pub, (k.coin, k.pub, k.t1))
let keys t = Hashtbl.to_seq_values t.ht |> List.of_seq |> List.map conv
let find_key t h_pub = Hashtbl.find_opt t.ht h_pub |> Option.map conv
let sign_secmod t s = Eddsa.sign ~key:t.sm_priv s
let sign t h_pub s =
let k = find_exn t h_pub in
Rsa.sign ~key:k.priv s
let revoke t h_pub =
let k = find_exn t h_pub in
Hashtbl.remove t.ht h_pub;
let* () = delete_file t.fs (key_spath k) in
let k = gen_key k.coin k.t1 k.t2 in
Hashtbl.replace t.ht k.h_pub k;
let+ () = write_key t.fs k in
()