balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Client refactor: use the error_monad for all RPC services

Browse Source
This commit is contained in:
Grégoire Henry 2018-02-11 19:17:39 +01:00
parent 4820aa6098
commit 66c2a60530
31 changed files with 480 additions and 268 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

131
src/lib_base/protocol_environment.ml
View File

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

8
src/lib_client_base/client_generic_rpcs.ml
View File

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

12
src/lib_protocol_environment_sigs/v1/RPC_answer.mli
View File

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

22
src/lib_protocol_environment_sigs/v1/RPC_service.mli
View File

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

13
src/lib_rpc/RPC_answer.ml
View File

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

13
src/lib_rpc/RPC_answer.mli
View File

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

33
src/lib_rpc/RPC_context.ml
View File

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

12
src/lib_rpc/RPC_context.mli
View File

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

3
src/lib_rpc/RPC_description.ml
View File

@ -9,3 +9,6 @@
include Resto.Description
let describe ctxt ?(recurse = false) path =
RPC_context.make_call1
RPC_service.description_service ctxt path { recurse } ()

9
src/lib_rpc/RPC_description.mli
View File

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

52
src/lib_rpc/RPC_directory.ml
View File

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

101
src/lib_rpc/RPC_directory.mli
View File

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

43
src/lib_rpc/RPC_error.ml
View File

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

10
src/lib_rpc/RPC_error.mli
View File

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

55
src/lib_rpc/RPC_service.ml
View File

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

18
src/lib_rpc/RPC_service.mli
View File

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

6
src/lib_rpc_http/RPC_client.ml
View File

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

109
src/lib_shell/node_rpc.ml
View File

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

8
src/lib_shell_services/block_services.ml
View File

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

4
src/lib_shell_services/block_services.mli
View File

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

4
src/lib_shell_services/p2p_services.ml
View File

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

2
src/lib_shell_services/p2p_services.mli
View File

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

24
src/lib_shell_services/shell_services.ml
View File

@ -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 } ()

13
src/lib_shell_services/shell_services.mli
View File

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

3
vendors/ocplib-resto/lib_ezresto/ezResto.ml vendored
View File

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

19
vendors/ocplib-resto/lib_resto-cohttp/server.ml vendored
View File

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

2
vendors/ocplib-resto/lib_resto-directory/resto_directory.ml vendored
View File

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

2
vendors/ocplib-resto/lib_resto-directory/resto_directory.mli vendored
View File

@ -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
(**/**)

2
vendors/ocplib-resto/lib_resto-directory/test/services.ml vendored
View File

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

8
vendors/ocplib-resto/lib_resto/resto.ml vendored
View File

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

7
vendors/ocplib-resto/lib_resto/resto.mli vendored
View File

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