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

Client: introduce an alternative context alpha's commands

Browse Source
This commit is contained in:
Grégoire Henry 2018-02-11 19:17:40 +01:00
parent d539072f1b
commit e4cde4c196
39 changed files with 315 additions and 134 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

89
src/lib_base/protocol_environment.ml
View File

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

8
src/lib_base/protocol_environment.mli
View File

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

22
src/lib_client_base/client_commands.ml
View File

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

2
src/lib_client_base/client_commands.mli
View File

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

32
src/lib_rpc/RPC_context.ml
View File

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

24
src/lib_rpc/RPC_context.mli
View File

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

7
src/lib_rpc_http/RPC_client.ml
View File

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

18
src/lib_rpc_http/RPC_client.mli
View File

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

2
src/lib_shell/node_rpc.ml
View File

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

7
src/lib_shell_services/block_services.ml
View File

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

2
src/lib_shell_services/block_services.mli
View File

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

6
src/proto_alpha/lib_client/client_baking_blocks.mli
View File

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

2
src/proto_alpha/lib_client/client_baking_daemon.ml
View File

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

2
src/proto_alpha/lib_client/client_baking_daemon.mli
View File

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

2
src/proto_alpha/lib_client/client_baking_denunciation.mli
View File

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

10
src/proto_alpha/lib_client/client_baking_endorsement.ml
View File

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

4
src/proto_alpha/lib_client/client_baking_endorsement.mli
View File

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

8
src/proto_alpha/lib_client/client_baking_forge.ml
View File

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

12
src/proto_alpha/lib_client/client_baking_forge.mli
View File

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

4
src/proto_alpha/lib_client/client_baking_lib.ml
View File

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

12
src/proto_alpha/lib_client/client_baking_lib.mli
View File

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

2
src/proto_alpha/lib_client/client_baking_main.mli
View File

@ -7,4 +7,4 @@
(* *)
(**************************************************************************)
val commands: unit -> Client_commands.command list
val commands: unit -> (Proto_alpha.full_context, unit) Cli_entries.command list

4
src/proto_alpha/lib_client/client_baking_operations.mli
View File

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

2
src/proto_alpha/lib_client/client_baking_revelation.ml
View File

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

4
src/proto_alpha/lib_client/client_baking_revelation.mli
View File

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

38
src/proto_alpha/lib_client/client_proto_args.mli
View File

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

8
src/proto_alpha/lib_client/client_proto_context.ml
View File

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

24
src/proto_alpha/lib_client/client_proto_context.mli
View File

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

20
src/proto_alpha/lib_client/client_proto_context_commands.ml
View File

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

6
src/proto_alpha/lib_client/client_proto_contracts.mli
View File

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

4
src/proto_alpha/lib_client/client_proto_contracts_commands.ml
View File

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

1
src/proto_alpha/lib_client/client_proto_main.ml
View File

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

10
src/proto_alpha/lib_client/client_proto_programs.mli
View File

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

6
src/proto_alpha/lib_client/client_proto_programs_commands.ml
View File

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

2
src/proto_alpha/lib_client/client_proto_programs_commands.mli
View File

@ -7,4 +7,4 @@
(* *)
(**************************************************************************)
val commands: unit -> Client_commands.command list
val commands: unit -> (Proto_alpha.full_context, unit) Cli_entries.command list

6
src/proto_alpha/lib_client/client_proto_rpcs.ml
View File

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

6
src/proto_alpha/lib_client/jbuild
View File

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

30
src/proto_alpha/lib_client/proto_alpha.ml
View File

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

1
src/proto_alpha/lib_client/test/proto_alpha_helpers.ml
View File

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