mte/src/management.ml

open Syntax
open Api

module Keys_get = struct
  let mk_future_denom ~sm_key_priv
      ({
         pub;
         priv= _;
         section_name;
         value;
         stamp_start;
         stamp_expire_withdraw;
         stamp_expire_deposit;
         stamp_expire_legal;
         fee_withdraw;
         fee_deposit;
         fee_refresh;
         fee_refund;
         age_mask;
         h_pub;
         master_sig= _;
       } :
        Denomination.t) =
    let denom_pub =
      DenominationKey.of_rsa RsaDenominationKey.{ age_mask; rsa_pub= pub }
    in
    let denom_secmod_sig =
      let open Bin_sig.DenominationKeyAnnouncement in
      let h_denom_pub = h_pub in
      let h_section_name = Bin_type.Hash_64_cstr.hash section_name in
      let anchor_time = stamp_start in
      let duration_withdraw =
        Timestamp.diff stamp_start stamp_expire_withdraw
      in
      sign ~key:sm_key_priv
        { h_denom_pub; h_section_name; anchor_time; duration_withdraw }
    in
    FutureDenom.
      {
        section_name;
        value;
        stamp_start;
        stamp_expire_withdraw;
        stamp_expire_deposit;
        stamp_expire_legal;
        denom_pub;
        fee_withdraw;
        fee_deposit;
        fee_refresh;
        fee_refund;
        denom_secmod_sig;
      }

  let mk_future_signkey ~sm_signkey_priv
      ({ pub; priv= _; stamp_start; stamp_expire; stamp_end; master_sig= _ } :
        Signkey.t) =
    let signkey_secmod_sig =
      let open Bin_sig.SigningKeyAnnouncement in
      let exchange_pub = pub in
      let anchor_time = stamp_start in
      let duration = Timestamp.diff stamp_start stamp_expire in
      sign ~key:sm_signkey_priv { exchange_pub; anchor_time; duration }
    in
    FutureSignKey.
      { key= pub; stamp_start; stamp_expire; stamp_end; signkey_secmod_sig }

  let mk_future_keys_response ~sm =
    let future_signkeys =
      Secmod.get_signkeys sm
      |> List.filter (fun k -> Option.is_none k.Signkey.master_sig)
      |> List.map (fun signkey ->
          let sm_signkey_priv = Secmod.get_sm_key_priv sm in
          mk_future_signkey ~sm_signkey_priv signkey)
    in
    let future_denoms =
      Secmod.get_denoms sm
      |> List.filter (fun k -> Option.is_none k.Denomination.master_sig)
      |> List.map (fun denom ->
          let sm_key_priv = Secmod.get_sm_key_priv sm in
          mk_future_denom ~sm_key_priv denom)
    in
    let master_pub = Config.Exchange.master_public_key in
    let denom_secmod_public_key = Secmod.get_sm_key_pub sm in
    let signkey_secmod_public_key = Secmod.get_sm_key_pub sm in
    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 sm = Vif.Server.device Devices.secmod server in
    let res =
      let v = mk_future_keys_response ~sm in
      let s = Api.encode_exn jsont v in
      Ok s
    in
    Respond_util.respond_with_res res req
end

module Keys_post = struct
  let verify_denom_signature ~sm DenomSignature.{ h_denom_pub; master_sig } =
    let denom_hash = HashCode.to_denomination_hash h_denom_pub in
    let* denom =
      Secmod.get_denoms sm
      |> List.find_opt (fun (denom : Denomination.t) ->
          denom.h_pub = denom_hash)
      |> function
      | None ->
          Fmt.error
            "404 not found, One of the keys for which a signature was provided \
             is unknown to the exchange."
      | Some denom -> Ok denom
    in
    let open Bin_sig.DenominationKeyValidity in
    let r : r =
      {
        master= Config.master_public_key;
        start= denom.stamp_start;
        expire_withdraw= denom.stamp_expire_withdraw;
        expire_spend= denom.stamp_expire_deposit;
        expire_legal= denom.stamp_expire_legal;
        value= denom.value;
        fee_withdraw= denom.fee_withdraw;
        fee_deposit= denom.fee_deposit;
        fee_refresh= denom.fee_refresh;
        denom_hash;
      }
    in
    verify ~key:Config.master_public_key master_sig r

  let verify_signkey_signature ~sm SignKeySignature.{ key; master_sig } =
    let* signkey =
      Secmod.get_signkeys sm
      |> List.find_opt (fun (signkey : Signkey.t) -> signkey.pub = key)
      |> function
      | None ->
          Fmt.error
            "404 not found, One of the keys for which a signature was provided \
             is unknown to the exchange."
      | Some signkey -> Ok signkey
    in
    let open Bin_sig.ExchangeSigningKeyValidity in
    let r : r =
      {
        start= signkey.stamp_start;
        expire= signkey.stamp_expire;
        end_= signkey.stamp_end;
        signkey_pub= signkey.pub;
      }
    in
    verify ~key:Config.master_public_key master_sig r

  let verify ~sm MasterSignatures.{ denom_sigs; signkey_sigs } =
    let* () = list_iter (verify_denom_signature ~sm) denom_sigs in
    let* () = list_iter (verify_signkey_signature ~sm) signkey_sigs in
    Ok ()

  (* TODO move to test *)
  let check_master_signatures_update ~db_conn ~sm =
    Secmod.get_denoms sm
    |> list_iter (fun denom ->
        let error = Error "update_master_signatures sanity check failure" in
        let* opt =
          Pg.lookup_denomination_key db_conn denom.Denomination.h_pub
          |> unwrap_err_caqti
        in
        let* ( valid_from,
               _expire_withdraw,
               _expire_deposit,
               _expire_legal,
               coin,
               _fee_withdraw,
               _fee_deposit,
               _fee_refresh,
               fee_refund,
               age_mask ) =
          match opt with None -> error | Some v -> Ok v
        in
        let check = function false -> error | true -> Ok () in
        let* () =
          check (Timestamp.compare valid_from denom.stamp_start = Some 0)
        in
        let* () = check (coin = denom.value) in
        let* () = check (fee_refund = denom.fee_refund) in
        let* () = check (age_mask = denom.age_mask) in
        Ok ())

  let do_ ~db_conn ~sm MasterSignatures.{ denom_sigs; signkey_sigs } =
    let* () =
      signkey_sigs
      |> List.map (fun SignKeySignature.{ key; master_sig } ->
          (key, master_sig))
      |> Secmod.add_signkey_master_signatures db_conn sm
    in
    let* () =
      denom_sigs
      |> List.map (fun DenomSignature.{ h_denom_pub; master_sig } ->
          let h_denom_pub = HashCode.to_denomination_hash h_denom_pub in
          (h_denom_pub, master_sig))
      |> Secmod.add_denom_master_signatures db_conn sm
    in
    let* () = check_master_signatures_update ~db_conn ~sm 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 sm = Vif.Server.device Devices.secmod server in
    let res =
      let* v = Vif.Request.of_json req |> unwrap_err_msg in
      let* () = verify ~sm v in
      let* () = do_ ~db_conn ~sm v in
      Ok ""
    in
    Respond_util.respond_with_res res req
end

module Denom_revoke = struct
  let verify h_denom_pub DenomRevocationSignature.{ master_sig } =
    let open Bin_sig.MasterDenominationKeyRevocation in
    verify ~key:Config.Exchange.master_public_key master_sig { h_denom_pub }

  let do_ ~db_conn ~sm h_denom_pub DenomRevocationSignature.{ master_sig } =
    let* () = Secmod.revoke_denomination sm h_denom_pub master_sig in
    let+ () =
      Pg.insert_denomination_revocation db_conn h_denom_pub master_sig
      |> unwrap_err_caqti
    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 db_conn = Vif.Server.device Devices.db_connection server in
    let sm = Vif.Server.device Devices.secmod server in
    let res =
      let* h_denom_pub = HashCode.of_b32 h_denom_pub in
      let h_denom_pub = HashCode.to_denomination_hash h_denom_pub in
      let* v = Vif.Request.of_json req |> unwrap_err_msg in
      let* () = verify h_denom_pub v in
      let* () = do_ ~db_conn ~sm h_denom_pub v in
      Ok ""
    in
    Respond_util.respond_with_res res req
end

module Signkey_revoke = struct
  let verify exchange_pub SignkeyRevocationSignature.{ master_sig } =
    let open Bin_sig.MasterSigningKeyRevocation in
    verify ~key:Config.Exchange.master_public_key master_sig { exchange_pub }

  let do_ ~db_conn ~sm exchange_pub SignkeyRevocationSignature.{ master_sig } =
    let* () = Secmod.revoke_signkey sm exchange_pub master_sig in
    let+ () =
      Pg.insert_signkey_revocation db_conn exchange_pub master_sig
      |> unwrap_err_caqti
    in
    ()

  let jsont = SignkeyRevocationSignature.jsont

  let f req exchange_pub server _env =
    Logs.info (fun m -> m "POST /management/signkeys/$EXCHANGE_PUB/revoke/");
    let db_conn = Vif.Server.device Devices.db_connection server in
    let sm = Vif.Server.device Devices.secmod 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 exchange_pub v in
      let* () = do_ ~db_conn ~sm exchange_pub v in
      Ok ""
    in
    Respond_util.respond_with_res res req
end

module Auditors = struct
  let verify
      AuditorSetupMessage.
        {
          auditor_url;
          auditor_name= _;
          auditor_pub;
          master_sig;
          validity_start;
        } =
    let open Bin_sig.MasterAddAuditor in
    verify ~key:Config.Exchange.master_public_key master_sig
      {
        start_date= validity_start;
        auditor_pub;
        h_auditor_url= Bin_type.Hash_64_cstr.hash auditor_url;
      }

  (* TODO timestamps last_change +/- checks *)
  (* todo: there is something about use of monotonic time
   + protection against replay attack that I don't understand *)
  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.lookup_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
        ()
    | Some last_date ->
        let cmp = Timestamp.compare last_date validity_start |> Option.get in
        if cmp > 0 then Error "more recent management auditor already present"
        else
          let+ () = Pg.update_auditor db_conn v |> unwrap_err_caqti in
          ()

  let jsont = AuditorSetupMessage.jsont

  let f req server _env =
    Logs.info (fun m -> m "POST /management/auditors/");
    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 v in
      let* () = do_ ~db_conn v in
      Ok ""
    in
    Respond_util.respond_with_res res req
end

module Auditors_disable = struct
  let verify auditor_pub AuditorTeardownMessage.{ master_sig; validity_end } =
    let open Bin_sig.MasterDelAuditor in
    verify ~key:Config.Exchange.master_public_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.lookup_auditor_timestamp db_conn auditor_pub |> unwrap_err_caqti
    in
    match last_date_opt with
    | None -> Error "auditor not found"
    | Some last_date ->
        let cmp = Timestamp.compare last_date validity_end |> Option.get in
        if cmp > 0 then Error "more recent management auditor already present"
        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 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 auditor_pub v in
      let* () = do_ ~db_conn auditor_pub v in
      Ok ""
    in
    Respond_util.respond_with_res res req
end

module Wire_fee = struct
  let verify
      WireFeeSetupMessage.
        {
          wire_method;
          master_sig_wire;
          fee_start;
          fee_end;
          closing_fee;
          wire_fee;
        } =
    let open Bin_sig.MasterWireFee in
    verify ~key:Config.Exchange.master_public_key master_sig_wire
      {
        h_wire_method= Bin_type.Hash_64_cstr.hash wire_method;
        start_date= fee_start;
        end_date= fee_end;
        wire_fee;
        closing_fee;
      }

  let do_ ~db_conn
      WireFeeSetupMessage.
        {
          wire_method;
          master_sig_wire;
          fee_start;
          fee_end;
          closing_fee;
          wire_fee;
        } =
    let* wire_fee_opt =
      Pg.lookup_wire_fee_by_time db_conn ~wire_method ~start_date:fee_start
        ~end_date:fee_end
      |> unwrap_err_caqti
    in
    match wire_fee_opt with
    | Some (_wire_fee, _closing_fee) -> Error "wire-fee already setup"
    | None ->
        let+ () =
          Pg.insert_wire_fee db_conn ~wire_method ~start_date:fee_start
            ~end_date:fee_end ~wire_fee ~closing_fee ~master_sig:master_sig_wire
          |> unwrap_err_caqti
        in
        ()

  let jsont = WireFeeSetupMessage.jsont

  let f req server _env =
    Logs.info (fun m -> m "POST /management/wire-fee/");
    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 v in
      let* () = do_ ~db_conn v in
      Ok ""
    in
    Respond_util.respond_with_res res req
end

module Global_fees = struct
  let verify
      GlobalFees.
        {
          start_date;
          end_date;
          history_fee;
          account_fee;
          purse_fee;
          history_expiration;
          purse_account_limit;
          purse_timeout;
          master_sig;
        } =
    (* TODO what is kyc_timeout, kyc_fee ? *)
    let dummy_amount =
      Amount.make ~sign:None ~currency:"EUR" ~value:0_L ~fraction:0_l
      |> Result.get_ok
    in
    let kyc_timeout = None in
    let kyc_fee = dummy_amount in
    (* * *)
    let open Bin_sig.GlobalFees in
    verify ~key:Config.Exchange.master_public_key master_sig
      {
        start_date;
        end_date;
        purse_timeout;
        kyc_timeout;
        history_expiration;
        history_fee;
        kyc_fee;
        account_fee;
        purse_fee;
        purse_account_limit;
      }

  let do_ ~db_conn v =
    let* global_fees_opt =
      let start_date = v.GlobalFees.start_date in
      let end_date = v.GlobalFees.end_date in
      Pg.lookup_global_fee_by_time db_conn ~start_date ~end_date
      |> unwrap_err_caqti
    in
    match global_fees_opt with
    | Some _ -> Error "global-fees already setup"
    | None ->
        let+ () = Pg.insert_global_fee db_conn v |> unwrap_err_caqti in
        ()

  let jsont = GlobalFees.jsont

  let f req server _env =
    Logs.info (fun m -> m "POST /management/global-fees/");
    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 v in
      let* () = do_ ~db_conn v in
      Ok ""
    in
    Respond_util.respond_with_res res req
end

module Wire = struct
  let verify
      WireSetupMessage.
        {
          payto_uri;
          master_sig_wire;
          master_sig_add;
          validity_start;
          bank_label= _;
          priority= _;
        } =
    (* TODO wire *)
    let conversion_url = "" in
    let credit_restrictions = "" in
    let debit_restrictions = "" in
    let open Bin_type in
    let* () =
      let open Bin_sig.MasterWireDetails in
      verify ~key:Config.Exchange.master_public_key master_sig_wire
        {
          h_wire_details= FullPaytoHash.hash payto_uri;
          h_conversion_url= Hash_64_cstr.hash conversion_url;
          h_credit_restrictions= Hash_64_cstr.hash credit_restrictions;
          h_debit_restrictions= Hash_64_cstr.hash debit_restrictions;
        }
    in
    let* () =
      let open Bin_sig.MasterAddWire in
      verify ~key:Config.Exchange.master_public_key master_sig_add
        {
          start_date= validity_start;
          h_wire= FullPaytoHash.hash payto_uri;
          h_conversion_url= Hash_64_cstr.hash conversion_url;
          h_credit_restrictions= Hash_64_cstr.hash credit_restrictions;
          h_debit_restrictions= Hash_64_cstr.hash debit_restrictions;
        }
    in
    Ok ()

  let do_ ~db_conn v =
    let* last_change_opt =
      let payto_uri = v.WireSetupMessage.payto_uri in
      Pg.lookup_wire_timestamp db_conn ~payto_uri |> unwrap_err_caqti
    in
    match last_change_opt with
    | Some _ -> Error "wire already setup"
    | None ->
        (* TODO wire *)
        let last_change = Ptime_clock.now () |> Option.some in
        let v =
          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 |> unwrap_err_caqti in
        ()

  let jsont = WireSetupMessage.jsont

  let f req server _env =
    Logs.info (fun m -> m "POST /management/wire/");
    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 v in
      let* () = do_ ~db_conn v in
      Ok ""
    in
    Respond_util.respond_with_res res req
end

module Wire_disable = struct
  let verify WireTeardownMessage.{ payto_uri; master_sig_del; validity_end } =
    let open Bin_sig.MasterDelWire in
    verify ~key:Config.Exchange.master_public_key master_sig_del
      { end_date= validity_end; h_wire= Bin_type.FullPaytoHash.hash payto_uri }

  let do_ ~db_conn
      WireTeardownMessage.{ payto_uri; master_sig_del= _; validity_end } =
    let* last_change_opt =
      Pg.lookup_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 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 v in
      let* () = do_ ~db_conn v in
      Ok ""
    in
    Respond_util.respond_with_res res req
end

module Drain = struct
  let verify
      DrainProfitsMessage.
        {
          debit_account_section;
          credit_payto_uri;
          wtid;
          master_sig;
          date;
          amount;
        } =
    let open Bin_sig.MasterDrainProfit in
    let open Bin_type in
    verify ~key:Config.Exchange.master_public_key master_sig
      {
        wtid;
        date;
        amount;
        h_section= Hash_64_cstr.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 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 v in
      let* () = do_ ~db_conn v in
      Ok ""
    in
    Respond_util.respond_with_res res req
end

module AmlOfficer = struct
  let verify
      AmlOfficerSetup.
        {
          officer_pub;
          officer_name;
          is_active;
          read_only= _;
          master_sig;
          change_date;
        } =
    let open Bin_sig.MasterAmlOfficerStatus in
    let is_active = match is_active with true -> 1_l | false -> 0_l in
    verify ~key:Config.Exchange.master_public_key master_sig
      {
        change_date;
        officer_pub;
        h_officer_name= Bin_type.Hash_64_cstr.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 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 v in
      let* () = do_ ~db_conn v in
      Ok ""
    in
    Respond_util.respond_with_res res req
end

module Partners = struct
  let verify
      ExchangePartnerSetupRequest.
        {
          partner_base_url;
          partner_pub;
          wad_frequency;
          master_sig;
          start_date;
          end_date;
          wad_fee;
        } =
    let open Bin_sig.PartnerConfiguration in
    verify ~key:Config.Exchange.master_public_key master_sig
      {
        partner_pub;
        start_date;
        end_date;
        wad_frequency;
        wad_fee;
        h_url= Bin_type.Hash_64_cstr.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 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 v in
      let* () = do_ ~db_conn v in
      Ok ""
    in
    Respond_util.respond_with_res res req
end