From 66c2a605308a825064c40d28362f57f03d9229ca Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Sun, 11 Feb 2018 19:17:39 +0100 Subject: [PATCH] Client refactor: use the error_monad for all RPC services --- src/lib_base/protocol_environment.ml | 131 +++++++++++++++--- src/lib_client_base/client_generic_rpcs.ml | 8 +- .../v1/RPC_answer.mli | 12 +- .../v1/RPC_service.mli | 22 --- src/lib_rpc/RPC_answer.ml | 13 +- src/lib_rpc/RPC_answer.mli | 13 +- src/lib_rpc/RPC_context.ml | 33 +++-- src/lib_rpc/RPC_context.mli | 12 -- src/lib_rpc/RPC_description.ml | 3 + src/lib_rpc/RPC_description.mli | 9 ++ src/lib_rpc/RPC_directory.ml | 52 +++++++ src/lib_rpc/RPC_directory.mli | 101 +++++++++++++- src/lib_rpc/RPC_error.ml | 43 +----- src/lib_rpc/RPC_error.mli | 10 +- src/lib_rpc/RPC_service.ml | 55 +++++++- src/lib_rpc/RPC_service.mli | 18 ++- src/lib_rpc_http/RPC_client.ml | 6 +- src/lib_shell/node_rpc.ml | 109 +++++++-------- src/lib_shell_services/block_services.ml | 8 +- src/lib_shell_services/block_services.mli | 4 +- src/lib_shell_services/p2p_services.ml | 4 +- src/lib_shell_services/p2p_services.mli | 2 +- src/lib_shell_services/shell_services.ml | 24 +--- src/lib_shell_services/shell_services.mli | 13 +- vendors/ocplib-resto/lib_ezresto/ezResto.ml | 3 +- .../ocplib-resto/lib_resto-cohttp/server.ml | 19 ++- .../lib_resto-directory/resto_directory.ml | 2 +- .../lib_resto-directory/resto_directory.mli | 2 +- .../lib_resto-directory/test/services.ml | 2 +- vendors/ocplib-resto/lib_resto/resto.ml | 8 +- vendors/ocplib-resto/lib_resto/resto.mli | 7 +- 31 files changed, 480 insertions(+), 268 deletions(-) diff --git a/src/lib_base/protocol_environment.ml b/src/lib_base/protocol_environment.ml index 5fd51e52e..d49bef88b 100644 --- a/src/lib_base/protocol_environment.ml +++ b/src/lib_base/protocol_environment.ml @@ -182,32 +182,11 @@ module MakeV1 module Data_encoding = Data_encoding module Time = Time module Ed25519 = Ed25519 - module S = struct - include S - end - module Block_hash = Block_hash - module Operation_hash = Operation_hash - module Operation_list_hash = Operation_list_hash - module Operation_list_list_hash = Operation_list_list_hash - module Context_hash = Context_hash - module Protocol_hash = Protocol_hash - module Blake2B = Blake2B - module Fitness = Fitness - module Operation = Operation - module Block_header = Block_header - module Protocol = Protocol - module RPC_arg = RPC_arg - module RPC_path = RPC_path - module RPC_query = RPC_query - module RPC_service = RPC_service - module RPC_answer = RPC_answer - module RPC_directory = RPC_directory + module S = S module Error_monad = struct type error_category = [ `Branch | `Temporary | `Permanent ] include Error_monad.Make() end - module Micheline = Micheline - module Logging = Logging.Make(Param) type error += Ecoproto_error of Error_monad.error list @@ -231,6 +210,114 @@ module MakeV1 | Ok _ as ok -> ok | Error errors -> Error [Ecoproto_error errors] + module Block_hash = Block_hash + module Operation_hash = Operation_hash + module Operation_list_hash = Operation_list_hash + module Operation_list_list_hash = Operation_list_list_hash + module Context_hash = Context_hash + module Protocol_hash = Protocol_hash + module Blake2B = Blake2B + module Fitness = Fitness + module Operation = Operation + module Block_header = Block_header + module Protocol = Protocol + module RPC_arg = RPC_arg + module RPC_path = RPC_path + module RPC_query = RPC_query + module RPC_service = RPC_service + module RPC_answer = struct + + type 'o t = + [ `Ok of 'o (* 200 *) + | `OkStream of 'o stream (* 200 *) + | `Created of string option (* 201 *) + | `No_content (* 204 *) + | `Unauthorized of Error_monad.error list option (* 401 *) + | `Forbidden of Error_monad.error list option (* 403 *) + | `Not_found of Error_monad.error list option (* 404 *) + | `Conflict of Error_monad.error list option (* 409 *) + | `Error of Error_monad.error list option (* 500 *) + ] + + and 'a stream = 'a Resto_directory.Answer.stream = { + next: unit -> 'a option Lwt.t ; + shutdown: unit -> unit ; + } + + let return x = Lwt.return (`Ok x) + let return_stream x = Lwt.return (`OkStream x) + let not_found = Lwt.return (`Not_found None) + + let fail err = Lwt.return (`Error (Some err)) + end + module RPC_directory = struct + include RPC_directory + let register dir service handler = + gen_register dir service + (fun p q i -> + handler p q i >>= function + | `Ok o -> RPC_answer.return o + | `OkStream s -> RPC_answer.return_stream s + | `Created s -> Lwt.return (`Created s) + | `No_content -> Lwt.return (`No_content) + | `Unauthorized e -> + let e = Option.map e ~f:(fun e -> [Ecoproto_error e]) in + Lwt.return (`Unauthorized e) + | `Forbidden e -> + let e = Option.map e ~f:(fun e -> [Ecoproto_error e]) in + Lwt.return (`Forbidden e) + | `Not_found e -> + let e = Option.map e ~f:(fun e -> [Ecoproto_error e]) in + Lwt.return (`Not_found e) + | `Conflict e -> + let e = Option.map e ~f:(fun e -> [Ecoproto_error e]) in + Lwt.return (`Conflict e) + | `Error e -> + let e = Option.map e ~f:(fun e -> [Ecoproto_error e]) in + Lwt.return (`Error e)) + + (* + let tz_register dir service handler = + register dir service + (fun p q i -> + handler p q i >>= function + | Ok o -> RPC_answer.return o + | Error e -> RPC_answer.fail e) + + let lwt_register dir service handler = + register dir service + (fun p q i -> + handler p q i >>= fun o -> + RPC_answer.return o) +*) + open Curry + + let register0 root s f = register root s (curry Z f) + let register1 root s f = register root s (curry (S Z) f) + let register2 root s f = register root s (curry (S (S Z)) f) + let register3 root s f = register root s (curry (S (S (S Z))) f) + let register4 root s f = register root s (curry (S (S (S (S Z)))) f) + let register5 root s f = register root s (curry (S (S (S (S (S Z))))) f) + + (* + let tz_register0 root s f = tz_register root s (curry Z f) + let tz_register1 root s f = tz_register root s (curry (S Z) f) + let tz_register2 root s f = tz_register root s (curry (S (S Z)) f) + let tz_register3 root s f = tz_register root s (curry (S (S (S Z))) f) + let tz_register4 root s f = tz_register root s (curry (S (S (S (S Z)))) f) + let tz_register5 root s f = tz_register root s (curry (S (S (S (S (S Z))))) f) + + let lwt_register0 root s f = lwt_register root s (curry Z f) + let lwt_register1 root s f = lwt_register root s (curry (S Z) f) + let lwt_register2 root s f = lwt_register root s (curry (S (S Z)) f) + let lwt_register3 root s f = lwt_register root s (curry (S (S (S Z))) f) + let lwt_register4 root s f = lwt_register root s (curry (S (S (S (S Z)))) f) + let lwt_register5 root s f = lwt_register root s (curry (S (S (S (S (S Z))))) f) +*) + end + module Micheline = Micheline + module Logging = Logging.Make(Param) + module Updater = struct include Updater diff --git a/src/lib_client_base/client_generic_rpcs.ml b/src/lib_client_base/client_generic_rpcs.ml index 299420741..4fd123554 100644 --- a/src/lib_client_base/client_generic_rpcs.ml +++ b/src/lib_client_base/client_generic_rpcs.ml @@ -193,7 +193,7 @@ let rec count = let list url (cctxt : Client_commands.full_context) = let args = String.split '/' url in - Shell_services.describe cctxt + RPC_description.describe cctxt ~recurse:true args >>=? fun tree -> let open RPC_description in let collected_args = ref [] in @@ -293,7 +293,7 @@ let list url (cctxt : Client_commands.full_context) = let schema url (cctxt : Client_commands.full_context) = let args = String.split '/' url in let open RPC_description in - Shell_services.describe cctxt ~recurse:false args >>=? function + RPC_description.describe cctxt ~recurse:false args >>=? function | Static { services } -> begin match RPC_service.MethMap.find `POST services with | exception Not_found -> @@ -318,7 +318,7 @@ let schema url (cctxt : Client_commands.full_context) = let format url (cctxt : #Client_commands.logging_rpcs) = let args = String.split '/' url in let open RPC_description in - Shell_services.describe cctxt ~recurse:false args >>=? function + RPC_description.describe cctxt ~recurse:false args >>=? function | Static { services } -> begin match RPC_service.MethMap.find `POST services with | exception Not_found -> @@ -369,7 +369,7 @@ let display_answer (cctxt : #Client_commands.full_context) = function let call raw_url (cctxt : #Client_commands.full_context) = let uri = Uri.of_string raw_url in let args = String.split_path (Uri.path uri) in - Shell_services.describe cctxt ~recurse:false args >>=? function + RPC_description.describe cctxt ~recurse:false args >>=? function | Static { services } -> begin match RPC_service.MethMap.find `POST services with | exception Not_found -> diff --git a/src/lib_protocol_environment_sigs/v1/RPC_answer.mli b/src/lib_protocol_environment_sigs/v1/RPC_answer.mli index 0b78c33a6..4e3a83543 100644 --- a/src/lib_protocol_environment_sigs/v1/RPC_answer.mli +++ b/src/lib_protocol_environment_sigs/v1/RPC_answer.mli @@ -13,11 +13,11 @@ type 'o t = | `OkStream of 'o stream (* 200 *) | `Created of string option (* 201 *) | `No_content (* 204 *) - | `Unauthorized of unit option (* 401 *) - | `Forbidden of unit option (* 403 *) - | `Not_found of unit option (* 404 *) - | `Conflict of unit option (* 409 *) - | `Error of unit option (* 500 *) + | `Unauthorized of error list option (* 401 *) + | `Forbidden of error list option (* 403 *) + | `Not_found of error list option (* 404 *) + | `Conflict of error list option (* 409 *) + | `Error of error list option (* 500 *) ] and 'a stream = { @@ -27,3 +27,5 @@ and 'a stream = { val return: 'o -> 'o t Lwt.t val return_stream: 'o stream -> 'o t Lwt.t +val not_found: 'o t Lwt.t +val fail: error list -> 'a t Lwt.t diff --git a/src/lib_protocol_environment_sigs/v1/RPC_service.mli b/src/lib_protocol_environment_sigs/v1/RPC_service.mli index 0fac2a381..922eb17c7 100644 --- a/src/lib_protocol_environment_sigs/v1/RPC_service.mli +++ b/src/lib_protocol_environment_sigs/v1/RPC_service.mli @@ -16,33 +16,11 @@ type meth = [ | `PATCH ] -module MethMap : Map.S with type key = meth - type (+'meth, 'prefix, 'params, 'query, 'input, 'output) t constraint 'meth = [< meth ] type (+'meth, 'prefix, 'params, 'query, 'input, 'output) service = ('meth, 'prefix, 'params, 'query, 'input, 'output) t -val query: - ('meth, 'prefix, 'params, 'query, 'input, 'output) service -> - 'query RPC_query.t - -type _ input = - | No_input : unit input - | Input : 'input Data_encoding.t -> 'input input - -val input_encoding: - ('meth, 'prefix, 'params, 'query, 'input, 'output) service -> - 'input input - -val output_encoding: - ('meth, 'prefix, 'params, 'query, 'input, 'output) service -> - 'output Data_encoding.t - -val error_encoding: - ('meth, 'prefix, 'params, 'query, 'input, 'output) service -> - unit Data_encoding.t - val get_service: ?description: string -> query: 'query RPC_query.t -> diff --git a/src/lib_rpc/RPC_answer.ml b/src/lib_rpc/RPC_answer.ml index 06380d84d..5d12fdc51 100644 --- a/src/lib_rpc/RPC_answer.ml +++ b/src/lib_rpc/RPC_answer.ml @@ -13,11 +13,11 @@ type 'o t = | `OkStream of 'o stream (* 200 *) | `Created of string option (* 201 *) | `No_content (* 204 *) - | `Unauthorized of unit option (* 401 *) - | `Forbidden of unit option (* 403 *) - | `Not_found of unit option (* 404 *) - | `Conflict of unit option (* 409 *) - | `Error of unit option (* 500 *) + | `Unauthorized of RPC_service.error option (* 401 *) + | `Forbidden of RPC_service.error option (* 403 *) + | `Not_found of RPC_service.error option (* 404 *) + | `Conflict of RPC_service.error option (* 409 *) + | `Error of RPC_service.error option (* 500 *) ] and 'a stream = 'a Resto_directory.Answer.stream = { @@ -27,3 +27,6 @@ and 'a stream = 'a Resto_directory.Answer.stream = { let return x = Lwt.return (`Ok x) let return_stream x = Lwt.return (`OkStream x) + +let not_found = Lwt.return (`Not_found None) +let fail err = Lwt.return (`Error (Some err)) diff --git a/src/lib_rpc/RPC_answer.mli b/src/lib_rpc/RPC_answer.mli index 573cb47c9..d4940c45e 100644 --- a/src/lib_rpc/RPC_answer.mli +++ b/src/lib_rpc/RPC_answer.mli @@ -13,11 +13,11 @@ type 'o t = | `OkStream of 'o stream (* 200 *) | `Created of string option (* 201 *) | `No_content (* 204 *) - | `Unauthorized of unit option (* 401 *) - | `Forbidden of unit option (* 403 *) - | `Not_found of unit option (* 404 *) - | `Conflict of unit option (* 409 *) - | `Error of unit option (* 500 *) + | `Unauthorized of RPC_service.error option (* 401 *) + | `Forbidden of RPC_service.error option (* 403 *) + | `Not_found of RPC_service.error option (* 404 *) + | `Conflict of RPC_service.error option (* 409 *) + | `Error of RPC_service.error option (* 500 *) ] and 'a stream = 'a Resto_directory.Answer.stream = { @@ -27,3 +27,6 @@ and 'a stream = 'a Resto_directory.Answer.stream = { val return: 'o -> 'o t Lwt.t val return_stream: 'o stream -> 'o t Lwt.t +val not_found: 'o t Lwt.t + +val fail: Error_monad.error list -> 'a t Lwt.t diff --git a/src/lib_rpc/RPC_context.ml b/src/lib_rpc/RPC_context.ml index 876f8d76c..9b9e656ea 100644 --- a/src/lib_rpc/RPC_context.ml +++ b/src/lib_rpc/RPC_context.ml @@ -60,12 +60,16 @@ let of_directory (dir : unit RPC_directory.t) : t = object | None -> shutdown () ; not_found s p q end | `Not_found None -> not_found s p q - | `Unauthorized _ - | `Error _ - | `Not_found _ - | `Forbidden _ + | `Unauthorized (Some err) + | `Forbidden (Some err) + | `Not_found (Some err) + | `Conflict (Some err) + | `Error (Some err) -> Lwt.return_error err + | `Unauthorized None + | `Error None + | `Forbidden None | `Created _ - | `Conflict _ + | `Conflict None | `No_content -> generic_error s p q method call_streamed_service : 'm 'p 'q 'i 'o. ([< Resto.meth ] as 'm, unit, 'p, 'q, 'i, 'o) RPC_service.t -> @@ -85,12 +89,16 @@ let of_directory (dir : unit RPC_directory.t) : t = object on_chunk v ; on_close () ; return (fun () -> ()) | `Not_found None -> not_found s p q - | `Unauthorized _ - | `Error _ - | `Not_found (Some _) - | `Forbidden _ + | `Unauthorized (Some err) + | `Forbidden (Some err) + | `Not_found (Some err) + | `Conflict (Some err) + | `Error (Some err) -> Lwt.return_error err + | `Unauthorized None + | `Error None + | `Forbidden None | `Created _ - | `Conflict _ + | `Conflict None | `No_content -> generic_error s p q end @@ -99,11 +107,6 @@ let make_call1 s ctxt x = make_call s ctxt ((), x) let make_call2 s ctxt x y = make_call s ctxt (((), x), y) let make_call3 s ctxt x y z = make_call s ctxt ((((), x), y), z) -let make_err_call s ctxt p q i = - make_call s ctxt p q i >>=? Lwt.return -let make_err_call1 s ctxt x = make_err_call s ctxt ((), x) -let make_err_call2 s ctxt x y = make_err_call s ctxt (((), x), y) - type stopper = unit -> unit let make_streamed_call s (ctxt : #streamed) p q i = diff --git a/src/lib_rpc/RPC_context.mli b/src/lib_rpc/RPC_context.mli index 44d96fba5..3469bd750 100644 --- a/src/lib_rpc/RPC_context.mli +++ b/src/lib_rpc/RPC_context.mli @@ -54,18 +54,6 @@ val make_call3 : ([< Resto.meth ], unit, ((unit * 'a) * 'b) * 'c, 'q, 'i, 'o) RPC_service.t -> #simple -> 'a -> 'b -> 'c -> 'q -> 'i -> 'o tzresult Lwt.t -val make_err_call : - ([< Resto.meth ], unit, 'p, 'q, 'i, 'o tzresult) RPC_service.t -> - #simple -> 'p -> 'q -> 'i -> 'o tzresult Lwt.t - -val make_err_call1 : - ([< Resto.meth ], unit, unit * 'a, 'q, 'i, 'o tzresult) RPC_service.t -> - #simple -> 'a -> 'q -> 'i -> 'o tzresult Lwt.t - -val make_err_call2 : - ([< Resto.meth ], unit, (unit * 'a) * 'b, 'q, 'i, 'o tzresult) RPC_service.t -> - #simple -> 'a -> 'b -> 'q -> 'i -> 'o tzresult Lwt.t - type stopper = unit -> unit val make_streamed_call : diff --git a/src/lib_rpc/RPC_description.ml b/src/lib_rpc/RPC_description.ml index c808c572f..dde9d5cca 100644 --- a/src/lib_rpc/RPC_description.ml +++ b/src/lib_rpc/RPC_description.ml @@ -9,3 +9,6 @@ include Resto.Description +let describe ctxt ?(recurse = false) path = + RPC_context.make_call1 + RPC_service.description_service ctxt path { recurse } () diff --git a/src/lib_rpc/RPC_description.mli b/src/lib_rpc/RPC_description.mli index 7106dee1e..061606287 100644 --- a/src/lib_rpc/RPC_description.mli +++ b/src/lib_rpc/RPC_description.mli @@ -7,4 +7,13 @@ (* *) (**************************************************************************) +open Error_monad + include (module type of struct include Resto.Description end) + +val describe: + #RPC_context.simple -> + ?recurse:bool -> + string list -> + Json_schema.schema directory tzresult Lwt.t + diff --git a/src/lib_rpc/RPC_directory.ml b/src/lib_rpc/RPC_directory.ml index eabd8cb21..6f9f935b6 100644 --- a/src/lib_rpc/RPC_directory.ml +++ b/src/lib_rpc/RPC_directory.ml @@ -7,4 +7,56 @@ (* *) (**************************************************************************) +open Error_monad + include Resto_directory.Make(RPC_encoding) + +let gen_register dir service handler = + register dir service + (fun p q i -> + Lwt.catch + (fun () -> handler p q i) + (function + | Not_found -> RPC_answer.not_found + | exn -> RPC_answer.fail [Exn exn])) + +let gen_register = + (gen_register + : _ -> _ -> (_ -> _ -> _ -> _ RPC_answer.t Lwt.t) -> _ + :> _ -> _ -> (_ -> _ -> _ -> [< _ RPC_answer.t ] Lwt.t) -> _) + +let register dir service handler = + gen_register dir service + (fun p q i -> + handler p q i >>= function + | Ok o -> RPC_answer.return o + | Error e -> RPC_answer.fail e) + +let lwt_register dir service handler = + gen_register dir service + (fun p q i -> + handler p q i >>= fun o -> + RPC_answer.return o) + +open Curry + +let register0 root s f = register root s (curry Z f) +let register1 root s f = register root s (curry (S Z) f) +let register2 root s f = register root s (curry (S (S Z)) f) +let register3 root s f = register root s (curry (S (S (S Z))) f) +let register4 root s f = register root s (curry (S (S (S (S Z)))) f) +let register5 root s f = register root s (curry (S (S (S (S (S Z))))) f) + +let gen_register0 root s f = gen_register root s (curry Z f) +let gen_register1 root s f = gen_register root s (curry (S Z) f) +let gen_register2 root s f = gen_register root s (curry (S (S Z)) f) +let gen_register3 root s f = gen_register root s (curry (S (S (S Z))) f) +let gen_register4 root s f = gen_register root s (curry (S (S (S (S Z)))) f) +let gen_register5 root s f = gen_register root s (curry (S (S (S (S (S Z))))) f) + +let lwt_register0 root s f = lwt_register root s (curry Z f) +let lwt_register1 root s f = lwt_register root s (curry (S Z) f) +let lwt_register2 root s f = lwt_register root s (curry (S (S Z)) f) +let lwt_register3 root s f = lwt_register root s (curry (S (S (S Z))) f) +let lwt_register4 root s f = lwt_register root s (curry (S (S (S (S Z)))) f) +let lwt_register5 root s f = lwt_register root s (curry (S (S (S (S (S Z))))) f) diff --git a/src/lib_rpc/RPC_directory.mli b/src/lib_rpc/RPC_directory.mli index 56521a316..d5fdb9847 100644 --- a/src/lib_rpc/RPC_directory.mli +++ b/src/lib_rpc/RPC_directory.mli @@ -7,48 +7,139 @@ (* *) (**************************************************************************) +open Error_monad + include module type of (struct include Resto_directory.Make(RPC_encoding) end) (** Registring handler in service tree. *) val register: + 'prefix directory -> + ([< Resto.meth ], 'prefix, 'p, 'q, 'i, 'o) RPC_service.t -> + ('p -> 'q -> 'i -> 'o tzresult Lwt.t) -> + 'prefix directory + +val gen_register: 'prefix directory -> ('meth, 'prefix, 'params, 'query, 'input, 'output) RPC_service.t -> ('params -> 'query -> 'input -> [< 'output RPC_answer.t ] Lwt.t) -> 'prefix directory +val lwt_register: + 'prefix directory -> + ([< Resto.meth ], 'prefix, 'p, 'q, 'i, 'o) RPC_service.t -> + ('p -> 'q -> 'i -> 'o Lwt.t) -> + 'prefix directory + (** Registring handler in service tree. Curryfied variant. *) + val register0: unit directory -> ('m, unit, unit, 'q, 'i, 'o) RPC_service.t -> - ('q -> 'i -> [< 'o RPC_answer.t ] Lwt.t) -> + ('q -> 'i -> 'o tzresult Lwt.t) -> unit directory val register1: 'prefix directory -> ('m, 'prefix, unit * 'a, 'q , 'i, 'o) RPC_service.t -> - ('a -> 'q -> 'i -> [< 'o RPC_answer.t ] Lwt.t) -> + ('a -> 'q -> 'i -> 'o tzresult Lwt.t) -> 'prefix directory val register2: 'prefix directory -> ('m, 'prefix, (unit * 'a) * 'b, 'q , 'i, 'o) RPC_service.t -> - ('a -> 'b -> 'q -> 'i -> [< 'o RPC_answer.t ] Lwt.t) -> + ('a -> 'b -> 'q -> 'i -> 'o tzresult Lwt.t) -> 'prefix directory val register3: 'prefix directory -> ('m, 'prefix, ((unit * 'a) * 'b) * 'c, 'q , 'i, 'o) RPC_service.t -> - ('a -> 'b -> 'c -> 'q -> 'i -> [< 'o RPC_answer.t ] Lwt.t) -> + ('a -> 'b -> 'c -> 'q -> 'i -> 'o tzresult Lwt.t) -> 'prefix directory val register4: 'prefix directory -> ('m, 'prefix, (((unit * 'a) * 'b) * 'c) * 'd, 'q , 'i, 'o) RPC_service.t -> - ('a -> 'b -> 'c -> 'd -> 'q -> 'i -> [< 'o RPC_answer.t ] Lwt.t) -> + ('a -> 'b -> 'c -> 'd -> 'q -> 'i -> 'o tzresult Lwt.t) -> 'prefix directory val register5: + 'prefix directory -> + ('m, 'prefix, ((((unit * 'a) * 'b) * 'c) * 'd) * 'e, 'q , 'i, 'o) RPC_service.t -> + ('a -> 'b -> 'c -> 'd -> 'e -> 'q -> 'i -> 'o tzresult Lwt.t) -> + 'prefix directory + + +val gen_register0: + unit directory -> + ('m, unit, unit, 'q, 'i, 'o) RPC_service.t -> + ('q -> 'i -> [< 'o RPC_answer.t ] Lwt.t) -> + unit directory + +val gen_register1: + 'prefix directory -> + ('m, 'prefix, unit * 'a, 'q , 'i, 'o) RPC_service.t -> + ('a -> 'q -> 'i -> [< 'o RPC_answer.t ] Lwt.t) -> + 'prefix directory + +val gen_register2: + 'prefix directory -> + ('m, 'prefix, (unit * 'a) * 'b, 'q , 'i, 'o) RPC_service.t -> + ('a -> 'b -> 'q -> 'i -> [< 'o RPC_answer.t ] Lwt.t) -> + 'prefix directory + +val gen_register3: + 'prefix directory -> + ('m, 'prefix, ((unit * 'a) * 'b) * 'c, 'q , 'i, 'o) RPC_service.t -> + ('a -> 'b -> 'c -> 'q -> 'i -> [< 'o RPC_answer.t ] Lwt.t) -> + 'prefix directory + +val gen_register4: + 'prefix directory -> + ('m, 'prefix, (((unit * 'a) * 'b) * 'c) * 'd, 'q , 'i, 'o) RPC_service.t -> + ('a -> 'b -> 'c -> 'd -> 'q -> 'i -> [< 'o RPC_answer.t ] Lwt.t) -> + 'prefix directory + +val gen_register5: 'prefix directory -> ('m, 'prefix, ((((unit * 'a) * 'b) * 'c) * 'd) * 'e, 'q , 'i, 'o) RPC_service.t -> ('a -> 'b -> 'c -> 'd -> 'e -> 'q -> 'i -> [< 'o RPC_answer.t ] Lwt.t) -> 'prefix directory + + +val lwt_register0: + unit directory -> + ('m, unit, unit, 'q, 'i, 'o) RPC_service.t -> + ('q -> 'i -> 'o Lwt.t) -> + unit directory + +val lwt_register1: + 'prefix directory -> + ('m, 'prefix, unit * 'a, 'q , 'i, 'o) RPC_service.t -> + ('a -> 'q -> 'i -> 'o Lwt.t) -> + 'prefix directory + +val lwt_register2: + 'prefix directory -> + ('m, 'prefix, (unit * 'a) * 'b, 'q , 'i, 'o) RPC_service.t -> + ('a -> 'b -> 'q -> 'i -> 'o Lwt.t) -> + 'prefix directory + +val lwt_register3: + 'prefix directory -> + ('m, 'prefix, ((unit * 'a) * 'b) * 'c, 'q , 'i, 'o) RPC_service.t -> + ('a -> 'b -> 'c -> 'q -> 'i -> 'o Lwt.t) -> + 'prefix directory + +val lwt_register4: + 'prefix directory -> + ('m, 'prefix, (((unit * 'a) * 'b) * 'c) * 'd, 'q , 'i, 'o) RPC_service.t -> + ('a -> 'b -> 'c -> 'd -> 'q -> 'i -> 'o Lwt.t) -> + 'prefix directory + +val lwt_register5: + 'prefix directory -> + ('m, 'prefix, ((((unit * 'a) * 'b) * 'c) * 'd) * 'e, 'q , 'i, 'o) RPC_service.t -> + ('a -> 'b -> 'c -> 'd -> 'e -> 'q -> 'i -> 'o Lwt.t) -> + 'prefix directory + + diff --git a/src/lib_rpc/RPC_error.ml b/src/lib_rpc/RPC_error.ml index cbce5262a..d9eae134f 100644 --- a/src/lib_rpc/RPC_error.ml +++ b/src/lib_rpc/RPC_error.ml @@ -7,44 +7,7 @@ (* *) (**************************************************************************) -let service = - RPC_service.post_service - ~description: "Schema for all the RPC errors from the shell" - ~query: RPC_query.empty - ~input: Data_encoding.empty - ~output: Data_encoding.json_schema - RPC_path.(root / "errors") +let list ctxt = + RPC_context.make_call RPC_service.error_service ctxt () () () -let encoding = - let { RPC_service.meth ; uri ; _ } = - RPC_service.forge_request service () () in - let open Data_encoding in - describe - ~description: - (Printf.sprintf - "The full list of error is available with \ - the global RPC `%s %s`" - (RPC_service.string_of_meth meth) (Uri.path_and_query uri)) - (conv - ~schema:Json_schema.any - (fun exn -> `A (List.map Error_monad.json_of_error exn)) - (function `A exns -> List.map Error_monad.error_of_json exns | _ -> []) - json) - -let wrap param_encoding = - let open Data_encoding in - union [ - case (Tag 0) - (obj1 (req "ok" param_encoding)) - (function Ok x -> Some x | _ -> None) - (fun x -> Ok x) ; - case (Tag 1) - (obj1 (req "error" encoding)) - (function Error x -> Some x | _ -> None) - (fun x -> Error x) ; - ] - -module F = struct - open RPC_context - let schema ctxt = make_call service ctxt () () () -end +let encoding = RPC_service.error_encoding diff --git a/src/lib_rpc/RPC_error.mli b/src/lib_rpc/RPC_error.mli index 0a80e4dfb..8096f7446 100644 --- a/src/lib_rpc/RPC_error.mli +++ b/src/lib_rpc/RPC_error.mli @@ -9,12 +9,6 @@ open Error_monad -val service: - ([ `POST ], unit, unit, unit, unit, Json_schema.schema) RPC_service.t -val encoding: error list Data_encoding.t -val wrap: 'a Data_encoding.t -> 'a tzresult Data_encoding.encoding +val list: #RPC_context.simple -> Json_schema.schema tzresult Lwt.t -module F : sig - open RPC_context - val schema: #simple -> Json_schema.schema tzresult Lwt.t -end +val encoding: error list Data_encoding.t diff --git a/src/lib_rpc/RPC_service.ml b/src/lib_rpc/RPC_service.ml index 4a647689f..c6ced6336 100644 --- a/src/lib_rpc/RPC_service.ml +++ b/src/lib_rpc/RPC_service.ml @@ -28,12 +28,14 @@ type (+'m,'pr,'p,'q,'i,'o, 'e) raw = ('m,'pr,'p,'q,'i,'o, 'e) Resto.MakeService(RPC_encoding).t constraint 'meth = [< meth ] +type error = Error_monad.error list + type (+'meth, 'prefix, 'params, 'query, 'input, 'output) t = - ('meth, 'prefix, 'params, 'query, 'input, 'output, unit) raw + ('meth, 'prefix, 'params, 'query, 'input, 'output, error) raw constraint 'meth = [< meth ] type (+'meth, 'prefix, 'params, 'query, 'input, 'output) service = - ('meth, 'prefix, 'params, 'query, 'input, 'output, unit) raw + ('meth, 'prefix, 'params, 'query, 'input, 'output, error) raw constraint 'meth = [< meth ] include (Resto.MakeService(RPC_encoding) @@ -42,8 +44,47 @@ include (Resto.MakeService(RPC_encoding) and type (+'m,'pr,'p,'q,'i,'o, 'e) service := ('m,'pr,'p,'q,'i,'o, 'e) raw) ) -let get_service = get_service ~error:Data_encoding.empty -let post_service = post_service ~error:Data_encoding.empty -let delete_service = delete_service ~error:Data_encoding.empty -let patch_service = patch_service ~error:Data_encoding.empty -let put_service = put_service ~error:Data_encoding.empty + +let error_path = ref None + +let error_encoding = + let open Data_encoding in + delayed begin fun () -> + let { meth ; uri ; _ } = + match !error_path with + | None -> assert false + | Some p -> p in + describe + ~description: + (Printf.sprintf + "The full list of error is available with \ + the global RPC `%s %s`" + (string_of_meth meth) (Uri.path_and_query uri)) + (conv + ~schema:Json_schema.any + (fun exn -> `A (List.map Error_monad.json_of_error exn)) + (function `A exns -> List.map Error_monad.error_of_json exns | _ -> []) + json) + end + +let get_service = get_service ~error:error_encoding +let post_service = post_service ~error:error_encoding +let delete_service = delete_service ~error:error_encoding +let patch_service = patch_service ~error:error_encoding +let put_service = put_service ~error:error_encoding + +let error_service = + post_service + ~description: "Schema for all the RPC errors from the shell" + ~query: RPC_query.empty + ~input: Data_encoding.empty + ~output: Data_encoding.json_schema + RPC_path.(root / "errors") + +let () = error_path := Some (forge_request error_service () ()) + +let description_service = + description_service + ~description: "RPCs documentation and input/output schema" + error_encoding + RPC_path.(root / "describe") diff --git a/src/lib_rpc/RPC_service.mli b/src/lib_rpc/RPC_service.mli index 3f5007daf..58a506994 100644 --- a/src/lib_rpc/RPC_service.mli +++ b/src/lib_rpc/RPC_service.mli @@ -19,12 +19,14 @@ type (+'m,'pr,'p,'q,'i,'o, 'e) raw = ('m,'pr,'p,'q,'i,'o, 'e) Resto.MakeService(RPC_encoding).t constraint 'meth = [< meth ] +type error = Error_monad.error list + type (+'meth, 'prefix, 'params, 'query, 'input, 'output) t = - ('meth, 'prefix, 'params, 'query, 'input, 'output, unit) raw + ('meth, 'prefix, 'params, 'query, 'input, 'output, error) raw constraint 'meth = [< meth ] type (+'meth, 'prefix, 'params, 'query, 'input, 'output) service = - ('meth, 'prefix, 'params, 'query, 'input, 'output, unit) raw + ('meth, 'prefix, 'params, 'query, 'input, 'output, error) raw constraint 'meth = [< meth ] include (module type of struct include Resto.MakeService(RPC_encoding) end @@ -68,3 +70,15 @@ val put_service: output: 'output Data_encoding.t -> ('prefix, 'params) RPC_path.t -> ([ `PUT ], 'prefix, 'params, 'query, 'input, 'output) service + + +(**/**) + +val description_service: + ([ `GET ], unit, unit * string list, Resto.Description.request, + unit, Json_schema.schema Resto.Description.directory) service + +val error_service: + ([ `POST ], unit, unit, unit, unit, Json_schema.schema) service + +val error_encoding: error Data_encoding.t diff --git a/src/lib_rpc_http/RPC_client.ml b/src/lib_rpc_http/RPC_client.ml index cc4f71265..99f524883 100644 --- a/src/lib_rpc_http/RPC_client.ml +++ b/src/lib_rpc_http/RPC_client.ml @@ -331,8 +331,10 @@ let handle accept (meth, uri, ans) = | `Ok (Some v) -> return v | `Ok None -> request_failed meth uri Empty_answer | `Not_found None -> fail (RPC_context.Not_found { meth ; uri }) - | `Conflict _ | `Error _ | `Forbidden _ | `Unauthorized _ - | `Not_found (Some _) -> + | `Conflict (Some err) | `Error (Some err) + | `Forbidden (Some err) | `Unauthorized (Some err) + | `Not_found (Some err) -> Lwt.return_error err + | `Conflict None | `Error None | `Forbidden None | `Unauthorized None -> fail (RPC_context.Generic_error { meth ; uri }) | `Unexpected_status_code (code, (content, _, media_type)) -> let media_type = Option.map media_type ~f:Media_type.name in diff --git a/src/lib_shell/node_rpc.ml b/src/lib_shell/node_rpc.ml index 49a7d8373..7c5439b4b 100644 --- a/src/lib_shell/node_rpc.ml +++ b/src/lib_shell/node_rpc.ml @@ -40,63 +40,63 @@ let register_bi_dir node dir = let dir = let implementation b () include_ops = Node.RPC.block_info node b >>= fun bi -> - RPC_answer.return (filter_bi include_ops bi) in + return (filter_bi include_ops bi) in RPC_directory.register1 dir Block_services.S.info implementation in let dir = let implementation b () () = Node.RPC.block_info node b >>= fun bi -> - RPC_answer.return bi.hash in + return bi.hash in RPC_directory.register1 dir Block_services.S.hash implementation in let dir = let implementation b () () = Node.RPC.block_info node b >>= fun bi -> - RPC_answer.return bi.net_id in + return bi.net_id in RPC_directory.register1 dir Block_services.S.net_id implementation in let dir = let implementation b () () = Node.RPC.block_info node b >>= fun bi -> - RPC_answer.return bi.level in + return bi.level in RPC_directory.register1 dir Block_services.S.level implementation in let dir = let implementation b () () = Node.RPC.block_info node b >>= fun bi -> - RPC_answer.return bi.predecessor in + return bi.predecessor in RPC_directory.register1 dir Block_services.S.predecessor implementation in let dir = let implementation b () len = Node.RPC.block_info node b >>= fun bi -> Node.RPC.predecessors node len bi.hash >>= fun hashes -> - RPC_answer.return hashes in + return hashes in RPC_directory.register1 dir Block_services.S.predecessors implementation in let dir = let implementation b () () = Node.RPC.block_info node b >>= fun bi -> - RPC_answer.return bi.fitness in + return bi.fitness in RPC_directory.register1 dir Block_services.S.fitness implementation in let dir = let implementation b () () = Node.RPC.block_info node b >>= fun bi -> - RPC_answer.return bi.timestamp in + return bi.timestamp in RPC_directory.register1 dir Block_services.S.timestamp implementation in let dir = let implementation b () () = Node.RPC.block_info node b >>= fun bi -> - RPC_answer.return bi.protocol in + return bi.protocol in RPC_directory.register1 dir Block_services.S.protocol implementation in let dir = let implementation b () () = Node.RPC.block_info node b >>= fun bi -> - RPC_answer.return bi.test_network in + return bi.test_network in RPC_directory.register1 dir Block_services.S.test_network implementation in let dir = @@ -114,12 +114,12 @@ let register_bi_dir node dir = RPC_answer.return @@ List.map (List.map (fun h -> h, None)) hashes in - RPC_directory.register1 dir + RPC_directory.gen_register1 dir Block_services.S.operations implementation in let dir = let implementation b () () = Node.RPC.pending_operations node b >>= fun res -> - RPC_answer.return res in + return res in RPC_directory.register1 dir Block_services.S.pending_operations implementation in @@ -129,11 +129,9 @@ let register_bi_dir node dir = { Block_services.S.operations ; sort_operations ; timestamp ; proto_header} = Node.RPC.preapply node b - ~timestamp ~proto_header ~sort_operations operations >>= function - | Ok (shell_header, operations) -> - RPC_answer.return - (Ok { Block_services.shell_header ; operations }) - | Error _ as err -> RPC_answer.return err in + ~timestamp ~proto_header ~sort_operations operations + >>=? fun (shell_header, operations) -> + return { Block_services.shell_header ; operations } in RPC_directory.register1 dir Block_services.S.preapply implementation in dir @@ -324,12 +322,10 @@ let list_blocks end let list_invalid node () () = - Node.RPC.list_invalid node >>= fun l -> - RPC_answer.return l + Node.RPC.list_invalid node >>= return let unmark_invalid node block () () = - Node.RPC.unmark_invalid node block >>= fun x -> - RPC_answer.return x + Node.RPC.unmark_invalid node block let list_protocols node () { Protocol_services.S.monitor ; contents } = let monitor = match monitor with None -> false | Some x -> x in @@ -363,14 +359,12 @@ let list_protocols node () { Protocol_services.S.monitor ; contents } = RPC_answer.return_stream { next ; shutdown } let get_protocols node hash () () = - Node.RPC.protocol_content node hash >>= function - | Ok bytes -> RPC_answer.return bytes - | Error _ -> raise Not_found + Node.RPC.protocol_content node hash let build_rpc_directory node = let dir = RPC_directory.empty in let dir = - RPC_directory.register0 dir Block_services.S.list + RPC_directory.gen_register0 dir Block_services.S.list (list_blocks node) in let dir = RPC_directory.register0 dir Block_services.S.list_invalid @@ -391,7 +385,7 @@ let build_rpc_directory node = "All the RPCs which are specific to the protocol version." dir Block_services.S.proto_path implementation in let dir = - RPC_directory.register0 dir Protocol_services.S.list + RPC_directory.gen_register0 dir Protocol_services.S.list (list_protocols node) in let dir = RPC_directory.register1 dir Protocol_services.S.contents @@ -401,7 +395,7 @@ let build_rpc_directory node = let res = Data_encoding.Binary.to_bytes Block_header.encoding header in RPC_answer.return res in - RPC_directory.register0 dir Shell_services.S.forge_block_header + RPC_directory.gen_register0 dir Shell_services.S.forge_block_header implementation in let dir = let implementation () @@ -411,7 +405,7 @@ let build_rpc_directory node = node ~force raw operations >>=? fun (hash, wait) -> (if blocking then wait else return ()) >>=? fun () -> return hash - end >>= RPC_answer.return in + end in RPC_directory.register0 dir Shell_services.S.inject_block implementation in let dir = let implementation () (contents, blocking, net_id) = @@ -419,39 +413,36 @@ let build_rpc_directory node = node ?net_id contents >>= fun (hash, wait) -> begin (if blocking then wait else return ()) >>=? fun () -> return hash - end >>= RPC_answer.return in + end in RPC_directory.register0 dir Shell_services.S.inject_operation implementation in let dir = let implementation () (proto, blocking, force) = Node.RPC.inject_protocol ?force node proto >>= fun (hash, wait) -> begin (if blocking then wait else return ()) >>=? fun () -> return hash - end >>= RPC_answer.return in + end in RPC_directory.register0 dir Shell_services.S.inject_protocol implementation in let dir = let implementation () () = RPC_answer.return_stream (Node.RPC.bootstrapped node) in - RPC_directory.register0 dir Shell_services.S.bootstrapped implementation in + RPC_directory.gen_register0 dir Shell_services.S.bootstrapped implementation in let dir = let implementation () () = - RPC_answer.return - Data_encoding.Json.(schema Error_monad.error_encoding) in - RPC_directory.register0 dir RPC_error.service implementation in + return Data_encoding.Json.(schema Error_monad.error_encoding) in + RPC_directory.register0 dir RPC_service.error_service implementation in let dir = RPC_directory.register1 dir Shell_services.S.complete - (fun s () () -> - Node.RPC.complete node s >>= RPC_answer.return) in + (fun s () () -> Node.RPC.complete node s >>= return) in let dir = RPC_directory.register2 dir Block_services.S.complete - (fun block s () () -> - Node.RPC.complete node ~block s >>= RPC_answer.return) in + (fun block s () () -> Node.RPC.complete node ~block s >>= return) in (* Workers : Prevalidators *) let dir = RPC_directory.register0 dir Worker_services.Prevalidators.S.list (fun () () -> - RPC_answer.return + return (List.map (fun (id, w) -> (id, Prevalidator.status w)) (Prevalidator.running_workers ()))) in @@ -459,7 +450,7 @@ let build_rpc_directory node = RPC_directory.register1 dir Worker_services.Prevalidators.S.state (fun net_id () () -> let w = List.assoc net_id (Prevalidator.running_workers ()) in - RPC_answer.return + return { Worker_types.status = Prevalidator.status w ; pending_requests = Prevalidator.pending_requests w ; backlog = Prevalidator.last_events w ; @@ -471,7 +462,7 @@ let build_rpc_directory node = RPC_directory.register0 dir Worker_services.Block_validator.S.state (fun () () -> let w = Block_validator.running_worker () in - RPC_answer.return + return { Worker_types.status = Block_validator.status w ; pending_requests = Block_validator.pending_requests w ; backlog = Block_validator.last_events w ; @@ -482,7 +473,7 @@ let build_rpc_directory node = let dir = RPC_directory.register1 dir Worker_services.Peer_validators.S.list (fun net_id () () -> - RPC_answer.return + return (List.filter_map (fun ((id, peer_id), w) -> if Net_id.equal id net_id then @@ -493,7 +484,7 @@ let build_rpc_directory node = RPC_directory.register2 dir Worker_services.Peer_validators.S.state (fun net_id peer_id () () -> let w = List.assoc (net_id, peer_id) (Peer_validator.running_workers ()) in - RPC_answer.return + return { Worker_types.status = Peer_validator.status w ; pending_requests = [] ; backlog = Peer_validator.last_events w ; @@ -504,7 +495,7 @@ let build_rpc_directory node = let dir = RPC_directory.register0 dir Worker_services.Net_validators.S.list (fun () () -> - RPC_answer.return + return (List.map (fun (id, w) -> (id, Net_validator.status w)) (Net_validator.running_workers ()))) in @@ -512,7 +503,7 @@ let build_rpc_directory node = RPC_directory.register1 dir Worker_services.Net_validators.S.state (fun net_id () () -> let w = List.assoc net_id (Net_validator.running_workers ()) in - RPC_answer.return + return { Worker_types.status = Net_validator.status w ; pending_requests = Net_validator.pending_requests w ; backlog = Net_validator.last_events w ; @@ -521,11 +512,11 @@ let build_rpc_directory node = (* Network : Global *) let dir = - let implementation () () = Node.RPC.Network.stat node |> RPC_answer.return in + let implementation () () = Node.RPC.Network.stat node |> return in RPC_directory.register0 dir P2p_services.S.stat implementation in let dir = let implementation () () = - RPC_answer.return Distributed_db.Raw.supported_versions in + return Distributed_db.Raw.supported_versions in RPC_directory.register0 dir P2p_services.S.versions implementation in let dir = let implementation () () = @@ -533,10 +524,10 @@ let build_rpc_directory node = let shutdown () = Lwt_watcher.shutdown stopper in let next () = Lwt_stream.get stream in RPC_answer.return_stream { next ; shutdown } in - RPC_directory.register0 dir P2p_services.S.events implementation in + RPC_directory.gen_register0 dir P2p_services.S.events implementation in let dir = let implementation point () timeout = - Node.RPC.Network.connect node point timeout >>= RPC_answer.return in + Node.RPC.Network.connect node point timeout in RPC_directory.register1 dir P2p_services.S.connect implementation in (* Network : Connection *) @@ -545,28 +536,28 @@ let build_rpc_directory node = let implementation peer_id () () = match Node.RPC.Network.Connection.info node peer_id with | None -> raise Not_found - | Some v -> RPC_answer.return v in + | Some v -> return v in RPC_directory.register1 dir P2p_services.Connections.S.info implementation in let dir = let implementation peer_id () wait = - Node.RPC.Network.Connection.kick node peer_id wait >>= RPC_answer.return in + Node.RPC.Network.Connection.kick node peer_id wait >>= return in RPC_directory.register1 dir P2p_services.Connections.S.kick implementation in let dir = let implementation () () = - Node.RPC.Network.Connection.list node |> RPC_answer.return in + Node.RPC.Network.Connection.list node |> return in RPC_directory.register0 dir P2p_services.Connections.S.list implementation in (* Network : Peer_id *) let dir = let implementation () state = - Node.RPC.Network.Peer_id.list node ~restrict:state |> RPC_answer.return in + Node.RPC.Network.Peer_id.list node ~restrict:state |> return in RPC_directory.register0 dir P2p_services.Peers.S.list implementation in let dir = let implementation peer_id () () = match Node.RPC.Network.Peer_id.info node peer_id with | None -> raise Not_found - | Some v -> RPC_answer.return v in + | Some v -> return v in RPC_directory.register1 dir P2p_services.Peers.S.info implementation in let dir = let implementation peer_id () monitor = @@ -584,19 +575,19 @@ let build_rpc_directory node = RPC_answer.return_stream { next ; shutdown } else Node.RPC.Network.Peer_id.events node peer_id |> RPC_answer.return in - RPC_directory.register1 dir P2p_services.Peers.S.events implementation in + RPC_directory.gen_register1 dir P2p_services.Peers.S.events implementation in (* Network : Point *) let dir = let implementation () state = - Node.RPC.Network.Point.list node ~restrict:state |> RPC_answer.return in + Node.RPC.Network.Point.list node ~restrict:state |> return in RPC_directory.register0 dir P2p_services.Points.S.list implementation in let dir = let implementation point () () = match Node.RPC.Network.Point.info node point with | None -> raise Not_found - | Some v -> RPC_answer.return v in + | Some v -> return v in RPC_directory.register1 dir P2p_services.Points.S.info implementation in let dir = let implementation point () monitor = @@ -614,7 +605,7 @@ let build_rpc_directory node = RPC_answer.return_stream { next ; shutdown } else Node.RPC.Network.Point.events node point |> RPC_answer.return in - RPC_directory.register1 dir P2p_services.Points.S.events implementation in + RPC_directory.gen_register1 dir P2p_services.Points.S.events implementation in let dir = - RPC_directory.register_describe_directory_service dir Shell_services.S.describe in + RPC_directory.register_describe_directory_service dir RPC_service.description_service in dir diff --git a/src/lib_shell_services/block_services.ml b/src/lib_shell_services/block_services.ml index 71b9e1fb6..df049a420 100644 --- a/src/lib_shell_services/block_services.ml +++ b/src/lib_shell_services/block_services.ml @@ -303,7 +303,7 @@ module S = struct the given operations and return the resulting fitness." ~query: RPC_query.empty ~input: preapply_param_encoding - ~output: (RPC_error.wrap preapply_result_encoding) + ~output: preapply_result_encoding RPC_path.(block_path / "preapply") let complete = @@ -416,7 +416,7 @@ module S = struct "Unmark an invalid block" ~query: RPC_query.empty ~input: Data_encoding.empty - ~output:(RPC_error.wrap Data_encoding.empty) + ~output: Data_encoding.empty RPC_path.(root / "invalid_blocks" /: Block_hash.rpc_arg / "unmark" ) end @@ -458,11 +458,11 @@ let complete ctxt b s = make_call2 S.complete ctxt b s () () let preapply ctxt h ?(timestamp = Time.now ()) ?(sort = false) ~proto_header operations = - make_err_call1 S.preapply ctxt h () + make_call1 S.preapply ctxt h () { timestamp ; proto_header ; sort_operations = sort ; operations } let unmark_invalid ctxt h = - make_err_call1 S.unmark_invalid ctxt h () () + make_call1 S.unmark_invalid ctxt h () () let list_invalid ctxt = make_call S.list_invalid ctxt () () () diff --git a/src/lib_shell_services/block_services.mli b/src/lib_shell_services/block_services.mli index 5b2ce037b..d133b2789 100644 --- a/src/lib_shell_services/block_services.mli +++ b/src/lib_shell_services/block_services.mli @@ -189,7 +189,7 @@ module S : sig val unmark_invalid: ([ `POST ], unit, unit * Block_hash.t, unit, unit, - unit tzresult) RPC_service.t + unit) RPC_service.t type preapply_param = { timestamp: Time.t ; @@ -201,7 +201,7 @@ module S : sig val preapply: ([ `POST ], unit, unit * block, unit, preapply_param, - preapply_result tzresult) RPC_service.t + preapply_result) RPC_service.t val complete: ([ `POST ], unit, diff --git a/src/lib_shell_services/p2p_services.ml b/src/lib_shell_services/p2p_services.ml index a96ccf6d1..a3cba92be 100644 --- a/src/lib_shell_services/p2p_services.ml +++ b/src/lib_shell_services/p2p_services.ml @@ -38,7 +38,7 @@ module S = struct ~description:"Connect to a peer" ~query: RPC_query.empty ~input: Data_encoding.(obj1 (dft "timeout" float 5.)) - ~output: (RPC_error.wrap Data_encoding.empty) + ~output: Data_encoding.empty RPC_path.(root / "network" / "connect" /: P2p_point.Id.rpc_arg) end @@ -48,7 +48,7 @@ let stat ctxt = make_call S.stat ctxt () () () let versions ctxt = make_call S.versions ctxt () () () let events ctxt = make_streamed_call S.events ctxt () () () let connect ctxt ~timeout peer_id = - make_err_call1 S.connect ctxt peer_id () timeout + make_call1 S.connect ctxt peer_id () timeout let monitor_encoding = Data_encoding.(obj1 (dft "monitor" bool false)) diff --git a/src/lib_shell_services/p2p_services.mli b/src/lib_shell_services/p2p_services.mli index 827398a9b..dad4faac9 100644 --- a/src/lib_shell_services/p2p_services.mli +++ b/src/lib_shell_services/p2p_services.mli @@ -38,7 +38,7 @@ module S : sig val connect : ([ `POST ], unit, unit * P2p_point.Id.t, unit, float, - unit tzresult) RPC_service.t + unit) RPC_service.t end diff --git a/src/lib_shell_services/shell_services.ml b/src/lib_shell_services/shell_services.ml index 4fc1d63df..1d9a310fe 100644 --- a/src/lib_shell_services/shell_services.ml +++ b/src/lib_shell_services/shell_services.ml @@ -66,9 +66,7 @@ module S = struct validated before answering." ~query: RPC_query.empty ~input: inject_block_param - ~output: - (RPC_error.wrap @@ - (obj1 (req "block_hash" Block_hash.encoding))) + ~output: (obj1 (req "block_hash" Block_hash.encoding)) RPC_path.(root / "inject_block") let inject_operation = @@ -96,8 +94,7 @@ module S = struct true) (opt "net_id" Net_id.encoding)) ~output: - (RPC_error.wrap @@ - describe + (describe ~title: "Hash of the injected operation" @@ (obj1 (req "injectedOperation" Operation_hash.encoding))) RPC_path.(root / "inject_operation") @@ -124,8 +121,7 @@ module S = struct "Should we inject protocol that is invalid. (default: false)" bool))) ~output: - (RPC_error.wrap @@ - describe + (describe ~title: "Hash of the injected protocol" @@ (obj1 (req "injectedProtocol" Protocol_hash.encoding))) RPC_path.(root / "inject_protocol") @@ -154,11 +150,6 @@ module S = struct ~output: (list string) RPC_path.(root / "complete" /: prefix_arg ) - let describe = - RPC_service.description_service - ~description: "RPCs documentation and input/output schema" - RPC_path.(root / "describe") - end open RPC_context @@ -169,15 +160,15 @@ let forge_block_header ctxt header = let inject_block ctxt ?(async = false) ?(force = false) ?net_id raw operations = - make_err_call S.inject_block ctxt () () + make_call S.inject_block ctxt () () { raw ; blocking = not async ; force ; net_id ; operations } let inject_operation ctxt ?(async = false) ?net_id operation = - make_err_call S.inject_operation ctxt () () + make_call S.inject_operation ctxt () () (operation, not async, net_id) let inject_protocol ctxt ?(async = false) ?force protocol = - make_err_call S.inject_protocol ctxt () () + make_call S.inject_protocol ctxt () () (protocol, not async, force) let bootstrapped ctxt = @@ -189,6 +180,3 @@ let complete ctxt ?block prefix = make_call1 S.complete ctxt prefix () () | Some block -> Block_services.complete ctxt block prefix - -let describe ctxt ?(recurse = true) path = - make_call1 S.describe ctxt path { recurse } () diff --git a/src/lib_shell_services/shell_services.mli b/src/lib_shell_services/shell_services.mli index 9632aedfd..2eb7ac377 100644 --- a/src/lib_shell_services/shell_services.mli +++ b/src/lib_shell_services/shell_services.mli @@ -45,11 +45,6 @@ val complete: #simple -> ?block:Block_services.block -> string -> string list tzresult Lwt.t -val describe: - #simple -> - ?recurse:bool -> string list -> - Data_encoding.json_schema RPC_description.directory tzresult Lwt.t - module S : sig val forge_block_header: @@ -68,17 +63,17 @@ module S : sig val inject_block: ([ `POST ], unit, unit, unit, inject_block_param, - Block_hash.t tzresult) RPC_service.t + Block_hash.t) RPC_service.t val inject_operation: ([ `POST ], unit, unit, unit, (MBytes.t * bool * Net_id.t option), - Operation_hash.t tzresult) RPC_service.t + Operation_hash.t) RPC_service.t val inject_protocol: ([ `POST ], unit, unit, unit, (Protocol.t * bool * bool option), - Protocol_hash.t tzresult) RPC_service.t + Protocol_hash.t) RPC_service.t val bootstrapped: ([ `POST ], unit, @@ -90,6 +85,4 @@ module S : sig unit * string, unit, unit, string list) RPC_service.t - val describe: (unit, unit) RPC_service.description_service - end diff --git a/vendors/ocplib-resto/lib_ezresto/ezResto.ml b/vendors/ocplib-resto/lib_ezresto/ezResto.ml index 13eb6547a..344a7496b 100644 --- a/vendors/ocplib-resto/lib_ezresto/ezResto.ml +++ b/vendors/ocplib-resto/lib_ezresto/ezResto.ml @@ -49,4 +49,5 @@ module Description = Resto.Description type description_service = ([`GET], unit * string list, Description.request, unit, Json_schema.schema Description.directory, unit) service -let description_service = description_service +let description_service ?description path = + description_service ?description Json_encoding.empty path diff --git a/vendors/ocplib-resto/lib_resto-cohttp/server.ml b/vendors/ocplib-resto/lib_resto-cohttp/server.ml index 6069e33c7..5c3ebd49c 100644 --- a/vendors/ocplib-resto/lib_resto-cohttp/server.ml +++ b/vendors/ocplib-resto/lib_resto-cohttp/server.ml @@ -327,13 +327,18 @@ module Make (Encoding : Resto.ENCODING)(Log : LOGGING) = struct and callback (io, con) req body = Lwt.catch begin fun () -> callback server (io, con) req body end - begin fun exn -> - let headers = Header.init () in - let headers = - Header.add headers "content-type" "text/ocaml.exception" in - let status = `Internal_server_error in - let body = Cohttp_lwt.Body.of_string (Printexc.to_string exn) in - Lwt.return (Response.make ~status ~headers (), body) + begin function + | Not_found -> + let status = `Not_found in + let body = Cohttp_lwt.Body.empty in + Lwt.return (Response.make ~status (), body) + | exn -> + let headers = Header.init () in + let headers = + Header.add headers "content-type" "text/ocaml.exception" in + let status = `Internal_server_error in + let body = Cohttp_lwt.Body.of_string (Printexc.to_string exn) in + Lwt.return (Response.make ~status ~headers (), body) end in Cohttp_lwt_unix.Server.create ~stop ~ctx ~mode ~on_exn diff --git a/vendors/ocplib-resto/lib_resto-directory/resto_directory.ml b/vendors/ocplib-resto/lib_resto-directory/resto_directory.ml index 0ed751556..6c98c4bdf 100644 --- a/vendors/ocplib-resto/lib_resto-directory/resto_directory.ml +++ b/vendors/ocplib-resto/lib_resto-directory/resto_directory.ml @@ -684,7 +684,7 @@ module Make (Encoding : ENCODING) = struct let register_describe_directory_service : type pr. pr directory -> - (pr, pr) Service.description_service -> + (pr, pr, _) Service.description_service -> pr directory = fun root service -> let dir = ref root in diff --git a/vendors/ocplib-resto/lib_resto-directory/resto_directory.mli b/vendors/ocplib-resto/lib_resto-directory/resto_directory.mli index fd558521a..015045dd6 100644 --- a/vendors/ocplib-resto/lib_resto-directory/resto_directory.mli +++ b/vendors/ocplib-resto/lib_resto-directory/resto_directory.mli @@ -174,7 +174,7 @@ module Make (Encoding : ENCODING) : sig (** Registring a description service. *) val register_describe_directory_service: 'prefix directory -> - ('prefix, 'prefix) Service.description_service -> + ('prefix, 'prefix, 'error) Service.description_service -> 'prefix directory (**/**) diff --git a/vendors/ocplib-resto/lib_resto-directory/test/services.ml b/vendors/ocplib-resto/lib_resto-directory/test/services.ml index 21c677b64..c6aa06e5a 100644 --- a/vendors/ocplib-resto/lib_resto-directory/test/services.ml +++ b/vendors/ocplib-resto/lib_resto-directory/test/services.ml @@ -54,7 +54,7 @@ let minus_service = Path.(open_root /: Arg.int / "minus") let describe_service = - description_service Path.(root / "describe") + description_service Json_encoding.empty Path.(root / "describe") let dummy_service = post_service diff --git a/vendors/ocplib-resto/lib_resto/resto.ml b/vendors/ocplib-resto/lib_resto/resto.ml index d020c613f..5b529634e 100644 --- a/vendors/ocplib-resto/lib_resto/resto.ml +++ b/vendors/ocplib-resto/lib_resto/resto.ml @@ -635,11 +635,11 @@ module MakeService(Encoding : ENCODING) = struct (_, pr, p, q, i, o, e) service -> e Encoding.t = fun { types } -> types.error - type ('prefix, 'params) description_service = + type ('prefix, 'params, 'error) description_service = ([ `GET ], 'prefix, 'params * string list, Description.request, - unit, Encoding.schema Description.directory, unit) service + unit, Encoding.schema Description.directory, 'error) service - let description_service ?description path = + let description_service ?description error path = let description = match description with | Some descr -> descr @@ -649,7 +649,7 @@ module MakeService(Encoding : ENCODING) = struct ~description ~query:Description.request_query ~output:Encoding.description_answer_encoding - ~error:Encoding.unit + ~error Path.(path /:* Arg.string) type 'input request = { diff --git a/vendors/ocplib-resto/lib_resto/resto.mli b/vendors/ocplib-resto/lib_resto/resto.mli index eda4b4ac0..1364682a0 100644 --- a/vendors/ocplib-resto/lib_resto/resto.mli +++ b/vendors/ocplib-resto/lib_resto/resto.mli @@ -345,14 +345,15 @@ module MakeService(Encoding : ENCODING) : sig ([< meth ] as 'm, 'p, (('p * 'a) * 'b) * 'c, 'q, 'i, 'o, 'e) service -> ('m, 'p2, (('p2 * 'a) * 'b) * 'c, 'q, 'i, 'o, 'e) service - type ('prefix, 'params) description_service = + type ('prefix, 'params, 'error) description_service = ([ `GET ], 'prefix, 'params * string list, Description.request, - unit, Encoding.schema Description.directory, unit) service + unit, Encoding.schema Description.directory, 'error) service val description_service: ?description:string -> + 'error Encoding.t -> ('prefix, 'params) Path.t -> - ('prefix, 'params) description_service + ('prefix, 'params, 'error) description_service type 'input request = { meth: meth ;