clean up

src/mte_management.ml

@@ -0,0 +1,581 @@
+open Syntax
+open Api
+open Hash
+
+module Keys_get = struct
+  let jsont = FutureKeysResponse.jsont
+
+  let f req server _env =
+    Logs.info (fun m -> m "GET /management/keys/");
+    let (module Keys : Keys.S) = Vif.Server.device Devices.keys server in
+    let res =
+      let* v = Keys.make_future_keys_response () in
+      Api.encode jsont v
+    in
+    Respond.result res req
+end
+
+module Keys_post = struct
+  let verify (module Keys : Keys.S)
+      MasterSignatures.{ denom_sigs; signkey_sigs } =
+    let* () = list_iter Keys.verify_future_signkey signkey_sigs in
+    let* () = list_iter Keys.verify_future_denomination denom_sigs in
+    Ok ()
+
+  let do_ (module Keys : Keys.S) MasterSignatures.{ denom_sigs; signkey_sigs } =
+    let* () = list_iter Keys.certify_future_signkey signkey_sigs in
+    let* () = list_iter Keys.certify_future_denomination denom_sigs in
+    Ok ()
+
+  let jsont = MasterSignatures.jsont
+
+  let f req server _env =
+    Logs.info (fun m -> m "POST /management/keys/");
+    let keys = Vif.Server.device Devices.keys server in
+    let res =
+      let* v = Vif.Request.of_json req |> unwrap_msg in
+      let* () = verify keys v in
+      let* () = do_ keys v in
+      Ok ()
+    in
+    Respond.result_no_content 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 Config.master_public_key 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 = Crypto.DenominationHash.of_b32 h_denom_pub in
+      let* v = Vif.Request.of_json req |> unwrap_msg in
+      let* () = verify keys h_denom_pub v in
+      let* () = do_ keys h_denom_pub v in
+      Ok ()
+    in
+    Respond.result_no_content res req
+end
+
+module Signkey_revoke = struct
+  let verify (module Keys : Keys.S) exchange_pub
+      SignkeyRevocationSignature.{ master_sig } =
+    let open Signatures.MasterSigningKeyRevocation in
+    verify Config.master_public_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_msg in
+      let* () = verify keys exchange_pub v in
+      let* () = do_ keys exchange_pub v in
+      Ok ()
+    in
+    Respond.result_no_content 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 Config.master_public_key master_sig
+      {
+        start_date= validity_start;
+        auditor_pub;
+        h_auditor_url= Hash.Cstring.H64.hash auditor_url;
+      }
+
+  let do_ ~db_conn v =
+    let auditor_pub = v.AuditorSetupMessage.auditor_pub in
+    let validity_start = v.AuditorSetupMessage.validity_start in
+    let* opt = Pg.find_auditor db_conn auditor_pub |> unwrap_caqti in
+    match opt with
+    | None ->
+        let auditor = Auditor.of_setup_message v in
+        let+ () = Pg.update_auditor db_conn auditor |> unwrap_caqti in
+        Logs.info (fun m -> m "enabled auditor");
+        ()
+    | Some auditor ->
+        if Timestamp.compare validity_start auditor.last_change <= 0 then
+          Error "replay detected on enable-auditor"
+        else
+          let+ () = Pg.update_auditor db_conn auditor |> unwrap_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_msg in
+      let* () = verify keys v in
+      let* () = do_ ~db_conn v in
+      Ok ()
+    in
+    Respond.result_no_content 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 Config.master_public_key master_sig
+      { end_date= validity_end; auditor_pub }
+
+  let do_ ~db_conn auditor_pub
+      AuditorTeardownMessage.{ master_sig= _; validity_end } =
+    let* opt = Pg.find_auditor db_conn auditor_pub |> unwrap_caqti in
+    match opt with
+    | None -> Error "auditor not found"
+    | Some auditor -> (
+        if Timestamp.compare validity_end auditor.last_change <= 0 then
+          Error "replay detected on disable-auditor"
+        else
+          match auditor.is_active with
+          | false ->
+              Logs.info (fun m -> m "auditor was already revoked");
+              Ok ()
+          | true ->
+              let auditor =
+                { auditor with last_change= validity_end; is_active= false }
+              in
+              let+ () = Pg.update_auditor db_conn auditor |> unwrap_caqti in
+              Logs.info (fun m ->
+                  m "revoked auditor `%s`"
+                    (Crypto.EddsaPublicKey.to_b32 auditor_pub));
+              ())
+
+  let jsont = AuditorTeardownMessage.jsont
+
+  let f req auditor_pub server _env =
+    Logs.info (fun m -> m "POST /management/auditors/$AUDITOR_PUB/disable/");
+    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_msg in
+      let* () = verify keys auditor_pub v in
+      let* () = do_ ~db_conn auditor_pub v in
+      Ok ()
+    in
+    Respond.result_no_content 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 Config.master_public_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_caqti
+    in
+    match wire_fees with
+    | [] ->
+        let+ () = Pg.insert_wire_fee db_conn v |> unwrap_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_msg in
+      let* () = verify keys v in
+      let* () = do_ ~db_conn v in
+      Ok ()
+    in
+    Respond.result_no_content res req
+end
+
+module Global_fees = struct
+  let verify v = GlobalFees.verify_global_fees ~key:Config.master_public_key v
+
+  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_caqti
+    in
+    match global_fees with
+    | [] ->
+        let+ () = Pg.insert_global_fees db_conn v |> unwrap_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 db_conn = Vif.Server.device Devices.db_connection server in
+    let res =
+      let* v = Vif.Request.of_json req |> unwrap_msg in
+      let* () = verify v in
+      let* () = do_ ~db_conn v in
+      Ok ()
+    in
+    Respond.result_no_content res req
+end
+
+module Wire = struct
+  let verify (module Keys : Keys.S)
+      WireSetupMessage.
+        {
+          payto_uri;
+          master_sig_wire;
+          master_sig_add;
+          conversion_url;
+          credit_restrictions;
+          debit_restrictions;
+          validity_start;
+          bank_label= _;
+          priority= _;
+        } =
+    (* TODO wire
+       hash over json, hash over string option? *)
+    let* () =
+      match (credit_restrictions, debit_restrictions) with
+      | [], [] -> Ok ()
+      | _ ->
+          Fmt.error
+            "wire setup: credit_restrictions and debit_restrictions are not \
+             supported"
+    in
+    let h_wire_details = Hash.FullPaytoHash.hash payto_uri in
+    let h_conversion_url =
+      Hash.Cstring.H64.hash ((* ?? *) Option.value ~default:"" conversion_url)
+    in
+    let h_credit_restrictions = Hash.Cstring.H64.hash "" in
+    let h_debit_restrictions = Hash.Cstring.H64.hash "" in
+    (* - *)
+    let* () =
+      let open Signatures.MasterWireDetails in
+      verify Config.master_public_key master_sig_wire
+        {
+          h_wire_details;
+          h_conversion_url;
+          h_credit_restrictions;
+          h_debit_restrictions;
+        }
+    in
+    let* () =
+      let open Signatures.MasterAddWire in
+      verify Config.master_public_key master_sig_add
+        {
+          start_date= validity_start;
+          h_wire= h_wire_details;
+          h_conversion_url;
+          h_credit_restrictions;
+          h_debit_restrictions;
+        }
+    in
+    Ok ()
+
+  let do_ ~db_conn
+      WireSetupMessage.
+        {
+          payto_uri;
+          master_sig_wire;
+          master_sig_add= _;
+          conversion_url;
+          credit_restrictions;
+          debit_restrictions;
+          validity_start;
+          bank_label;
+          priority;
+        } =
+    let* opt = Pg.find_wire db_conn ~payto_uri |> unwrap_caqti in
+    match opt with
+    | None ->
+        let wire =
+          ExchangeWireAccount.
+            {
+              payto_uri;
+              conversion_url;
+              credit_restrictions;
+              debit_restrictions;
+              master_sig= master_sig_wire;
+              bank_label;
+              priority;
+            }
+        in
+        let+ () =
+          Pg.update_wire db_conn ~is_active:true ~last_change:validity_start
+            wire
+          |> unwrap_caqti
+        in
+        Logs.info (fun m -> m "added wire method");
+        ()
+    | Some (wire, _is_active, last_change) ->
+        if Timestamp.compare validity_start last_change <= 0 then
+          Error "replay detected on enable-wire"
+        else
+          let+ () =
+            Pg.update_wire db_conn ~is_active:true ~last_change:validity_start
+              wire
+            |> unwrap_caqti
+          in
+          Logs.info (fun m -> m "updated wire method");
+          ()
+
+  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_msg in
+      let* () = verify keys v in
+      let* () = do_ ~db_conn v in
+      Ok ()
+    in
+    Respond.result_no_content 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 Config.master_public_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* opt = Pg.find_wire db_conn ~payto_uri |> unwrap_caqti in
+    match opt with
+    | None -> Error "wire not found"
+    | Some (wire, _is_active, last_change) ->
+        if Timestamp.compare validity_end last_change <= 0 then
+          Error "replay detected on disable-wire"
+        else
+          let+ () =
+            Pg.update_wire db_conn ~is_active:false ~last_change:validity_end
+              wire
+            |> unwrap_caqti
+          in
+          Logs.info (fun m -> m "disabled wire method");
+          ()
+
+  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_msg in
+      let* () = verify keys v in
+      let* () = do_ ~db_conn v in
+      Ok ()
+    in
+    Respond.result_no_content 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 Config.master_public_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* opt =
+      Pg.find_drain_profit db_conn v.DrainProfitsMessage.wtid |> unwrap_caqti
+    in
+    match opt with
+    | Some _ ->
+        Logs.info (fun m -> m "drain profit message already added to database");
+        Ok ()
+    | None ->
+        let+ () = Pg.insert_drain_profit db_conn v |> unwrap_caqti in
+        Logs.info (fun m -> m "added drain profit message to database");
+        ()
+
+  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_msg in
+      let* () = verify keys v in
+      let* () = do_ ~db_conn v in
+      Ok ()
+    in
+    Respond.result_no_content 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 Config.master_public_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_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_msg in
+      let* () = verify keys v in
+      let* () = do_ ~db_conn v in
+      Ok ()
+    in
+    Respond.result_no_content 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 Config.master_public_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_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_msg in
+      let* () = verify keys v in
+      let* () = do_ ~db_conn v in
+      Ok ()
+    in
+    Respond.result_no_content res req
+end