swrup/mte
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

better response status

Browse source
This commit is contained in:
swrup 2026-03-29 16:54:08 +02:00 • committed by Swrup
parent 42b0ec1445
commit 5532798ea5
5 changed files with 170 additions and 178 deletions
Download patch file Download diff file Expand all files Collapse all files

4
src/keys.ml
View file

@ -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

28
src/mte_info.ml
View file

@ -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

214
src/mte_management.ml
View file

@ -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

88
src/respond.ml
View file

@ -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

14
src/result.ml
View file

@ -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