mte/src/secmod_eddsa.ml

(* TODO
   ! use lock
   !? Scanf not thread-safe
   schedule tasks
   sign: check timestamps before signing *)
(* IMPROVE
   list_issue_date: save timestamp of key generation
   key validity period:
     more checks + do not exceed lookahead
   refacto common parts with secmod_eddsa *)
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: TimeAbsolute.t;
  t2: TimeAbsolute.t;
}

type t = {
  fs: Fat.t;
  sm_key_priv: EddsaPrivateKey.t;
  sm_pub: EddsaPublicKey.t;
  ht: (EddsaPublicKey.t, key) Hashtbl.t;
}

let parse_filename =
  let scan_filename s =
    Scanf.sscanf_opt s "%Lu-%Lu" (fun t1 t2 ->
        (TimeAbsolute.of_s t1, TimeAbsolute.of_s t2))
  in
  fun fpath -> scan_filename (Fpath.filename fpath)

let pp_filename =
  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 fname = Fmt.str "%a" pp_filename (k.t1, k.t2) in
  Fpath.(v Cfg.key_dir / fname)

(* -- 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 |> unwrap_msg 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 =
  let* dir = Fpath.of_string dir |> unwrap_msg in
  let dir = Fpath.to_string dir in
  let* () = Fat.mkdir fs dir |> unwrap_msg in
  Log.info (fun m -> m "created directory `%s`" dir);
  let+ l = Fat.ls fs dir |> unwrap_msg in
  (*   List.map Fpath.normalize l *)
  let l = List.map (fun entry -> entry.Fat.name) l in
  let l = List.map Fpath.v l in
  l

(* -- *)

let gen_key t1 t2 =
  let priv, pub = EddsaPrivateKey.generate () in
  Log.debug (fun m ->
      m "generated key (%a):@,`%s`" pp_filename (t1, t2)
        (EddsaPublicKey.to_b32 pub));
  { priv; pub; t1; t2 }

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 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* keys = list_map (load_key fs) l in
  match keys with
  | [] -> Ok None
  | _l ->
      let* sm_key_priv = read_key fs 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 { fs; sm_key_priv; sm_pub; ht })

let init fs =
  let* opt = load fs 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 fs sm_key_fpath sm_key_priv in
        let ht = Hashtbl.create 0xff in
        Ok { fs; sm_key_priv; sm_pub; ht }
  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: %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+ () = write_key t.fs k in
    ()

  let delete pub =
    let* k = find pub in
    Hashtbl.remove t.ht k.pub;
    delete_file t.fs (key_fpath k)

  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 sm_pub = t.sm_pub
  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
    let* () = add k.t1 k.t2 in
    Ok ()

  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
end