mte/src/http_management.ml

open Syntax
open Api
open Hash

module Keys_get = struct
  let mk_future_keys_response (module Keys : Keys.S) =
    let* future_signkeys = Keys.future_signkeys () in
    let* future_denoms = Keys.future_denominations () in
    let master_pub = Keys.master_pub in
    let denom_secmod_public_key = Keys.secmod_rsa_pub in
    let signkey_secmod_public_key = Keys.secmod_eddsa_pub in
    Ok
      FutureKeysResponse.
        {
          future_denoms;
          future_signkeys;
          master_pub;
          denom_secmod_public_key;
          signkey_secmod_public_key;
        }

  let jsont = FutureKeysResponse.jsont

  let f req server _env =
    Logs.info (fun m -> m "GET /management/keys/");
    let keys = Vif.Server.device Devices.keys server in
    let res =
      let* v = mk_future_keys_response keys in
      let s = Api.encode_exn jsont v in
      Ok s
    in
    Respond.result res req
end

module Keys_post = struct
  let verify_dn (module Keys : Keys.S) fdn denom_hash master_sig =
    let open FutureDenom in
    let open Signatures.DenominationKeyValidity in
    let r : r =
      {
        master= Config.master_public_key;
        start= fdn.stamp_start;
        expire_withdraw= fdn.stamp_expire_withdraw;
        expire_spend= fdn.stamp_expire_deposit;
        expire_legal= fdn.stamp_expire_legal;
        value= fdn.value;
        fee_withdraw= fdn.fee_withdraw;
        fee_deposit= fdn.fee_deposit;
        fee_refresh= fdn.fee_refresh;
        fee_refund= fdn.fee_refund;
        denom_hash;
      }
    in
    verify_f ~f:(Crypto.EddsaSignature.verify ~key:Keys.master_pub) master_sig r

  let verify_denom_sigs (module Keys : Keys.S) denom_sigs =
    let* fdn_l = Keys.future_denominations () in
    let fdn_l =
      List.map
        (fun fdn ->
          let h_pub =
            (* TODO DenominationHash.of_denom_pub *)
            DenominationHash.hash
              (DenominationKey.to_octets fdn.FutureDenom.denom_pub)
          in
          (h_pub, fdn))
        fdn_l
    in
    list_iter
      (fun DenomSignature.{ h_denom_pub; master_sig } ->
        match List.assoc_opt h_denom_pub fdn_l with
        | None -> Error "future denomination not found"
        | Some fdn -> verify_dn (module Keys) fdn h_denom_pub master_sig)
      denom_sigs

  let verify_sk (module Keys : Keys.S)
      FutureSignKey.
        { key; stamp_start; stamp_expire; stamp_end; signkey_secmod_sig= _ }
      master_sig =
    let open Signatures.ExchangeSigningKeyValidity in
    let r : r =
      {
        start= stamp_start;
        expire= stamp_expire;
        end_= stamp_end;
        signkey_pub= key;
      }
    in
    verify_f ~f:(Crypto.EddsaSignature.verify ~key:Keys.master_pub) master_sig r

  let verify_signkey_sigs (module Keys : Keys.S) signkey_sigs =
    let* fsk_l = Keys.future_signkeys () in
    list_iter
      (fun SignKeySignature.{ key; master_sig } ->
        match List.find_opt (fun sk -> sk.FutureSignKey.key = key) fsk_l with
        | None -> Error "future signkey not found"
        | Some fsk -> verify_sk (module Keys) fsk master_sig)
      signkey_sigs

  let verify keys MasterSignatures.{ denom_sigs; signkey_sigs } =
    let* () = verify_signkey_sigs keys signkey_sigs in
    let* () = verify_denom_sigs keys denom_sigs in
    Ok ()

  let do_ ~db_conn:_ (module Keys : Keys.S)
      MasterSignatures.{ denom_sigs; signkey_sigs } =
    let* () =
      list_iter
        (fun SignKeySignature.{ key; master_sig } ->
          Keys.certify_future_signkey key master_sig)
        signkey_sigs
    in
    let* () =
      list_iter
        (fun DenomSignature.{ h_denom_pub; master_sig } ->
          Keys.certify_future_denomination h_denom_pub master_sig)
        denom_sigs
    in
    Ok ()

  let jsont = MasterSignatures.jsont

  let f req server _env =
    Logs.info (fun m -> m "POST /management/keys/");
    let db_conn = Vif.Server.device Devices.db_connection server in
    let keys = Vif.Server.device Devices.keys server in
    let res =
      let* v = Vif.Request.of_json req |> unwrap_err_msg in
      let* () = verify keys v in
      let* () = do_ ~db_conn keys v in
      Ok ""
    in
    Respond.result res req
end

module Denom_revoke = struct
  let verify (module Keys : Keys.S) h_denom_pub
      DenomRevocationSignature.{ master_sig } =
    let open Signatures.MasterDenominationKeyRevocation in
    verify_f
      ~f:(Crypto.EddsaSignature.verify ~key:Keys.master_pub)
      master_sig { h_denom_pub }

  let do_ (module Keys : Keys.S) h_denom_pub
      DenomRevocationSignature.{ master_sig } =
    let+ () = Keys.revoke_denomination h_denom_pub master_sig in
    ()

  let jsont = DenomRevocationSignature.jsont

  let f req h_denom_pub server _env =
    Logs.info (fun m -> m "POST /management/denominations/$H_DENOM_PUB/revoke/");
    let keys = Vif.Server.device Devices.keys server in
    let res =
      let* h_denom_pub = DenominationHash.of_b32 h_denom_pub in
      let* v = Vif.Request.of_json req |> unwrap_err_msg in
      let* () = verify keys h_denom_pub v in
      let* () = do_ keys h_denom_pub v in
      Ok ""
    in
    Respond.result res req
end

module Signkey_revoke = struct
  let verify (module Keys : Keys.S) exchange_pub
      SignkeyRevocationSignature.{ master_sig } =
    let open Signatures.MasterSigningKeyRevocation in
    verify_f ~f:Keys.verify_with_master_key master_sig { exchange_pub }

  let do_ (module Keys : Keys.S) exchange_pub
      SignkeyRevocationSignature.{ master_sig } =
    let+ () = Keys.revoke_signkey exchange_pub master_sig in
    ()

  let jsont = SignkeyRevocationSignature.jsont

  let f req exchange_pub server _env =
    Logs.info (fun m -> m "POST /management/signkeys/$EXCHANGE_PUB/revoke/");
    let keys = Vif.Server.device Devices.keys server in
    let res =
      let* exchange_pub = Crypto.EddsaPublicKey.of_b32 exchange_pub in
      let* v = Vif.Request.of_json req |> unwrap_err_msg in
      let* () = verify keys exchange_pub v in
      let* () = do_ keys exchange_pub v in
      Ok ""
    in
    Respond.result res req
end

module Auditors = struct
  let verify (module Keys : Keys.S)
      AuditorSetupMessage.
        {
          auditor_url;
          auditor_name= _;
          auditor_pub;
          master_sig;
          validity_start;
        } =
    let open Signatures.MasterAddAuditor in
    verify_f ~f:Keys.verify_with_master_key master_sig
      {
        start_date= validity_start;
        auditor_pub;
        h_auditor_url= Hash.Cstring.H64.hash auditor_url;
      }

  (* TODO monotonic time *)
  let do_ ~db_conn v =
    let auditor_pub = v.AuditorSetupMessage.auditor_pub in
    let validity_start = v.AuditorSetupMessage.validity_start in
    let* last_date_opt =
      Pg.get_auditor_timestamp db_conn auditor_pub |> unwrap_err_caqti
    in
    match last_date_opt with
    | None ->
        let+ () = Pg.insert_auditor db_conn v |> unwrap_err_caqti in
        Logs.info (fun m -> m "enabled auditor");
        ()
    | Some last_date ->
        if Timestamp.compare last_date validity_start > 0 then
          Error
            "database has more recent auditor data for this auditor public key"
        else
          let+ () = Pg.update_auditor db_conn v |> unwrap_err_caqti in
          Logs.info (fun m -> m "updated auditor");
          ()

  let jsont = AuditorSetupMessage.jsont

  let f req server _env =
    Logs.info (fun m -> m "POST /management/auditors/");
    let keys = Vif.Server.device Devices.keys server in
    let db_conn = Vif.Server.device Devices.db_connection server in
    let res =
      let* v = Vif.Request.of_json req |> unwrap_err_msg in
      let* () = verify keys v in
      let* () = do_ ~db_conn v in
      Ok ""
    in
    Respond.result res req
end

module Auditors_disable = struct
  let verify (module Keys : Keys.S) auditor_pub
      AuditorTeardownMessage.{ master_sig; validity_end } =
    let open Signatures.MasterDelAuditor in
    verify_f ~f:Keys.verify_with_master_key master_sig
      { end_date= validity_end; auditor_pub }

  let do_ ~db_conn auditor_pub
      AuditorTeardownMessage.{ master_sig= _; validity_end } =
    let* last_date_opt =
      Pg.get_auditor_timestamp db_conn auditor_pub |> unwrap_err_caqti
    in
    match last_date_opt with
    | None -> Error "auditor not found"
    | Some last_date ->
        if Timestamp.compare last_date validity_end > 0 then
          Error
            "database has more recent auditor data for this auditor public key"
        else
          let+ () =
            Pg.disable_auditor db_conn ~auditor_pub ~change_date:validity_end
            |> unwrap_err_caqti
          in
          ()

  let jsont = AuditorTeardownMessage.jsont

  let f req auditor_pub server _env =
    Logs.info (fun m -> m "POST /management/auditors/$AUDITOR_PUB/revoke/");
    let keys = Vif.Server.device Devices.keys server in
    let db_conn = Vif.Server.device Devices.db_connection server in
    let res =
      let* auditor_pub = Crypto.EddsaPublicKey.of_b32 auditor_pub in
      let* v = Vif.Request.of_json req |> unwrap_err_msg in
      let* () = verify keys auditor_pub v in
      let* () = do_ ~db_conn auditor_pub v in
      Ok ""
    in
    Respond.result res req
end

module Wire_fee = struct
  let verify (module Keys : Keys.S)
      WireFeeSetupMessage.
        {
          wire_method;
          master_sig_wire;
          fee_start;
          fee_end;
          closing_fee;
          wire_fee;
        } =
    let open Signatures.MasterWireFee in
    verify_f ~f:Keys.verify_with_master_key master_sig_wire
      {
        h_wire_method= Hash.Cstring.H64.hash wire_method;
        start_date= fee_start;
        end_date= fee_end;
        wire_fee;
        closing_fee;
      }

  let do_ ~db_conn (v : WireFeeSetupMessage.t) =
    let* wire_fees =
      Pg.get_wire_fees_by_time db_conn ~wire_method:v.wire_method
        ~start_date:v.fee_start ~end_date:v.fee_end
      |> unwrap_err_caqti
    in
    match wire_fees with
    | [] ->
        let+ () = Pg.insert_wire_fee db_conn v |> unwrap_err_caqti in
        Logs.info (fun m -> m "added wire fee");
        ()
    | [ vv ] -> (
        match v.master_sig_wire = vv.sig_ with
        | false ->
            Error "a different wire-fee was already setup for this time frame"
        | true ->
            Logs.info (fun m -> m "an identical wire-fee was already setup");
            Ok ())
    | _ ->
        Error
          "invalid database state, multiple wire-fee found in database for \
           this time frame"

  let jsont = WireFeeSetupMessage.jsont

  let f req server _env =
    Logs.info (fun m -> m "POST /management/wire-fee/");
    let keys = Vif.Server.device Devices.keys server in
    let db_conn = Vif.Server.device Devices.db_connection server in
    let res =
      let* v = Vif.Request.of_json req |> unwrap_err_msg in
      let* () = verify keys v in
      let* () = do_ ~db_conn v in
      Ok ""
    in
    Respond.result res req
end

module Global_fees = struct
  let verify (module Keys : Keys.S)
      GlobalFees.
        {
          start_date;
          end_date;
          history_fee;
          account_fee;
          purse_fee;
          history_expiration;
          purse_account_limit;
          purse_timeout;
          master_sig;
        } =
    let open Signatures.GlobalFees in
    verify_f ~f:Keys.verify_with_master_key master_sig
      {
        start_date;
        end_date;
        purse_timeout;
        history_expiration;
        history_fee;
        account_fee;
        purse_fee;
        purse_account_limit;
      }

  let do_ ~db_conn v =
    let* global_fees =
      let start_date = v.GlobalFees.start_date in
      let end_date = v.GlobalFees.end_date in
      Pg.get_global_fees_by_time db_conn ~start_date ~end_date
      |> unwrap_err_caqti
    in
    match global_fees with
    | [] ->
        let+ () = Pg.insert_global_fees db_conn v |> unwrap_err_caqti in
        Logs.info (fun m -> m "added global fees");
        ()
    | [ vv ] -> (
        match v.master_sig = vv.master_sig with
        | false ->
            Error
              "a different global-fees was already setup for this time frame"
        | true ->
            Logs.info (fun m -> m "an identical global-fees was already setup");
            Ok ())
    | _ ->
        Error
          "invalid database state, multiple global-fees found in database for \
           this time frame"

  let jsont = GlobalFees.jsont

  (* TODO better global_fees
     ensure it is defined for the current time.
     there should be only one global_fees for each moment in time
     and once set for a timeframe, it should not change. *)
  let f req server _env =
    Logs.info (fun m -> m "POST /management/global-fees/");
    let keys = Vif.Server.device Devices.keys server in
    let db_conn = Vif.Server.device Devices.db_connection server in
    let res =
      let* v = Vif.Request.of_json req |> unwrap_err_msg in
      let* () = verify keys v in
      let* () = do_ ~db_conn v in
      Ok ""
    in
    Respond.result res req
end

module Wire = struct
  let verify (module Keys : Keys.S)
      WireSetupMessage.
        {
          payto_uri;
          master_sig_wire;
          master_sig_add;
          validity_start;
          bank_label= _;
          priority= _;
        } =
    (* TODO are those read from payto_uri? *)
    let conversion_url = "" in
    let credit_restrictions = "" in
    let debit_restrictions = "" in
    let* () =
      let open Signatures.MasterWireDetails in
      verify_f ~f:Keys.verify_with_master_key master_sig_wire
        {
          h_wire_details= FullPaytoHash.hash payto_uri;
          h_conversion_url= Hash.Cstring.H64.hash conversion_url;
          h_credit_restrictions= Hash.Cstring.H64.hash credit_restrictions;
          h_debit_restrictions= Hash.Cstring.H64.hash debit_restrictions;
        }
    in
    let* () =
      let open Signatures.MasterAddWire in
      verify_f ~f:Keys.verify_with_master_key master_sig_add
        {
          start_date= validity_start;
          h_wire= FullPaytoHash.hash payto_uri;
          h_conversion_url= Hash.Cstring.H64.hash conversion_url;
          h_credit_restrictions= Hash.Cstring.H64.hash credit_restrictions;
          h_debit_restrictions= Hash.Cstring.H64.hash debit_restrictions;
        }
    in
    Ok ()

  let do_ ~db_conn v =
    let* last_change_opt =
      let payto_uri = v.WireSetupMessage.payto_uri in
      Pg.get_wire_timestamp db_conn ~payto_uri |> unwrap_err_caqti
    in
    match last_change_opt with
    | Some _ -> Error "wire already setup"
    | None ->
        let r =
          ExchangeWireAccount.
            {
              payto_uri= v.payto_uri;
              conversion_url= None;
              debit_restrictions= [];
              credit_restrictions= [];
              master_sig= v.master_sig_wire;
              bank_label= v.bank_label;
              priority= v.priority;
            }
        in
        let+ () =
          Pg.insert_wire db_conn ~last_change:v.validity_start r
          |> unwrap_err_caqti
        in
        ()

  let jsont = WireSetupMessage.jsont

  let f req server _env =
    Logs.info (fun m -> m "POST /management/wire/");
    let keys = Vif.Server.device Devices.keys server in
    let db_conn = Vif.Server.device Devices.db_connection server in
    let res =
      let* v = Vif.Request.of_json req |> unwrap_err_msg in
      let* () = verify keys v in
      let* () = do_ ~db_conn v in
      Ok ""
    in
    Respond.result res req
end

module Wire_disable = struct
  let verify (module Keys : Keys.S)
      WireTeardownMessage.{ payto_uri; master_sig_del; validity_end } =
    let open Signatures.MasterDelWire in
    verify_f ~f:Keys.verify_with_master_key master_sig_del
      { end_date= validity_end; h_wire= FullPaytoHash.hash payto_uri }

  let do_ ~db_conn
      WireTeardownMessage.{ payto_uri; master_sig_del= _; validity_end } =
    let* last_change_opt =
      Pg.get_wire_timestamp db_conn ~payto_uri |> unwrap_err_caqti
    in
    match last_change_opt with
    | None -> Error "wire not found"
    | Some _ ->
        let+ () =
          Pg.disable_wire db_conn ~payto_uri ~validity_end |> unwrap_err_caqti
        in
        ()

  let jsont = WireTeardownMessage.jsont

  let f req server _env =
    Logs.info (fun m -> m "POST /management/wire/disable/");
    let keys = Vif.Server.device Devices.keys server in
    let db_conn = Vif.Server.device Devices.db_connection server in
    let res =
      let* v = Vif.Request.of_json req |> unwrap_err_msg in
      let* () = verify keys v in
      let* () = do_ ~db_conn v in
      Ok ""
    in
    Respond.result res req
end

module Drain = struct
  let verify (module Keys : Keys.S)
      DrainProfitsMessage.
        {
          debit_account_section;
          credit_payto_uri;
          wtid;
          master_sig;
          date;
          amount;
        } =
    let open Signatures.MasterDrainProfit in
    verify_f ~f:Keys.verify_with_master_key master_sig
      {
        wtid;
        date;
        amount;
        h_section= Hash.Cstring.H64.hash debit_account_section;
        h_payto= FullPaytoHash.hash credit_payto_uri;
      }

  let do_ ~db_conn v =
    let+ () = Pg.insert_drain_profit db_conn v |> unwrap_err_caqti in
    ()

  let jsont = DrainProfitsMessage.jsont

  let f req server _env =
    Logs.info (fun m -> m "POST /management/drain/");
    let keys = Vif.Server.device Devices.keys server in
    let db_conn = Vif.Server.device Devices.db_connection server in
    let res =
      let* v = Vif.Request.of_json req |> unwrap_err_msg in
      let* () = verify keys v in
      let* () = do_ ~db_conn v in
      Ok ""
    in
    Respond.result res req
end

module AmlOfficer = struct
  let verify (module Keys : Keys.S)
      AmlOfficerSetup.
        {
          officer_pub;
          officer_name;
          is_active;
          read_only= _;
          master_sig;
          change_date;
        } =
    let open Signatures.MasterAmlOfficerStatus in
    let is_active = match is_active with true -> 1_l | false -> 0_l in
    verify_f ~f:Keys.verify_with_master_key master_sig
      {
        change_date;
        officer_pub;
        h_officer_name= Hash.Cstring.H64.hash officer_name;
        is_active;
      }

  let do_ ~db_conn v =
    let+ _last_change = Pg.insert_aml_officer db_conn v |> unwrap_err_caqti in
    ()

  let jsont = AmlOfficerSetup.jsont

  let f req server _env =
    Logs.info (fun m -> m "POST /management/aml-officers/");
    let keys = Vif.Server.device Devices.keys server in
    let db_conn = Vif.Server.device Devices.db_connection server in
    let res =
      let* v = Vif.Request.of_json req |> unwrap_err_msg in
      let* () = verify keys v in
      let* () = do_ ~db_conn v in
      Ok ""
    in
    Respond.result res req
end

module Partners = struct
  let verify (module Keys : Keys.S)
      ExchangePartnerSetupRequest.
        {
          partner_base_url;
          partner_pub;
          wad_frequency;
          master_sig;
          start_date;
          end_date;
          wad_fee;
        } =
    let open Signatures.PartnerConfiguration in
    verify_f ~f:Keys.verify_with_master_key master_sig
      {
        partner_pub;
        start_date;
        end_date;
        wad_frequency;
        wad_fee;
        h_url= Hash.Cstring.H64.hash partner_base_url;
      }

  let do_ ~db_conn v =
    let+ () = Pg.insert_partner db_conn v |> unwrap_err_caqti in
    ()

  let jsont = ExchangePartnerSetupRequest.jsont

  let f req server _env =
    Logs.info (fun m -> m "POST /management/partners/");
    let keys = Vif.Server.device Devices.keys server in
    let db_conn = Vif.Server.device Devices.db_connection server in
    let res =
      let* v = Vif.Request.of_json req |> unwrap_err_msg in
      let* () = verify keys v in
      let* () = do_ ~db_conn v in
      Ok ""
    in
    Respond.result res req
end