mte/src/devices.ml

open Syntax

type env = {
  caqti_switch: Caqti_miou.Switch.t;
  db_uri: Uri.t;
}

let db_connection : (env, Caqti_miou.connection) Vif.Device.device =
  let finally (module Conn : Caqti_miou.CONNECTION) = Conn.disconnect () in
  Vif.Device.v ~name:"db_connection" ~finally []
  @@ fun { caqti_switch; db_uri } ->
  match Caqti_miou_unix.connect ~sw:caqti_switch db_uri with
  | Error err ->
      Fmt.failwith "Database connection failure: %a." Caqti_error.pp err
  | Ok conn -> (
      match Pg.preflight conn with
      | Error err ->
          Fmt.failwith "Database preflight failure: %a." Caqti_error.pp err
      | Ok () ->
          Logs.info (fun m -> m "database connection initialized");
          conn)

module Secmod_signkey = struct
  (* TODO
     - key rotation
     - how many signkey to use?
       we just use 1 for now *)
  type t = {
    sm_key: Signkey.t;
    keys: Signkey.t list;
  }

  let dir = Fpath.(v "data" / "secmod_signkey")

  let store_secmod_data t =
    let* () = Data_file.write_eddsa Fpath.(dir / "sm_key") t.sm_key.priv in
    t.keys
    |> List.mapi (fun i key ->
        let fname = Fpath.(dir / string_of_int i) in
        (fname, key.Signkey.priv))
    |> list_iter (fun (fname, key) -> Data_file.write_eddsa fname key)

  let load conn =
    let error_invalid_state =
      Fmt.error_msg "secmod_signkey load error: invalid store state."
    in
    let* sm_key = Data_file.load_signkey conn Fpath.(dir / "sm_key") in
    let* keys =
      let l = List.init 1 (fun i -> Fpath.(dir / string_of_int i)) in
      let* l =
        Syntax.list_map (fun fname -> Data_file.load_signkey conn fname) l
      in
      match Syntax.opt_list l with
      | Error () -> error_invalid_state
      | Ok opt -> Ok opt
    in
    match (sm_key, keys) with
    | None, None -> Ok None
    | Some sm_key, Some keys -> Ok (Some { sm_key; keys })
    | _, _ -> error_invalid_state

  let generate_fresh_secmod_data () =
    let sm_key = Signkey.generate () in
    let keys = [ Signkey.generate () ] in
    { sm_key; keys }

  let v =
    let finally _key = () in
    Vif.Device.v ~name:"secmod_signkey" ~finally
      [ Vif.Device.value db_connection ]
    @@ fun conn (_env : env) ->
    match load conn with
    | Ok None ->
        let t = generate_fresh_secmod_data () in
        Logs.info (fun m -> m "secmod_signkey initialized with fresh keys");
        t
    | Ok (Some v) ->
        Logs.info (fun m -> m "secmod_signkey initialized from storage");
        v
    | Error _ ->
        (* TODO error: pretty print *)
        Fmt.failwith "secmod_signkey init failure."
end

module Secmod_denom = struct
  type t = {
    sm_key: Signkey.t;
    keys: Denomination.t list;
  }

  let dir = Fpath.(v "data" / "secmod_signkey")

  let store_secmod_data t =
    let* () = Data_file.write_eddsa Fpath.(dir / "sm_key") t.sm_key.priv in
    t.keys
    |> List.mapi (fun i key ->
        let fname = Fpath.(dir / string_of_int i) in
        (fname, key.Denomination.priv))
    |> list_iter (fun (fname, key) -> Data_file.write_rsa fname key)

  let load conn =
    let error_invalid_state =
      Fmt.error_msg "secmod_denom load error: invalid store state."
    in
    let* sm_key = Data_file.load_signkey conn Fpath.(dir / "sm_key") in
    let* keys =
      let* l =
        let open Config.Coin in
        Syntax.list_map
          (fun coin ->
            let section_name = coin.section_name in
            let fname = Fpath.(dir / section_name) in
            (* todo: could check that coin config match db values *)
            Data_file.load_denom conn ~section_name fname)
          all_coins
      in
      match Syntax.opt_list l with
      | Error () -> error_invalid_state
      | Ok opt -> Ok opt
    in
    match (sm_key, keys) with
    | None, None -> Ok None
    | Some sm_key, Some keys -> Ok (Some { sm_key; keys })
    | _, _ -> error_invalid_state

  let generate_fresh_secmod_data () =
    let sm_key = Signkey.generate () in
    let keys = List.map Denomination.make Config.Coin.all_coins in
    { sm_key; keys }

  let v =
    let finally _key = () in
    Vif.Device.v ~name:"secmod_denom" ~finally
      [ Vif.Device.value db_connection ]
    @@ fun conn (_env : env) ->
    match load conn with
    | Ok None ->
        let t = generate_fresh_secmod_data () in
        Logs.info (fun m -> m "secmod_denom initialized with fresh keys");
        t
    | Ok (Some v) ->
        Logs.info (fun m -> m "secmod_denom initialized from storage");
        v
    | Error _ -> Fmt.failwith "secmod_denom init failure."
end

let secmod_signkey = Secmod_signkey.v
let secmod_denom = Secmod_denom.v