mte/src/secmod_rsa.ml

let src = Logs.Src.create "mte.secmod_rsa"

module Log = (val Logs.src_log src : Logs.LOG)

(* - *)
open Syntax
open Time
module Sfn = Mfat.Sfn
module Spath = Mfat.Spath
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 Cfg = struct
  include Config.Exchange_secmod_rsa

  let to_spath s =
    let open Fat.Spath in
    match of_string s with Error (`Msg e) -> Fmt.failwith "%s" e | Ok v -> v

  let key_dir = to_spath "/RSA"
  let sm_key = to_spath "/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;
  priv: Rsa.priv;
  pub: Rsa.pub;
  h_pub: DenominationHash.t;
  t1: TimeAbsolute.t;
  t2: TimeAbsolute.t;
}

type t = {
  fs: Fat.t;
  sm_priv: Eddsa.priv;
  sm_pub: Eddsa.pub;
  ht: (DenominationHash.t, key) Hashtbl.t;
}

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 })
  |+ 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)
  |> sealr

let key_spath k =
  let sfn_res =
    String.sub (DenominationHash.to_b32 k.h_pub) 0 8 |> Sfn.of_string
  in
  match sfn_res with
  | Error _ -> failwith "not possible"
  | Ok sfn -> Spath.(Cfg.key_dir / sfn)

let read_eddsa fs spath =
  Log.debug (fun m -> m "reading key file `%a`" Spath.pp spath);
  let* data = Fat.read fs spath |> unwrap_msg in
  let* priv = Eddsa.priv_of_octets data 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 `%a`" Spath.pp spath);
  let data = Eddsa.priv_to_octets priv in
  Fat.write fs spath data |> unwrap_msg

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
  let k = Bin.decode key_bin data (ref 0) in
  Ok k

let write_key fs k =
  let spath = key_spath k in
  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 delete_file fs spath =
  Log.debug (fun m -> m "delete key file `%a`" Spath.pp spath);
  let+ () = Fat.remove fs spath |> unwrap_msg 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
  Log.debug (fun m ->
      m "generated key %s `%s`" cfg.Coin_config.name
        (DenominationHash.to_b32 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_ =
  assert (start < end_);
  (* no overlap on first periode *)
  let t1 = start in
  let t2 = TimeAbsolute.add start cfg.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
    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 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 cfg ~start ~end_ in
    let new_keys = List.map (fun (t1, t2) -> gen_key cfg 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
  in
  let* l = Fat.ls fs Cfg.key_dir |> unwrap_msg in
  let l = List.map (fun entry -> Spath.add Cfg.key_dir entry.Fat.name) l in
  let l = List.filter (fun spath -> not @@ Spath.equal spath Cfg.sm_key) l in
  let* keys = list_map (read_key fs) l in
  match keys with
  | [] -> Ok None
  | _l ->
      let* sm_priv, sm_pub = read_eddsa fs Cfg.sm_key in
      let ht = Hashtbl.create 0xff in
      let () = List.iter (fun k -> Hashtbl.replace ht k.h_pub k) keys in
      Ok (Some { fs; sm_priv; sm_pub; ht })

let init fs =
  let* opt = load fs in
  let now = TimeAbsolute.of_ptime (Mirage_ptime.now ()) in
  let* t =
    match opt with
    | 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));
        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)
  in
  let new_keys = List.concat new_keys_l in
  List.iter (fun k -> Hashtbl.replace t.ht k.h_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_rsa initialization failure: %s." e
    | Ok t -> t

  let find h_pub =
    Hashtbl.find_opt t.ht h_pub |> Option.to_result ~none:"key not found"

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

  let _delete_outdated ~now =
    Hashtbl.to_seq t.ht
    |> List.of_seq
    |> List.filter (fun (_h_pub, k) -> TimeAbsolute.compare now k.t2 >= 0)
    |> 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+ () = write_key t.fs k in
    Hashtbl.replace t.ht k.h_pub k;
    ()

  let sm_pub = t.sm_pub
  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 revoke h_pub =
    Log.debug (fun m ->
        m "revoke `%s`" (DenominationHash.to_octets h_pub |> B32.encode));
    let* k = find 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
    Ok ()

  let conv =
   fun { section_name; priv= _; pub; h_pub; t1; t2= _ } ->
    (h_pub, (section_name, pub, 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