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

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 = struct
  open Config
  include Exchange_secmod_rsa

  let sections = Coin.all_coins |> List.map (fun coin -> coin.Coin.section_name)

  (* helper functions to get config value from section_name: *)

  let duration_withdraw =
    let duration_withdraw_assoc =
      Coin.all_coins
      |> List.map (fun coin -> (coin.Coin.section_name, coin.duration_withdraw))
    in
    fun ~section_name ->
      match List.assoc_opt section_name duration_withdraw_assoc with
      | None ->
          Fmt.failwith "section_name `%s` not found in config" section_name
      | Some v -> v

  let rsa_keysize =
    let rsa_keysize_assoc =
      Coin.all_coins
      |> List.map (fun coin -> (coin.Coin.section_name, coin.rsa_keysize))
    in
    fun ~section_name ->
      match List.assoc_opt section_name rsa_keysize_assoc with
      | None ->
          Fmt.failwith "section_name `%s` not found in config" section_name
      | Some v -> v
end

type key = {
  section_name: string;
  priv: RsaPrivateKey.t;
  pub: RsaPublicKey.t;
  h_pub: DenominationHash.t;
  t1: TimeAbsolute.t;
  t2: TimeAbsolute.t;
}

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

let key_bin =
  let open Bin in
  record (fun t1 t2 section_name priv ->
      let pub = RsaPrivateKey.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 RsaPrivateKey.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 = EddsaPrivateKey.of_octets data in
  let pub = EddsaPrivateKey.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 = EddsaPrivateKey.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 ~section_name t1 t2 =
  let bits = Cfg.rsa_keysize ~section_name in
  let priv, pub = RsaPrivateKey.generate ~bits () in
  let h_pub = DenominationHash.hash_of_rsa pub in
  let k = { section_name; priv; pub; h_pub; t1; t2 } in
  Log.debug (fun m ->
      m "generated key %s `%s`" section_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 ~start ~end_ ~duration_withdraw =
  assert (start < end_);
  (* no overlap on first periode *)
  let t1 = start in
  let t2 = TimeAbsolute.add start 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 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 ~now ~section_name 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 duration_withdraw = Cfg.duration_withdraw ~section_name in
    let periodes = split_in_periodes ~start ~end_ ~duration_withdraw in
    let new_keys =
      List.map (fun (t1, t2) -> gen_key ~section_name 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 -> entry.Fat.name) l in
  let l = List.map (Spath.add Cfg.key_dir) l in
  let l =
    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_priv, sm_pub = read_eddsa fs Cfg.sm_priv_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 = EddsaPrivateKey.generate () in
        Log.debug (fun m ->
            m "generated secmod key: `%s`" (EddsaPublicKey.to_b32 sm_pub));
        let* () = write_eddsa fs Cfg.sm_priv_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 =
    List.map
      (fun section_name ->
        let keys =
          List.filter (fun k -> k.section_name = section_name) all_keys
        in
        gen_additional_keys_until_lookahead ~now ~section_name keys)
      Cfg.sections
  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 section_name t1 t2 =
    let k = gen_key ~section_name 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 = EddsaSignature.sign ~key:t.sm_priv s

  let sign h_pub msg =
    let+ k = find h_pub in
    let data = RsaSignature.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* () = add k.section_name 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