fix secmod_eddsa; use Mfat.Spath

src/config.ml

@@ -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
@@ -220,8 +224,8 @@ module Exchange_secmod_rsa = struct
   let overlap_duration = get "overlap_duration" |> duration
 
   (* 8.3 filenames for FAT *)
-  let key_dir = "secmod_rsa"
+  let key_dir = "rsa" |> spath
-  let sm_priv_key = "secmod_rsa/sm_key"
+  let sm_priv_key = "rsa/sm_key" |> spath
 end
 
 module Exchange_secmod_eddsa = struct
@@ -232,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 = "secmod_eddsa"
+  let key_dir = "eddsa" |> spath
-  let sm_priv_key = "secmod_eddsa/sm_key"
+  let sm_priv_key = "eddsa/sm_key" |> spath
 end
 
 (* -- *)

src/fat.ml

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

src/secmod_eddsa.ml

@@ -16,6 +16,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,89 +29,71 @@ 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 =
+(* todo: this should be encoded in little-endian *)
-  let scan_filename s =
+let key_bin =
-    Scanf.sscanf_opt s "%Lu-%Lu" (fun t1 t2 ->
+  let open Bin in
-        (TimeAbsolute.of_s t1, TimeAbsolute.of_s t2))
+  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 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 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_eddsa fs spath k =
+  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 write_sm_key fs t =
+  let k =
+    {
+      t1= TimeAbsolute.never;
+      t2= TimeAbsolute.never;
+      priv= t.sm_priv;
+      pub= t.sm_pub;
+    }
   in
-  fun fpath -> scan_filename (Fpath.filename fpath)
+  write_eddsa fs Cfg.sm_priv_key k
 
-let pp_filename =
+let write_key fs k = write_eddsa fs (key_spath k) k
-  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 key_fpath k =
+let delete_file fs spath =
-  let fname = Fmt.str "%a" pp_filename (k.t1, k.t2) in
+  Log.debug (fun m -> m "delete key file `%a`" Spath.pp spath);
-  Fpath.(v Cfg.key_dir / fname)
+  let+ () = Fat.remove fs spath |> unwrap_msg in
-
-(* -- 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 |> function
-    | Error (`Msg _e) -> Error "uhuh read_keay"
-    | Ok v -> Ok v
-  in
-  EddsaPrivateKey.of_octets data
-
-let write_eddsa fs fpath priv =
-  Log.debug (fun m -> m "writing key file `%a`" Fpath.pp fpath);
-  let data = EddsaPrivateKey.to_octets priv in
-  let fpath = Fpath.to_string fpath in
-  Fat.write fs fpath data |> unwrap_msg
-
-let write_key fs k = write_eddsa fs (key_fpath k) k.priv
-
-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 get_key_dir_contents fs dir =
-  Log.debug (fun m -> m "get_key_dir_contents `%s`" dir);
+  Log.debug (fun m -> m "get_key_dir_contents `%a`" Spath.pp dir);
-  let* dir = Fpath.of_string dir |> unwrap_msg in
-  let dir = Fpath.to_string dir in
-  let dir = String.uppercase_ascii dir in
-  let dir = "/" ^ dir in
   let* () = Fat.mkdir fs dir |> unwrap_msg in
-  Log.debug (fun m -> m "created directory `%s`" dir);
   let+ l = Fat.ls fs dir |> unwrap_msg in
-  Log.debug (fun m -> m "ls ok --");
-  (*   List.map Fpath.normalize l *)
   let l = List.map (fun entry -> entry.Fat.name) l in
-  let l = List.map Fpath.v l in
+  let l = List.map (Spath.add dir) l in
   l
 
-(* -- *)
-
 let gen_key t1 t2 =
   let priv, pub = EddsaPrivateKey.generate () in
-  Log.debug (fun m ->
+  let k = { priv; pub; t1; t2 } in
-      m "generated key (%a):@,`%s`" pp_filename (t1, t2)
+  Log.debug (fun m -> m "generated key `%s`" (EddsaPublicKey.to_b32 pub));
-        (EddsaPublicKey.to_b32 pub));
+  k
-  { priv; pub; t1; t2 }
 
 let sort_keys l = List.sort (fun a b -> TimeAbsolute.compare a.t2 b.t2) l
 
@@ -141,34 +125,19 @@ 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 l =
-  let* keys = list_map (load_key fs) l in
+    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_key = read_key fs Cfg.sm_priv_key in
-      let sm_pub = EddsaPrivateKey.pub_of_priv sm_key_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_key_priv; sm_pub; ht })
+      Ok (Some { fs; sm_priv= sm_key.priv; sm_pub= sm_key.pub; ht })
 
 let init fs =
   let* opt = load fs in
@@ -176,12 +145,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_sm_key fs t 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
@@ -208,7 +178,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
@@ -220,7 +190,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

src/time.ml

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

src/time.mli

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