From e4cde4c196343e8263a809eaa311961292762d2e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Sun, 11 Feb 2018 19:17:40 +0100 Subject: [PATCH] Client: introduce an alternative context alpha's commands --- src/lib_base/protocol_environment.ml | 89 +++++++++++++++++++ src/lib_base/protocol_environment.mli | 8 ++ src/lib_client_base/client_commands.ml | 22 +++++ src/lib_client_base/client_commands.mli | 2 + src/lib_rpc/RPC_context.ml | 32 +++++-- src/lib_rpc/RPC_context.mli | 24 +++-- src/lib_rpc_http/RPC_client.ml | 7 +- src/lib_rpc_http/RPC_client.mli | 18 ++-- src/lib_shell/node_rpc.ml | 2 +- src/lib_shell_services/block_services.ml | 7 +- src/lib_shell_services/block_services.mli | 2 +- .../lib_client/client_baking_blocks.mli | 6 +- .../lib_client/client_baking_daemon.ml | 2 +- .../lib_client/client_baking_daemon.mli | 2 +- .../lib_client/client_baking_denunciation.mli | 2 +- .../lib_client/client_baking_endorsement.ml | 10 +-- .../lib_client/client_baking_endorsement.mli | 4 +- .../lib_client/client_baking_forge.ml | 8 +- .../lib_client/client_baking_forge.mli | 12 +-- .../lib_client/client_baking_lib.ml | 4 +- .../lib_client/client_baking_lib.mli | 12 +-- .../lib_client/client_baking_main.mli | 2 +- .../lib_client/client_baking_operations.mli | 4 +- .../lib_client/client_baking_revelation.ml | 2 +- .../lib_client/client_baking_revelation.mli | 4 +- .../lib_client/client_proto_args.mli | 38 ++++---- .../lib_client/client_proto_context.ml | 8 +- .../lib_client/client_proto_context.mli | 24 ++--- .../client_proto_context_commands.ml | 20 ++--- .../lib_client/client_proto_contracts.mli | 6 +- .../client_proto_contracts_commands.ml | 4 +- .../lib_client/client_proto_main.ml | 1 + .../lib_client/client_proto_programs.mli | 10 +-- .../client_proto_programs_commands.ml | 6 +- .../client_proto_programs_commands.mli | 2 +- .../lib_client/client_proto_rpcs.ml | 6 +- src/proto_alpha/lib_client/jbuild | 6 +- src/proto_alpha/lib_client/proto_alpha.ml | 30 +++++++ .../lib_client/test/proto_alpha_helpers.ml | 1 + 39 files changed, 315 insertions(+), 134 deletions(-) diff --git a/src/lib_base/protocol_environment.ml b/src/lib_base/protocol_environment.ml index 782486dc3..2b40ff836 100644 --- a/src/lib_base/protocol_environment.ml +++ b/src/lib_base/protocol_environment.ml @@ -143,6 +143,14 @@ module type V1 = sig and type rpc_context := Updater.rpc_context and type 'a tzresult := 'a tzresult + class ['block] proto_rpc_context : + Tezos_rpc.RPC_context.t -> (unit, unit * 'block) RPC_path.t -> + ['block] RPC_context.simple + + class ['block] proto_rpc_context_of_directory : + ('block -> RPC_context.t) -> RPC_context.t RPC_directory.t -> + ['block] RPC_context.simple + end module MakeV1 @@ -454,6 +462,87 @@ module MakeV1 configure_sandbox c j >|= wrap_error end + class ['block] proto_rpc_context + (t : Tezos_rpc.RPC_context.t) + (prefix : (unit, unit * 'block) RPC_path.t) = + object + method call_proto_service0 + : 'm 'q 'i 'o. + ([< RPC_service.meth ] as 'm, RPC_context.t, + RPC_context.t, 'q, 'i, 'o) RPC_service.t -> + 'block -> 'q -> 'i -> 'o tzresult Lwt.t + = fun s block q i -> + let s = RPC_service.subst0 s in + let s = RPC_service.prefix prefix s in + t#call_service s ((), block) q i + method call_proto_service1 + : 'm 'a 'q 'i 'o. + ([< RPC_service.meth ] as 'm, RPC_context.t, + RPC_context.t * 'a, 'q, 'i, 'o) RPC_service.t -> + 'block -> 'a -> 'q -> 'i -> 'o tzresult Lwt.t + = fun s block a1 q i -> + let s = RPC_service.subst1 s in + let s = RPC_service.prefix prefix s in + t#call_service s (((), block), a1) q i + method call_proto_service2 + : 'm 'a 'b 'q 'i 'o. + ([< RPC_service.meth ] as 'm, RPC_context.t, + (RPC_context.t * 'a) * 'b, 'q, 'i, 'o) RPC_service.t -> + 'block -> 'a -> 'b -> 'q -> 'i -> 'o tzresult Lwt.t + = fun s block a1 a2 q i -> + let s = RPC_service.subst2 s in + let s = RPC_service.prefix prefix s in + t#call_service s ((((), block), a1), a2) q i + method call_proto_service3 + : 'm 'a 'b 'c 'q 'i 'o. + ([< RPC_service.meth ] as 'm, RPC_context.t, + ((RPC_context.t * 'a) * 'b) * 'c, + 'q, 'i, 'o) RPC_service.t -> + 'block -> 'a -> 'b -> 'c -> 'q -> 'i -> 'o tzresult Lwt.t + = fun s block a1 a2 a3 q i -> + let s = RPC_service.subst3 s in + let s = RPC_service.prefix prefix s in + t#call_service s (((((), block), a1), a2), a3) q i + end + + class ['block] proto_rpc_context_of_directory conv dir : ['block] RPC_context.simple = + let lookup = new Tezos_rpc.RPC_context.of_directory dir in + object + method call_proto_service0 + : 'm 'q 'i 'o. + ([< RPC_service.meth ] as 'm, RPC_context.t, + RPC_context.t, 'q, 'i, 'o) RPC_service.t -> + 'block -> 'q -> 'i -> 'o tzresult Lwt.t + = fun s block q i -> + let rpc_context = conv block in + lookup#call_service s rpc_context q i + method call_proto_service1 + : 'm 'a 'q 'i 'o. + ([< RPC_service.meth ] as 'm, RPC_context.t, + RPC_context.t * 'a, 'q, 'i, 'o) RPC_service.t -> + 'block -> 'a -> 'q -> 'i -> 'o tzresult Lwt.t + = fun s block a1 q i -> + let rpc_context = conv block in + lookup#call_service s (rpc_context, a1) q i + method call_proto_service2 + : 'm 'a 'b 'q 'i 'o. + ([< RPC_service.meth ] as 'm, RPC_context.t, + (RPC_context.t * 'a) * 'b, 'q, 'i, 'o) RPC_service.t -> + 'block -> 'a -> 'b -> 'q -> 'i -> 'o tzresult Lwt.t + = fun s block a1 a2 q i -> + let rpc_context = conv block in + lookup#call_service s ((rpc_context, a1), a2) q i + method call_proto_service3 + : 'm 'a 'b 'c 'q 'i 'o. + ([< RPC_service.meth ] as 'm, RPC_context.t, + ((RPC_context.t * 'a) * 'b) * 'c, + 'q, 'i, 'o) RPC_service.t -> + 'block -> 'a -> 'b -> 'c -> 'q -> 'i -> 'o tzresult Lwt.t + = fun s block a1 a2 a3 q i -> + let rpc_context = conv block in + lookup#call_service s (((rpc_context, a1), a2), a3) q i + end + end diff --git a/src/lib_base/protocol_environment.mli b/src/lib_base/protocol_environment.mli index 99a258bf2..664102f3b 100644 --- a/src/lib_base/protocol_environment.mli +++ b/src/lib_base/protocol_environment.mli @@ -136,6 +136,14 @@ module type V1 = sig and type rpc_context := Updater.rpc_context and type 'a tzresult := 'a tzresult + class ['block] proto_rpc_context : + Tezos_rpc.RPC_context.t -> (unit, unit * 'block) RPC_path.t -> + ['block] RPC_context.simple + + class ['block] proto_rpc_context_of_directory : + ('block -> RPC_context.t) -> RPC_context.t RPC_directory.t -> + ['block] RPC_context.simple + end module MakeV1 diff --git a/src/lib_client_base/client_commands.ml b/src/lib_client_base/client_commands.ml index 9b569cebf..dc19c848e 100644 --- a/src/lib_client_base/client_commands.ml +++ b/src/lib_client_base/client_commands.ml @@ -64,6 +64,28 @@ class type full_context = object inherit block end +class proxy_context (obj : full_context) = object + method block = obj#block + method answer : type a. (a, unit) lwt_format -> a = obj#answer + method call_service : + 'm 'p 'q 'i 'o. + ([< Resto.meth ] as 'm, 'pr, 'p, 'q, 'i, 'o) RPC_service.t -> + 'p -> 'q -> 'i -> 'o tzresult Lwt.t = obj#call_service + method call_streamed_service : + 'm 'p 'q 'i 'o. + ([< Resto.meth ] as 'm, 'pr, 'p, 'q, 'i, 'o) RPC_service.t -> + on_chunk: ('o -> unit) -> + on_close: (unit -> unit) -> + 'p -> 'q -> 'i -> (unit -> unit) tzresult Lwt.t = obj#call_streamed_service + method error : type a b. (a, b) lwt_format -> a = obj#error + method generic_json_call = obj#generic_json_call + method load : type a. string -> default:a -> a Data_encoding.encoding -> a tzresult Lwt.t = obj#load + method log : type a. string -> (a, unit) lwt_format -> a = obj#log + method message : type a. (a, unit) lwt_format -> a = obj#message + method warning : type a. (a, unit) lwt_format -> a = obj#warning + method write : type a. string -> a -> a Data_encoding.encoding -> unit tzresult Lwt.t = obj#write +end + class file_wallet dir : wallet = object (self) method private filename alias_name = diff --git a/src/lib_client_base/client_commands.mli b/src/lib_client_base/client_commands.mli index 2ed91a29c..c754aa449 100644 --- a/src/lib_client_base/client_commands.mli +++ b/src/lib_client_base/client_commands.mli @@ -54,6 +54,8 @@ end handler when running a command, and must be transmitted to all basic operations, also making client commands reantrant. *) +class proxy_context : full_context -> full_context + val make_context : ?base_dir:string -> ?block:Block_services.block -> diff --git a/src/lib_rpc/RPC_context.ml b/src/lib_rpc/RPC_context.ml index 9b9e656ea..2bb99b066 100644 --- a/src/lib_rpc/RPC_context.ml +++ b/src/lib_rpc/RPC_context.ml @@ -9,27 +9,41 @@ open Error_monad -class type simple = object +class type ['pr] gen_simple = object method call_service : 'm 'p 'q 'i 'o. - ([< Resto.meth ] as 'm, unit, 'p, 'q, 'i, 'o) RPC_service.t -> + ([< Resto.meth ] as 'm, 'pr, 'p, 'q, 'i, 'o) RPC_service.t -> 'p -> 'q -> 'i -> 'o tzresult Lwt.t end -class type streamed = object +class type ['pr] gen_streamed = object method call_streamed_service : 'm 'p 'q 'i 'o. - ([< Resto.meth ] as 'm, unit, 'p, 'q, 'i, 'o) RPC_service.t -> + ([< Resto.meth ] as 'm, 'pr, 'p, 'q, 'i, 'o) RPC_service.t -> on_chunk: ('o -> unit) -> on_close: (unit -> unit) -> 'p -> 'q -> 'i -> (unit -> unit) tzresult Lwt.t end +class type ['pr] gen = object + inherit ['pr] gen_simple + inherit ['pr] gen_streamed +end + +class type simple = object + inherit [unit] gen_simple +end + +class type streamed = object + inherit [unit] gen_streamed +end + class type t = object inherit simple inherit streamed end + type error += | Not_found of { meth: RPC_service.meth ; uri: Uri.t } @@ -39,17 +53,17 @@ type error += let base = Uri.make ~scheme:"ocaml" () let not_found s p q = let { RPC_service.meth ; uri ; _ } = - RPC_service.forge_request s ~base p q in + RPC_service.forge_partial_request s ~base p q in fail (Not_found { meth ; uri }) let generic_error s p q = let { RPC_service.meth ; uri ; _ } = - RPC_service.forge_request s ~base p q in + RPC_service.forge_partial_request s ~base p q in fail (Generic_error { meth ; uri }) -let of_directory (dir : unit RPC_directory.t) : t = object +class ['pr] of_directory (dir : 'pr RPC_directory.t) = object method call_service : 'm 'p 'q 'i 'o. - ([< Resto.meth ] as 'm, unit, 'p, 'q, 'i, 'o) RPC_service.t -> + ([< Resto.meth ] as 'm, 'pr, 'p, 'q, 'i, 'o) RPC_service.t -> 'p -> 'q -> 'i -> 'o tzresult Lwt.t = fun s p q i -> RPC_directory.transparent_lookup dir s p q i >>= function @@ -72,7 +86,7 @@ let of_directory (dir : unit RPC_directory.t) : t = object | `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 -> + ([< Resto.meth ] as 'm, 'pr, 'p, 'q, 'i, 'o) RPC_service.t -> on_chunk: ('o -> unit) -> on_close: (unit -> unit) -> 'p -> 'q -> 'i -> (unit -> unit) tzresult Lwt.t = diff --git a/src/lib_rpc/RPC_context.mli b/src/lib_rpc/RPC_context.mli index 3469bd750..ce7e4be68 100644 --- a/src/lib_rpc/RPC_context.mli +++ b/src/lib_rpc/RPC_context.mli @@ -9,28 +9,41 @@ open Error_monad -class type simple = object +class type ['pr] gen_simple = object method call_service : 'm 'p 'q 'i 'o. - ([< Resto.meth ] as 'm, unit, 'p, 'q, 'i, 'o) RPC_service.t -> + ([< Resto.meth ] as 'm, 'pr, 'p, 'q, 'i, 'o) RPC_service.t -> 'p -> 'q -> 'i -> 'o tzresult Lwt.t end -class type streamed = object +class type ['pr] gen_streamed = object method call_streamed_service : 'm 'p 'q 'i 'o. - ([< Resto.meth ] as 'm, unit, 'p, 'q, 'i, 'o) RPC_service.t -> + ([< Resto.meth ] as 'm, 'pr, 'p, 'q, 'i, 'o) RPC_service.t -> on_chunk: ('o -> unit) -> on_close: (unit -> unit) -> 'p -> 'q -> 'i -> (unit -> unit) tzresult Lwt.t end +class type ['pr] gen = object + inherit ['pr] gen_simple + inherit ['pr] gen_streamed +end + +class type simple = object + inherit [unit] gen_simple +end + +class type streamed = object + inherit [unit] gen_streamed +end + class type t = object inherit simple inherit streamed end -val of_directory : unit RPC_directory.t -> t +class ['pr] of_directory : 'pr RPC_directory.t -> ['pr] gen type error += | Not_found of { meth: RPC_service.meth ; @@ -60,3 +73,4 @@ val make_streamed_call : ([< Resto.meth ], unit, 'p, 'q, 'i, 'o) RPC_service.t -> #streamed -> 'p -> 'q -> 'i -> ('o Lwt_stream.t * stopper) tzresult Lwt.t + diff --git a/src/lib_rpc_http/RPC_client.ml b/src/lib_rpc_http/RPC_client.ml index cc7cbfc8c..0bcc7e543 100644 --- a/src/lib_rpc_http/RPC_client.ml +++ b/src/lib_rpc_http/RPC_client.ml @@ -23,10 +23,6 @@ type ('o, 'e) rest_result = | `Not_found of 'e | `Unauthorized of 'e ] tzresult -type content_type = (string * string) -type raw_content = Cohttp_lwt.Body.t * content_type option -type content = Cohttp_lwt.Body.t * content_type option * Media_type.t option - type rpc_error = | Empty_answer | Connection_failed of string @@ -222,6 +218,9 @@ let request_failed meth uri error = let meth = ( meth : [< RPC_service.meth ] :> RPC_service.meth) in fail (Request_failed { meth ; uri ; error }) +type content_type = (string * string) +type content = Cohttp_lwt.Body.t * content_type option * Media_type.t option + let generic_call ?logger ?accept ?body ?media meth uri : (content, content) rest_result Lwt.t = Client.generic_call meth ?logger ?accept ?body ?media uri >>= function | `Ok (Some v) -> return (`Ok v) diff --git a/src/lib_rpc_http/RPC_client.mli b/src/lib_rpc_http/RPC_client.mli index f72342d01..2bbe41367 100644 --- a/src/lib_rpc_http/RPC_client.mli +++ b/src/lib_rpc_http/RPC_client.mli @@ -82,10 +82,6 @@ type error += (**/**) -type content_type = (string * string) -type raw_content = Cohttp_lwt.Body.t * content_type option -type content = Cohttp_lwt.Body.t * content_type option * Media_type.t option - val call_service : Media_type.t list -> ?logger:logger -> @@ -102,6 +98,15 @@ val call_streamed_service : on_close: (unit -> unit) -> 'p -> 'q -> 'i -> (unit -> unit) tzresult Lwt.t +val generic_json_call : + ?logger:logger -> + ?body:Data_encoding.json -> + [< RPC_service.meth ] -> Uri.t -> + (Data_encoding.json, Data_encoding.json option) rest_result Lwt.t + +type content_type = (string * string) +type content = Cohttp_lwt.Body.t * content_type option * Media_type.t option + val generic_call : ?logger:logger -> ?accept:Media_type.t list -> @@ -110,8 +115,3 @@ val generic_call : [< RPC_service.meth ] -> Uri.t -> (content, content) rest_result Lwt.t -val generic_json_call : - ?logger:logger -> - ?body:Data_encoding.json -> - [< RPC_service.meth ] -> Uri.t -> - (Data_encoding.json, Data_encoding.json option) rest_result Lwt.t diff --git a/src/lib_shell/node_rpc.ml b/src/lib_shell/node_rpc.ml index 7c5439b4b..6f08df840 100644 --- a/src/lib_shell/node_rpc.ml +++ b/src/lib_shell/node_rpc.ml @@ -383,7 +383,7 @@ let build_rpc_directory node = RPC_directory.register_dynamic_directory1 ~descr: "All the RPCs which are specific to the protocol version." - dir Block_services.S.proto_path implementation in + dir (Block_services.S.proto_path ()) implementation in let dir = RPC_directory.gen_register0 dir Protocol_services.S.list (list_protocols node) in diff --git a/src/lib_shell_services/block_services.ml b/src/lib_shell_services/block_services.ml index c6d9d8106..99b396780 100644 --- a/src/lib_shell_services/block_services.ml +++ b/src/lib_shell_services/block_services.ml @@ -131,7 +131,9 @@ module S = struct RPC_arg.make ~name ~descr ~construct ~destruct () let block_path : (unit, unit * block) RPC_path.path = - RPC_path.(root / "blocks" /: blocks_arg ) + RPC_path.(root / "blocks" /: blocks_arg) + let proto_path () = + RPC_path.(open_root / "blocks" /: blocks_arg / "proto") let info = RPC_service.post_service @@ -279,9 +281,6 @@ module S = struct (obj1 (req "unprocessed" (list (dynamic_size operation_encoding)))))) RPC_path.(block_path / "pending_operations") - let proto_path = - RPC_path.(block_path / "proto") - type preapply_param = { timestamp: Time.t ; proto_header: MBytes.t ; diff --git a/src/lib_shell_services/block_services.mli b/src/lib_shell_services/block_services.mli index bd422ad6d..b8737729f 100644 --- a/src/lib_shell_services/block_services.mli +++ b/src/lib_shell_services/block_services.mli @@ -215,6 +215,6 @@ module S : sig (unit * block) * string, unit, unit, string list) RPC_service.t - val proto_path: (unit, unit * block) RPC_path.path + val proto_path: unit -> ('a, 'a * block) RPC_path.path end diff --git a/src/proto_alpha/lib_client/client_baking_blocks.mli b/src/proto_alpha/lib_client/client_baking_blocks.mli index fe5eaa871..d76b9a6a6 100644 --- a/src/proto_alpha/lib_client/client_baking_blocks.mli +++ b/src/proto_alpha/lib_client/client_baking_blocks.mli @@ -21,21 +21,21 @@ type block_info = { } val info: - #RPC_context.simple -> + #Proto_alpha.rpc_context -> ?include_ops:bool -> Block_services.block -> block_info tzresult Lwt.t val compare: block_info -> block_info -> int val monitor: - #RPC_context.t -> + #Proto_alpha.rpc_context -> ?include_ops:bool -> ?length:int -> ?heads:Block_hash.t list -> ?delay:int -> ?min_date:Time.t -> ?min_heads:int -> ?compare:(block_info -> block_info -> int) -> unit -> block_info list tzresult Lwt_stream.t tzresult Lwt.t val blocks_from_cycle: - #RPC_context.simple -> + #Proto_alpha.rpc_context -> Block_services.block -> Cycle.t -> Block_hash.t list tzresult Lwt.t diff --git a/src/proto_alpha/lib_client/client_baking_daemon.ml b/src/proto_alpha/lib_client/client_baking_daemon.ml index f89d8ede4..970789976 100644 --- a/src/proto_alpha/lib_client/client_baking_daemon.ml +++ b/src/proto_alpha/lib_client/client_baking_daemon.ml @@ -7,7 +7,7 @@ (* *) (**************************************************************************) -let run (cctxt : #Client_commands.full_context) ?max_priority ~delay ?min_date delegates ~endorsement ~denunciation ~baking = +let run (cctxt : #Proto_alpha.full_context) ?max_priority ~delay ?min_date delegates ~endorsement ~denunciation ~baking = (* TODO really detach... *) let endorsement = if endorsement then diff --git a/src/proto_alpha/lib_client/client_baking_daemon.mli b/src/proto_alpha/lib_client/client_baking_daemon.mli index 6023c44df..ca6236129 100644 --- a/src/proto_alpha/lib_client/client_baking_daemon.mli +++ b/src/proto_alpha/lib_client/client_baking_daemon.mli @@ -11,7 +11,7 @@ open Proto_alpha open Alpha_context val run: - #Client_commands.full_context -> + #Proto_alpha.full_context -> ?max_priority: int -> delay: int -> ?min_date: Time.t -> diff --git a/src/proto_alpha/lib_client/client_baking_denunciation.mli b/src/proto_alpha/lib_client/client_baking_denunciation.mli index c5c7d7296..ee25c4e28 100644 --- a/src/proto_alpha/lib_client/client_baking_denunciation.mli +++ b/src/proto_alpha/lib_client/client_baking_denunciation.mli @@ -8,6 +8,6 @@ (**************************************************************************) val create: - #Client_commands.full_context -> + #Proto_alpha.full_context -> Client_baking_operations.valid_endorsement tzresult Lwt_stream.t -> unit Lwt.t diff --git a/src/proto_alpha/lib_client/client_baking_endorsement.ml b/src/proto_alpha/lib_client/client_baking_endorsement.ml index bd057b181..9e444394f 100644 --- a/src/proto_alpha/lib_client/client_baking_endorsement.ml +++ b/src/proto_alpha/lib_client/client_baking_endorsement.ml @@ -91,7 +91,7 @@ let get_signing_slots cctxt ?max_priority block delegate level = @@ List.filter (fun (l, _) -> l = level) possibilities in return slots -let inject_endorsement (cctxt : #Client_commands.full_context) +let inject_endorsement (cctxt : #Proto_alpha.full_context) block level ?async src_sk source slot = let block = Block_services.last_baked_block block in @@ -123,7 +123,7 @@ let check_endorsement cctxt level slot = Block_hash.pp_short block Raw_level.pp level slot -let forge_endorsement (cctxt : #Client_commands.full_context) +let forge_endorsement (cctxt : #Proto_alpha.full_context) block ~src_sk ?slot ?max_priority src_pk = let block = Block_services.last_baked_block block in @@ -186,7 +186,7 @@ let drop_old_endorsement ~before state = (fun { block } -> Fitness.compare before block.fitness <= 0) state.to_endorse -let schedule_endorsements (cctxt : #Client_commands.full_context) state bis = +let schedule_endorsements (cctxt : #Proto_alpha.full_context) state bis = let may_endorse (block: Client_baking_blocks.block_info) delegate time = Client_keys.Public_key_hash.name cctxt delegate >>=? fun name -> lwt_log_info "May endorse block %a for %s" @@ -256,7 +256,7 @@ let schedule_endorsements (cctxt : #Client_commands.full_context) state bis = bis) delegates -let schedule_endorsements (cctxt : #Client_commands.full_context) state bis = +let schedule_endorsements (cctxt : #Proto_alpha.full_context) state bis = schedule_endorsements cctxt state bis >>= function | Error exns -> lwt_log_error @@ -311,7 +311,7 @@ let compute_timeout state = else Lwt_unix.sleep (Int64.to_float delay) -let create (cctxt : #Client_commands.full_context) ~delay contracts block_stream = +let create (cctxt : #Proto_alpha.full_context) ~delay contracts block_stream = lwt_log_info "Starting endorsement daemon" >>= fun () -> Lwt_stream.get block_stream >>= function | None | Some (Ok []) | Some (Error _) -> diff --git a/src/proto_alpha/lib_client/client_baking_endorsement.mli b/src/proto_alpha/lib_client/client_baking_endorsement.mli index ee6087ff1..09d5bd61c 100644 --- a/src/proto_alpha/lib_client/client_baking_endorsement.mli +++ b/src/proto_alpha/lib_client/client_baking_endorsement.mli @@ -11,7 +11,7 @@ open Proto_alpha open Alpha_context val forge_endorsement: - #Client_commands.full_context -> + #Proto_alpha.full_context -> Block_services.block -> src_sk:Client_keys.sk_locator -> ?slot:int -> @@ -20,7 +20,7 @@ val forge_endorsement: Operation_hash.t tzresult Lwt.t val create : - #Client_commands.full_context -> + #Proto_alpha.full_context -> delay:int -> public_key_hash list -> Client_baking_blocks.block_info list tzresult Lwt_stream.t -> unit Lwt.t diff --git a/src/proto_alpha/lib_client/client_baking_forge.ml b/src/proto_alpha/lib_client/client_baking_forge.ml index 69d43e14e..f9f227d95 100644 --- a/src/proto_alpha/lib_client/client_baking_forge.ml +++ b/src/proto_alpha/lib_client/client_baking_forge.ml @@ -368,7 +368,7 @@ let compute_timeout { future_slots } = else Lwt_unix.sleep (Int64.to_float delay) -let get_unrevealed_nonces (cctxt : #Client_commands.full_context) ?(force = false) block = +let get_unrevealed_nonces (cctxt : #Proto_alpha.full_context) ?(force = false) block = Client_proto_rpcs.Context.next_level cctxt block >>=? fun level -> let cur_cycle = level.cycle in match Cycle.pred cur_cycle with @@ -416,7 +416,7 @@ let get_delegates cctxt state = | _ :: _ as delegates -> return delegates let insert_block - (cctxt : #Client_commands.full_context) ?max_priority state (bi: Client_baking_blocks.block_info) = + (cctxt : #Proto_alpha.full_context) ?max_priority state (bi: Client_baking_blocks.block_info) = begin safe_get_unrevealed_nonces cctxt (`Hash bi.hash) >>= fun nonces -> Client_baking_revelation.forge_seed_nonce_revelation @@ -461,7 +461,7 @@ let insert_blocks cctxt ?max_priority state bis = Format.eprintf "Error: %a" pp_print_error err ; Lwt.return_unit -let bake (cctxt : #Client_commands.full_context) state = +let bake (cctxt : #Proto_alpha.full_context) state = let slots = pop_baking_slots state in let seed_nonce = generate_seed_nonce () in let seed_nonce_hash = Nonce.hash seed_nonce in @@ -550,7 +550,7 @@ let bake (cctxt : #Client_commands.full_context) state = return () let create - (cctxt : #Client_commands.full_context) ?max_priority delegates + (cctxt : #Proto_alpha.full_context) ?max_priority delegates (block_stream: Client_baking_blocks.block_info list tzresult Lwt_stream.t) (endorsement_stream: diff --git a/src/proto_alpha/lib_client/client_baking_forge.mli b/src/proto_alpha/lib_client/client_baking_forge.mli index f0bb0f735..98e243d64 100644 --- a/src/proto_alpha/lib_client/client_baking_forge.mli +++ b/src/proto_alpha/lib_client/client_baking_forge.mli @@ -17,7 +17,7 @@ val generate_seed_nonce: unit -> Nonce.t reveal the aforementionned nonce during the next cycle. *) val inject_block: - #RPC_context.simple -> + #Proto_alpha.rpc_context -> ?force:bool -> ?net_id:Net_id.t -> shell_header:Block_header.shell_header -> @@ -36,7 +36,7 @@ type error += | Failed_to_preapply of Tezos_base.Operation.t * error list val forge_block: - #RPC_context.simple -> + #Proto_alpha.rpc_context -> Block_services.block -> ?force:bool -> ?operations:Operation.raw list -> @@ -68,15 +68,15 @@ val forge_block: module State : sig val get_block: - #Client_commands.full_context -> + #Proto_alpha.full_context -> Raw_level.t -> Block_hash.t list tzresult Lwt.t val record_block: - #Client_commands.full_context -> + #Proto_alpha.full_context -> Raw_level.t -> Block_hash.t -> Nonce.t -> unit tzresult Lwt.t end val create: - #Client_commands.full_context -> + #Proto_alpha.full_context -> ?max_priority: int -> public_key_hash list -> Client_baking_blocks.block_info list tzresult Lwt_stream.t -> @@ -84,7 +84,7 @@ val create: unit tzresult Lwt.t val get_unrevealed_nonces: - #Client_commands.full_context -> + #Proto_alpha.full_context -> ?force:bool -> Block_services.block -> (Block_hash.t * (Raw_level.t * Nonce.t)) list tzresult Lwt.t diff --git a/src/proto_alpha/lib_client/client_baking_lib.ml b/src/proto_alpha/lib_client/client_baking_lib.ml index 38bcb596e..16f3941a8 100644 --- a/src/proto_alpha/lib_client/client_baking_lib.ml +++ b/src/proto_alpha/lib_client/client_baking_lib.ml @@ -10,7 +10,7 @@ open Proto_alpha open Alpha_context -let bake_block (cctxt : #Client_commands.full_context) block +let bake_block (cctxt : #Proto_alpha.full_context) block ?force ?max_priority ?(free_baking=false) ?src_sk delegate = begin match src_sk with @@ -59,7 +59,7 @@ let do_reveal cctxt block blocks = Client_proto_nonces.dels cctxt (List.map fst blocks) >>=? fun () -> return () -let reveal_block_nonces (cctxt : #Client_commands.full_context) block_hashes = +let reveal_block_nonces (cctxt : #Proto_alpha.full_context) block_hashes = Lwt_list.filter_map_p (fun hash -> Lwt.catch diff --git a/src/proto_alpha/lib_client/client_baking_lib.mli b/src/proto_alpha/lib_client/client_baking_lib.mli index 80b12ad28..26fbbf2e4 100644 --- a/src/proto_alpha/lib_client/client_baking_lib.mli +++ b/src/proto_alpha/lib_client/client_baking_lib.mli @@ -12,7 +12,7 @@ open Alpha_context (** Mine a block *) val bake_block: - #Client_commands.full_context -> + #Proto_alpha.full_context -> Block_services.block -> ?force:bool -> ?max_priority: int -> @@ -23,32 +23,32 @@ val bake_block: (** Endorse a block *) val endorse_block: - #Client_commands.full_context -> + #Proto_alpha.full_context -> ?max_priority:int -> Client_keys.Public_key_hash.t -> unit Error_monad.tzresult Lwt.t (** Get the previous cycle of the given cycle *) val get_predecessor_cycle: - #Client_commands.full_context -> + #Proto_alpha.full_context -> Cycle.t -> Cycle.t Lwt.t (** Reveal the nonces used to bake each block in the given list *) val reveal_block_nonces : - #Client_commands.full_context -> + #Proto_alpha.full_context -> Block_hash.t list -> unit Error_monad.tzresult Lwt.t (** Reveal all unrevealed nonces *) val reveal_nonces : - #Client_commands.full_context -> + #Proto_alpha.full_context -> unit -> unit Error_monad.tzresult Lwt.t (** Initialize the baking daemon *) val run_daemon: - #Client_commands.full_context -> + #Proto_alpha.full_context -> ?max_priority:int -> endorsement_delay:int -> ('a * public_key_hash) list -> diff --git a/src/proto_alpha/lib_client/client_baking_main.mli b/src/proto_alpha/lib_client/client_baking_main.mli index cd41b6053..dc60437ab 100644 --- a/src/proto_alpha/lib_client/client_baking_main.mli +++ b/src/proto_alpha/lib_client/client_baking_main.mli @@ -7,4 +7,4 @@ (* *) (**************************************************************************) -val commands: unit -> Client_commands.command list +val commands: unit -> (Proto_alpha.full_context, unit) Cli_entries.command list diff --git a/src/proto_alpha/lib_client/client_baking_operations.mli b/src/proto_alpha/lib_client/client_baking_operations.mli index 117f3d13c..28fb93605 100644 --- a/src/proto_alpha/lib_client/client_baking_operations.mli +++ b/src/proto_alpha/lib_client/client_baking_operations.mli @@ -16,7 +16,7 @@ type operation = { } val monitor: - #RPC_context.t -> + #Proto_alpha.rpc_context -> ?contents:bool -> ?check:bool -> unit -> operation list tzresult Lwt_stream.t tzresult Lwt.t @@ -28,6 +28,6 @@ type valid_endorsement = { } val monitor_endorsement: - #RPC_context.t -> + #Proto_alpha.rpc_context -> valid_endorsement tzresult Lwt_stream.t tzresult Lwt.t diff --git a/src/proto_alpha/lib_client/client_baking_revelation.ml b/src/proto_alpha/lib_client/client_baking_revelation.ml index 82df93657..72c3effcd 100644 --- a/src/proto_alpha/lib_client/client_baking_revelation.ml +++ b/src/proto_alpha/lib_client/client_baking_revelation.ml @@ -25,7 +25,7 @@ let inject_seed_nonce_revelation rpc_config block ?async nonces = return oph let forge_seed_nonce_revelation - (cctxt: #Client_commands.full_context) + (cctxt: #Proto_alpha.full_context) block nonces = Block_services.hash cctxt block >>=? fun hash -> match nonces with diff --git a/src/proto_alpha/lib_client/client_baking_revelation.mli b/src/proto_alpha/lib_client/client_baking_revelation.mli index faa201672..38a933631 100644 --- a/src/proto_alpha/lib_client/client_baking_revelation.mli +++ b/src/proto_alpha/lib_client/client_baking_revelation.mli @@ -11,14 +11,14 @@ open Proto_alpha open Alpha_context val inject_seed_nonce_revelation: - #RPC_context.simple -> + #Proto_alpha.rpc_context -> Block_services.block -> ?async:bool -> (Raw_level.t * Nonce.t) list -> Operation_hash.t tzresult Lwt.t val forge_seed_nonce_revelation: - #Client_commands.full_context -> + #Proto_alpha.full_context -> Block_services.block -> (Raw_level.t * Nonce.t) list -> unit tzresult Lwt.t diff --git a/src/proto_alpha/lib_client/client_proto_args.mli b/src/proto_alpha/lib_client/client_proto_args.mli index 90ec654a8..5f9797a87 100644 --- a/src/proto_alpha/lib_client/client_proto_args.mli +++ b/src/proto_alpha/lib_client/client_proto_args.mli @@ -12,36 +12,36 @@ open Alpha_context val tez_sym: string -val init_arg: (string, Client_commands.full_context) Cli_entries.arg -val fee_arg: (Tez.t, Client_commands.full_context) Cli_entries.arg -val arg_arg: (string, Client_commands.full_context) Cli_entries.arg -val source_arg: (string option, Client_commands.full_context) Cli_entries.arg +val init_arg: (string, Proto_alpha.full_context) Cli_entries.arg +val fee_arg: (Tez.t, Proto_alpha.full_context) Cli_entries.arg +val arg_arg: (string, Proto_alpha.full_context) Cli_entries.arg +val source_arg: (string option, Proto_alpha.full_context) Cli_entries.arg -val delegate_arg: (string option, Client_commands.full_context) Cli_entries.arg -val delegatable_switch: (bool, Client_commands.full_context) Cli_entries.arg -val spendable_switch: (bool, Client_commands.full_context) Cli_entries.arg -val max_priority_arg: (int option, Client_commands.full_context) Cli_entries.arg -val free_baking_switch: (bool, Client_commands.full_context) Cli_entries.arg -val force_switch: (bool, Client_commands.full_context) Cli_entries.arg -val endorsement_delay_arg: (int, Client_commands.full_context) Cli_entries.arg +val delegate_arg: (string option, Proto_alpha.full_context) Cli_entries.arg +val delegatable_switch: (bool, Proto_alpha.full_context) Cli_entries.arg +val spendable_switch: (bool, Proto_alpha.full_context) Cli_entries.arg +val max_priority_arg: (int option, Proto_alpha.full_context) Cli_entries.arg +val free_baking_switch: (bool, Proto_alpha.full_context) Cli_entries.arg +val force_switch: (bool, Proto_alpha.full_context) Cli_entries.arg +val endorsement_delay_arg: (int, Proto_alpha.full_context) Cli_entries.arg -val no_print_source_flag : (bool, Client_commands.full_context) Cli_entries.arg +val no_print_source_flag : (bool, Proto_alpha.full_context) Cli_entries.arg val tez_arg : default:string -> parameter:string -> doc:string -> - (Tez.t, Client_commands.full_context) Cli_entries.arg + (Tez.t, Proto_alpha.full_context) Cli_entries.arg val tez_param : name:string -> desc:string -> - ('a, Client_commands.full_context, 'ret) Cli_entries.params -> - (Tez.t -> 'a, Client_commands.full_context, 'ret) Cli_entries.params + ('a, full_context, 'ret) Cli_entries.params -> + (Tez.t -> 'a, full_context, 'ret) Cli_entries.params module Daemon : sig - val baking_switch: (bool, Client_commands.full_context) Cli_entries.arg - val endorsement_switch: (bool, Client_commands.full_context) Cli_entries.arg - val denunciation_switch: (bool, Client_commands.full_context) Cli_entries.arg + val baking_switch: (bool, Proto_alpha.full_context) Cli_entries.arg + val endorsement_switch: (bool, Proto_alpha.full_context) Cli_entries.arg + val denunciation_switch: (bool, Proto_alpha.full_context) Cli_entries.arg end -val string_parameter : (string, Client_commands.full_context) Cli_entries.parameter +val string_parameter : (string, full_context) Cli_entries.parameter diff --git a/src/proto_alpha/lib_client/client_proto_context.ml b/src/proto_alpha/lib_client/client_proto_context.ml index 056894027..a0198762a 100644 --- a/src/proto_alpha/lib_client/client_proto_context.ml +++ b/src/proto_alpha/lib_client/client_proto_context.ml @@ -13,10 +13,10 @@ open Tezos_micheline open Client_proto_contracts open Client_keys -let get_balance (rpc : #RPC_context.simple) block contract = +let get_balance (rpc : #Proto_alpha.rpc_context) block contract = Client_proto_rpcs.Context.Contract.balance rpc block contract -let get_storage (rpc : #RPC_context.simple) block contract = +let get_storage (rpc : #Proto_alpha.rpc_context) block contract = Client_proto_rpcs.Context.Contract.storage rpc block contract let rec find_predecessor rpc_config h n = @@ -195,7 +195,7 @@ let set_delegate (cctxt : #RPC_context.simple) block ~fee contract ~src_pk ~mana cctxt block ~source:contract ~src_pk ~manager_sk ~fee opt_delegate -let source_to_keys (wallet : #Client_commands.full_context) block source = +let source_to_keys (wallet : #Proto_alpha.full_context) block source = get_manager wallet block source >>=? fun (_src_name, _src_pkh, src_pk, src_sk) -> return (src_pk, src_sk) @@ -216,7 +216,7 @@ let originate_contract ~src_pk ~src_sk ~code - (cctxt : #Client_commands.full_context) = + (cctxt : #Proto_alpha.full_context) = Lwt.return (Michelson_v1_parser.parse_expression initial_storage) >>= fun result -> Lwt.return (Micheline_parser.no_parsing_error result) >>=? fun { Michelson_v1_parser.expanded = storage } -> diff --git a/src/proto_alpha/lib_client/client_proto_context.mli b/src/proto_alpha/lib_client/client_proto_context.mli index 68d08d1c1..8f808fcf6 100644 --- a/src/proto_alpha/lib_client/client_proto_context.mli +++ b/src/proto_alpha/lib_client/client_proto_context.mli @@ -11,31 +11,31 @@ open Proto_alpha open Alpha_context val list_contract_labels : - #Client_commands.full_context -> + #Proto_alpha.full_context -> Block_services.block -> (string * string * string) list tzresult Lwt.t val get_storage : - #RPC_context.simple -> + #Proto_alpha.rpc_context -> Block_services.block -> Contract.t -> Script.expr option tzresult Lwt.t val get_manager : - #Client_commands.full_context -> + #Proto_alpha.full_context -> Block_services.block -> Contract.t -> (string * public_key_hash * public_key * Client_keys.sk_locator) tzresult Lwt.t val get_balance: - #RPC_context.simple -> + #Proto_alpha.rpc_context -> Block_services.block -> Contract.t -> Tez.t tzresult Lwt.t val set_delegate : - #RPC_context.simple -> + #Proto_alpha.rpc_context -> Block_services.block -> fee:Tez.tez -> Contract.t -> @@ -50,7 +50,7 @@ val operation_submitted_message : unit tzresult Lwt.t val source_to_keys: - #Client_commands.full_context -> + #Proto_alpha.full_context -> Block_services.block -> Contract.t -> (public_key * Client_keys.sk_locator) tzresult Lwt.t @@ -66,12 +66,12 @@ val originate_account : balance:Tez.tez -> fee:Tez.tez -> Block_services.block -> - #RPC_context.simple -> + #Proto_alpha.rpc_context -> unit -> (Operation_list_hash.elt * Contract.t) tzresult Lwt.t val save_contract : force:bool -> - #Client_commands.full_context -> + #Proto_alpha.full_context -> string -> Contract.t -> unit tzresult Lwt.t @@ -94,18 +94,18 @@ val originate_contract: src_pk:public_key -> src_sk:Client_keys.sk_locator -> code:Script.expr -> - #Client_commands.full_context -> + #Proto_alpha.full_context -> (Operation_hash.t * Contract.t) tzresult Lwt.t val faucet : ?branch:int -> manager_pkh:public_key_hash -> Block_services.block -> - #RPC_context.simple -> + #Proto_alpha.rpc_context -> unit -> (Operation_list_hash.elt * Contract.t) tzresult Lwt.t val transfer : - #RPC_context.simple -> + #Proto_alpha.rpc_context -> Block_services.block -> ?branch:int -> source:Contract.t -> @@ -119,7 +119,7 @@ val transfer : (Operation_hash.t * Contract.t list) tzresult Lwt.t val dictate : - #RPC_context.simple -> + #Proto_alpha.rpc_context -> Block_services.block -> dictator_operation -> secret_key -> diff --git a/src/proto_alpha/lib_client/client_proto_context_commands.ml b/src/proto_alpha/lib_client/client_proto_context_commands.ml index 15dea9c28..ac8bbbe99 100644 --- a/src/proto_alpha/lib_client/client_proto_context_commands.ml +++ b/src/proto_alpha/lib_client/client_proto_context_commands.ml @@ -47,7 +47,7 @@ let commands () = command ~group ~desc: "Access the timestamp of the block." no_options (fixed [ "get" ; "timestamp" ]) - begin fun () (cctxt : Client_commands.full_context) -> + begin fun () (cctxt : Proto_alpha.full_context) -> Block_services.timestamp cctxt cctxt#block >>=? fun v -> cctxt#message "%s" (Time.to_notation v) >>= fun () -> @@ -57,7 +57,7 @@ let commands () = command ~group ~desc: "Lists all non empty contracts of the block." no_options (fixed [ "list" ; "contracts" ]) - begin fun () (cctxt : Client_commands.full_context) -> + begin fun () (cctxt : Proto_alpha.full_context) -> list_contract_labels cctxt cctxt#block >>=? fun contracts -> Lwt_list.iter_s (fun (alias, hash, kind) -> cctxt#message "%s%s%s" hash kind alias) @@ -70,7 +70,7 @@ let commands () = (prefixes [ "get" ; "balance" ; "for" ] @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract" @@ stop) - begin fun () (_, contract) (cctxt : Client_commands.full_context) -> + begin fun () (_, contract) (cctxt : Proto_alpha.full_context) -> get_balance cctxt cctxt#block contract >>=? fun amount -> cctxt#answer "%a %s" Tez.pp amount Client_proto_args.tez_sym >>= fun () -> return () @@ -81,7 +81,7 @@ let commands () = (prefixes [ "get" ; "storage" ; "for" ] @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract" @@ stop) - begin fun () (_, contract) (cctxt : Client_commands.full_context) -> + begin fun () (_, contract) (cctxt : Proto_alpha.full_context) -> get_storage cctxt cctxt#block contract >>=? function | None -> cctxt#error "This is not a smart contract." @@ -95,7 +95,7 @@ let commands () = (prefixes [ "get" ; "manager" ; "for" ] @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract" @@ stop) - begin fun () (_, contract) (cctxt : Client_commands.full_context) -> + begin fun () (_, contract) (cctxt : Proto_alpha.full_context) -> Client_proto_contracts.get_manager cctxt cctxt#block contract >>=? fun manager -> Public_key_hash.rev_find cctxt manager >>=? fun mn -> @@ -110,7 +110,7 @@ let commands () = (prefixes [ "get" ; "delegate" ; "for" ] @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract" @@ stop) - begin fun () (_, contract) (cctxt : Client_commands.full_context) -> + begin fun () (_, contract) (cctxt : Proto_alpha.full_context) -> Client_proto_contracts.get_delegate cctxt cctxt#block contract >>=? fun delegate -> Public_key_hash.rev_find cctxt delegate >>=? fun mn -> @@ -128,7 +128,7 @@ let commands () = @@ Public_key_hash.alias_param ~name: "mgr" ~desc: "new delegate of the contract" @@ stop) - begin fun fee (_, contract) (_, delegate) cctxt -> + begin fun fee (_, contract) (_, delegate) (cctxt : Proto_alpha.full_context) -> source_to_keys cctxt cctxt#block contract >>=? fun (src_pk, manager_sk) -> set_delegate ~fee cctxt cctxt#block contract (Some delegate) ~src_pk ~manager_sk >>=? fun oph -> operation_submitted_message cctxt oph @@ -150,7 +150,7 @@ let commands () = ~name:"src" ~desc: "name of the source contract" @@ stop) begin fun (fee, delegate, delegatable, force) - new_contract (_, manager_pkh) balance (_, source) (cctxt : Client_commands.full_context) -> + new_contract (_, manager_pkh) balance (_, source) (cctxt : Proto_alpha.full_context) -> RawContractAlias.of_fresh cctxt force new_contract >>=? fun alias_name -> source_to_keys cctxt cctxt#block source >>=? fun (src_pk, src_sk) -> get_pkh cctxt delegate >>=? fun delegate -> @@ -192,7 +192,7 @@ let commands () = Combine with -init if the storage type is not unit." @@ stop) begin fun (fee, delegate, force, delegatable, spendable, initial_storage, no_print_source) - alias_name (_, manager) balance (_, source) program (cctxt : Client_commands.full_context) -> + alias_name (_, manager) balance (_, source) program (cctxt : Proto_alpha.full_context) -> RawContractAlias.of_fresh cctxt force alias_name >>=? fun alias_name -> Lwt.return (Micheline_parser.no_parsing_error program) >>=? fun { expanded = code } -> source_to_keys cctxt cctxt#block source >>=? fun (src_pk, src_sk) -> @@ -238,7 +238,7 @@ let commands () = @@ Public_key_hash.alias_param ~name: "mgr" ~desc: "manager of the new contract" @@ stop) - begin fun force alias_name (_, manager_pkh) cctxt -> + begin fun force alias_name (_, manager_pkh) (cctxt: Proto_alpha.full_context) -> RawContractAlias.of_fresh cctxt force alias_name >>=? fun alias_name -> faucet ~manager_pkh cctxt#block cctxt () >>=? fun (oph, contract) -> operation_submitted_message cctxt diff --git a/src/proto_alpha/lib_client/client_proto_contracts.mli b/src/proto_alpha/lib_client/client_proto_contracts.mli index ea2a1625f..419d717da 100644 --- a/src/proto_alpha/lib_client/client_proto_contracts.mli +++ b/src/proto_alpha/lib_client/client_proto_contracts.mli @@ -42,19 +42,19 @@ val list_contracts: (string * string * RawContractAlias.t) list tzresult Lwt.t val get_manager: - #RPC_context.simple -> + #Proto_alpha.rpc_context -> Block_services.block -> Contract.t -> public_key_hash tzresult Lwt.t val get_delegate: - #RPC_context.simple -> + #Proto_alpha.rpc_context -> Block_services.block -> Contract.t -> public_key_hash tzresult Lwt.t val check_public_key : - #RPC_context.simple -> + #Proto_alpha.rpc_context -> Block_services.block -> ?src_pk:public_key -> public_key_hash -> diff --git a/src/proto_alpha/lib_client/client_proto_contracts_commands.ml b/src/proto_alpha/lib_client/client_proto_contracts_commands.ml index a0a18d543..c6416c6bc 100644 --- a/src/proto_alpha/lib_client/client_proto_contracts_commands.ml +++ b/src/proto_alpha/lib_client/client_proto_contracts_commands.ml @@ -40,7 +40,7 @@ let commands () = command ~group ~desc: "Lists all known contracts in the wallet." no_options (fixed [ "list" ; "known" ; "contracts" ]) - (fun () (cctxt : Client_commands.full_context) -> + (fun () (cctxt : Proto_alpha.full_context) -> list_contracts cctxt >>=? fun contracts -> iter_s (fun (prefix, alias, contract) -> @@ -62,7 +62,7 @@ let commands () = (prefixes [ "show" ; "known" ; "contract" ] @@ RawContractAlias.alias_param @@ stop) - (fun () (_, contract) (cctxt : Client_commands.full_context) -> + (fun () (_, contract) (cctxt : Proto_alpha.full_context) -> cctxt#message "%a\n%!" Contract.pp contract >>= fun () -> return ()) ; diff --git a/src/proto_alpha/lib_client/client_proto_main.ml b/src/proto_alpha/lib_client/client_proto_main.ml index 0b2489b2f..aa555bee6 100644 --- a/src/proto_alpha/lib_client/client_proto_main.ml +++ b/src/proto_alpha/lib_client/client_proto_main.ml @@ -13,6 +13,7 @@ let protocol = let () = Client_commands.register protocol @@ + List.map (Cli_entries.map_command (new Proto_alpha.wrap_full_context)) @@ Client_proto_programs_commands.commands () @ Client_proto_contracts_commands.commands () @ Client_proto_context_commands.commands () @ diff --git a/src/proto_alpha/lib_client/client_proto_programs.mli b/src/proto_alpha/lib_client/client_proto_programs.mli index d93f6ba96..4ad18b5a4 100644 --- a/src/proto_alpha/lib_client/client_proto_programs.mli +++ b/src/proto_alpha/lib_client/client_proto_programs.mli @@ -20,7 +20,7 @@ val run : storage:Michelson_v1_parser.parsed -> input:Michelson_v1_parser.parsed -> Block_services.block -> - #RPC_context.simple -> + #Proto_alpha.rpc_context -> (Script.expr * Script.expr * (Script.expr * Script.expr option) list option) tzresult Lwt.t val trace : @@ -29,7 +29,7 @@ val trace : storage:Michelson_v1_parser.parsed -> input:Michelson_v1_parser.parsed -> Block_services.block -> - #RPC_context.simple -> + #Proto_alpha.rpc_context -> (Script.expr * Script.expr * (int * Gas.t * Script.expr list) list * (Script.expr * Script.expr option) list option) tzresult Lwt.t val print_run_result : @@ -53,20 +53,20 @@ val hash_and_sign : Michelson_v1_parser.parsed -> Client_keys.sk_locator -> Block_services.block -> - #RPC_context.simple -> + #Proto_alpha.rpc_context -> (string * string) tzresult Lwt.t val typecheck_data : data:Michelson_v1_parser.parsed -> ty:Michelson_v1_parser.parsed -> Block_services.block -> - #RPC_context.simple -> + #Proto_alpha.rpc_context -> unit tzresult Lwt.t val typecheck_program : Michelson_v1_parser.parsed -> Block_services.block -> - #RPC_context.simple -> + #Proto_alpha.rpc_context -> Script_tc_errors.type_map tzresult Lwt.t val print_typecheck_result : diff --git a/src/proto_alpha/lib_client/client_proto_programs_commands.ml b/src/proto_alpha/lib_client/client_proto_programs_commands.ml index 9e6e7008c..6d02980f5 100644 --- a/src/proto_alpha/lib_client/client_proto_programs_commands.ml +++ b/src/proto_alpha/lib_client/client_proto_programs_commands.ml @@ -43,7 +43,7 @@ let commands () = command ~group ~desc: "Lists all programs in the library." no_options (fixed [ "list" ; "known" ; "programs" ]) - (fun () (cctxt : Client_commands.full_context) -> + (fun () (cctxt : Proto_alpha.full_context) -> Program.load cctxt >>=? fun list -> Lwt_list.iter_s (fun (n, _) -> cctxt#message "%s" n) list >>= fun () -> return ()) ; @@ -54,7 +54,7 @@ let commands () = @@ Program.fresh_alias_param @@ Program.source_param @@ stop) - (fun force name hash (cctxt : Client_commands.full_context) -> + (fun force name hash cctxt -> Program.of_fresh cctxt force name >>=? fun name -> Program.add ~force cctxt name hash) ; @@ -70,7 +70,7 @@ let commands () = (prefixes [ "show" ; "known" ; "program" ] @@ Program.alias_param @@ stop) - (fun () (_, program) (cctxt : Client_commands.full_context) -> + (fun () (_, program) (cctxt : Proto_alpha.full_context) -> Program.to_source program >>=? fun source -> cctxt#message "%s\n" source >>= fun () -> return ()) ; diff --git a/src/proto_alpha/lib_client/client_proto_programs_commands.mli b/src/proto_alpha/lib_client/client_proto_programs_commands.mli index cd41b6053..dc60437ab 100644 --- a/src/proto_alpha/lib_client/client_proto_programs_commands.mli +++ b/src/proto_alpha/lib_client/client_proto_programs_commands.mli @@ -7,4 +7,4 @@ (* *) (**************************************************************************) -val commands: unit -> Client_commands.command list +val commands: unit -> (Proto_alpha.full_context, unit) Cli_entries.command list diff --git a/src/proto_alpha/lib_client/client_proto_rpcs.ml b/src/proto_alpha/lib_client/client_proto_rpcs.ml index 8deed616b..34feeee68 100644 --- a/src/proto_alpha/lib_client/client_proto_rpcs.ml +++ b/src/proto_alpha/lib_client/client_proto_rpcs.ml @@ -11,11 +11,11 @@ open Proto_alpha open Alpha_context let make_call1 cctxt s= - RPC_context.make_call1 (s Block_services.S.proto_path) cctxt + RPC_context.make_call1 (s (Block_services.S.proto_path ())) cctxt let make_call2 cctxt s = - RPC_context.make_call2 (s Block_services.S.proto_path) cctxt + RPC_context.make_call2 (s (Block_services.S.proto_path ())) cctxt let make_call3 cctxt s = - RPC_context.make_call3 (s Block_services.S.proto_path) cctxt + RPC_context.make_call3 (s (Block_services.S.proto_path ())) cctxt let make_opt_call2 cctxt s block a1 q i = make_call2 cctxt s block a1 q i >>= function diff --git a/src/proto_alpha/lib_client/jbuild b/src/proto_alpha/lib_client/jbuild index 781c0a8e2..e856317c4 100644 --- a/src/proto_alpha/lib_client/jbuild +++ b/src/proto_alpha/lib_client/jbuild @@ -7,13 +7,15 @@ tezos-protocol-alpha tezos-protocol-environment-client tezos-shell-services - tezos-client-base)) + tezos-client-base + tezos-rpc-http)) (library_flags (:standard -linkall)) (flags (:standard -w -9+27-30-32-40@8 -safe-string -open Tezos_base__TzPervasives -open Tezos_shell_services - -open Tezos_client_base)))) + -open Tezos_client_base + -open Tezos_rpc_http)))) (alias ((name runtest_indent) diff --git a/src/proto_alpha/lib_client/proto_alpha.ml b/src/proto_alpha/lib_client/proto_alpha.ml index ebcc00e65..3a10cf4a9 100644 --- a/src/proto_alpha/lib_client/proto_alpha.ml +++ b/src/proto_alpha/lib_client/proto_alpha.ml @@ -10,3 +10,33 @@ module Name = struct let name = "alpha" end module Alpha_environment = Tezos_protocol_environment_client.Fake.Make(Name)() include Tezos_protocol_alpha.Functor.Make(Alpha_environment) + +class type rpc_context = object + inherit RPC_client.ctxt + inherit [Block_services.block] Alpha_environment.RPC_context.simple +end + +class wrap_proto_context (t : RPC_client.ctxt) : rpc_context = object + method generic_json_call = t#generic_json_call + method call_service : 'm 'p 'q 'i 'o. + ([< Resto.meth ] as 'm, unit, 'p, 'q, 'i, 'o) RPC_service.t -> + 'p -> 'q -> 'i -> 'o tzresult Lwt.t= t#call_service + method call_streamed_service : 'm 'p 'q 'i 'o. + ([< Resto.meth ] as 'm, unit, 'p, 'q, 'i, 'o) RPC_service.t -> + on_chunk: ('o -> unit) -> + on_close: (unit -> unit) -> + 'p -> 'q -> 'i -> (unit -> unit) tzresult Lwt.t = t#call_streamed_service + inherit [Block_services.block] Alpha_environment.proto_rpc_context + (t :> RPC_context.t) (Block_services.S.proto_path ()) +end + +class type full_context = object + inherit Client_commands.full_context + inherit [Block_services.block] Alpha_environment.RPC_context.simple +end + +class wrap_full_context (t : Client_commands.full_context) : full_context = object + inherit Client_commands.proxy_context t + inherit [Block_services.block] Alpha_environment.proto_rpc_context + (t :> RPC_context.t) (Block_services.S.proto_path ()) +end diff --git a/src/proto_alpha/lib_client/test/proto_alpha_helpers.ml b/src/proto_alpha/lib_client/test/proto_alpha_helpers.ml index d939cc5e8..89f6abc37 100644 --- a/src/proto_alpha/lib_client/test/proto_alpha_helpers.ml +++ b/src/proto_alpha/lib_client/test/proto_alpha_helpers.ml @@ -22,6 +22,7 @@ let rpc_config = ref { } let build_rpc_context config = + new Proto_alpha.wrap_proto_context @@ new RPC_client.http_ctxt config Media_type.all_media_types let rpc_ctxt = ref (build_rpc_context !rpc_config)