better secmod

src/secmod_eddsa.ml

@@ -0,0 +1,245 @@
+let src = Logs.Src.create "mte.secmod_eddsa"
+
+module Log = (val Logs.src_log src : Logs.LOG)
+
+(* - *)
+open Syntax
+open Crypto
+open Time
+module Cfg = Config.Exchange_secmod_eddsa
+
+type key = {
+  priv: EddsaPrivateKey.t;
+  pub: EddsaPublicKey.t;
+  t1: Absolute.t;
+  t2: Absolute.t;
+}
+
+type t = {
+  sm_key_priv: EddsaPrivateKey.t;
+  sm_pub: EddsaPublicKey.t;
+  ht: (EddsaPublicKey.t, key) Hashtbl.t;
+}
+
+(* -- util -- *)
+
+(* TODO time *)
+let time_abs_of_string s =
+  int_of_string_opt s |> Option.map (fun n -> Absolute.of_s (Int64.of_int n))
+
+let t1_t2_of_fpath fpath =
+  let fname = Fpath.filename fpath in
+  match String.split_on_char '-' fname with
+  | [] -> Fmt.failwith "not possible"
+  | [ t1; t2 ] -> (
+      match (time_abs_of_string t1, time_abs_of_string t2) with
+      | None, _ | _, None -> None
+      | Some t1, Some t2 -> Some (t1, t2))
+  | _ -> None
+
+let time_abs_to_string abs =
+  abs
+  |> Timestamp.of_absolute
+  |> Timestamp.to_s
+  |> Option.get
+  |> Int64.to_int
+  |> string_of_int
+
+let key_fpath k =
+  let t1 = time_abs_to_string k.t1 in
+  let t2 = time_abs_to_string k.t2 in
+  let fname = Fmt.str "%s-%s" t1 t2 in
+  Fpath.(v Cfg.key_dir / fname)
+
+(* -- IO -- *)
+
+let read_key fpath =
+  Log.debug (fun m -> m "reading key file `%a`" Fpath.pp fpath);
+  let* data = Bos.OS.File.read fpath |> unwrap_err_msg in
+  EddsaPrivateKey.of_octets data
+
+let write_eddsa fpath priv =
+  Log.debug (fun m -> m "writing key file `%a`" Fpath.pp fpath);
+  let data = EddsaPrivateKey.to_octets priv in
+  Bos.OS.File.write fpath data |> unwrap_err_msg
+
+let write_key k = write_eddsa (key_fpath k) k.priv
+
+let delete_file fpath =
+  Log.debug (fun m -> m "(disabled) delete key file `%a`" Fpath.pp fpath);
+  (* TODO just to be safe~~
+  let+ () = Bos.OS.File.delete ~must_exist:true fpath |> unwrap_err_msg in
+*)
+  Ok ()
+
+let get_key_dir_contents dir =
+  let* dir = Fpath.of_string dir |> unwrap_err_msg in
+  let* b = Bos.OS.Dir.create ~mode:0o700 dir |> unwrap_err_msg in
+  if b then Log.info (fun m -> m "created directory `%a`" Fpath.pp dir);
+  let+ l =
+    Bos.OS.Dir.contents ~dotfiles:false ~rel:false dir |> unwrap_err_msg
+  in
+  l
+
+(* -- *)
+
+let gen_key t1 t2 =
+  let priv, pub = EddsaPrivateKey.generate () in
+  Log.debug (fun m ->
+      m "generated key (%s-%s):@,`%s`" (time_abs_to_string t1)
+        (time_abs_to_string t2)
+        (EddsaPublicKey.to_b32 pub));
+  { priv; pub; t1; t2 }
+
+let sort_keys l = List.sort (fun a b -> Absolute.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 = Absolute.add start Cfg.duration in
+  let acc = [ (t1, t2) ] in
+  let start = t2 in
+  let rec go acc start end_ =
+    let t1 = Absolute.sub start Cfg.overlap_duration in
+    let t2 = Absolute.add start Cfg.duration in
+    if t2 > end_ then acc else go ((t1, t2) :: acc) t2 end_
+  in
+  go acc start end_
+
+(* TODO do not exceed lookahead (probably more important...) *)
+(* 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 :: _ -> Absolute.sub hd.t2 Cfg.overlap_duration
+  in
+  let end_ = Absolute.add now Cfg.lookahead_sign in
+  if Absolute.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
+
+(* TODO config *)
+let sm_key_fpath =
+  Result.get_ok
+  @@
+  let+ fpath = Fpath.of_string Cfg.sm_priv_key |> unwrap_err_msg in
+  Fpath.normalize 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 t1_t2_of_fpath 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 }))
+
+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
+  match keys with
+  | [] -> Ok None
+  | _l ->
+      let* sm_key_priv = read_key sm_key_fpath 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 { sm_key_priv; sm_pub; ht })
+
+let init () =
+  let* opt = load () in
+  let* t =
+    match opt with
+    | Some t -> Ok t
+    | None ->
+        let sm_key_priv, sm_pub = EddsaPrivateKey.generate () in
+        Log.debug (fun m ->
+            m "generated secmod key: `%s`" (EddsaPublicKey.to_b32 sm_pub));
+        let* () = write_eddsa sm_key_fpath sm_key_priv in
+        let ht = Hashtbl.create 0xff in
+        Ok { sm_key_priv; sm_pub; ht }
+  in
+  let now = Absolute.of_ptime (Ptime_clock.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
+  let () = List.iter (fun k -> Hashtbl.replace t.ht k.pub k) keys in
+  let+ () = list_iter write_key new_keys in
+  t
+
+type info = eddsa_pub * Time.Absolute.t * Time.Absolute.t
+
+module Make () = struct
+  type pub = EddsaPublicKey.t
+  type info = EddsaPublicKey.t * Time.Absolute.t * Time.Absolute.t
+
+  let t =
+    match init () with
+    | Error e -> Fmt.failwith "secmod_eddsa initialization failure: %s." e
+    | Ok t -> t
+
+  let find pub =
+    Hashtbl.find_opt t.ht pub |> Option.to_result ~none:"key not found"
+
+  let add t1 t2 =
+    let k = gen_key t1 t2 in
+    Hashtbl.replace t.ht k.pub k;
+    ()
+
+  let delete pub =
+    let* k = find pub in
+    Hashtbl.remove t.ht k.pub;
+    delete_file (key_fpath k)
+
+  let _delete_outdated ~now =
+    Hashtbl.to_seq_values t.ht
+    |> List.of_seq
+    |> List.filter (fun k -> Absolute.compare now k.t2 >= 0)
+    |> List.map (fun k -> k.pub)
+    |> list_iter delete
+
+  (* ---- *)
+
+  let sm_pub = t.sm_pub
+
+  let keys () =
+    Hashtbl.to_seq_values t.ht
+    |> List.of_seq
+    |> List.map (fun { priv= _; pub; t1; t2 } -> (pub, t1, t2))
+
+  let sign_secmod s = EddsaSignature.sign ~key:t.sm_key_priv s
+
+  let sign pub s =
+    let+ k = find pub in
+    let data = EddsaSignature.sign ~key:k.priv s in
+    data
+
+  (* delete and replace *)
+  let revoke pub =
+    let* k = find pub in
+    let* () = delete pub in
+    add k.t1 k.t2; Ok ()
+end
+
+(* TODO
+  - more checks
+  - sign: check timestamps before signing
+  - schedule tasks
+  - !lock
+
+  taler doc/config is confusing
+  how is computed stamp_expire stamp_end
+  what to do of 'Exchange.signkey_legal_duration'
+  =>
+    stamp_expire = stamp_start + duration
+    stamp_end = stamp_start + signkey_legal_duration
+    (not sure about it)
+*)