From 3c384588436263802eb42362dfb30b505cbbed63 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Fri, 8 Dec 2017 22:08:29 +0100 Subject: [PATCH] RPC: simplify the signature of `Client_rpcs.ctxt` --- bin_client/jbuild | 2 + bin_client/main.ml | 6 +- lib_client_base/client_commands.ml | 2 +- lib_client_base/client_generic_rpcs.ml | 43 +- lib_client_base/client_helpers.ml | 14 +- lib_client_base/client_node_rpcs.ml | 16 +- lib_client_base/client_node_rpcs.mli | 6 +- lib_client_base/client_rpcs.ml | 448 ++++-------------- lib_client_base/client_rpcs.mli | 118 +++-- .../client_baking_blocks.ml | 1 - .../client_baking_operations.ml | 1 - .../client_proto_rpcs.mli | 6 +- test/proto_alpha/jbuild | 2 + test/proto_alpha/proto_alpha_helpers.ml | 50 +- 14 files changed, 213 insertions(+), 502 deletions(-) diff --git a/bin_client/jbuild b/bin_client/jbuild index f3cd2b790..fb33f3ab6 100644 --- a/bin_client/jbuild +++ b/bin_client/jbuild @@ -4,12 +4,14 @@ ((name main) (public_name tezos-client) (libraries (tezos-base + tezos-rpc-http tezos-client-base tezos-embedded-client-genesis tezos-embedded-client-alpha)) (flags (:standard -w -9+27-30-32-40@8 -safe-string -open Tezos_base__TzPervasives + -open Tezos_rpc_http -open Tezos_client_base -linkall)))) diff --git a/bin_client/main.ml b/bin_client/main.ml index 3f16d1a58..3012f3c09 100644 --- a/bin_client/main.ml +++ b/bin_client/main.ml @@ -31,7 +31,7 @@ let main () = port = parsed_config_file.node_port ; tls = parsed_config_file.tls ; } in - let ctxt = new Client_rpcs.rpc rpc_config in + let ctxt = new Client_rpcs.http_ctxt rpc_config in begin Client_node_rpcs.Blocks.protocol ctxt parsed_args.block >>= function | Ok version -> begin @@ -72,9 +72,9 @@ let main () = let rpc_config = if parsed_args.print_timings then { rpc_config with - logger = Client_rpcs.timings_logger Format.err_formatter } + logger = RPC_client.timings_logger Format.err_formatter } else if parsed_args.log_requests - then { rpc_config with logger = Client_rpcs.full_logger Format.err_formatter } + then { rpc_config with logger = RPC_client.full_logger Format.err_formatter } else rpc_config in let client_config = diff --git a/lib_client_base/client_commands.ml b/lib_client_base/client_commands.ml index dbcbb31c3..d31a300f4 100644 --- a/lib_client_base/client_commands.ml +++ b/lib_client_base/client_commands.ml @@ -142,7 +142,7 @@ let make_context object inherit logger log inherit file_wallet base_dir - inherit Client_rpcs.rpc rpc_config + inherit Client_rpcs.http_ctxt rpc_config method block = block end diff --git a/lib_client_base/client_generic_rpcs.ml b/lib_client_base/client_generic_rpcs.ml index 770d5de45..cf6ec4981 100644 --- a/lib_client_base/client_generic_rpcs.ml +++ b/lib_client_base/client_generic_rpcs.ml @@ -350,9 +350,21 @@ let fill_in schema = | Any | Object { properties = [] } -> Lwt.return (Ok (`O [])) | _ -> editor_fill_in schema -let call url (cctxt : Client_commands.full_context) = - let args = String.split '/' url in - let open RPC_description in +let display_answer (cctxt : #Client_commands.full_context) = function + | `Ok json -> + cctxt#message "%a" + Json_repr.(pp (module Ezjsonm)) json >>= fun () -> + return () + | `Not_found _ -> + cctxt#message "No service found at this URL\n%!" >>= fun () -> + return () + | `Unauthorized _ | `Error _ | `Forbidden _ | `Conflict _ -> + cctxt#message "Unexpected server answer\n%!" >>= fun () -> + return () + +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 Client_node_rpcs.describe cctxt ~recurse:false args >>=? function | Static { services } -> begin match RPC_service.MethMap.find `POST services with @@ -360,35 +372,32 @@ let call url (cctxt : Client_commands.full_context) = cctxt#message "No service found at this URL (but this is a valid prefix)\n%!" >>= fun () -> return () - | { input = None } -> assert false (* TODO *) + | { input = None } -> + cctxt#generic_json_call `POST uri >>=? + display_answer cctxt | { input = Some input } -> fill_in input >>= function | Error msg -> cctxt#error "%s" msg >>= fun () -> return () | Ok json -> - cctxt#get_json `POST args json >>=? fun json -> - cctxt#message "%a" - Json_repr.(pp (module Ezjsonm)) json >>= fun () -> - return () + cctxt#generic_json_call `POST ~body:json uri >>=? + display_answer cctxt end | _ -> - cctxt#message - "No service found at this URL (but this is a valid prefix)\n%!" >>= fun () -> + cctxt#message "No service found at this URL\n%!" >>= fun () -> return () -let call_with_json url json (cctxt: Client_commands.full_context) = - let args = String.split '/' url in +let call_with_json raw_url json (cctxt: Client_commands.full_context) = + let uri = Uri.of_string raw_url in match Data_encoding_ezjsonm.from_string json with | Error err -> cctxt#error "Failed to parse the provided json: %s\n%!" err - | Ok json -> - cctxt#get_json `POST args json >>=? fun json -> - cctxt#message "%a" - Json_repr.(pp (module Ezjsonm)) json >>= fun () -> - return () + | Ok body -> + cctxt#generic_json_call `POST ~body uri >>=? + display_answer cctxt let group = { Cli_entries.name = "rpc" ; diff --git a/lib_client_base/client_helpers.ml b/lib_client_base/client_helpers.ml index 17d95961d..797f5dd53 100644 --- a/lib_client_base/client_helpers.ml +++ b/lib_client_base/client_helpers.ml @@ -40,15 +40,11 @@ let commands () = Cli_entries.[ stop) (fun () (cctxt : Client_commands.full_context) -> Client_node_rpcs.bootstrapped cctxt >>=? fun stream -> - Lwt_stream.iter_s (function - | Ok (hash, time) -> - cctxt#message "Current head: %a (%a)" - Block_hash.pp_short hash - Time.pp_hum time - | Error err -> - cctxt#error "Error: %a" - pp_print_error err - ) stream >>= fun () -> + Lwt_stream.iter_s + (fun (hash, time) -> + cctxt#message "Current head: %a (%a)" + Block_hash.pp_short hash + Time.pp_hum time) stream >>= fun () -> cctxt#answer "Bootstrapped." >>= fun () -> return () ) diff --git a/lib_client_base/client_node_rpcs.ml b/lib_client_base/client_node_rpcs.ml index 116255004..863095fa9 100644 --- a/lib_client_base/client_node_rpcs.ml +++ b/lib_client_base/client_node_rpcs.ml @@ -42,18 +42,10 @@ let complete cctxt ?block prefix = | Some block -> call_service2 cctxt Services.Blocks.complete block prefix () -let describe config ?(recurse = true) path = - let { RPC_service.meth ; uri } = - RPC_service.forge_request Node_rpc_services.describe - ((), path) { RPC_description.recurse } in - let path = String.split_path (Uri.path uri) in (* Temporary *) - config#get_json meth path (`O []) >>=? fun json -> - match Data_encoding.Json.destruct (RPC_service.output_encoding Node_rpc_services.describe) json with - | exception msg -> - let msg = - Format.asprintf "%a" (fun x -> Data_encoding.Json.print_error x) msg in - failwith "Failed to parse Json answer: %s" msg - | v -> return v +let describe cctxt ?(recurse = true) path = + Client_rpcs.call_service cctxt + Node_rpc_services.describe + ((), path) { recurse } () module Blocks = struct diff --git a/lib_client_base/client_node_rpcs.mli b/lib_client_base/client_node_rpcs.mli index 19806489f..dead54edd 100644 --- a/lib_client_base/client_node_rpcs.mli +++ b/lib_client_base/client_node_rpcs.mli @@ -109,7 +109,7 @@ module Blocks : sig #Client_rpcs.ctxt -> ?include_ops:bool -> ?length:int -> ?heads:Block_hash.t list -> ?delay:int -> ?min_date:Time.t -> ?min_heads:int -> - unit -> block_info list list tzresult Lwt_stream.t tzresult Lwt.t + unit -> block_info list list Lwt_stream.t tzresult Lwt.t type preapply_result = { shell_header: Block_header.shell_header ; @@ -132,7 +132,7 @@ module Operations : sig #Client_rpcs.ctxt -> ?contents:bool -> unit -> - (Operation_hash.t * Operation.t option) list list tzresult Lwt_stream.t tzresult Lwt.t + (Operation_hash.t * Operation.t option) list list Lwt_stream.t tzresult Lwt.t end @@ -150,7 +150,7 @@ module Protocols : sig end val bootstrapped: - #Client_rpcs.ctxt -> (Block_hash.t * Time.t) tzresult Lwt_stream.t tzresult Lwt.t + #Client_rpcs.ctxt -> (Block_hash.t * Time.t) Lwt_stream.t tzresult Lwt.t module Network : sig diff --git a/lib_client_base/client_rpcs.ml b/lib_client_base/client_rpcs.ml index 63ef56f72..5dd884775 100644 --- a/lib_client_base/client_rpcs.ml +++ b/lib_client_base/client_rpcs.ml @@ -7,408 +7,128 @@ (* *) (**************************************************************************) -type logger = Logger : { - log_request: Uri.t -> Data_encoding.json -> 'a Lwt.t ; - log_success: - 'a -> Cohttp.Code.status_code -> Data_encoding.json -> unit Lwt.t ; - log_error: - 'a -> Cohttp.Code.status_code -> string -> unit Lwt.t ; - } -> logger +module Client = Resto_cohttp.Client.Make(RPC_encoding) type config = { host : string ; port : int ; tls : bool ; - logger : logger ; + logger : RPC_client.logger ; } -let null_logger = - Logger { - log_request = (fun _ _ -> Lwt.return_unit) ; - log_success = (fun _ _ _ -> Lwt.return_unit) ; - log_error = (fun _ _ _ -> Lwt.return_unit) ; - } - let config_encoding = let open Data_encoding in conv (fun { host ; port ; tls } -> (host, port, tls)) - (fun (host, port, tls) -> { host ; port ; tls ; logger = null_logger}) + (fun (host, port, tls) -> { host ; port ; tls ; logger = RPC_client.null_logger}) (obj3 (req "host" string) (req "port" uint16) (req "tls" bool)) -let timings_logger ppf = - Logger { - log_request = begin fun url _body -> - let tzero = Unix.gettimeofday () in - let url = Uri.to_string url in - Lwt.return (url, tzero) - end ; - log_success = begin fun (url, tzero) _code _body -> - let time = Unix.gettimeofday () -. tzero in - Format.fprintf ppf "Request to %s succeeded in %gs" url time ; - Lwt.return_unit - end ; - log_error = begin fun (url, tzero) _code _body -> - let time = Unix.gettimeofday () -. tzero in - Format.fprintf ppf "Request to %s failed in %gs" url time ; - Lwt.return_unit - end ; - } - -let full_logger ppf = - let cpt = ref 0 in - Logger { - log_request = begin fun url body -> - let id = !cpt in - let url = Uri.to_string url in - let body = Data_encoding_ezjsonm.to_string body in - incr cpt ; - Format.fprintf ppf ">>>>%d: %s\n%s@." id url body ; - Lwt.return (id, url) - end ; - log_success = begin fun (id, _url) code body -> - let code = Cohttp.Code.string_of_status code in - let body = Data_encoding_ezjsonm.to_string body in - Format.fprintf ppf "<<<<%d: %s\n%s@." id code body ; - Lwt.return_unit - end ; - log_error = begin fun (id, _url) code body -> - let code = Cohttp.Code.string_of_status code in - Format.fprintf ppf "<<<<%d: %s\n%s@." id code body ; - Lwt.return_unit - end ; - } - let default_config = { host = "localhost" ; port = 8732 ; tls = false ; - logger = null_logger ; + logger = RPC_client.null_logger ; } -type rpc_error = - | Connection_failed of string - | Request_failed of string list * Cohttp.Code.status_code - | Malformed_json of string list * string * string - | Unexpected_json of string list * Data_encoding.json * string +class type json_ctxt = object + method generic_json_call : + RPC_service.meth -> + ?body:Data_encoding.json -> + Uri.t -> + (Data_encoding.json, Data_encoding.json option) RPC_client.rest_result Lwt.t +end -type error += RPC_error of config * rpc_error - -let rpc_error_encoding = - let open Data_encoding in - union - [ case ~tag: 1 - (obj2 - (req "rpc_error_kind" (constant "connection_failed")) - (req "message" string)) - (function Connection_failed msg -> Some ((), msg) | _ -> None) - (function (), msg -> Connection_failed msg) ; - case ~tag: 2 - (obj3 - (req "rpc_error_kind" (constant "request_failed")) - (req "path" (list string)) - (req "http_code" (conv Cohttp.Code.code_of_status Cohttp.Code.status_of_code uint16))) - (function Request_failed (path, code) -> Some ((), path, code) | _ -> None) - (function (), path, code -> Request_failed (path, code)) ; - case ~tag: 3 - (obj4 - (req "rpc_error_kind" (constant "malformed_json")) - (req "path" (list string)) - (req "message" string) - (req "text" string)) - (function Malformed_json (path, json, msg) -> Some ((), path, msg, json) | _ -> None) - (function (), path, msg, json -> Malformed_json (path, json, msg)) ; - case ~tag: 4 - (obj4 - (req "rpc_error_kind" (constant "unexpected_json")) - (req "path" (list string)) - (req "message" string) - (req "json" json)) - (function Unexpected_json (path, json, msg) -> Some ((), path, msg, json) | _ -> None) - (function (), path, msg, json -> Unexpected_json (path, json, msg)) ] - -let pp_error ppf (config, err) = - let pp_path ppf path = - Format.fprintf ppf "%s://%s:%d/%s" - (if config.tls then "https" else "http") - config.host config.port - (String.concat "/" path) in - match err with - | Connection_failed msg -> - Format.fprintf ppf - "@[Unable to connect to the node:@,\ - Node's address: %s@,\ - Node's RPC port: %d@,\ - Error: %s@]" - config.host config.port msg - | Request_failed (path, code) -> - let code = Cohttp.Code.code_of_status code in - Format.fprintf ppf "@[RPC Request failed:@,\ - Path: %a@,\ - HTTP status: %d (%s)@]" - pp_path path - code (Cohttp.Code.reason_phrase_of_code code) - | Malformed_json (path, json, msg) -> - Format.fprintf ppf "@[RPC request returned malformed JSON:@,\ - Path: %a@,\ - Error: %s@,\ - @[JSON data:@,%a@]@]" - pp_path path - msg - (Format.pp_print_list - (fun ppf s -> Format.fprintf ppf "> %s" s)) - (String.split '\n' json) - | Unexpected_json (path, json, msg) -> - Format.fprintf ppf "@[RPC request returned unexpected JSON:@,\ - Path: %a@,\ - @[Error:@,%a@]@,\ - @[JSON data:@,%a@]@]" - pp_path path - (Format.pp_print_list (fun ppf s -> Format.fprintf ppf "%s" s)) - (String.split '\n' msg) - Json_repr.(pp (module Ezjsonm)) json - -let () = - register_error_kind - `Branch - ~id: "client_rpc" - ~title: "Client side RPC error" - ~description: "An RPC call failed" - ~pp: pp_error - Data_encoding.(obj2 - (req "config" config_encoding) - (req "error" rpc_error_encoding)) - (function RPC_error (config, err) -> Some (config, err) | _ -> None) - (fun (config, err) -> RPC_error (config, err)) - -let fail config err = fail (RPC_error (config, err)) +class type service_ctxt = object + method call_service : + 'm 'p 'q 'i 'o 'e. + ([< Resto.meth ] as 'm, unit, 'p, 'q, 'i, 'o, 'e) RPC_service.t -> + 'p -> 'q -> 'i -> 'o tzresult Lwt.t + method call_streamed_service : + 'm 'p 'q 'i 'o 'e. + ([< Resto.meth ] as 'm, unit, 'p, 'q, 'i, 'o, 'e) RPC_service.t -> + on_chunk: ('o -> unit) -> + on_close: (unit -> unit) -> + 'p -> 'q -> 'i -> (unit -> unit) tzresult Lwt.t +end class type ctxt = object - method get_json : - RPC_service.meth -> - string list -> Data_encoding.json -> Data_encoding.json tzresult Lwt.t - method get_streamed_json : - RPC_service.meth -> - string list -> - Data_encoding.json -> - Data_encoding.json tzresult Lwt_stream.t tzresult Lwt.t - method make_request : - (Uri.t -> Data_encoding.json -> 'a Lwt.t) -> - RPC_service.meth -> - string list -> - Data_encoding.json -> - ('a * Cohttp.Code.status_code * Cohttp_lwt.Body.t) tzresult Lwt.t - method parse_answer : - 'meth 'params 'input 'output. - ([< Resto.meth ] as 'meth, unit, 'params, unit, 'input, 'output, unit) RPC_service.t -> - string list -> - Data_encoding.json -> 'output tzresult Lwt.t - method parse_err_answer : - 'meth 'params 'input 'output. - ([< Resto.meth ] as 'meth, unit, 'params, unit, 'input, 'output tzresult, unit) RPC_service.t -> - string list -> - Data_encoding.json -> 'output tzresult Lwt.t + inherit json_ctxt + inherit service_ctxt end -class rpc config : ctxt = object (self) - val config = config - method make_request : - type a. (Uri.t -> Data_encoding.json -> a Lwt.t) -> - RPC_service.meth -> - string list -> - Data_encoding.json -> - (a * Cohttp.Code.status_code * Cohttp_lwt.Body.t) tzresult Lwt.t = - fun log_request meth service json -> - let scheme = if config.tls then "https" else "http" in - let path = String.concat "/" service in - let uri = - Uri.make ~scheme ~host:config.host ~port:config.port ~path () in - let reqbody = Data_encoding_ezjsonm.to_string json in - Lwt.catch begin fun () -> - let body = Cohttp_lwt.Body.of_string reqbody in - Cohttp_lwt_unix.Client.call - (meth :> Cohttp.Code.meth) ~body uri >>= fun (code, ansbody) -> - log_request uri json >>= fun reqid -> - return (reqid, code.Cohttp.Response.status, ansbody) - end begin fun exn -> - let msg = match exn with - | Unix.Unix_error (e, _, _) -> Unix.error_message e - | Failure msg -> msg - | Invalid_argument msg -> msg - | e -> Printexc.to_string e in - fail config (Connection_failed msg) - end - - method get_streamed_json meth service json = - let Logger logger = config.logger in - self#make_request logger.log_request - meth service json >>=? fun (reqid, code, ansbody) -> - match code with - | #Cohttp.Code.success_status -> - let ansbody = Cohttp_lwt.Body.to_stream ansbody in - let json_st = Data_encoding_ezjsonm.from_stream ansbody in - let parsed_st, push = Lwt_stream.create () in - let rec loop () = - Lwt_stream.get json_st >>= function - | Some (Ok json) as v -> - push v ; - logger.log_success reqid code json >>= fun () -> - loop () - | None -> - push None ; - Lwt.return_unit - | Some (Error msg) -> - let error = - RPC_error (config, Malformed_json (service, "", msg)) in - push (Some (Error [error])) ; - push None ; - Lwt.return_unit - in - Lwt.async loop ; - return parsed_st - | err -> - Cohttp_lwt.Body.to_string ansbody >>= fun ansbody -> - logger.log_error reqid code ansbody >>= fun () -> - fail config (Request_failed (service, err)) - - method parse_answer - : 'm 'p 'i 'o. - ([< Resto.meth ] as 'm, unit, 'p, unit, 'i, 'o, unit) RPC_service.t -> - string list -> - Data_encoding.json -> 'o tzresult Lwt.t = - fun service path json -> - match Data_encoding.Json.destruct (RPC_service.output_encoding service) json with - | exception msg -> - let msg = - Format.asprintf "%a" (fun x -> Data_encoding.Json.print_error x) msg in - fail config (Unexpected_json (path, json, msg)) - | v -> return v - - - method get_json : RPC_service.meth -> - string list -> Data_encoding.json -> Data_encoding.json tzresult Lwt.t = - fun meth service json -> - let Logger logger = config.logger in - self#make_request logger.log_request - meth service json >>=? fun (reqid, code, ansbody) -> - Cohttp_lwt.Body.to_string ansbody >>= fun ansbody -> - match code with - | #Cohttp.Code.success_status -> begin - if ansbody = "" then - return `Null - else - match Data_encoding_ezjsonm.from_string ansbody with - | Error msg -> - logger.log_error reqid code ansbody >>= fun () -> - fail config (Malformed_json (service, ansbody, msg)) - | Ok json -> - logger.log_success reqid code json >>= fun () -> - return json - end - | err -> - logger.log_error reqid code ansbody >>= fun () -> - fail config (Request_failed (service, err)) - - method parse_err_answer - : 'm 'p 'i 'o. - ([< Resto.meth ] as 'm, unit, 'p, unit, 'i, 'o tzresult, unit) RPC_service.t -> - string list -> - Data_encoding.json -> 'o tzresult Lwt.t = - fun service path json -> - match Data_encoding.Json.destruct (RPC_service.output_encoding service) json with - | exception msg -> (* TODO print_error *) - let msg = - Format.asprintf "%a" (fun x -> Data_encoding.Json.print_error x) msg in - fail config (Unexpected_json (path, json, msg)) - | v -> Lwt.return v -end - -let make_request config log_request meth service json = - let scheme = if config.tls then "https" else "http" in - let path = String.concat "/" service in - let uri = - Uri.make ~scheme ~host:config.host ~port:config.port ~path () in - let reqbody = Data_encoding_ezjsonm.to_string json in - Lwt.catch begin fun () -> - let body = Cohttp_lwt.Body.of_string reqbody in - Cohttp_lwt_unix.Client.call - (meth :> Cohttp.Code.meth) - ~body uri >>= fun (code, ansbody) -> - log_request uri json >>= fun reqid -> - return (reqid, code.Cohttp.Response.status, ansbody) - end begin fun exn -> - let msg = match exn with - | Unix.Unix_error (e, _, _) -> Unix.error_message e - | e -> Printexc.to_string e in - fail config (Connection_failed msg) +class http_ctxt config : ctxt = + let base = + Uri.make + ~scheme:(if config.tls then "https" else "http") + ~host:config.host + ~port:config.port + () in + let logger = config.logger in + object + method generic_json_call meth ?body uri = + let uri = Uri.with_path base (Uri.path uri) in + let uri = Uri.with_query uri (Uri.query uri) in + RPC_client.generic_json_call ~logger meth ?body uri + method call_service + : 'm 'p 'q 'i 'o 'e. + ([< Resto.meth ] as 'm, unit, 'p, 'q, 'i, 'o, 'e) RPC_service.t -> + 'p -> 'q -> 'i -> 'o tzresult Lwt.t = + fun service params query body -> + RPC_client.call_service Media_type.all_media_types ~logger ~base service params query body + method call_streamed_service + : 'm 'p 'q 'i 'o 'e. + ([< Resto.meth ] as 'm, unit, 'p, 'q, 'i, 'o, 'e) RPC_service.t -> + on_chunk: ('o -> unit) -> + on_close: (unit -> unit) -> + 'p -> 'q -> 'i -> (unit -> unit) tzresult Lwt.t = + fun service ~on_chunk ~on_close params query body -> + RPC_client.call_streamed_service Media_type.all_media_types service + ~logger ~base ~on_chunk ~on_close params query body end -let forge_request (type i) (service: (_,_,_,_,i,_,_) RPC_service.t) params body = - let { RPC_service.meth ; uri } = - RPC_service.forge_request service params () in - let json = - match RPC_service.input_encoding service with - | RPC_service.No_input -> assert false (* TODO *) - | RPC_service.Input input -> Data_encoding.Json.construct input body in - let path = String.split_path (Uri.path uri) in (* Temporary *) - meth, path, json +let call_service (ctxt : #service_ctxt) service params query body = + ctxt#call_service service params query body -let call_service0 (rpc : #ctxt) service arg = - let meth, path, arg = forge_request service () arg in - rpc#get_json meth path arg >>=? fun json -> - rpc#parse_answer service path json +let call_err_service ctxt service params query body = + call_service ctxt service params query body >>=? Lwt.return -let call_service1 (rpc : #ctxt) service a1 arg = - let meth, path, arg = forge_request service ((), a1) arg in - rpc#get_json meth path arg >>=? fun json -> - rpc#parse_answer service path json +let call_streamed_service (ctxt : #service_ctxt) service param query body = + let stream, push = Lwt_stream.create () in + ctxt#call_streamed_service + ~on_chunk:(fun o -> push (Some o)) ~on_close:(fun () -> push None) + service param query body >>= function + | Error _ as err -> Lwt.return err + | Ok _finalizer -> + return stream -let call_service2 (rpc : #ctxt) service a1 a2 arg = - let meth, path, arg = forge_request service (((), a1), a2) arg in - rpc#get_json meth path arg >>=? fun json -> - rpc#parse_answer service path json +(* Currified params *) -let call_streamed (rpc : #ctxt) service (meth, path, arg) = - rpc#get_streamed_json meth path arg >>=? fun json_st -> - let parsed_st, push = Lwt_stream.create () in - let rec loop () = - Lwt_stream.get json_st >>= function - | Some (Ok json) -> begin - rpc#parse_answer service path json >>= function - | Ok v -> push (Some (Ok v)) ; loop () - | Error _ as err -> - push (Some err) ; push None ; Lwt.return_unit - end - | Some (Error _) as v -> - push v ; push None ; Lwt.return_unit - | None -> push None ; Lwt.return_unit - in - Lwt.async loop ; - return parsed_st +let call_service0 ctxt service body = + call_service ctxt service () () body -let call_streamed_service0 (rpc : #ctxt) service arg = - call_streamed rpc service (forge_request service () arg) +let call_service1 ctxt service a1 body = + call_service ctxt service ((), a1) () body -let call_streamed_service1 cctxt service arg1 arg2 = - call_streamed cctxt service (forge_request service ((), arg1) arg2) +let call_service2 ctxt service a1 a2 body = + call_service ctxt service (((), a1), a2) () body -let call_err_service0 (rpc : #ctxt) service arg = - let meth, path, arg = forge_request service () arg in - rpc#get_json meth path arg >>=? fun json -> - rpc#parse_err_answer service path json +let call_streamed_service0 ctxt service body = + call_streamed_service ctxt service () () body -let call_err_service1 (rpc : #ctxt) service a1 arg = - let meth, path, arg = forge_request service ((), a1) arg in - rpc#get_json meth path arg >>=? fun json -> - rpc#parse_err_answer service path json +let call_streamed_service1 ctxt service a1 body = + call_streamed_service ctxt service ((), a1) () body -let call_err_service2 (rpc : #ctxt) service a1 a2 arg = - let meth, path, arg = forge_request service (((), a1), a2) arg in - rpc#get_json meth path arg >>=? fun json -> - rpc#parse_err_answer service path json +let call_err_service0 ctxt service body = + call_err_service ctxt service () () body + +let call_err_service1 ctxt service a1 body = + call_err_service ctxt service ((), a1) () body + +let call_err_service2 ctxt service a1 a2 body = + call_err_service ctxt service (((), a1), a2) () body type block = Node_rpc_services.Blocks.block diff --git a/lib_client_base/client_rpcs.mli b/lib_client_base/client_rpcs.mli index 5e7032bf7..d8484b6b7 100644 --- a/lib_client_base/client_rpcs.mli +++ b/lib_client_base/client_rpcs.mli @@ -11,107 +11,99 @@ type config = { host : string ; port : int ; tls : bool ; - logger : logger ; + logger : RPC_client.logger ; } -and logger = - Logger : { - log_request : Uri.t -> Data_encoding.json -> 'a Lwt.t ; - log_success : - 'a -> Cohttp.Code.status_code -> Data_encoding.json -> unit Lwt.t ; - log_error : - 'a -> Cohttp.Code.status_code -> string -> unit Lwt.t ; - } -> logger - -class type ctxt = object - method get_json : +class type json_ctxt = object + method generic_json_call : RPC_service.meth -> - string list -> Data_encoding.json -> - Data_encoding.json tzresult Lwt.t - method get_streamed_json : - RPC_service.meth -> - string list -> - Data_encoding.json -> - Data_encoding.json tzresult Lwt_stream.t tzresult Lwt.t - method make_request : - (Uri.t -> Data_encoding.json -> 'a Lwt.t) -> - RPC_service.meth -> - string list -> - Data_encoding.json -> - ('a * Cohttp.Code.status_code * Cohttp_lwt.Body.t) tzresult Lwt.t - method parse_answer : - 'meth 'params 'input 'output. - ([< Resto.meth ] as 'meth, unit, 'params, unit, 'input, 'output, unit) RPC_service.t -> - string list -> - Data_encoding.json -> 'output tzresult Lwt.t - method parse_err_answer : - 'meth 'params 'input 'output. - ([< Resto.meth ] as 'meth, unit, 'params, unit, 'input, 'output tzresult, unit) RPC_service.t -> - string list -> - Data_encoding.json -> 'output tzresult Lwt.t + ?body:Data_encoding.json -> + Uri.t -> + (Data_encoding.json, Data_encoding.json option) RPC_client.rest_result Lwt.t end -class rpc : config -> ctxt +class type service_ctxt = object + method call_service : + 'm 'p 'q 'i 'o 'e. + ([< Resto.meth ] as 'm, unit, 'p, 'q, 'i, 'o, 'e) RPC_service.t -> + 'p -> 'q -> 'i -> 'o tzresult Lwt.t + method call_streamed_service : + 'm 'p 'q 'i 'o 'e. + ([< Resto.meth ] as 'm, unit, 'p, 'q, 'i, 'o, 'e) RPC_service.t -> + on_chunk: ('o -> unit) -> + on_close: (unit -> unit) -> + 'p -> 'q -> 'i -> (unit -> unit) tzresult Lwt.t +end + +class type ctxt = object + inherit json_ctxt + inherit service_ctxt +end val default_config: config -val null_logger: logger -val timings_logger: Format.formatter -> logger -val full_logger: Format.formatter -> logger +class http_ctxt: config -> ctxt + +val call_service: + #service_ctxt -> + ('m, unit, + 'p, 'q, 'i, + 'o, 'e) RPC_service.t -> + 'p -> 'q -> 'i -> 'o tzresult Lwt.t val call_service0: - #ctxt -> - ([ `POST ], unit, + #service_ctxt -> + ('m, unit, unit, unit, 'i, - 'o, unit) RPC_service.t -> + 'o, 'e) RPC_service.t -> 'i -> 'o tzresult Lwt.t val call_service1: - #ctxt -> - ([ `POST ], unit, + #service_ctxt -> + ('m, unit, unit * 'a, unit, 'i, - 'o, unit) RPC_service.t -> + 'o, 'e) RPC_service.t -> 'a -> 'i -> 'o tzresult Lwt.t val call_service2: - #ctxt -> - ([ `POST ], unit, + #service_ctxt -> + ('m, unit, (unit * 'a) * 'b, unit, 'i, - 'o, unit) RPC_service.t -> + 'o, 'e) RPC_service.t -> 'a -> 'b -> 'i -> 'o tzresult Lwt.t val call_streamed_service0: - #ctxt -> - ([ `POST ], unit, + #service_ctxt -> + ('m, unit, unit, unit, 'a, 'b, unit) RPC_service.t -> - 'a -> 'b tzresult Lwt_stream.t tzresult Lwt.t + 'a -> 'b Lwt_stream.t tzresult Lwt.t val call_streamed_service1: - #ctxt -> - ([ `POST ], unit, + #service_ctxt -> + ('m, unit, unit * 'a, unit, 'b, 'c, unit) RPC_service.t -> - 'a -> 'b -> 'c tzresult Lwt_stream.t tzresult Lwt.t + 'a -> 'b -> 'c Lwt_stream.t tzresult Lwt.t val call_err_service0: - #ctxt -> - ([ `POST ], unit, + #service_ctxt -> + ('m, unit, unit, unit, 'i, - 'o tzresult, unit) RPC_service.t -> + 'o tzresult, 'e) RPC_service.t -> 'i -> 'o tzresult Lwt.t val call_err_service1: - #ctxt -> - ([ `POST ], unit, + #service_ctxt -> + ('m, unit, unit * 'a, unit, 'i, - 'o tzresult, unit) RPC_service.t -> + 'o tzresult, 'e) RPC_service.t -> 'a -> 'i -> 'o tzresult Lwt.t val call_err_service2: - #ctxt -> - ([ `POST ], unit, + #service_ctxt -> + ('m, unit, (unit * 'a) * 'b, unit, 'i, - 'o tzresult, unit) RPC_service.t -> + 'o tzresult, 'e) RPC_service.t -> 'a -> 'b -> 'i -> 'o tzresult Lwt.t type block = Node_rpc_services.Blocks.block diff --git a/lib_embedded_client_alpha/client_baking_blocks.ml b/lib_embedded_client_alpha/client_baking_blocks.ml index a1d1fa8b9..1c697e752 100644 --- a/lib_embedded_client_alpha/client_baking_blocks.ml +++ b/lib_embedded_client_alpha/client_baking_blocks.ml @@ -63,7 +63,6 @@ let monitor cctxt ?include_ops ?length ?heads ?delay ?min_date ?min_heads () >>=? fun block_stream -> let convert blocks = - Lwt.return blocks >>=? fun blocks -> sort_blocks cctxt ?compare (List.flatten blocks) >>= return in return (Lwt_stream.map_s convert block_stream) diff --git a/lib_embedded_client_alpha/client_baking_operations.ml b/lib_embedded_client_alpha/client_baking_operations.ml index 6a3473c69..4320a5fe0 100644 --- a/lib_embedded_client_alpha/client_baking_operations.ml +++ b/lib_embedded_client_alpha/client_baking_operations.ml @@ -15,7 +15,6 @@ type operation = { let monitor cctxt ?contents ?check () = Client_node_rpcs.Operations.monitor cctxt ?contents () >>=? fun ops_stream -> let convert ops = - Lwt.return ops >>=? fun ops -> map_s (fun (hash, op) -> match op with diff --git a/lib_embedded_client_alpha/client_proto_rpcs.mli b/lib_embedded_client_alpha/client_proto_rpcs.mli index ae3caed24..a4318ee9a 100644 --- a/lib_embedded_client_alpha/client_proto_rpcs.mli +++ b/lib_embedded_client_alpha/client_proto_rpcs.mli @@ -13,13 +13,13 @@ val handle_error: Client_commands.full_context -> 'a tzresult -> 'a Lwt.t type block = Node_rpc_services.Blocks.block val header: - Client_rpcs.rpc -> block -> Block_header.t tzresult Lwt.t + #Client_rpcs.ctxt -> block -> Block_header.t tzresult Lwt.t module Header : sig val priority: - Client_rpcs.rpc -> block -> int tzresult Lwt.t + #Client_rpcs.ctxt -> block -> int tzresult Lwt.t val seed_nonce_hash: - Client_rpcs.rpc -> block -> Nonce_hash.t tzresult Lwt.t + #Client_rpcs.ctxt -> block -> Nonce_hash.t tzresult Lwt.t end module Constants : sig diff --git a/test/proto_alpha/jbuild b/test/proto_alpha/jbuild index e145c64e9..f3c94b12f 100644 --- a/test/proto_alpha/jbuild +++ b/test/proto_alpha/jbuild @@ -7,12 +7,14 @@ test_transaction test_vote)) (libraries (tezos-base + tezos-rpc-http tezos-client-base tezos-embedded-client-genesis tezos-embedded-client-alpha test_lib)) (flags (:standard -w -9-32 -safe-string -open Tezos_base__TzPervasives + -open Tezos_rpc_http -open Tezos_embedded_protocol_environment_alpha -open Tezos_embedded_raw_protocol_alpha -open Tezos_client_base diff --git a/test/proto_alpha/proto_alpha_helpers.ml b/test/proto_alpha/proto_alpha_helpers.ml index 6613aa456..5665260c7 100644 --- a/test/proto_alpha/proto_alpha_helpers.ml +++ b/test/proto_alpha/proto_alpha_helpers.ml @@ -17,12 +17,12 @@ let rpc_config = ref { Client_rpcs.host = "localhost" ; port = 8192 + Random.int 8192 ; tls = false ; - logger = Client_rpcs.null_logger ; + logger = RPC_client.null_logger ; } (* Context that does not write to alias files *) let no_write_context config block : Client_commands.full_context = object - inherit Client_rpcs.rpc config + inherit Client_rpcs.http_ctxt config inherit Client_commands.logger (fun _ _ -> Lwt.return_unit) method load : type a. string -> default:a -> a Data_encoding.encoding -> a Error_monad.tzresult Lwt.t = fun _ ~default _ -> return default @@ -41,7 +41,7 @@ let dictator_sk = let activate_alpha () = let fitness = Fitness_repr.from_int64 0L in Tezos_embedded_client_genesis.Client_proto_main.bake - (new Client_rpcs.rpc !rpc_config) (`Head 0) + (new Client_rpcs.http_ctxt !rpc_config) (`Head 0) (Activate { protocol = Client_proto_main.protocol ; validation_passes = 1}) fitness dictator_sk @@ -67,7 +67,7 @@ let init ?(sandbox = "sandbox.json") ?rpc_port () = return (pid, hash) let level block = - Client_proto_rpcs.Context.level (new Client_rpcs.rpc !rpc_config) block + Client_proto_rpcs.Context.level (new Client_rpcs.http_ctxt !rpc_config) block module Account = struct @@ -194,7 +194,7 @@ module Account = struct ~(account:t) ~destination ~amount () = - Client_proto_context.transfer (new Client_rpcs.rpc !rpc_config) + Client_proto_context.transfer (new Client_rpcs.http_ctxt !rpc_config) block ~source:account.contract ~src_pk:account.pk @@ -224,7 +224,7 @@ module Account = struct ?delegate ~fee block - (new Client_rpcs.rpc !rpc_config) + (new Client_rpcs.http_ctxt !rpc_config) () let set_delegate @@ -235,7 +235,7 @@ module Account = struct ~src_pk delegate_opt = Client_proto_context.set_delegate - (new Client_rpcs.rpc !rpc_config) + (new Client_rpcs.http_ctxt !rpc_config) block ~fee contract @@ -244,12 +244,12 @@ module Account = struct delegate_opt let balance ?(block = `Prevalidation) (account : t) = - Client_proto_rpcs.Context.Contract.balance (new Client_rpcs.rpc !rpc_config) + Client_proto_rpcs.Context.Contract.balance (new Client_rpcs.http_ctxt !rpc_config) block account.contract (* TODO: gather contract related functions in a Contract module? *) let delegate ?(block = `Prevalidation) (contract : Contract.t) = - Client_proto_rpcs.Context.Contract.delegate (new Client_rpcs.rpc !rpc_config) + Client_proto_rpcs.Context.Contract.delegate (new Client_rpcs.http_ctxt !rpc_config) block contract end @@ -259,12 +259,12 @@ module Protocol = struct open Account let voting_period_kind ?(block = `Prevalidation) () = - Client_proto_rpcs.Context.voting_period_kind (new Client_rpcs.rpc !rpc_config) block + Client_proto_rpcs.Context.voting_period_kind (new Client_rpcs.http_ctxt !rpc_config) block let proposals ?(block = `Prevalidation) ~src:({ pk; sk } : Account.t) proposals = - Client_node_rpcs.Blocks.info (new Client_rpcs.rpc !rpc_config) block >>=? fun block_info -> - Client_proto_rpcs.Context.next_level (new Client_rpcs.rpc !rpc_config) block >>=? fun next_level -> - Client_proto_rpcs.Helpers.Forge.Delegate.proposals (new Client_rpcs.rpc !rpc_config) block + Client_node_rpcs.Blocks.info (new Client_rpcs.http_ctxt !rpc_config) block >>=? fun block_info -> + Client_proto_rpcs.Context.next_level (new Client_rpcs.http_ctxt !rpc_config) block >>=? fun next_level -> + Client_proto_rpcs.Helpers.Forge.Delegate.proposals (new Client_rpcs.http_ctxt !rpc_config) block ~branch:block_info.hash ~source:pk ~period:next_level.voting_period @@ -274,7 +274,7 @@ module Protocol = struct return (Tezos_base.Operation.of_bytes_exn signed_bytes) let ballot ?(block = `Prevalidation) ~src:({ pk; sk } : Account.t) ~proposal ballot = - let rpc = new Client_rpcs.rpc !rpc_config in + let rpc = new Client_rpcs.http_ctxt !rpc_config in Client_node_rpcs.Blocks.info rpc block >>=? fun block_info -> Client_proto_rpcs.Context.next_level rpc block >>=? fun next_level -> Client_proto_rpcs.Helpers.Forge.Delegate.ballot rpc block @@ -408,7 +408,7 @@ module Assert = struct end let check_protocol ?msg ~block h = - Client_node_rpcs.Blocks.protocol (new Client_rpcs.rpc !rpc_config) block >>=? fun block_proto -> + Client_node_rpcs.Blocks.protocol (new Client_rpcs.http_ctxt !rpc_config) block >>=? fun block_proto -> return @@ Assert.equal ?msg:(Assert.format_msg msg) ~prn:Protocol_hash.to_b58check @@ -416,7 +416,7 @@ module Assert = struct block_proto h let check_voting_period_kind ?msg ~block kind = - Client_proto_rpcs.Context.voting_period_kind (new Client_rpcs.rpc !rpc_config) block + Client_proto_rpcs.Context.voting_period_kind (new Client_rpcs.http_ctxt !rpc_config) block >>=? fun current_kind -> return @@ Assert.equal ?msg:(Assert.format_msg msg) @@ -434,7 +434,7 @@ module Baking = struct | Ok nonce -> nonce in let seed_nonce_hash = Nonce.hash seed_nonce in Client_baking_forge.forge_block - (new Client_rpcs.rpc !rpc_config) + (new Client_rpcs.http_ctxt !rpc_config) block ~operations ~force:true @@ -446,7 +446,7 @@ module Baking = struct () let endorsement_reward block = - Client_proto_rpcs.Header.priority (new Client_rpcs.rpc !rpc_config) block >>=? fun prio -> + Client_proto_rpcs.Header.priority (new Client_rpcs.http_ctxt !rpc_config) block >>=? fun prio -> Baking.endorsement_reward ~block_priority:prio >|= Environment.wrap_error >>|? Tez.to_mutez @@ -461,7 +461,7 @@ module Endorse = struct source slot = let block = Client_rpcs.last_baked_block block in - let rpc = new Client_rpcs.rpc !rpc_config in + let rpc = new Client_rpcs.http_ctxt !rpc_config in Client_node_rpcs.Blocks.info rpc block >>=? fun { hash ; _ } -> Client_proto_rpcs.Helpers.Forge.Delegate.endorsement rpc block @@ -479,7 +479,7 @@ module Endorse = struct delegate level = Client_proto_rpcs.Helpers.Rights.endorsement_rights_for_delegate - (new Client_rpcs.rpc !rpc_config) ~max_priority ~first_level:level ~last_level:level + (new Client_rpcs.http_ctxt !rpc_config) ~max_priority ~first_level:level ~last_level:level block delegate () >>=? fun possibilities -> let slots = List.map (fun (_,slot) -> slot) @@ -490,7 +490,7 @@ module Endorse = struct ?slot (contract : Account.t) block = - Client_proto_rpcs.Context.next_level (new Client_rpcs.rpc !rpc_config) block >>=? fun { level } -> + Client_proto_rpcs.Context.next_level (new Client_rpcs.http_ctxt !rpc_config) block >>=? fun { level } -> begin match slot with | Some slot -> return slot @@ -509,7 +509,7 @@ module Endorse = struct let endorsers_list block = let get_endorser_list result (account : Account.t) level block = Client_proto_rpcs.Helpers.Rights.endorsement_rights_for_delegate - (new Client_rpcs.rpc !rpc_config) block account.pkh + (new Client_rpcs.http_ctxt !rpc_config) block account.pkh ~max_priority:16 ~first_level:level ~last_level:level () >>|? fun slots -> @@ -517,7 +517,7 @@ module Endorse = struct in let { Account.b1 ; b2 ; b3 ; b4 ; b5 } = Account.bootstrap_accounts in let result = Array.make 16 b1 in - Client_proto_rpcs.Context.level (new Client_rpcs.rpc !rpc_config) block >>=? fun level -> + Client_proto_rpcs.Context.level (new Client_rpcs.http_ctxt !rpc_config) block >>=? fun level -> let level = Raw_level.succ @@ level.level in get_endorser_list result b1 level block >>=? fun () -> get_endorser_list result b2 level block >>=? fun () -> @@ -529,7 +529,7 @@ module Endorse = struct let endorsement_rights ?(max_priority = 1024) (contract : Account.t) block = - let rpc = new Client_rpcs.rpc !rpc_config in + let rpc = new Client_rpcs.http_ctxt !rpc_config in Client_proto_rpcs.Context.level rpc block >>=? fun level -> let delegate = contract.pkh in let level = level.level in @@ -543,6 +543,6 @@ module Endorse = struct end let display_level block = - Client_proto_rpcs.Context.level (new Client_rpcs.rpc !rpc_config) block >>=? fun lvl -> + Client_proto_rpcs.Context.level (new Client_rpcs.http_ctxt !rpc_config) block >>=? fun lvl -> Format.eprintf "Level: %a@." Level.pp_full lvl ; return ()