diff --git a/src/http_information.ml b/src/http_information.ml index 79ac240e..5019553b 100644 --- a/src/http_information.ml +++ b/src/http_information.ml @@ -18,7 +18,7 @@ let seed req _server _env = let config req _server _env = Logs.info (fun m -> m "GET /config"); let s = Api.(encode_exn ExchangeVersionResponse.jsont config) in - Respond_util.respond_with_ok_json s req + Respond.ok s req (* TODO for now we only have one item in each "denom group" @@ -276,4 +276,4 @@ let keys req server _env = let s = Api.encode_exn jsont v in Ok s in - Respond_util.respond_with_res res req + Respond.result res req diff --git a/src/http_management.ml b/src/http_management.ml index 29b08016..84178e6e 100644 --- a/src/http_management.ml +++ b/src/http_management.ml @@ -109,7 +109,7 @@ module Keys_get = struct let s = Api.encode_exn jsont v in Ok s in - Respond_util.respond_with_res res req + Respond.result res req end module Keys_post = struct @@ -215,7 +215,7 @@ module Keys_post = struct let* () = do_ ~db_conn sm v in Ok "" in - Respond_util.respond_with_res res req + Respond.result res req end module Denom_revoke = struct @@ -246,7 +246,7 @@ module Denom_revoke = struct let* () = do_ ~db_conn sm h_denom_pub v in Ok "" in - Respond_util.respond_with_res res req + Respond.result res req end module Signkey_revoke = struct @@ -277,7 +277,7 @@ module Signkey_revoke = struct let* () = do_ ~db_conn sm exchange_pub v in Ok "" in - Respond_util.respond_with_res res req + Respond.result res req end module Auditors = struct @@ -333,7 +333,7 @@ module Auditors = struct let* () = do_ ~db_conn v in Ok "" in - Respond_util.respond_with_res res req + Respond.result res req end module Auditors_disable = struct @@ -374,7 +374,7 @@ module Auditors_disable = struct let* () = do_ ~db_conn auditor_pub v in Ok "" in - Respond_util.respond_with_res res req + Respond.result res req end module Wire_fee = struct @@ -433,7 +433,7 @@ module Wire_fee = struct let* () = do_ ~db_conn v in Ok "" in - Respond_util.respond_with_res res req + Respond.result res req end module Global_fees = struct @@ -504,7 +504,7 @@ module Global_fees = struct let* () = do_ ~db_conn v in Ok "" in - Respond_util.respond_with_res res req + Respond.result res req end module Wire = struct @@ -582,7 +582,7 @@ module Wire = struct let* () = do_ ~db_conn v in Ok "" in - Respond_util.respond_with_res res req + Respond.result res req end module Wire_disable = struct @@ -617,7 +617,7 @@ module Wire_disable = struct let* () = do_ ~db_conn v in Ok "" in - Respond_util.respond_with_res res req + Respond.result res req end module Drain = struct @@ -657,7 +657,7 @@ module Drain = struct let* () = do_ ~db_conn v in Ok "" in - Respond_util.respond_with_res res req + Respond.result res req end module AmlOfficer = struct @@ -697,7 +697,7 @@ module AmlOfficer = struct let* () = do_ ~db_conn v in Ok "" in - Respond_util.respond_with_res res req + Respond.result res req end module Partners = struct @@ -739,5 +739,5 @@ module Partners = struct let* () = do_ ~db_conn v in Ok "" in - Respond_util.respond_with_res res req + Respond.result res req end diff --git a/src/static.ml b/src/http_terms.ml similarity index 64% rename from src/static.ml rename to src/http_terms.ml index 5706022c..4dca972a 100644 --- a/src/static.ml +++ b/src/http_terms.ml @@ -1,31 +1,5 @@ (* /terms + /privacy *) -(* TODO response *) -module Respond_with = struct - open Vif.Response - open Syntax - - open struct - let error_detail ?hint _status = - let open Api in - let code = -1 in - let err = ErrorDetail.make ?hint code in - let s = encode_exn ErrorDetail.jsont err in - Logs.err (fun m -> m "ErrorDetail: `%s`" s); - s - end - - let bad_request ?hint req = - let body = error_detail ?hint `Bad_request in - let* () = add ~field:"content-type" "application/json" in - let* () = with_string ?compression:None req body in - respond `Bad_request - - let not_modified () = - let* () = empty in - respond `Not_modified -end - let aux asset req _server _env = let etag = Assets.etag asset in let headers = Vif.Request.headers req in @@ -37,12 +11,8 @@ let aux asset req _server _env = |> Result.map (Headers_lib.If_none_match.evaluate etag) in match has_matching_etag with - | Error e -> - Logs.err (fun m -> m "bad request"); - Respond_with.bad_request ~hint:e req - | Ok true -> - Logs.err (fun m -> m "not modified"); - Respond_with.not_modified () + | Error e -> Respond.bad_request ~hint:e req + | Ok true -> Respond.not_modified () | Ok false -> let mime = Headers.select_mimetype headers in let lang = Headers.select_language headers in diff --git a/src/mte.ml b/src/mte.ml index abfc68a8..5dcf79a3 100644 --- a/src/mte.ml +++ b/src/mte.ml @@ -23,28 +23,28 @@ let hello req _server _env = let routes = let open Vif.Uri in let open Vif.Route in - let get_ path = get (path /?? any) in + let get path = get (path /?? any) in let post path jsont = post (Vif.Type.json_encoding jsont) (path /?? any) in + let v s = rel / s in let tos = - let v s = rel / s in [ - get_ rel --> hello; - get_ (v "terms") --> Static.terms; - get_ (v "privacy") --> Static.privacy; + get rel --> hello; + get (v "terms") --> Http_terms.terms; + get (v "privacy") --> Http_terms.privacy; ] in let status_info = [ - get_ (rel / "seed") --> Http_information.seed; - get_ (rel / "config") --> Http_information.config; - get_ (rel / "keys") --> Http_information.keys; + get (v "seed") --> Http_information.seed; + get (v "config") --> Http_information.config; + get (v "keys") --> Http_information.keys; ] in let management = let open Http_management in - let v s = rel / "management" / s in + let v s = v "management" / s in [ - get_ (v "keys") --> Keys_get.f; + get (v "keys") --> Keys_get.f; post (v "keys") Keys_post.jsont --> Keys_post.f; post (v "denominations" /% string `Path / "revoke") Denom_revoke.jsont --> Denom_revoke.f; diff --git a/src/respond.ml b/src/respond.ml new file mode 100644 index 00000000..ea17f7f7 --- /dev/null +++ b/src/respond.ml @@ -0,0 +1,39 @@ +(* TODO response + use ErrorDetail *) + +let respond_json req content status = + let open Vif.Response in + let open Syntax in + let* () = add ~field:"content-type" "application/json" in + let* () = with_string req content in + respond status + +let mk_error_content ?hint _status = + let open Api in + let code = -1 in + let err = ErrorDetail.make ?hint code in + encode_exn ErrorDetail.jsont err + +let error ~hint req = + Logs.err (fun m -> m "internal server 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 not_modified () = + Logs.debug (fun m -> m "not modified"); + let open Vif.Response in + let open Syntax in + let* () = empty in + respond `Not_modified + +let result res req = + match res with Error hint -> error ~hint req | Ok content -> ok content req diff --git a/src/respond_util.ml b/src/respond_util.ml deleted file mode 100644 index 0303c12c..00000000 --- a/src/respond_util.ml +++ /dev/null @@ -1,25 +0,0 @@ -(* TODO response - use ErrorDetail *) - -let respond_with_plain_text_error ?status e req = - let open Vif.Response in - let open Syntax in - let status = Option.value ~default:`Bad_request status in - let* () = add ~field:"content-type" "text/plain; charset=utf-8" in - let* () = with_string req e in - respond status - -let respond_with_ok_json content req = - let open Vif.Response in - let open Syntax in - let* () = add ~field:"content-type" "application/json" in - let* () = with_string req content in - respond `OK - -let respond_with_res res req = - match res with - | Error err -> - Logs.err (fun m -> m "%s." err); - let err = Fmt.str "%s@." err in - respond_with_plain_text_error err req - | Ok content -> respond_with_ok_json content req