diff --git a/src/keys.ml b/src/keys.ml index afc67476..b4452fc7 100644 --- a/src/keys.ml +++ b/src/keys.ml @@ -269,7 +269,7 @@ module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct let certify_future_signkey Api.SignKeySignature.{ key= pub; master_sig } = match Sm_eddsa.find_key pub with - | None -> Error `Not_found + | None -> Error (`Not_found "future eddsa key") | Some (pub, (t1, t2)) -> (* rebuild it *) let future_sk = make_future_sk (pub, (t1, t2)) in @@ -281,7 +281,7 @@ module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct let certify_future_denomination Api.DenomSignature.{ h_denom_pub= h_pub; master_sig } = match Sm_rsa.find_key h_pub with - | None -> Error `Not_found + | None -> Error (`Not_found "future rsa denomination key") | Some (h_pub, (section_name, pub, t1)) -> let future_dn = make_future_dn (h_pub, (section_name, pub, t1)) in let dn = dn_of_future_dn future_dn h_pub master_sig in diff --git a/src/mte_info.ml b/src/mte_info.ml index 070734bf..c696ba04 100644 --- a/src/mte_info.ml +++ b/src/mte_info.ml @@ -18,8 +18,8 @@ let seed req _server _env = let config req _server _env = Logs.info (fun m -> m "GET /config"); - let res = Api.encode Api.ExchangeVersionResponse.jsont config in - Respond.result res req + let jsont = Api.ExchangeVersionResponse.jsont in + Respond.ok req jsont config (* not implemented: - kyc @@ -157,19 +157,17 @@ let jsont = ExchangeKeysResponse.jsont let keys req server _env = Logs.info (fun m -> m "GET /keys"); + Respond.result req jsont + @@ let db_conn = Vifu.Server.device Global.db_conn server in let keys = Vifu.Server.device Global.keys server in - let res = - let* last_issue_date = - match Vifu.Queries.get req "last_issue_date" with - | [] -> Ok None - | s :: _ -> ( - match Int64.of_string_opt s with - | None -> - Fmt.error_msg "invalid `?last_issue_date` query param, not an int" - | Some n -> Ok (Some (Timestamp.of_s n))) - in - let* v = mk_keys ~db_conn keys ~last_issue_date in - Api.encode jsont v + let* last_issue_date = + match Vifu.Queries.get req "last_issue_date" with + | [] -> Ok None + | s :: _ -> ( + match Int64.of_string_opt s with + | None -> + Fmt.error_msg "invalid `?last_issue_date` query param, not an int" + | Some n -> Ok (Some (Timestamp.of_s n))) in - Respond.result res req + mk_keys ~db_conn keys ~last_issue_date diff --git a/src/mte_management.ml b/src/mte_management.ml index 025d4bcc..73e2274d 100644 --- a/src/mte_management.ml +++ b/src/mte_management.ml @@ -3,23 +3,21 @@ open Api open Hash open Time -(* todo request.ml? *) -let request_of_json req = - Result.map_error (fun (`Msg e) -> `Json_decode e) (Vifu.Request.of_json req) - 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) = Vifu.Server.device Global.keys server in - let res = - let* v = Keys.make_future_keys_response () in - Api.encode jsont v - in - Respond.result res req + Respond.result req jsont + @@ + let* v = Keys.make_future_keys_response () in + Ok v end +let request_of_json req = + Vifu.Request.of_json req |> Result.map_error (fun (`Msg e) -> `Json_decode e) + module Keys_post = struct let verify (module Keys : Keys.S) MasterSignatures.{ denom_sigs; signkey_sigs } = @@ -27,7 +25,8 @@ module Keys_post = struct let* () = list_iter Keys.verify_future_denomination denom_sigs in Ok () - let do_ (module Keys : Keys.S) MasterSignatures.{ denom_sigs; signkey_sigs } = + let process (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 () @@ -36,14 +35,13 @@ module Keys_post = struct let f req server _env = Logs.info (fun m -> m "POST /management/keys/"); + Respond.result_no_content req + @@ let keys = Vifu.Server.device Global.keys server in - let res = - let* v = request_of_json req in - let* () = verify keys v in - let* () = do_ keys v in - Ok () - in - Respond.result_no_content res req + let* v = request_of_json req in + let* () = verify keys v in + let* () = process keys v in + Ok () end module Denom_revoke = struct @@ -52,7 +50,7 @@ module Denom_revoke = struct let open Signatures.MasterDenominationKeyRevocation in verify Config.master_public_key master_sig { h_denom_pub } - let do_ (module Keys : Keys.S) h_denom_pub + let process (module Keys : Keys.S) h_denom_pub DenomRevocationSignature.{ master_sig } = let+ () = Keys.revoke_denomination h_denom_pub master_sig in () @@ -61,18 +59,16 @@ module Denom_revoke = struct let f req h_denom_pub server _env = Logs.info (fun m -> m "POST /management/denominations/$H_DENOM_PUB/revoke/"); + Respond.result_no_content req + @@ let keys = Vifu.Server.device Global.keys server in - let res = - let* h_denom_pub = - DenominationHash.of_b32 h_denom_pub - |> Result.map_error (fun e -> `Msg e) - in - let* v = request_of_json req in - let* () = verify keys h_denom_pub v in - let* () = do_ keys h_denom_pub v in - Ok () + let* h_denom_pub = + DenominationHash.of_b32 h_denom_pub |> Result.map_error (fun e -> `Msg e) in - Respond.result_no_content res req + let* v = request_of_json req in + let* () = verify keys h_denom_pub v in + let* () = process keys h_denom_pub v in + Ok () end module Signkey_revoke = struct @@ -81,7 +77,7 @@ module Signkey_revoke = struct let open Signatures.MasterSigningKeyRevocation in verify Config.master_public_key master_sig { exchange_pub } - let do_ (module Keys : Keys.S) exchange_pub + let process (module Keys : Keys.S) exchange_pub SignkeyRevocationSignature.{ master_sig } = let+ () = Keys.revoke_signkey exchange_pub master_sig in () @@ -90,17 +86,16 @@ module Signkey_revoke = struct let f req exchange_pub server _env = Logs.info (fun m -> m "POST /management/signkeys/$EXCHANGE_PUB/revoke/"); + Respond.result_no_content req + @@ let keys = Vifu.Server.device Global.keys server in - let res = - let* exchange_pub = - Eddsa.pub_of_b32 exchange_pub |> Result.map_error (fun e -> `Msg e) - in - let* v = request_of_json req in - let* () = verify keys exchange_pub v in - let* () = do_ keys exchange_pub v in - Ok () + let* exchange_pub = + Eddsa.pub_of_b32 exchange_pub |> Result.map_error (fun e -> `Msg e) in - Respond.result_no_content res req + let* v = request_of_json req in + let* () = verify keys exchange_pub v in + let* () = process keys exchange_pub v in + Ok () end module Auditors = struct @@ -121,7 +116,7 @@ module Auditors = struct h_auditor_url= H64_cstring.hash auditor_url; } - let do_ ~db_conn v = + let process ~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 in @@ -143,15 +138,14 @@ module Auditors = struct let f req server _env = Logs.info (fun m -> m "POST /management/auditors/"); + Respond.result_no_content req + @@ let keys = Vifu.Server.device Global.keys server in let db_conn = Vifu.Server.device Global.db_conn server in - let res = - let* v = request_of_json req in - let* () = verify keys v in - let* () = do_ ~db_conn v in - Ok () - in - Respond.result_no_content res req + let* v = request_of_json req in + let* () = verify keys v in + let* () = process ~db_conn v in + Ok () end module Auditors_disable = struct @@ -161,11 +155,11 @@ module Auditors_disable = struct verify Config.master_public_key master_sig { end_date= validity_end; auditor_pub } - let do_ ~db_conn auditor_pub + let process ~db_conn auditor_pub AuditorTeardownMessage.{ master_sig= _; validity_end } = let* opt = Pg.find_auditor db_conn auditor_pub in match opt with - | None -> Error `Not_found + | None -> Error (`Not_found "auditor pub key") | Some auditor -> ( if Timestamp.compare validity_end auditor.last_change <= 0 then Error (`Conflict "replay detected on disable-auditor") @@ -187,18 +181,17 @@ module Auditors_disable = struct let f req auditor_pub server _env = Logs.info (fun m -> m "POST /management/auditors/$AUDITOR_PUB/disable/"); + Respond.result_no_content req + @@ let keys = Vifu.Server.device Global.keys server in let db_conn = Vifu.Server.device Global.db_conn server in - let res = - let* auditor_pub = - Eddsa.pub_of_b32 auditor_pub |> Result.map_error (fun e -> `Msg e) - in - let* v = request_of_json req in - let* () = verify keys auditor_pub v in - let* () = do_ ~db_conn auditor_pub v in - Ok () + let* auditor_pub = + Eddsa.pub_of_b32 auditor_pub |> Result.map_error (fun e -> `Msg e) in - Respond.result_no_content res req + let* v = request_of_json req in + let* () = verify keys auditor_pub v in + let* () = process ~db_conn auditor_pub v in + Ok () end module Wire_fee = struct @@ -222,7 +215,7 @@ module Wire_fee = struct closing_fee; } - let do_ ~db_conn (v : WireFeeSetupMessage.t) = + let process ~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 @@ -250,21 +243,20 @@ module Wire_fee = struct let f req server _env = Logs.info (fun m -> m "POST /management/wire-fee/"); + Respond.result_no_content req + @@ let keys = Vifu.Server.device Global.keys server in let db_conn = Vifu.Server.device Global.db_conn server in - let res = - let* v = request_of_json req in - let* () = verify keys v in - let* () = do_ ~db_conn v in - Ok () - in - Respond.result_no_content res req + let* v = request_of_json req in + let* () = verify keys v in + let* () = process ~db_conn v in + Ok () end module Global_fees = struct let verify v = GlobalFees.verify_global_fees ~key:Config.master_public_key v - let do_ ~db_conn v = + let process ~db_conn v = let* global_fees = let start_date = v.GlobalFees.start_date in let end_date = v.GlobalFees.end_date in @@ -297,14 +289,13 @@ module Global_fees = struct and once set for a timeframe, it should not change. *) let f req server _env = Logs.info (fun m -> m "POST /management/global-fees/"); + Respond.result_no_content req + @@ let db_conn = Vifu.Server.device Global.db_conn server in - let res = - let* v = request_of_json req in - let* () = verify v in - let* () = do_ ~db_conn v in - Ok () - in - Respond.result_no_content res req + let* v = request_of_json req in + let* () = verify v in + let* () = process ~db_conn v in + Ok () end module Wire = struct @@ -362,7 +353,7 @@ module Wire = struct in Ok () - let do_ ~db_conn + let process ~db_conn WireSetupMessage. { payto_uri; @@ -411,15 +402,14 @@ module Wire = struct let f req server _env = Logs.info (fun m -> m "POST /management/wire/"); + Respond.result_no_content req + @@ let keys = Vifu.Server.device Global.keys server in let db_conn = Vifu.Server.device Global.db_conn server in - let res = - let* v = request_of_json req in - let* () = verify keys v in - let* () = do_ ~db_conn v in - Ok () - in - Respond.result_no_content res req + let* v = request_of_json req in + let* () = verify keys v in + let* () = process ~db_conn v in + Ok () end module Wire_disable = struct @@ -429,11 +419,11 @@ module Wire_disable = struct verify Config.master_public_key master_sig_del { end_date= validity_end; h_wire= FullPaytoHash.hash payto_uri } - let do_ ~db_conn + let process ~db_conn WireTeardownMessage.{ payto_uri; master_sig_del= _; validity_end } = let* opt = Pg.find_wire db_conn ~payto_uri in match opt with - | None -> Error `Not_found + | None -> Error (`Not_found "wire payto-uri") | Some (wire, _is_active, last_change) -> if Timestamp.compare validity_end last_change <= 0 then Error (`Conflict "replay detected on disable-wire") @@ -449,15 +439,14 @@ module Wire_disable = struct let f req server _env = Logs.info (fun m -> m "POST /management/wire/disable/"); + Respond.result_no_content req + @@ let keys = Vifu.Server.device Global.keys server in let db_conn = Vifu.Server.device Global.db_conn server in - let res = - let* v = request_of_json req in - let* () = verify keys v in - let* () = do_ ~db_conn v in - Ok () - in - Respond.result_no_content res req + let* v = request_of_json req in + let* () = verify keys v in + let* () = process ~db_conn v in + Ok () end module Drain = struct @@ -481,7 +470,7 @@ module Drain = struct h_payto= FullPaytoHash.hash credit_payto_uri; } - let do_ ~db_conn v = + let process ~db_conn v = let* opt = Pg.find_drain_profit db_conn v.DrainProfitsMessage.wtid in match opt with | Some _ -> @@ -496,15 +485,14 @@ module Drain = struct let f req server _env = Logs.info (fun m -> m "POST /management/drain/"); + Respond.result_no_content req + @@ let keys = Vifu.Server.device Global.keys server in let db_conn = Vifu.Server.device Global.db_conn server in - let res = - let* v = request_of_json req in - let* () = verify keys v in - let* () = do_ ~db_conn v in - Ok () - in - Respond.result_no_content res req + let* v = request_of_json req in + let* () = verify keys v in + let* () = process ~db_conn v in + Ok () end module AmlOfficer = struct @@ -528,7 +516,7 @@ module AmlOfficer = struct is_active; } - let do_ ~db_conn v = + let process ~db_conn v = let+ _last_change = Pg.insert_aml_officer db_conn v in () @@ -536,15 +524,14 @@ module AmlOfficer = struct let f req server _env = Logs.info (fun m -> m "POST /management/aml-officers/"); + Respond.result_no_content req + @@ let keys = Vifu.Server.device Global.keys server in let db_conn = Vifu.Server.device Global.db_conn server in - let res = - let* v = request_of_json req in - let* () = verify keys v in - let* () = do_ ~db_conn v in - Ok () - in - Respond.result_no_content res req + let* v = request_of_json req in + let* () = verify keys v in + let* () = process ~db_conn v in + Ok () end module Partners = struct @@ -570,7 +557,7 @@ module Partners = struct h_url= H64_cstring.hash partner_base_url; } - let do_ ~db_conn v = + let process ~db_conn v = let+ () = Pg.insert_partner db_conn v in () @@ -578,13 +565,12 @@ module Partners = struct let f req server _env = Logs.info (fun m -> m "POST /management/partners/"); + Respond.result_no_content req + @@ let keys = Vifu.Server.device Global.keys server in let db_conn = Vifu.Server.device Global.db_conn server in - let res = - let* v = request_of_json req in - let* () = verify keys v in - let* () = do_ ~db_conn v in - Ok () - in - Respond.result_no_content res req + let* v = request_of_json req in + let* () = verify keys v in + let* () = process ~db_conn v in + Ok () end diff --git a/src/respond.ml b/src/respond.ml index c898874c..6ac59bd9 100644 --- a/src/respond.ml +++ b/src/respond.ml @@ -1,53 +1,63 @@ -let encode_error_detail err = - match Api.encode Api.ErrorDetail.jsont err with - | Error e -> - Fmt.failwith "json encoding error on `ErrorDetail`: %a." Result.pp_err e - | Ok s -> s - -let respond_json req content status = +let bad_request _req = let open Vifu.Response in - let open Syntax in - let* () = add ~field:"content-type" "application/json" in - let* () = with_string req content in - respond status + Logs.debug (fun m -> m "Bad request"); + respond `Bad_request -let mk_error_content ?hint _status = - let open Api in - let code = -1 in - let err = ErrorDetail.make ?hint code in - encode_error_detail err - -let error err req = - let hint = Fmt.str "%a" Result.pp_err err in - Logs.err (fun m -> m "error: %s" hint); - let body = mk_error_content ~hint `Internal_server_error in - respond_json req body `Internal_server_error - -let bad_request ?hint req = - Logs.err (fun m -> m "bad request"); - let body = mk_error_content ?hint `Bad_request in - respond_json req body `Bad_request - -let ok content req = - Logs.debug (fun m -> m "ok"); - respond_json req content `OK - -let no_content () = - Logs.debug (fun m -> m "no content"); +let no_content _req = + Logs.debug (fun m -> m "No content"); let open Vifu.Response in let open Syntax in let* () = empty in respond `No_content let not_modified () = - Logs.debug (fun m -> m "not modified"); + Logs.debug (fun m -> m "Not modified"); let open Vifu.Response in let open Syntax in let* () = empty in respond `Not_modified -let result res req = - match res with Error e -> error e req | Ok content -> ok content req +let respond_json req jsont status body = + let open Vifu.Response in + let open Syntax in + let* () = add ~field:"content-type" "application/json" in + let* () = with_json req jsont body in + respond status -let result_no_content res req = - match res with Error e -> error e req | Ok () -> no_content () +let ok req jsont body = + Logs.debug (fun m -> m "OK"); + respond_json req jsont `OK body + +let map_err_status err = + match err with + | `Json_decode _ | `Bin_decode _ -> `Bad_request + | `Invalid_signature_eddsa | `Invalid_signature_rsa -> `Forbidden + | `Not_found _ -> `Not_found + | `Conflict _ -> `Conflict + | `Caqti _s | `Mfat _s | `Json_encode _s | `Bin_encode _s | `Msg _s -> + `Internal_server_error + +let status_to_string = function + | `Bad_request -> "Bad request" + | `Forbidden -> "Forbidden" + | `Not_found -> "Not found" + | `Conflict -> "Conflict" + | `Internal_server_error -> "Internal server error" + +let error_detail hint = + let open Api in + let code = -1 in + ErrorDetail.make ~hint code + +let error req err = + let status = map_err_status err in + let hint = Result.err_to_string err in + let body = error_detail hint in + Logs.err (fun m -> m "%s: %s" (status_to_string status) hint); + respond_json req Api.ErrorDetail.jsont status body + +let result req jsont res = + match res with Error e -> error req e | Ok body -> ok req jsont body + +let result_no_content req res = + match res with Error e -> error req e | Ok () -> no_content req diff --git a/src/result.ml b/src/result.ml index 5ccb32cc..744edfeb 100644 --- a/src/result.ml +++ b/src/result.ml @@ -1,26 +1,24 @@ include Stdlib.Result type err = - [ `Msg of string - | `Json_decode of string + [ `Json_decode of string | `Bin_decode of string | `Invalid_signature_eddsa | `Invalid_signature_rsa | (* - *) - `Not_found + `Not_found of string | `Conflict of string | (* - server errors - *) - `Server_err of string - | `Caqti of string + `Caqti of string | `Mfat of string | `Json_encode of string | `Bin_encode of string + | `Msg of string ] type 'a t = ('a, err) Stdlib.Result.t let err_to_string : err -> string = function - | `Msg s -> s | `Json_decode s -> Fmt.str "Json decode: %s" s | `Json_encode s -> Fmt.str "Json encode: %s" s | `Bin_decode s -> Fmt.str "Bin decode: %s" s @@ -28,12 +26,12 @@ let err_to_string : err -> string = function | `Invalid_signature_eddsa -> Fmt.str "Invalid eddsa signature" | `Invalid_signature_rsa -> Fmt.str "Invalid rsa signature" (* - *) - | `Not_found -> Fmt.str "Not found" + | `Not_found s -> Fmt.str "Not found: %s" s | `Conflict s -> Fmt.str "Conflict: %s" s (* - *) - | `Server_err s -> Fmt.str "Server error: %s" s | `Caqti s -> Fmt.str "Caqti: %s" s | `Mfat s -> Fmt.str "mFAT: %s" s + | `Msg s -> s let pp_err = Fmt.of_to_string err_to_string let unwrap_err r = map_error err_to_string r