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

RPC: simplify the signature of Client_rpcs.ctxt

Browse Source
This commit is contained in:
Grégoire Henry 2017-12-08 22:08:29 +01:00 committed by Benjamin Canou
parent c66f0232f5
commit 3c38458843
14 changed files with 213 additions and 502 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
bin_client/jbuild
View File

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

6
bin_client/main.ml
View File

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

2
lib_client_base/client_commands.ml
View File

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

43
lib_client_base/client_generic_rpcs.ml
View File

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

14
lib_client_base/client_helpers.ml
View File

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

16
lib_client_base/client_node_rpcs.ml
View File

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

6
lib_client_base/client_node_rpcs.mli
View File

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

448
lib_client_base/client_rpcs.ml
View File

@ -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
"@[<v 2>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 "@[<v 2>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 "@[<v 2>RPC request returned malformed JSON:@,\
Path: %a@,\
Error: %s@,\
@[<v 2>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 "@[<v 2>RPC request returned unexpected JSON:@,\
Path: %a@,\
@[<v 2>Error:@,%a@]@,\
@[<v 2>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

118
lib_client_base/client_rpcs.mli
View File

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

1
lib_embedded_client_alpha/client_baking_blocks.ml
View File

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

1
lib_embedded_client_alpha/client_baking_operations.ml
View File

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

6
lib_embedded_client_alpha/client_proto_rpcs.mli
View File

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

2
test/proto_alpha/jbuild
View File

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

50
test/proto_alpha/proto_alpha_helpers.ml
View File

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