diff --git a/src/keys.ml b/src/keys.ml index 69ff2fab..36357e6c 100644 --- a/src/keys.ml +++ b/src/keys.ml @@ -140,56 +140,46 @@ module Make (Conn : Pg.CONN) : S = struct } let future_signkeys () = - let l : Sm_eddsa.info list = Sm_eddsa.keys () in - let+ l = - list_map - (fun (pub, t1, t2) -> - let* opt = find_signkey pub in - match opt with - | None -> - let future_sk = make_future_sk ~pub ~start:t1 ~expire:t2 in - Ok (Some future_sk) - | Some sk -> ( - match Timestamp.of_absolute t1 = sk.stamp_start with - | false -> - Fmt.error - "secmod/database stamp_start mismatch for signkey `%s`" - (EddsaPublicKey.to_b32 pub) - | true -> Ok None)) - l - in - List.filter_map Fun.id l + Sm_eddsa.keys () + |> list_filter_map (fun (pub, t1, t2) -> + let* opt = find_signkey pub in + match opt with + | None -> + let future_sk = make_future_sk ~pub ~start:t1 ~expire:t2 in + Ok (Some future_sk) + | Some sk -> ( + match Timestamp.of_absolute t1 = sk.stamp_start with + | false -> + Fmt.error + "secmod/database stamp_start mismatch for signkey `%s`" + (EddsaPublicKey.to_b32 pub) + | true -> Ok None)) let future_denominations () = - let+ l = - list_map - (fun (section_name, pub, t1) -> - let h_pub = Hash.DenominationHash.hash (RsaPublicKey.to_octets pub) in - let* opt = find_denomination h_pub in - match opt with - | None -> - let* coin = - Config.Coin.all_coins - |> List.find_opt (fun coin -> - coin.Config.Coin.section_name = section_name) - |> function - | Some v -> Ok v - | None -> - Fmt.error "coin `%s` not found in configuration" - section_name - in - let future_dn = make_future_dn ~coin ~pub ~start:t1 in - Ok (Some future_dn) - | Some sk -> ( - match Timestamp.of_absolute t1 = sk.stamp_start with - | false -> - Fmt.error - "secmod/database stamp_start mismatch for denomination `%s`" - section_name - | true -> Ok None)) - (Sm_rsa.keys ()) - in - List.filter_map Fun.id l + Sm_rsa.keys () + |> list_filter_map (fun (section_name, pub, t1) -> + let h_pub = Hash.DenominationHash.hash (RsaPublicKey.to_octets pub) in + let* opt = find_denomination h_pub in + match opt with + | None -> + let* coin = + Config.Coin.all_coins + |> List.find_opt (fun coin -> + coin.Config.Coin.section_name = section_name) + |> function + | Some v -> Ok v + | None -> + Fmt.error "coin `%s` not found in configuration" section_name + in + let future_dn = make_future_dn ~coin ~pub ~start:t1 in + Ok (Some future_dn) + | Some sk -> ( + match Timestamp.of_absolute t1 = sk.stamp_start with + | false -> + Fmt.error + "secmod/database stamp_start mismatch for denomination `%s`" + section_name + | true -> Ok None)) let make_future_keys_response () = let* future_signkeys = future_signkeys () in diff --git a/src/secmod_eddsa.ml b/src/secmod_eddsa.ml index 17bd4100..7a753253 100644 --- a/src/secmod_eddsa.ml +++ b/src/secmod_eddsa.ml @@ -122,20 +122,21 @@ let sm_key_fpath = (* we load sm_key separately we don't accept non-key files in key_dir *) let load_key fpath = - match Fpath.equal (Fpath.normalize fpath) sm_key_fpath with - | true -> Ok None - | false -> ( - match parse_filename fpath with - | None -> Fmt.error "invalid file `%a`" Fpath.pp fpath - | Some (t1, t2) -> - let* priv = read_key fpath in - let pub = EddsaPrivateKey.pub_of_priv priv in - Ok (Some { priv; pub; t1; t2 })) + match parse_filename fpath with + | None -> Fmt.error "invalid file `%a`" Fpath.pp fpath + | Some (t1, t2) -> + let+ priv = read_key fpath in + let pub = EddsaPrivateKey.pub_of_priv priv in + { priv; pub; t1; t2 } let load () = let* l = get_key_dir_contents Cfg.key_dir in - let* l = list_map load_key l in - let keys = List.filter_map Fun.id l in + let l = + l + |> List.map Fpath.normalize + |> List.filter (fun fpath -> not @@ Fpath.equal fpath sm_key_fpath) + in + let* keys = list_map load_key l in match keys with | [] -> Ok None | _l -> diff --git a/src/secmod_rsa.ml b/src/secmod_rsa.ml index 90230beb..361302b5 100644 --- a/src/secmod_rsa.ml +++ b/src/secmod_rsa.ml @@ -167,21 +167,22 @@ let sm_key_fpath = (* we load sm_key separately we don't accept non-key files in key_dir *) let load_key ~section_name fpath = - match Fpath.equal (Fpath.normalize fpath) sm_key_fpath with - | true -> Ok None - | false -> ( - match parse_filename fpath with - | None -> Fmt.error "invalid file `%a`" Fpath.pp fpath - | Some (t1, t2) -> - let* priv = read_rsa fpath in - let pub = RsaPrivateKey.pub_of_priv priv in - Ok (Some { section_name; priv; pub; t1; t2 })) + match parse_filename fpath with + | None -> Fmt.error "invalid file `%a`" Fpath.pp fpath + | Some (t1, t2) -> + let+ priv = read_rsa fpath in + let pub = RsaPrivateKey.pub_of_priv priv in + { section_name; priv; pub; t1; t2 } let load_section section_name = let section_fpath = Fpath.(v Cfg.key_dir / section_name) in let* l = get_key_dir_contents section_fpath in - let* l = list_map (load_key ~section_name) l in - let keys = List.filter_map Fun.id l in + let l = + l + |> List.map Fpath.normalize + |> List.filter (fun fpath -> not @@ Fpath.equal fpath sm_key_fpath) + in + let* keys = list_map (load_key ~section_name) l in Ok keys let load () = diff --git a/src/syntax.ml b/src/syntax.ml index 426d9ac0..f0585100 100644 --- a/src/syntax.ml +++ b/src/syntax.ml @@ -7,8 +7,6 @@ let unwrap_err_msg o = match o with Error (`Msg e) -> Error e | Ok v -> Ok v let unwrap_err_caqti o = match o with Error err -> Fmt.error "%a" Caqti_error.pp err | Ok v -> Ok v -(* TODO list_filter_map *) - let list_iter f l = let err = ref None in try @@ -37,6 +35,20 @@ let list_map f l = l) with Exit -> ( match !err with None -> assert false | Some v -> v) +let list_filter_map f l = + let err = ref None in + try + Ok + (List.filter_map + (fun v -> + match f v with + | Error _e as e -> + err := Some e; + raise Exit + | Ok v -> v) + l) + with Exit -> ( match !err with None -> assert false | Some v -> v) + let list_fold_left f acc l = List.fold_left (fun acc v ->