add result.ml; polymorphic variant errors + refacto
This commit is contained in:
parent
9fd3b5a3cc
commit
42b0ec1445
36 changed files with 949 additions and 954 deletions
|
|
@ -6,41 +6,17 @@ module Log = (val Logs.src_log src : Logs.LOG)
|
|||
open Syntax
|
||||
open Time
|
||||
module DenominationHash = Hash.DenominationHash
|
||||
|
||||
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 Coin = Config.Coin
|
||||
|
||||
module Cfg = struct
|
||||
include Config.Exchange_secmod_rsa
|
||||
|
||||
let key_dir = "/RSA"
|
||||
let sm_key = "/SM_RSA"
|
||||
let coin_config_list = List.map Coin_config.of_coin Config.Coin.all_coins
|
||||
|
||||
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 = {
|
||||
section_name: string;
|
||||
coin: Coin.t;
|
||||
priv: Rsa.priv;
|
||||
pub: Rsa.pub;
|
||||
h_pub: DenominationHash.t;
|
||||
|
|
@ -55,16 +31,39 @@ 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_b32 o |> function Error e -> invalid_arg e | Ok v -> v
|
||||
in
|
||||
let encode o = Rsa.priv_to_b32 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_of_rsa pub in
|
||||
{ section_name; t1; t2; priv; pub; h_pub })
|
||||
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.section_name)
|
||||
|+ field Rsa.priv_bin (fun t -> t.priv)
|
||||
|+ field cstring (fun t -> t.coin.section_name)
|
||||
|+ field rsa_private_key_bin (fun t -> t.priv)
|
||||
|> sealr
|
||||
|
||||
let key_spath k =
|
||||
|
|
@ -73,61 +72,63 @@ let key_spath k =
|
|||
|
||||
let read_eddsa fs spath =
|
||||
Log.debug (fun m -> m "reading key file `%s`" spath);
|
||||
let* data = Fat.read fs spath |> unwrap_msg in
|
||||
let* priv = Eddsa.priv_of_octets data in
|
||||
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 |> unwrap_msg
|
||||
Fat.write fs spath data
|
||||
|
||||
let read_key fs spath =
|
||||
Log.debug (fun m -> m "reading key file `%s`" spath);
|
||||
let* data = Fat.read fs spath |> unwrap_msg in
|
||||
let k = Bin.decode key_bin data (ref 0) in
|
||||
Ok k
|
||||
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 data = Bin.to_string key_bin k in
|
||||
Fat.write fs spath data |> unwrap_msg
|
||||
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 |> unwrap_msg in
|
||||
let+ () = Fat.remove fs spath in
|
||||
()
|
||||
|
||||
(* -- *)
|
||||
|
||||
let gen_key cfg t1 t2 =
|
||||
let priv, pub = Rsa.generate ~bits:cfg.Coin_config.rsa_keysize () in
|
||||
let h_pub = DenominationHash.hash_of_rsa pub in
|
||||
let k = { section_name= cfg.name; priv; pub; h_pub; t1; t2 } 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 %s `%s`" cfg.Coin_config.name
|
||||
(DenominationHash.to_b32 k.h_pub));
|
||||
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 (cfg : Coin_config.t) ~start ~end_ =
|
||||
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 cfg.duration_withdraw 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 cfg.duration_withdraw 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 cfg ~now l =
|
||||
let gen_additional_keys_until_lookahead coin ~now l =
|
||||
let start =
|
||||
match List.rev (sort_keys l) with
|
||||
| [] -> now
|
||||
|
|
@ -136,16 +137,15 @@ let gen_additional_keys_until_lookahead cfg ~now l =
|
|||
let end_ = TimeAbsolute.add now Cfg.lookahead_sign in
|
||||
if TimeAbsolute.compare start end_ >= 0 then []
|
||||
else
|
||||
let periodes = split_in_periodes cfg ~start ~end_ in
|
||||
let new_keys = List.map (fun (t1, t2) -> gen_key cfg t1 t2) periodes in
|
||||
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 |> unwrap_msg
|
||||
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 |> unwrap_msg 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
|
||||
|
|
@ -165,18 +165,22 @@ let init fs =
|
|||
| Some t -> Ok t
|
||||
| None ->
|
||||
let sm_priv, sm_pub = Eddsa.generate () in
|
||||
Log.debug (fun m ->
|
||||
m "generated secmod key: `%s`" (Eddsa.pub_to_b32 sm_pub));
|
||||
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 =
|
||||
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)
|
||||
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;
|
||||
|
|
@ -186,14 +190,18 @@ let init fs =
|
|||
module Make (Fs : Fat.FS) = struct
|
||||
let t =
|
||||
match init Fs.t with
|
||||
| Error e -> Fmt.failwith "secmod_rsa initialization failure: %s." e
|
||||
| Error e ->
|
||||
Fmt.failwith "secmod_rsa initialization failure: %a." Result.pp_err e
|
||||
| Ok t -> t
|
||||
|
||||
let find h_pub =
|
||||
Hashtbl.find_opt t.ht h_pub |> Option.to_result ~none:"key not found"
|
||||
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 delete h_pub =
|
||||
let* k = find h_pub in
|
||||
let k = find_exn h_pub in
|
||||
Hashtbl.remove t.ht h_pub;
|
||||
delete_file t.fs (key_spath k)
|
||||
|
||||
|
|
@ -204,8 +212,8 @@ module Make (Fs : Fat.FS) = struct
|
|||
|> List.map (fun (h_pub, _k) -> h_pub)
|
||||
|> list_iter delete
|
||||
|
||||
let add cfg t1 t2 =
|
||||
let k = gen_key cfg t1 t2 in
|
||||
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;
|
||||
()
|
||||
|
|
@ -214,23 +222,17 @@ module Make (Fs : Fat.FS) = struct
|
|||
let sign_secmod s = Eddsa.sign ~key:t.sm_priv s
|
||||
|
||||
let sign h_pub msg =
|
||||
let+ k = find h_pub in
|
||||
let data = Rsa.sign ~key:k.priv msg in
|
||||
data
|
||||
let k = find_exn h_pub in
|
||||
Rsa.sign ~key:k.priv msg
|
||||
|
||||
let revoke h_pub =
|
||||
Log.debug (fun m ->
|
||||
m "revoke `%s`" (DenominationHash.to_octets h_pub |> B32.encode));
|
||||
let* k = find h_pub in
|
||||
Log.debug (fun m -> m "revoke `%a`" DenominationHash.pp h_pub);
|
||||
let k = find_exn h_pub in
|
||||
let* () = delete h_pub in
|
||||
let cfg = Cfg.get_coin_config ~section_name:k.section_name in
|
||||
let* () = add cfg k.t1 k.t2 in
|
||||
let* () = add k.coin k.t1 k.t2 in
|
||||
Ok ()
|
||||
|
||||
let conv =
|
||||
fun { section_name; priv= _; pub; h_pub; t1; t2= _ } ->
|
||||
(h_pub, (section_name, pub, t1))
|
||||
|
||||
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
|
||||
end
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue