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

Client library refactor

Browse Source
This commit is contained in:
Milo Davis 2017-11-07 17:38:11 +01:00 committed by Benjamin Canou
parent 0e2ed6f133
commit ae2959b91c
61 changed files with 1980 additions and 1662 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
bin_client/main.ml
View File

@ -9,29 +9,8 @@
(* Tezos Command line interface - Main Program *)
open Client_commands
let cctxt config rpc_config =
let startup =
CalendarLib.Printer.Precise_Calendar.sprint
"%Y-%m-%dT%H:%M:%SZ"
(CalendarLib.Calendar.Precise.now ()) in
let log channel msg = match channel with
| "stdout" ->
print_endline msg ;
Lwt.return ()
| "stderr" ->
prerr_endline msg ;
Lwt.return ()
| log ->
let (//) = Filename.concat in
Lwt_utils.create_dir (config.base_dir // "logs" // log) >>= fun () ->
Lwt_io.with_file
~flags: Unix.[ O_APPEND ; O_CREAT ; O_WRONLY ]
~mode: Lwt_io.Output
Client_commands.(config.base_dir // "logs" // log // startup)
(fun chan -> Lwt_io.write chan msg) in
Client_commands.make_context ~config ~rpc_config log
let cctxt ~base_dir ~block rpc_config =
Client_commands.make_context ~base_dir ~block ~rpc_config (Client_commands.default_log ~base_dir)
(* Main (lwt) entry *)
let main () =
@ -41,7 +20,9 @@ let main () =
let original_args = List.tl (Array.to_list Sys.argv) in
begin
Client_config.parse_config_args
(cctxt Client_commands.default_cfg Client_rpcs.default_config)
(cctxt ~base_dir:Client_commands.default_base_dir
~block:Client_commands.default_block
Client_rpcs.default_config)
original_args
>>=? fun (parsed_config_file, parsed_args, remaining) ->
let rpc_config : Client_rpcs.config = {
@ -51,7 +32,7 @@ let main () =
tls = parsed_config_file.tls ;
} in
begin
Client_node_rpcs.Blocks.protocol rpc_config parsed_args.block >>= function
Client_node_rpcs.Blocks.protocol (new Client_rpcs.rpc rpc_config) parsed_args.block >>= function
| Ok version -> begin
match parsed_args.protocol with
| None ->
@ -87,27 +68,24 @@ let main () =
Client_helpers.commands () @
Client_debug.commands () @
commands_for_version in
let config : Client_commands.cfg = {
base_dir = parsed_config_file.base_dir ;
block = parsed_args.block ;
} in
let rpc_config =
if parsed_args.print_timings then
{ rpc_config with
logger = Client_rpcs.timings_logger Format.err_formatter }
else if parsed_args.log_requests
then {rpc_config with logger = Client_rpcs.full_logger Format.err_formatter }
then { rpc_config with logger = Client_rpcs.full_logger Format.err_formatter }
else rpc_config
in
let client_config = (cctxt config rpc_config) in
let client_config =
cctxt ~block:parsed_args.block ~base_dir:parsed_config_file.base_dir rpc_config in
(Cli_entries.dispatch
~global_options:Client_config.global_options
commands
client_config
remaining) end >>=
Cli_entries.handle_cli_errors
~stdout: Format.std_formatter
~stderr: Format.err_formatter
~stdout:Format.std_formatter
~stderr:Format.err_formatter
~global_options:Client_config.global_options
>>= function
| Ok i ->

155
lib_client_base/client_aliases.ml
View File

@ -16,10 +16,10 @@ module type Entity = sig
type t
val encoding : t Data_encoding.t
val of_source :
Client_commands.context ->
#Client_commands.wallet ->
string -> t tzresult Lwt.t
val to_source :
Client_commands.context ->
#Client_commands.wallet ->
t -> string tzresult Lwt.t
val name : string
end
@ -28,140 +28,116 @@ module type Alias = sig
type t
type fresh_param
val load :
Client_commands.context ->
#Client_commands.wallet ->
(string * t) list tzresult Lwt.t
val set :
#Client_commands.wallet ->
(string * t) list ->
unit tzresult Lwt.t
val find :
Client_commands.context ->
#Client_commands.wallet ->
string -> t tzresult Lwt.t
val find_opt :
Client_commands.context ->
#Client_commands.wallet ->
string -> t option tzresult Lwt.t
val rev_find :
Client_commands.context ->
#Client_commands.wallet ->
t -> string option tzresult Lwt.t
val name :
Client_commands.context ->
#Client_commands.wallet ->
t -> string tzresult Lwt.t
val mem :
Client_commands.context ->
#Client_commands.wallet ->
string -> bool tzresult Lwt.t
val add :
force:bool ->
Client_commands.context ->
#Client_commands.wallet ->
string -> t -> unit tzresult Lwt.t
val del :
Client_commands.context ->
#Client_commands.wallet ->
string -> unit tzresult Lwt.t
val update :
Client_commands.context ->
#Client_commands.wallet ->
string -> t -> unit tzresult Lwt.t
val save :
Client_commands.context ->
(string * t) list -> unit tzresult Lwt.t
val of_source :
Client_commands.context ->
#Client_commands.wallet ->
string -> t tzresult Lwt.t
val to_source :
Client_commands.context ->
#Client_commands.wallet ->
t -> string tzresult Lwt.t
val alias_param :
?name:string ->
?desc:string ->
('a, Client_commands.context, 'ret) Cli_entries.params ->
(string * t -> 'a, Client_commands.context, 'ret) Cli_entries.params
('a, (#Client_commands.wallet as 'b), 'ret) Cli_entries.params ->
(string * t -> 'a, 'b, 'ret) Cli_entries.params
val fresh_alias_param :
?name:string ->
?desc:string ->
('a, Client_commands.context, 'ret) Cli_entries.params ->
(fresh_param -> 'a, Client_commands.context, 'ret) Cli_entries.params
('a, (< .. > as 'obj), 'ret) Cli_entries.params ->
(fresh_param -> 'a, 'obj, 'ret) Cli_entries.params
val of_fresh :
Client_commands.context ->
#Client_commands.wallet ->
bool ->
fresh_param ->
string tzresult Lwt.t
val source_param :
?name:string ->
?desc:string ->
('a, Client_commands.context, 'ret) Cli_entries.params ->
(t -> 'a, Client_commands.context, 'ret) Cli_entries.params
('a, (#Client_commands.wallet as 'obj), 'ret) Cli_entries.params ->
(t -> 'a, 'obj, 'ret) Cli_entries.params
val autocomplete:
Client_commands.context -> string list tzresult Lwt.t
#Client_commands.wallet -> string list tzresult Lwt.t
end
module Alias = functor (Entity : Entity) -> struct
open Client_commands
let encoding =
let wallet_encoding : (string * Entity.t) list Data_encoding.encoding =
let open Data_encoding in
list (obj2
(req "name" string)
(req "value" Entity.encoding))
let dirname cctxt =
cctxt.config.base_dir
let load (wallet : #wallet) =
wallet#load Entity.name ~default:[] wallet_encoding
let filename cctxt =
Filename.concat (dirname cctxt) (Entity.name ^ "s")
let set (wallet : #wallet) entries =
wallet#write Entity.name entries wallet_encoding
let load cctxt =
let filename = filename cctxt in
if not (Sys.file_exists filename) ||
Unix.(stat filename).st_size = 0 then
return []
else
Data_encoding_ezjsonm.read_file filename
|> generic_trace
"couldn't to read the %s alias file" Entity.name >>=? fun json ->
match Data_encoding.Json.destruct encoding json with
| exception _ -> (* TODO print_error *)
failwith "didn't understand the %s alias file" Entity.name
| list ->
return list
let autocomplete cctxt =
load cctxt >>= function
let autocomplete wallet =
load wallet >>= function
| Error _ -> return []
| Ok list -> return (List.map fst list)
let find_opt cctxt name =
load cctxt >>=? fun list ->
let find_opt (wallet : #wallet) name =
load wallet >>=? fun list ->
try return (Some (List.assoc name list))
with Not_found -> return None
let find cctxt name =
load cctxt >>=? fun list ->
let find (wallet : #wallet) name =
load wallet >>=? fun list ->
try return (List.assoc name list)
with Not_found ->
failwith "no %s alias named %s" Entity.name name
let rev_find cctxt v =
load cctxt >>=? fun list ->
let rev_find (wallet : #wallet) v =
load wallet >>=? fun list ->
try return (Some (List.find (fun (_, v') -> v = v') list |> fst))
with Not_found -> return None
let mem cctxt name =
load cctxt >>=? fun list ->
let mem (wallet : #wallet) name =
load wallet >>=? fun list ->
try
ignore (List.assoc name list) ;
return true
with
| Not_found -> return false
let save cctxt list =
Lwt.catch
(fun () ->
let dirname = dirname cctxt in
Lwt_utils.create_dir dirname >>= fun () ->
let filename = filename cctxt in
let json = Data_encoding.Json.construct encoding list in
Data_encoding_ezjsonm.write_file filename json)
(fun exn -> Lwt.return (error_exn exn))
|> generic_trace "could not write the %s alias file." Entity.name
let add ~force cctxt name value =
let add ~force (wallet : #wallet) name value =
let keep = ref false in
load cctxt >>=? fun list ->
load wallet >>=? fun list ->
begin
if force then
return ()
@ -169,19 +145,16 @@ module Alias = functor (Entity : Entity) -> struct
iter_s (fun (n, v) ->
if n = name && v = value then begin
keep := true ;
cctxt.message
"The %s alias %s already exists with the same value."
Entity.name n >>= fun () ->
return ()
end else if n = name && v <> value then begin
failwith
"another %s is already aliased as %s, \
use -force true to update"
use -force to update"
Entity.name n
end else if n <> name && v = value then begin
failwith
"this %s is already aliased as %s, \
use -force true to insert duplicate"
use -force to insert duplicate"
Entity.name n
end else begin
return ()
@ -193,51 +166,45 @@ module Alias = functor (Entity : Entity) -> struct
if !keep then
return ()
else
save cctxt list >>=? fun () ->
cctxt.Client_commands.message
"New %s alias '%s' saved." Entity.name name >>= fun () ->
return ()
wallet#write Entity.name list wallet_encoding
let del cctxt name =
load cctxt >>=? fun list ->
let del (wallet : #wallet) name =
load wallet >>=? fun list ->
let list = List.filter (fun (n, _) -> n <> name) list in
save cctxt list
wallet#write Entity.name list wallet_encoding
let update cctxt name value =
load cctxt >>=? fun list ->
let update (wallet : #wallet) name value =
load wallet >>=? fun list ->
let list =
List.map
(fun (n, v) -> (n, if n = name then value else v))
list in
save cctxt list
wallet#write Entity.name list wallet_encoding
let save cctxt list =
save cctxt list >>=? fun () ->
cctxt.Client_commands.message
"Successful update of the %s alias file." Entity.name >>= fun () ->
return ()
let save wallet list =
wallet#write Entity.name wallet_encoding list
include Entity
let alias_param
?(name = "name") ?(desc = "existing " ^ Entity.name ^ " alias") next =
param ~name ~desc
(parameter (fun cctxt s ->
(parameter (fun (cctxt : #Client_commands.wallet) s ->
find cctxt s >>=? fun v ->
return (s, v)))
next
type fresh_param = Fresh of string
let of_fresh cctxt force (Fresh s) =
load cctxt >>=? fun list ->
let of_fresh (wallet : #wallet) force (Fresh s) =
load wallet >>=? fun list ->
begin if force then
return ()
else
iter_s
(fun (n, _v) ->
if n = s then
Entity.to_source cctxt _v >>=? fun value ->
Entity.to_source wallet _v >>=? fun value ->
failwith
"@[<v 2>The %s alias %s already exists.@,\
The current value is %s.@,\
@ -253,7 +220,7 @@ module Alias = functor (Entity : Entity) -> struct
let fresh_alias_param
?(name = "new") ?(desc = "new " ^ Entity.name ^ " alias") next =
param ~name ~desc
(parameter (fun _ s -> return @@ Fresh s))
(parameter (fun (_ : < .. >) s -> return @@ Fresh s))
next
let source_param ?(name = "src") ?(desc = "source " ^ Entity.name) next =
@ -297,9 +264,9 @@ module Alias = functor (Entity : Entity) -> struct
end))
next
let name cctxt d =
rev_find cctxt d >>=? function
| None -> Entity.to_source cctxt d
let name (wallet : #wallet) d =
rev_find wallet d >>=? function
| None -> Entity.to_source wallet d
| Some name -> return name
end

49
lib_client_base/client_aliases.mli
View File

@ -12,10 +12,10 @@ module type Entity = sig
type t
val encoding : t Data_encoding.t
val of_source :
Client_commands.context ->
#Client_commands.wallet ->
string -> t tzresult Lwt.t
val to_source :
Client_commands.context ->
#Client_commands.wallet ->
t -> string tzresult Lwt.t
val name : string
end
@ -24,63 +24,64 @@ module type Alias = sig
type t
type fresh_param
val load :
Client_commands.context ->
#Client_commands.wallet ->
(string * t) list tzresult Lwt.t
val set :
#Client_commands.wallet ->
(string * t) list ->
unit tzresult Lwt.t
val find :
Client_commands.context ->
#Client_commands.wallet ->
string -> t tzresult Lwt.t
val find_opt :
Client_commands.context ->
#Client_commands.wallet ->
string -> t option tzresult Lwt.t
val rev_find :
Client_commands.context ->
#Client_commands.wallet ->
t -> string option tzresult Lwt.t
val name :
Client_commands.context ->
#Client_commands.wallet ->
t -> string tzresult Lwt.t
val mem :
Client_commands.context ->
#Client_commands.wallet ->
string -> bool tzresult Lwt.t
val add :
force:bool ->
Client_commands.context ->
#Client_commands.wallet ->
string -> t -> unit tzresult Lwt.t
val del :
Client_commands.context ->
#Client_commands.wallet ->
string -> unit tzresult Lwt.t
val update :
Client_commands.context ->
#Client_commands.wallet ->
string -> t -> unit tzresult Lwt.t
val save :
Client_commands.context ->
(string * t) list -> unit tzresult Lwt.t
val of_source :
Client_commands.context ->
#Client_commands.wallet ->
string -> t tzresult Lwt.t
val to_source :
Client_commands.context ->
#Client_commands.wallet ->
t -> string tzresult Lwt.t
val alias_param :
?name:string ->
?desc:string ->
('a, Client_commands.context, 'ret) Cli_entries.params ->
(string * t -> 'a, Client_commands.context, 'ret) Cli_entries.params
('a, (#Client_commands.wallet as 'b), 'ret) Cli_entries.params ->
(string * t -> 'a, 'b, 'ret) Cli_entries.params
val fresh_alias_param :
?name:string ->
?desc:string ->
('a, Client_commands.context, 'ret) Cli_entries.params ->
(fresh_param -> 'a, Client_commands.context, 'ret) Cli_entries.params
('a, (< .. > as 'obj), 'ret) Cli_entries.params ->
(fresh_param -> 'a, 'obj, 'ret) Cli_entries.params
val of_fresh :
Client_commands.context ->
#Client_commands.wallet ->
bool ->
fresh_param ->
string tzresult Lwt.t
val source_param :
?name:string ->
?desc:string ->
('a, Client_commands.context, 'ret) Cli_entries.params ->
(t -> 'a, Client_commands.context, 'ret) Cli_entries.params
('a, (#Client_commands.wallet as 'obj), 'ret) Cli_entries.params ->
(t -> 'a, 'obj, 'ret) Cli_entries.params
val autocomplete:
Client_commands.context -> string list tzresult Lwt.t
#Client_commands.wallet -> string list tzresult Lwt.t
end
module Alias (Entity : Entity) : Alias with type t = Entity.t

159
lib_client_base/client_commands.ml
View File

@ -10,64 +10,141 @@
type ('a, 'b) lwt_format =
('a, Format.formatter, unit, 'b Lwt.t) format4
type cfg = {
base_dir : string ;
block : Node_rpc_services.Blocks.block ;
}
class type logger_sig = object
method error : ('a, 'b) lwt_format -> 'a
method warning : ('a, unit) lwt_format -> 'a
method message : ('a, unit) lwt_format -> 'a
method answer : ('a, unit) lwt_format -> 'a
method log : string -> ('a, unit) lwt_format -> 'a
end
type context = {
rpc_config : Client_rpcs.config ;
config : cfg ;
error : 'a 'b. ('a, 'b) lwt_format -> 'a ;
warning : 'a. ('a, unit) lwt_format -> 'a ;
message : 'a. ('a, unit) lwt_format -> 'a ;
answer : 'a. ('a, unit) lwt_format -> 'a ;
log : 'a. string -> ('a, unit) lwt_format -> 'a ;
}
class logger log =
let message =
(fun x ->
Format.kasprintf (fun msg -> log "stdout" msg) x) in
object
method error : type a b. (a, b) lwt_format -> a =
Format.kasprintf
(fun msg ->
Lwt.fail (Failure msg))
method warning : type a. (a, unit) lwt_format -> a =
Format.kasprintf
(fun msg -> log "stderr" msg)
method message : type a. (a, unit) lwt_format -> a = message
method answer : type a. (a, unit) lwt_format -> a = message
method log : type a. string -> (a, unit) lwt_format -> a =
fun name ->
Format.kasprintf
(fun msg -> log name msg)
end
type command = (context, unit) Cli_entries.command
class type wallet = object
method load : string -> default:'a -> 'a Data_encoding.encoding -> 'a tzresult Lwt.t
method write : string -> 'a -> 'a Data_encoding.encoding -> unit tzresult Lwt.t
end
class type block = object
method block : Node_rpc_services.Blocks.block
end
class type logging_wallet = object
inherit logger
inherit wallet
end
class type logging_rpcs = object
inherit logger
inherit Client_rpcs.rpc_sig
end
class type full_context = object
inherit logger
inherit wallet
inherit Client_rpcs.rpc_sig
inherit block
end
class file_wallet dir : wallet = object (self)
method private filename alias_name =
Filename.concat
dir
(Str.(global_replace (regexp_string " ") "_" alias_name) ^ "s")
method load : type a. string -> default:a -> a Data_encoding.encoding -> a tzresult Lwt.t =
fun alias_name ~default encoding ->
let filename = self#filename alias_name in
if not (Sys.file_exists filename) then
return default
else
Data_encoding_ezjsonm.read_file filename
|> generic_trace
"couldn't to read the %s file" alias_name >>=? fun json ->
match Data_encoding.Json.destruct encoding json with
| exception _ -> (* TODO print_error *)
failwith "didn't understand the %s file" alias_name
| data ->
return data
method write :
type a. string -> a -> a Data_encoding.encoding -> unit tzresult Lwt.t =
fun alias_name list encoding ->
Lwt.catch
(fun () ->
Lwt_utils.create_dir dir >>= fun () ->
let filename = self#filename alias_name in
let json = Data_encoding.Json.construct encoding list in
Data_encoding_ezjsonm.write_file filename json)
(fun exn -> Lwt.return (error_exn exn))
|> generic_trace "could not write the %s alias file." alias_name
end
type command = (full_context, unit) Cli_entries.command
(* Default config *)
let (//) = Filename.concat
let default_cfg_of_base_dir base_dir = {
base_dir ;
block = `Prevalidation ;
}
let home =
try Sys.getenv "HOME"
with Not_found -> "/root"
let default_base_dir = home // ".tezos-client"
let default_cfg = default_cfg_of_base_dir default_base_dir
let default_block = `Prevalidation
let default_log ~base_dir channel msg =
let startup =
CalendarLib.Printer.Precise_Calendar.sprint
"%Y-%m-%dT%H:%M:%SZ"
(CalendarLib.Calendar.Precise.now ()) in
match channel with
| "stdout" ->
print_endline msg ;
Lwt.return ()
| "stderr" ->
prerr_endline msg ;
Lwt.return ()
| log ->
let (//) = Filename.concat in
Lwt_utils.create_dir (base_dir // "logs" // log) >>= fun () ->
Lwt_io.with_file
~flags: Unix.[ O_APPEND ; O_CREAT ; O_WRONLY ]
~mode: Lwt_io.Output
(base_dir // "logs" // log // startup)
(fun chan -> Lwt_io.write chan msg)
let make_context
?(config = default_cfg)
?(base_dir = default_base_dir)
?(block = default_block)
?(rpc_config = Client_rpcs.default_config)
log =
let error fmt =
Format.kasprintf
(fun msg ->
Lwt.fail (Failure msg))
fmt in
let warning fmt =
Format.kasprintf
(fun msg -> log "stderr" msg)
fmt in
let message fmt =
Format.kasprintf
(fun msg -> log "stdout" msg)
fmt in
let answer =
message in
let log name fmt =
Format.kasprintf
(fun msg -> log name msg)
fmt in
{ config ; rpc_config ; error ; warning ; message ; answer ; log }
object
inherit logger log
inherit file_wallet base_dir
inherit Client_rpcs.rpc rpc_config
method block = block
end
let ignore_context =
make_context (fun _ _ -> Lwt.return ())

70
lib_client_base/client_commands.mli
View File

@ -10,45 +10,66 @@
type ('a, 'b) lwt_format =
('a, Format.formatter, unit, 'b Lwt.t) format4
type cfg = {
base_dir : string ;
block : Node_rpc_services.Blocks.block ;
}
class type logger_sig = object
method error : ('a, 'b) lwt_format -> 'a
method warning : ('a, unit) lwt_format -> 'a
method message : ('a, unit) lwt_format -> 'a
method answer : ('a, unit) lwt_format -> 'a
method log : string -> ('a, unit) lwt_format -> 'a
end
type context = {
rpc_config : Client_rpcs.config ;
config : cfg ;
error : 'a 'b. ('a, 'b) lwt_format -> 'a ;
warning : 'a. ('a, unit) lwt_format -> 'a ;
message : 'a. ('a, unit) lwt_format -> 'a ;
answer : 'a. ('a, unit) lwt_format -> 'a ;
log : 'a. string -> ('a, unit) lwt_format -> 'a ;
}
(** This [context] allows the client {!command} handlers to work in
val default_log : base_dir:string -> string -> string -> unit Lwt.t
class logger : (string -> string -> unit Lwt.t) -> logger_sig
class type wallet = object
method load : string -> default:'a -> 'a Data_encoding.encoding -> 'a tzresult Lwt.t
method write : string -> 'a -> 'a Data_encoding.encoding -> unit tzresult Lwt.t
end
class type block = object
method block : Node_rpc_services.Blocks.block
end
class type logging_wallet = object
inherit logger_sig
inherit wallet
end
class type logging_rpcs = object
inherit logger_sig
inherit Client_rpcs.rpc_sig
end
class type full_context = object
inherit logger_sig
inherit wallet
inherit Client_rpcs.rpc_sig
inherit block
end
(** The [full_context] allows the client {!command} handlers to work in
>>>>>>> 3ab6ecd4... Client library refactor
various modes (command line, batch mode, web client, etc.) by
abstracting some basic operations such as logging and reading
configuration options. It is passed as parameter to the command
handler when running a command, and must be transmitted to all
basic operations, also making client commands reantrant. *)
val default_base_dir : string
val default_cfg_of_base_dir : string -> cfg
val default_cfg : cfg
val make_context :
?config:cfg ->
?base_dir:string ->
?block:Node_rpc_services.Blocks.block ->
?rpc_config:Client_rpcs.config ->
(string -> string -> unit Lwt.t) -> context
(string -> string -> unit Lwt.t) -> full_context
(** [make_context ?config log_fun] builds a context whose logging
callbacks call [log_fun section msg], and whose [error] function
fails with [Failure] and the given message. If not passed,
[config] is {!default_cfg}. *)
val ignore_context : context
val ignore_context : full_context
(** [ignore_context] is a context whose logging callbacks do nothing,
and whose [error] function calls [Lwt.fail_with]. *)
type command = (context, unit) Cli_entries.command
type command = (full_context, unit) Cli_entries.command
exception Version_not_found
@ -58,4 +79,7 @@ val get_versions: unit -> (Protocol_hash.t * (command list)) list
(** Have a command execute ignoring warnings.
This switch should be used when data will be overwritten. *)
val force_switch : (bool, context) Cli_entries.arg
val force_switch : (bool, full_context) Cli_entries.arg
val default_base_dir : string
val default_block : Node_rpc_services.Blocks.block

7
lib_client_base/client_config.ml
View File

@ -110,15 +110,16 @@ type cli_args = {
}
let default_cli_args = {
block = Client_commands.default_cfg.block ;
block = Client_commands.default_block ;
protocol = None ;
print_timings = false ;
log_requests = false ;
}
open Cli_entries
let string_parameter : (string, Client_commands.context) parameter =
let string_parameter : (string, Client_commands.full_context) parameter =
parameter (fun _ x -> return x)
let block_parameter =
@ -205,7 +206,7 @@ let global_options =
port_arg
tls_switch
let parse_config_args (ctx : Client_commands.context) argv =
let parse_config_args (ctx : Client_commands.full_context) argv =
parse_initial_options
global_options
ctx

7
lib_client_base/client_debug.ml
View File

@ -50,7 +50,7 @@ let pp_block ppf
operations
(Hex_encode.hex_of_bytes data)
let stuck_node_report (cctxt : Client_commands.context) file =
let stuck_node_report cctxt file =
let ppf = Format.formatter_of_out_channel (open_out file) in
let skip_line () =
Format.pp_print_newline ppf ();
@ -70,7 +70,7 @@ let stuck_node_report (cctxt : Client_commands.context) file =
(Client_commands.get_versions ()) >>=? fun () ->
skip_line () >>=? fun () ->
print_title "Heads:" 2 >>=? fun () ->
Client_rpcs.call_service0 cctxt.rpc_config Node_rpc_services.Blocks.list
Client_rpcs.call_service0 cctxt Node_rpc_services.Blocks.list
{ include_ops = true ;
length = Some 1 ;
heads = None ;
@ -89,8 +89,7 @@ let stuck_node_report (cctxt : Client_commands.context) file =
ppf heads >>=? fun () ->
skip_line () >>=? fun () ->
print_title "Rejected blocks:" 2 >>=? fun () ->
Client_rpcs.call_service0
cctxt.rpc_config
Client_rpcs.call_service0 cctxt
Node_rpc_services.Blocks.list_invalid () >>=? fun invalid ->
return @@
Format.pp_print_list

2
lib_client_base/client_debug.mli
View File

@ -8,4 +8,4 @@
(**************************************************************************)
val commands : unit -> (Client_commands.context, unit) Cli_entries.command list
val commands : unit -> (#Client_commands.logging_rpcs, unit) Cli_entries.command list

59
lib_client_base/client_generic_rpcs.ml
View File

@ -10,7 +10,6 @@
(* Tezos Command line interface - Generic JSON RPC interface *)
open Lwt.Infix
open Client_commands
open Cli_entries
open Json_schema
@ -188,9 +187,9 @@ let rec count =
(*-- Commands ---------------------------------------------------------------*)
let list url cctxt =
let list url (cctxt : Client_commands.full_context) =
let args = String.split '/' url in
Client_node_rpcs.describe cctxt.rpc_config
Client_node_rpcs.describe cctxt
~recurse:true args >>=? fun tree ->
let open RPC.Description in
let collected_args = ref [] in
@ -278,52 +277,52 @@ let list url cctxt =
Format.pp_print_list
(fun ppf (n,t) -> display ppf ([ n ], tpath @ [ n ], t))
in
cctxt.message "@ @[<v 2>Available services:@ @ %a@]@."
cctxt#message "@ @[<v 2>Available services:@ @ %a@]@."
display (args, args, tree) >>= fun () ->
if !collected_args <> [] then begin
cctxt.message "@,@[<v 2>Dynamic parameter description:@ @ %a@]@."
cctxt#message "@,@[<v 2>Dynamic parameter description:@ @ %a@]@."
(Format.pp_print_list display_arg) !collected_args >>= fun () ->
return ()
end else return ()
let schema url cctxt =
let schema url (cctxt : Client_commands.full_context) =
let args = String.split '/' url in
let open RPC.Description in
Client_node_rpcs.describe cctxt.rpc_config ~recurse:false args >>=? function
Client_node_rpcs.describe cctxt ~recurse:false args >>=? function
| Static { services } -> begin
match RPC.MethMap.find `POST services with
| exception Not_found ->
cctxt.message
cctxt#message
"No service found at this URL (but this is a valid prefix)\n%!" >>= fun () ->
return ()
| { input = Some input ; output } ->
let json = `O [ "input", Json_schema.to_json input ;
"output", Json_schema.to_json output ] in
cctxt.message "%a" Json_repr.(pp (module Ezjsonm)) json >>= fun () ->
cctxt#message "%a" Json_repr.(pp (module Ezjsonm)) json >>= fun () ->
return ()
| { input = None ; output } ->
let json = `O [ "output", Json_schema.to_json output ] in
cctxt.message "%a" Json_repr.(pp (module Ezjsonm)) json >>= fun () ->
cctxt#message "%a" Json_repr.(pp (module Ezjsonm)) json >>= fun () ->
return ()
end
| _ ->
cctxt.message
cctxt#message
"No service found at this URL (but this is a valid prefix)\n%!" >>= fun () ->
return ()
let format url cctxt =
let format url (cctxt : #Client_commands.logging_rpcs) =
let args = String.split '/' url in
let open RPC.Description in
Client_node_rpcs.describe cctxt.rpc_config ~recurse:false args >>=? function
Client_node_rpcs.describe cctxt ~recurse:false args >>=? function
| Static { services } -> begin
match RPC.MethMap.find `POST services with
| exception Not_found ->
cctxt.message
cctxt#message
"No service found at this URL (but this is a valid prefix)\n%!" >>= fun () ->
return ()
| { input = Some input ; output } ->
cctxt.message
cctxt#message
"@[<v 0>\
@[<v 2>Input format:@,%a@]@,\
@[<v 2>Output format:@,%a@]@,\
@ -332,7 +331,7 @@ let format url cctxt =
Json_schema.pp output >>= fun () ->
return ()
| { input = None ; output } ->
cctxt.message
cctxt#message
"@[<v 0>\
@[<v 2>Output format:@,%a@]@,\
@]"
@ -340,7 +339,7 @@ let format url cctxt =
return ()
end
| _ ->
cctxt.message
cctxt#message
"No service found at this URL (but this is a valid prefix)\n%!" >>= fun () ->
return ()
@ -351,43 +350,43 @@ let fill_in schema =
| Any | Object { properties = [] } -> Lwt.return (Ok (`O []))
| _ -> editor_fill_in schema
let call url cctxt =
let call url (cctxt : Client_commands.full_context) =
let args = String.split '/' url in
let open RPC.Description in
Client_node_rpcs.describe cctxt.rpc_config ~recurse:false args >>=? function
Client_node_rpcs.describe cctxt ~recurse:false args >>=? function
| Static { services } -> begin
match RPC.MethMap.find `POST services with
| exception Not_found ->
cctxt.message
cctxt#message
"No service found at this URL (but this is a valid prefix)\n%!" >>= fun () ->
return ()
| { input = None } -> assert false (* TODO *)
| { input = Some input } ->
fill_in input >>= function
| Error msg ->
cctxt.error "%s" msg >>= fun () ->
cctxt#error "%s" msg >>= fun () ->
return ()
| Ok json ->
Client_rpcs.get_json cctxt.rpc_config `POST args json >>=? fun json ->
cctxt.message "%a"
cctxt#get_json `POST args json >>=? fun json ->
cctxt#message "%a"
Json_repr.(pp (module Ezjsonm)) json >>= fun () ->
return ()
end
| _ ->
cctxt.message
cctxt#message
"No service found at this URL (but this is a valid prefix)\n%!" >>= fun () ->
return ()
let call_with_json url json (cctxt: Client_commands.context) =
let call_with_json url json (cctxt: Client_commands.full_context) =
let args = String.split '/' url in
match Data_encoding_ezjsonm.from_string json with
| Error err ->
cctxt.error
cctxt#error
"Failed to parse the provided json: %s\n%!"
err
| Ok json ->
Client_rpcs.get_json cctxt.rpc_config `POST args json >>=? fun json ->
cctxt.message "%a"
cctxt#get_json `POST args json >>=? fun json ->
cctxt#message "%a"
Json_repr.(pp (module Ezjsonm)) json >>= fun () ->
return ()
@ -400,9 +399,9 @@ let commands = [
command ~desc: "list all understood protocol versions"
no_options
(fixed [ "list" ; "versions" ])
(fun () cctxt ->
(fun () (cctxt : Client_commands.full_context) ->
Lwt_list.iter_s
(fun (ver, _) -> cctxt.Client_commands.message "%a" Protocol_hash.pp_short ver)
(fun (ver, _) -> cctxt#message "%a" Protocol_hash.pp_short ver)
(Client_commands.get_versions ()) >>= fun () ->
return ()) ;

16
lib_client_base/client_helpers.ml
View File

@ -7,8 +7,6 @@
(* *)
(**************************************************************************)
open Client_commands
let unique_switch =
Cli_entries.switch
~parameter:"-unique"
@ -26,9 +24,9 @@ let commands () = Cli_entries.[
~name: "prefix"
~desc: "the prefix of the Base58Check-encoded hash to be completed" @@
stop)
(fun unique prefix cctxt ->
(fun unique prefix (cctxt : Client_commands.full_context) ->
Client_node_rpcs.complete
cctxt.rpc_config ~block:cctxt.config.block prefix >>=? fun completions ->
cctxt ~block:cctxt#block prefix >>=? fun completions ->
match completions with
| [] -> Pervasives.exit 3
| _ :: _ :: _ when unique -> Pervasives.exit 3
@ -40,18 +38,18 @@ let commands () = Cli_entries.[
no_options
(prefixes [ "bootstrapped" ] @@
stop)
(fun () cctxt ->
Client_node_rpcs.bootstrapped cctxt.rpc_config >>=? fun stream ->
(fun () (cctxt : Client_commands.full_context) ->
Client_node_rpcs.bootstrapped cctxt >>=? fun stream ->
Lwt_stream.iter_s (function
| Ok (hash, time) ->
cctxt.message "Current head: %a (%a)"
cctxt#message "Current head: %a (%a)"
Block_hash.pp_short hash
Time.pp_hum time
| Error err ->
cctxt.error "Error: %a"
cctxt#error "Error: %a"
pp_print_error err
) stream >>= fun () ->
cctxt.answer "Bootstrapped." >>= fun () ->
cctxt#answer "Bootstrapped." >>= fun () ->
return ()
)
]

64
lib_client_base/client_keys.ml
View File

@ -31,7 +31,7 @@ module Secret_key = Client_aliases.Alias (struct
let name = "secret key"
end)
let gen_keys ?(force=false) ?seed cctxt name =
let gen_keys ?(force=false) ?seed (cctxt : #Client_commands.wallet) name =
let seed =
match seed with
| None -> Ed25519.Seed.generate ()
@ -41,16 +41,14 @@ let gen_keys ?(force=false) ?seed cctxt name =
Public_key.add ~force cctxt name public_key >>=? fun () ->
Public_key_hash.add ~force
cctxt name (Ed25519.Public_key.hash public_key) >>=? fun () ->
cctxt.message
"I generated a brand new pair of keys under the name '%s'." name >>= fun () ->
return ()
let gen_keys_containing ?(prefix=false) ?(force=false) ~containing ~name (cctxt : Client_commands.context) =
let gen_keys_containing ?(prefix=false) ?(force=false) ~containing ~name (cctxt : Client_commands.full_context) =
let unrepresentable =
List.filter (fun s -> not @@ Base58.Alphabet.all_in_alphabet Base58.Alphabet.bitcoin s) containing in
match unrepresentable with
| _ :: _ ->
cctxt.warning
cctxt#warning
"The following can't be written in the key alphabet (%a): %a"
Base58.Alphabet.pp Base58.Alphabet.bitcoin
(Format.pp_print_list
@ -61,11 +59,11 @@ let gen_keys_containing ?(prefix=false) ?(force=false) ~containing ~name (cctxt
Public_key_hash.mem cctxt name >>=? fun name_exists ->
if name_exists && not force
then
cctxt.warning
cctxt#warning
"Key for name '%s' already exists. Use -force to update." name >>= return
else
begin
cctxt.message "This process uses a brute force search and \
cctxt#warning "This process uses a brute force search and \
may take a long time to find a key." >>= fun () ->
let matches =
if prefix then
@ -89,11 +87,11 @@ let gen_keys_containing ?(prefix=false) ?(force=false) ~containing ~name (cctxt
Public_key_hash.add ~force cctxt name (Ed25519.Public_key.hash public_key) >>=? fun () ->
return hash
else begin if attempts mod 25_000 = 0
then cctxt.message "Tried %d keys without finding a match" attempts
then cctxt#message "Tried %d keys without finding a match" attempts
else Lwt.return () end >>= fun () ->
loop (attempts + 1) in
loop 1 >>=? fun key_hash ->
cctxt.message
cctxt#message
"Generated '%s' under the name '%s'." key_hash name >>= fun () ->
return ()
end
@ -103,21 +101,21 @@ let check_keys_consistency pk sk =
let signature = Ed25519.sign sk message in
Ed25519.Signature.check pk signature message
let get_key cctxt pkh =
let get_key (cctxt : #Client_commands.wallet) pkh =
Public_key_hash.rev_find cctxt pkh >>=? function
| None -> cctxt.error "no keys for the source contract manager"
| None -> failwith "no keys for the source contract manager"
| Some n ->
Public_key.find cctxt n >>=? fun pk ->
Secret_key.find cctxt n >>=? fun sk ->
return (n, pk, sk)
let get_keys cctxt =
Secret_key.load cctxt >>=? fun sks ->
let get_keys (wallet : #Client_commands.wallet) =
Secret_key.load wallet >>=? fun sks ->
Lwt_list.filter_map_s
(fun (name, sk) ->
begin
Public_key.find cctxt name >>=? fun pk ->
Public_key_hash.find cctxt name >>=? fun pkh ->
Public_key.find wallet name >>=? fun pk ->
Public_key_hash.find wallet name >>=? fun pkh ->
return (name, pkh, pk, sk)
end >>= function
| Ok r -> Lwt.return (Some r)
@ -165,7 +163,7 @@ let commands () =
(prefixes [ "gen" ; "keys" ]
@@ Secret_key.fresh_alias_param
@@ stop)
(fun force name cctxt ->
(fun force name (cctxt : Client_commands.full_context) ->
Secret_key.of_fresh cctxt force name >>=? fun name ->
gen_keys ~force cctxt name) ;
@ -202,6 +200,18 @@ let commands () =
please don't use -force" name) >>=? fun () ->
Secret_key.add ~force cctxt name sk) ;
command ~group ~desc: "add a public key to the wallet"
(args1 Client_commands.force_switch)
(prefixes [ "add" ; "public" ; "key" ]
@@ Public_key.fresh_alias_param
@@ Public_key.source_param
@@ stop)
(fun force name key cctxt ->
Public_key.of_fresh cctxt force name >>=? fun name ->
Public_key_hash.add ~force cctxt
name (Ed25519.Public_key.hash key) >>=? fun () ->
Public_key.add ~force cctxt name key) ;
command ~group ~desc: "add a public key to the wallet"
(args1 Client_commands.force_switch)
(prefixes [ "add" ; "identity" ]
@ -215,12 +225,12 @@ let commands () =
command ~group ~desc: "list all public key hashes and associated keys"
no_options
(fixed [ "list" ; "known" ; "identities" ])
(fun () cctxt ->
(fun () (cctxt : Client_commands.full_context) ->
list_keys cctxt >>=? fun l ->
iter_s
(fun (name, pkh, pkm, pks) ->
Public_key_hash.to_source cctxt pkh >>=? fun v ->
cctxt.message "%s: %s%s%s" name v
cctxt#message "%s: %s%s%s" name v
(if pkm then " (public key known)" else "")
(if pks then " (secret key known)" else "") >>= fun () ->
return ())
@ -231,25 +241,25 @@ let commands () =
(prefixes [ "show" ; "identity"]
@@ Public_key_hash.alias_param
@@ stop)
(fun show_private (name, _) cctxt ->
(fun show_private (name, _) (cctxt : Client_commands.full_context) ->
let ok_lwt x = x >>= (fun x -> return x) in
alias_keys cctxt name >>=? fun key_info ->
match key_info with
| None -> ok_lwt @@ cctxt.message "No keys found for identity"
| None -> ok_lwt @@ cctxt#message "No keys found for identity"
| Some (hash, pub, priv) ->
Public_key_hash.to_source cctxt hash >>=? fun hash ->
ok_lwt @@ cctxt.message "Hash: %s" hash >>=? fun () ->
ok_lwt @@ cctxt#message "Hash: %s" hash >>=? fun () ->
match pub with
| None -> return ()
| Some pub ->
Public_key.to_source cctxt pub >>=? fun pub ->
ok_lwt @@ cctxt.message "Public Key: %s" pub >>=? fun () ->
ok_lwt @@ cctxt#message "Public Key: %s" pub >>=? fun () ->
if show_private then
match priv with
| None -> return ()
| Some priv ->
Secret_key.to_source cctxt priv >>=? fun priv ->
ok_lwt @@ cctxt.message "Secret Key: %s" priv
ok_lwt @@ cctxt#message "Secret Key: %s" priv
else return ()) ;
command ~group ~desc: "forget all keys"
@ -257,9 +267,9 @@ let commands () =
(fixed [ "forget" ; "all" ; "keys" ])
(fun force cctxt ->
fail_unless force
(failure "this can only used with option -force true") >>=? fun () ->
Public_key.save cctxt [] >>=? fun () ->
Secret_key.save cctxt [] >>=? fun () ->
Public_key_hash.save cctxt []) ;
(failure "this can only used with option -force") >>=? fun () ->
Public_key.set cctxt [] >>=? fun () ->
Secret_key.set cctxt [] >>=? fun () ->
Public_key_hash.set cctxt []) ;
]

8
lib_client_base/client_keys.mli
View File

@ -13,22 +13,22 @@ module Public_key : Client_aliases.Alias with type t = Ed25519.Public_key.t
module Secret_key : Client_aliases.Alias with type t = Ed25519.Secret_key.t
val get_key:
Client_commands.context ->
Client_commands.full_context ->
Public_key_hash.t ->
( string * Public_key.t * Secret_key.t ) tzresult Lwt.t
val get_keys:
Client_commands.context ->
#Client_commands.wallet ->
( string * Public_key_hash.t * Public_key.t * Secret_key.t ) list tzresult Lwt.t
val list_keys:
Client_commands.context ->
Client_commands.full_context ->
(string * Public_key_hash.t * bool * bool) list tzresult Lwt.t
val gen_keys:
?force:bool ->
?seed: Ed25519.Seed.t ->
Client_commands.context ->
#Client_commands.wallet ->
string ->
unit tzresult Lwt.t

33
lib_client_base/client_network.ml
View File

@ -7,7 +7,6 @@
(* *)
(**************************************************************************)
open Client_commands
open P2p_types
let group =
@ -18,36 +17,36 @@ let commands () = [
let open Cli_entries in
command ~group ~desc: "show global network status"
no_options
(prefixes ["network" ; "stat"] stop) begin fun () cctxt ->
Client_node_rpcs.Network.stat cctxt.rpc_config >>=? fun stat ->
Client_node_rpcs.Network.connections cctxt.rpc_config >>=? fun conns ->
Client_node_rpcs.Network.peers cctxt.rpc_config >>=? fun peers ->
Client_node_rpcs.Network.points cctxt.rpc_config >>=? fun points ->
cctxt.message "GLOBAL STATS" >>= fun () ->
cctxt.message " %a" Stat.pp stat >>= fun () ->
cctxt.message "CONNECTIONS" >>= fun () ->
(prefixes ["network" ; "stat"] stop) begin fun () (cctxt : Client_commands.full_context) ->
Client_node_rpcs.Network.stat cctxt >>=? fun stat ->
Client_node_rpcs.Network.connections cctxt >>=? fun conns ->
Client_node_rpcs.Network.peers cctxt >>=? fun peers ->
Client_node_rpcs.Network.points cctxt >>=? fun points ->
cctxt#message "GLOBAL STATS" >>= fun () ->
cctxt#message " %a" Stat.pp stat >>= fun () ->
cctxt#message "CONNECTIONS" >>= fun () ->
let incoming, outgoing =
List.partition (fun c -> c.Connection_info.incoming) conns in
Lwt_list.iter_s begin fun conn ->
cctxt.message " %a" Connection_info.pp conn
cctxt#message " %a" Connection_info.pp conn
end incoming >>= fun () ->
Lwt_list.iter_s begin fun conn ->
cctxt.message " %a" Connection_info.pp conn
cctxt#message " %a" Connection_info.pp conn
end outgoing >>= fun () ->
cctxt.message "KNOWN PEERS" >>= fun () ->
cctxt#message "KNOWN PEERS" >>= fun () ->
Lwt_list.iter_s begin fun (p, pi) ->
cctxt.message " %a %.0f %a %a %s"
cctxt#message " %a %.0f %a %a %s"
Peer_state.pp_digram pi.Peer_info.state
pi.score
Peer_id.pp p
Stat.pp pi.stat
(if pi.trusted then "★" else " ")
end peers >>= fun () ->
cctxt.message "KNOWN POINTS" >>= fun () ->
cctxt#message "KNOWN POINTS" >>= fun () ->
Lwt_list.iter_s begin fun (p, pi) ->
match pi.Point_info.state with
| Running peer_id ->
cctxt.message " %a %a %a %s"
cctxt#message " %a %a %a %s"
Point_state.pp_digram pi.state
Point.pp p
Peer_id.pp peer_id
@ -55,14 +54,14 @@ let commands () = [
| _ ->
match pi.last_seen with
| Some (peer_id, ts) ->
cctxt.message " %a %a (last seen: %a %a) %s"
cctxt#message " %a %a (last seen: %a %a) %s"
Point_state.pp_digram pi.state
Point.pp p
Peer_id.pp peer_id
Time.pp_hum ts
(if pi.trusted then "★" else " ")
| None ->
cctxt.message " %a %a %s"
cctxt#message " %a %a %s"
Point_state.pp_digram pi.state
Point.pp p
(if pi.trusted then "★" else " ")

10
lib_client_base/client_node_rpcs.ml
View File

@ -12,11 +12,11 @@
open Client_rpcs
module Services = Node_rpc_services
let errors cctxt =
call_service0 cctxt Services.Error.service ()
let errors (rpc : #rpc_sig) =
call_service0 rpc Services.Error.service ()
let forge_block_header cctxt header =
call_service0 cctxt Services.forge_block_header header
let forge_block_header rpc header =
call_service0 rpc Services.forge_block_header header
let inject_block cctxt
?(async = false) ?(force = false) ?net_id
@ -46,7 +46,7 @@ let describe config ?(recurse = true) path =
let { RPC.Service.meth ; path } =
RPC.Service.forge_request Node_rpc_services.describe
((), path) { RPC.Description.recurse } in
get_json config meth path (`O []) >>=? fun json ->
config#get_json meth path (`O []) >>=? fun json ->
match Data_encoding.Json.destruct (RPC.Service.output_encoding Node_rpc_services.describe) json with
| exception msg ->
let msg =

60
lib_client_base/client_node_rpcs.mli
View File

@ -10,15 +10,15 @@
open Client_rpcs
val errors:
config -> Json_schema.schema tzresult Lwt.t
#rpc_sig -> Json_schema.schema tzresult Lwt.t
val forge_block_header:
config ->
#rpc_sig ->
Block_header.t ->
MBytes.t tzresult Lwt.t
val inject_block:
config ->
#rpc_sig ->
?async:bool -> ?force:bool -> ?net_id:Net_id.t ->
MBytes.t -> Operation.t list list ->
Block_hash.t tzresult Lwt.t
@ -29,13 +29,13 @@ val inject_block:
fitness. *)
val inject_operation:
config ->
#rpc_sig ->
?async:bool -> ?force:bool -> ?net_id:Net_id.t ->
MBytes.t ->
Operation_hash.t tzresult Lwt.t
val inject_protocol:
config ->
#rpc_sig ->
?async:bool -> ?force:bool ->
Protocol.t ->
Protocol_hash.t tzresult Lwt.t
@ -45,39 +45,39 @@ module Blocks : sig
type block = Node_rpc_services.Blocks.block
val net_id:
config ->
#rpc_sig ->
block -> Net_id.t tzresult Lwt.t
val level:
config ->
#rpc_sig ->
block -> Int32.t tzresult Lwt.t
val predecessor:
config ->
#rpc_sig ->
block -> Block_hash.t tzresult Lwt.t
val predecessors:
config ->
#rpc_sig ->
block -> int -> Block_hash.t list tzresult Lwt.t
val hash:
config ->
#rpc_sig ->
block -> Block_hash.t tzresult Lwt.t
val timestamp:
config ->
#rpc_sig ->
block -> Time.t tzresult Lwt.t
val fitness:
config ->
#rpc_sig ->
block -> MBytes.t list tzresult Lwt.t
val operations:
config ->
#rpc_sig ->
?contents:bool ->
block -> (Operation_hash.t * Operation.t option) list list tzresult Lwt.t
val protocol:
config ->
#rpc_sig ->
block -> Protocol_hash.t tzresult Lwt.t
val test_network:
config ->
#rpc_sig ->
block -> Test_network_status.t tzresult Lwt.t
val pending_operations:
config ->
#rpc_sig ->
block ->
(error Preapply_result.t * Operation.t Operation_hash.Map.t) tzresult Lwt.t
@ -98,17 +98,17 @@ module Blocks : sig
}
val info:
config ->
#rpc_sig ->
?include_ops:bool -> block -> block_info tzresult Lwt.t
val list:
config ->
#rpc_sig ->
?include_ops:bool -> ?length:int -> ?heads:Block_hash.t list ->
?delay:int -> ?min_date:Time.t -> ?min_heads:int ->
unit -> block_info list list tzresult Lwt.t
val monitor:
config ->
#rpc_sig ->
?include_ops:bool -> ?length:int -> ?heads:Block_hash.t list ->
?delay:int -> ?min_date:Time.t -> ?min_heads:int ->
unit -> block_info list list tzresult Lwt_stream.t tzresult Lwt.t
@ -119,7 +119,7 @@ module Blocks : sig
}
val preapply:
config ->
#rpc_sig ->
block ->
?timestamp:Time.t ->
?sort:bool ->
@ -131,7 +131,7 @@ end
module Operations : sig
val monitor:
config ->
#rpc_sig ->
?contents:bool ->
unit ->
(Operation_hash.t * Operation.t option) list list tzresult Lwt_stream.t tzresult Lwt.t
@ -141,42 +141,42 @@ end
module Protocols : sig
val contents:
config ->
#rpc_sig ->
Protocol_hash.t -> Protocol.t tzresult Lwt.t
val list:
config ->
#rpc_sig ->
?contents:bool -> unit ->
(Protocol_hash.t * Protocol.t option) list tzresult Lwt.t
end
val bootstrapped:
config -> (Block_hash.t * Time.t) tzresult Lwt_stream.t tzresult Lwt.t
#rpc_sig -> (Block_hash.t * Time.t) tzresult Lwt_stream.t tzresult Lwt.t
module Network : sig
open P2p_types
val stat:
config -> Stat.t tzresult Lwt.t
#rpc_sig -> Stat.t tzresult Lwt.t
val connections:
config -> Connection_info.t list tzresult Lwt.t
#rpc_sig -> Connection_info.t list tzresult Lwt.t
val peers:
config -> (Peer_id.t * P2p_types.Peer_info.t) list tzresult Lwt.t
#rpc_sig -> (Peer_id.t * P2p_types.Peer_info.t) list tzresult Lwt.t
val points:
config -> (Point.t * P2p_types.Point_info.t) list tzresult Lwt.t
#rpc_sig -> (Point.t * P2p_types.Point_info.t) list tzresult Lwt.t
end
val complete:
config ->
#rpc_sig ->
?block:Blocks.block -> string -> string list tzresult Lwt.t
val describe:
config ->
#rpc_sig ->
?recurse:bool -> string list ->
Data_encoding.json_schema RPC.Description.directory tzresult Lwt.t

28
lib_client_base/client_protocols.ml
View File

@ -7,8 +7,6 @@
(* *)
(**************************************************************************)
open Client_commands
let group =
{ Cli_entries.name = "protocols" ;
title = "Commands for managing protocols" }
@ -26,9 +24,9 @@ let commands () =
command ~group ~desc: "list known protocols"
no_options
(prefixes [ "list" ; "protocols" ] stop)
(fun () cctxt ->
Client_node_rpcs.Protocols.list cctxt.rpc_config ~contents:false () >>=? fun protos ->
Lwt_list.iter_s (fun (ph, _p) -> cctxt.message "%a" Protocol_hash.pp ph) protos >>= fun () ->
(fun () (cctxt : Client_commands.full_context) ->
Client_node_rpcs.Protocols.list cctxt ~contents:false () >>=? fun protos ->
Lwt_list.iter_s (fun (ph, _p) -> cctxt#message "%a" Protocol_hash.pp ph) protos >>= fun () ->
return ()
);
@ -37,21 +35,20 @@ let commands () =
(prefixes [ "inject" ; "protocol" ]
@@ param ~name:"dir" ~desc:"directory containing a protocol" check_dir_parameter
@@ stop)
(fun () dirname cctxt ->
(fun () dirname (cctxt : Client_commands.full_context) ->
Lwt.catch
(fun () ->
let _hash, proto = Tezos_protocol_compiler.Native.read_dir dirname in
Client_node_rpcs.inject_protocol cctxt.rpc_config proto >>= function
Client_node_rpcs.inject_protocol cctxt proto >>= function
| Ok hash ->
cctxt.message "Injected protocol %a successfully" Protocol_hash.pp_short hash >>= fun () ->
cctxt#message "Injected protocol %a successfully" Protocol_hash.pp_short hash >>= fun () ->
return ()
| Error err ->
cctxt.error "Error while injecting protocol from %s: %a"
cctxt#error "Error while injecting protocol from %s: %a"
dirname Error_monad.pp_print_error err >>= fun () ->
return ())
(fun exn ->
cctxt.error "Error while injecting protocol from %s: %a"
cctxt#error "Error while injecting protocol from %s: %a"
dirname Error_monad.pp_print_error [Error_monad.Exn exn] >>= fun () ->
return ())
);
@ -61,13 +58,10 @@ let commands () =
(prefixes [ "dump" ; "protocol" ]
@@ Protocol_hash.param ~name:"protocol hash" ~desc:""
@@ stop)
(fun () ph cctxt ->
Client_node_rpcs.Protocols.contents cctxt.rpc_config ph >>=? fun proto ->
(fun () ph (cctxt : Client_commands.full_context) ->
Client_node_rpcs.Protocols.contents cctxt ph >>=? fun proto ->
Updater.extract (Protocol_hash.to_short_b58check ph) ~hash:ph proto >>= fun () ->
cctxt.message "Extracted protocol %a" Protocol_hash.pp_short ph >>= fun () ->
cctxt#message "Extracted protocol %a" Protocol_hash.pp_short ph >>= fun () ->
return ()
) ;
(* | Error err -> *)
(* cctxt.error "Error while dumping protocol %a: %a" *)
(* Protocol_hash.pp_short ph Error_monad.pp_print_error err); *)
]

252
lib_client_base/client_rpcs.ml
View File

@ -181,6 +181,142 @@ let () =
let fail config err = fail (RPC_error (config, err))
class type rpc_sig = object
method get_json :
RPC.meth ->
string list -> Data_encoding.json -> Data_encoding.json Error_monad.tzresult Lwt.t
method get_streamed_json :
RPC.meth ->
string list ->
Data_encoding.json ->
(Data_encoding.json, Error_monad.error list) result Lwt_stream.t
Error_monad.tzresult Lwt.t
method make_request :
(Uri.t -> Data_encoding.json -> 'a Lwt.t) ->
RPC.meth ->
string list ->
Data_encoding.json ->
('a * Cohttp.Code.status_code * Cohttp_lwt_body.t)
Error_monad.tzresult Lwt.t
method parse_answer :
(unit, 'b, 'c, 'd) RPC.service ->
string list ->
Data_encoding.json -> 'd Error_monad.tzresult Lwt.t
method parse_err_answer :
(unit, 'e, 'f, 'g Error_monad.tzresult) RPC.service ->
string list ->
Data_encoding.json -> 'g Error_monad.tzresult Lwt.t
end
class rpc config = object (self)
val config = config
method make_request :
type a. (Uri.t -> Data_encoding.json -> a Lwt.t) ->
RPC.meth ->
string list ->
Data_encoding.json ->
(a * Cohttp.Code.status_code * Cohttp_lwt_body.t)
Error_monad.tzresult Lwt.t =
fun log_request meth service json ->
let scheme = if config.tls then "https" else "http" in
let path = String.concat "/" service in
let uri =
Uri.make ~scheme ~host:config.host ~port:config.port ~path () in
let reqbody = Data_encoding_ezjsonm.to_string json in
Lwt.catch begin fun () ->
let body = Cohttp_lwt_body.of_string reqbody in
Cohttp_lwt_unix.Client.call
(meth :> Cohttp.Code.meth) ~body uri >>= fun (code, ansbody) ->
log_request uri json >>= fun reqid ->
return (reqid, code.Cohttp.Response.status, ansbody)
end begin fun exn ->
let msg = match exn with
| Unix.Unix_error (e, _, _) -> Unix.error_message e
| e -> Printexc.to_string e in
fail config (Cannot_connect_to_RPC_server msg)
end
method get_streamed_json meth service json =
let Logger logger = config.logger in
self#make_request logger.log_request
meth service json >>=? fun (reqid, code, ansbody) ->
match code with
| #Cohttp.Code.success_status ->
let ansbody = Cohttp_lwt_body.to_stream ansbody in
let json_st = Data_encoding_ezjsonm.from_stream ansbody in
let parsed_st, push = Lwt_stream.create () in
let rec loop () =
Lwt_stream.get json_st >>= function
| Some (Ok json) as v ->
push v ;
logger.log_success reqid code json >>= fun () ->
loop ()
| None ->
push None ;
Lwt.return_unit
| Some (Error msg) ->
let error =
RPC_error (config, Malformed_json (service, "", msg)) in
push (Some (Error [error])) ;
push None ;
Lwt.return_unit
in
Lwt.async loop ;
return parsed_st
| err ->
Cohttp_lwt_body.to_string ansbody >>= fun ansbody ->
logger.log_error reqid code ansbody >>= fun () ->
fail config (Request_failed (service, err))
method parse_answer : type b c d. (unit, b, c, d) RPC.service ->
string list ->
Data_encoding.json -> d Error_monad.tzresult Lwt.t =
fun service path json ->
match Data_encoding.Json.destruct (RPC.Service.output_encoding service) json with
| exception msg ->
let msg =
Format.asprintf "%a" (fun x -> Data_encoding.Json.print_error x) msg in
fail config (Unexpected_json (path, json, msg))
| v -> return v
method get_json : RPC.meth ->
string list -> Data_encoding.json -> Data_encoding.json Error_monad.tzresult Lwt.t =
fun meth service json ->
let Logger logger = config.logger in
self#make_request logger.log_request
meth service json >>=? fun (reqid, code, ansbody) ->
Cohttp_lwt_body.to_string ansbody >>= fun ansbody ->
match code with
| #Cohttp.Code.success_status -> begin
if ansbody = "" then
return `Null
else
match Data_encoding_ezjsonm.from_string ansbody with
| Error msg ->
logger.log_error reqid code ansbody >>= fun () ->
fail config (Malformed_json (service, ansbody, msg))
| Ok json ->
logger.log_success reqid code json >>= fun () ->
return json
end
| err ->
logger.log_error reqid code ansbody >>= fun () ->
fail config (Request_failed (service, err))
method parse_err_answer : type e f g.
(unit, e, f, g Error_monad.tzresult) RPC.service ->
string list ->
Data_encoding.json -> g Error_monad.tzresult Lwt.t =
fun service path json ->
match Data_encoding.Json.destruct (RPC.Service.output_encoding service) json with
| exception msg -> (* TODO print_error *)
let msg =
Format.asprintf "%a" (fun x -> Data_encoding.Json.print_error x) msg in
fail config (Unexpected_json (path, json, msg))
| v -> Lwt.return v
end
let make_request config log_request meth service json =
let scheme = if config.tls then "https" else "http" in
let path = String.concat "/" service in
@ -201,90 +337,28 @@ let make_request config log_request meth service json =
fail config (Cannot_connect_to_RPC_server msg)
end
let get_streamed_json config meth service json =
let Logger logger = config.logger in
make_request config logger.log_request
meth service json >>=? fun (reqid, code, ansbody) ->
match code with
| #Cohttp.Code.success_status ->
let ansbody = Cohttp_lwt_body.to_stream ansbody in
let json_st = Data_encoding_ezjsonm.from_stream ansbody in
let parsed_st, push = Lwt_stream.create () in
let rec loop () =
Lwt_stream.get json_st >>= function
| Some (Ok json) as v ->
push v ;
logger.log_success reqid code json >>= fun () ->
loop ()
| None ->
push None ;
Lwt.return_unit
| Some (Error msg) ->
let error =
RPC_error (config, Malformed_json (service, "", msg)) in
push (Some (Error [error])) ;
push None ;
Lwt.return_unit
in
Lwt.async loop ;
return parsed_st
| err ->
Cohttp_lwt_body.to_string ansbody >>= fun ansbody ->
logger.log_error reqid code ansbody >>= fun () ->
fail config (Request_failed (service, err))
let get_json config meth service json =
let Logger logger = config.logger in
make_request config logger.log_request
meth service json >>=? fun (reqid, code, ansbody) ->
Cohttp_lwt_body.to_string ansbody >>= fun ansbody ->
match code with
| #Cohttp.Code.success_status -> begin
if ansbody = "" then
return `Null
else
match Data_encoding_ezjsonm.from_string ansbody with
| Error msg ->
logger.log_error reqid code ansbody >>= fun () ->
fail config (Malformed_json (service, ansbody, msg))
| Ok json ->
logger.log_success reqid code json >>= fun () ->
return json
end
| err ->
logger.log_error reqid code ansbody >>= fun () ->
fail config (Request_failed (service, err))
let parse_answer config service path json =
match Data_encoding.Json.destruct (RPC.Service.output_encoding service) json with
| exception msg ->
let msg =
Format.asprintf "%a" (fun x -> Data_encoding.Json.print_error x) msg in
fail config (Unexpected_json (path, json, msg))
| v -> return v
let call_service0 cctxt service arg =
let call_service0 (rpc : #rpc_sig) service arg =
let meth, path, arg = RPC.forge_request service () arg in
get_json cctxt meth path arg >>=? fun json ->
parse_answer cctxt service path json
rpc#get_json meth path arg >>=? fun json ->
rpc#parse_answer service path json
let call_service1 cctxt service a1 arg =
let call_service1 (rpc : #rpc_sig) service a1 arg =
let meth, path, arg = RPC.forge_request service ((), a1) arg in
get_json cctxt meth path arg >>=? fun json ->
parse_answer cctxt service path json
rpc#get_json meth path arg >>=? fun json ->
rpc#parse_answer service path json
let call_service2 cctxt service a1 a2 arg =
let call_service2 (rpc : #rpc_sig) service a1 a2 arg =
let meth, path, arg = RPC.forge_request service (((), a1), a2) arg in
get_json cctxt meth path arg >>=? fun json ->
parse_answer cctxt service path json
rpc#get_json meth path arg >>=? fun json ->
rpc#parse_answer service path json
let call_streamed cctxt service (meth, path, arg) =
get_streamed_json cctxt meth path arg >>=? fun json_st ->
let call_streamed (rpc : #rpc_sig) service (meth, path, arg) =
rpc#get_streamed_json meth path arg >>=? fun json_st ->
let parsed_st, push = Lwt_stream.create () in
let rec loop () =
Lwt_stream.get json_st >>= function
| Some (Ok json) -> begin
parse_answer cctxt service path json >>= function
rpc#parse_answer service path json >>= function
| Ok v -> push (Some (Ok v)) ; loop ()
| Error _ as err ->
push (Some err) ; push None ; Lwt.return_unit
@ -296,34 +370,26 @@ let call_streamed cctxt service (meth, path, arg) =
Lwt.async loop ;
return parsed_st
let call_streamed_service0 cctxt service arg =
call_streamed cctxt service (RPC.forge_request service () arg)
let call_streamed_service0 (rpc : #rpc_sig) service arg =
call_streamed rpc service (RPC.forge_request service () arg)
let call_streamed_service1 cctxt service arg1 arg2 =
call_streamed cctxt service (RPC.forge_request service ((), arg1) arg2)
let parse_err_answer config service path json =
match Data_encoding.Json.destruct (RPC.Service.output_encoding service) json with
| exception msg -> (* TODO print_error *)
let msg =
Format.asprintf "%a" (fun x -> Data_encoding.Json.print_error x) msg in
fail config (Unexpected_json (path, json, msg))
| v -> Lwt.return v
let call_err_service0 cctxt service arg =
let call_err_service0 (rpc : #rpc_sig) service arg =
let meth, path, arg = RPC.forge_request service () arg in
get_json cctxt meth path arg >>=? fun json ->
parse_err_answer cctxt service path json
rpc#get_json meth path arg >>=? fun json ->
rpc#parse_err_answer service path json
let call_err_service1 cctxt service a1 arg =
let call_err_service1 (rpc : #rpc_sig) service a1 arg =
let meth, path, arg = RPC.forge_request service ((), a1) arg in
get_json cctxt meth path arg >>=? fun json ->
parse_err_answer cctxt service path json
rpc#get_json meth path arg >>=? fun json ->
rpc#parse_err_answer service path json
let call_err_service2 cctxt service a1 a2 arg =
let call_err_service2 (rpc : #rpc_sig) service a1 a2 arg =
let meth, path, arg = RPC.forge_request service (((), a1), a2) arg in
get_json cctxt meth path arg >>=? fun json ->
parse_err_answer cctxt service path json
rpc#get_json meth path arg >>=? fun json ->
rpc#parse_err_answer service path json
type block = Node_rpc_services.Blocks.block

51
lib_client_base/client_rpcs.mli
View File

@ -23,53 +23,78 @@ and logger =
'a -> Cohttp.Code.status_code -> string -> unit Lwt.t ;
} -> logger
class type rpc_sig = object
method get_json :
RPC.meth ->
string list -> Data_encoding.json ->
Data_encoding.json Error_monad.tzresult Lwt.t
method get_streamed_json :
RPC.meth ->
string list ->
Data_encoding.json ->
(Data_encoding.json, Error_monad.error list) result Lwt_stream.t
Error_monad.tzresult Lwt.t
method make_request :
(Uri.t -> Data_encoding.json -> 'a Lwt.t) ->
RPC.meth ->
string list ->
Data_encoding.json ->
('a * Cohttp.Code.status_code * Cohttp_lwt_body.t)
Error_monad.tzresult Lwt.t
method parse_answer :
(unit, 'b, 'c, 'd) RPC.service ->
string list ->
Data_encoding.json -> 'd Error_monad.tzresult Lwt.t
method parse_err_answer :
(unit, 'e, 'f, 'g Error_monad.tzresult) RPC.service ->
string list ->
Data_encoding.json -> 'g Error_monad.tzresult Lwt.t
end
class rpc : config -> rpc_sig
val default_config: config
val null_logger: logger
val timings_logger: Format.formatter -> logger
val full_logger: Format.formatter -> logger
val get_json:
config ->
RPC.meth -> string list -> Data_encoding.json ->
Data_encoding.json tzresult Lwt.t
val call_service0:
config ->
#rpc_sig ->
(unit, unit, 'i, 'o) RPC.service ->
'i -> 'o tzresult Lwt.t
val call_service1:
config ->
#rpc_sig ->
(unit, unit * 'a, 'i, 'o) RPC.service ->
'a -> 'i -> 'o tzresult Lwt.t
val call_service2:
config ->
#rpc_sig ->
(unit, (unit * 'a) * 'b, 'i, 'o) RPC.service ->
'a -> 'b -> 'i -> 'o tzresult Lwt.t
val call_streamed_service0:
config ->
#rpc_sig ->
(unit, unit, 'a, 'b) RPC.service ->
'a -> ('b, error list) result Lwt_stream.t tzresult Lwt.t
val call_streamed_service1:
config ->
#rpc_sig ->
(unit, unit * 'a, 'b, 'c) RPC.service ->
'a -> 'b -> ('c, error list) result Lwt_stream.t tzresult Lwt.t
val call_err_service0:
config ->
#rpc_sig ->
(unit, unit, 'i, 'o tzresult) RPC.service ->
'i -> 'o tzresult Lwt.t
val call_err_service1:
config ->
#rpc_sig ->
(unit, unit * 'a, 'i, 'o tzresult) RPC.service ->
'a -> 'i -> 'o tzresult Lwt.t
val call_err_service2:
config ->
#rpc_sig ->
(unit, (unit * 'a) * 'b, 'i, 'o tzresult) RPC.service ->
'a -> 'b -> 'i -> 'o tzresult Lwt.t

10
lib_client_base/client_tags.mli
View File

@ -28,21 +28,21 @@ module Tags (Entity : Entity) : sig
val tag_param:
?name:string ->
?desc:string ->
('a, Client_commands.context, 'ret) Cli_entries.params ->
(Tag.t -> 'a, Client_commands.context, 'ret) Cli_entries.params
('a, Client_commands.full_context, 'ret) Cli_entries.params ->
(Tag.t -> 'a, Client_commands.full_context, 'ret) Cli_entries.params
val rev_find_by_tag:
Client_commands.context ->
Client_commands.full_context ->
string ->
string option tzresult Lwt.t
val filter:
Client_commands.context ->
Client_commands.full_context ->
(string * t -> bool) ->
(string * t) list tzresult Lwt.t
val filter_by_tag:
Client_commands.context ->
Client_commands.full_context ->
string ->
(string * t) list tzresult Lwt.t

16
lib_embedded_client_alpha/alpha.ml Normal file
View File

@ -0,0 +1,16 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
module RPCs = Client_rpcs
module Contracts = Client_proto_contracts
module Context = Client_proto_context
module Programs = Client_proto_programs

16
lib_embedded_client_alpha/alpha.mli Normal file
View File

@ -0,0 +1,16 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
module RPCs = Client_rpcs
module Contracts : module type of Client_proto_contracts
module Context : module type of Client_proto_context
module Programs : module type of Client_proto_programs

6
lib_embedded_client_alpha/client_baking_blocks.mli
View File

@ -18,21 +18,21 @@ type block_info = {
}
val info:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
?include_ops:bool -> Client_node_rpcs.Blocks.block -> block_info tzresult Lwt.t
val compare:
block_info -> block_info -> int
val monitor:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
?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:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
Client_node_rpcs.Blocks.block ->
Cycle.t ->
Block_hash.t list tzresult Lwt.t

12
lib_embedded_client_alpha/client_baking_daemon.ml
View File

@ -7,14 +7,12 @@
(* *)
(**************************************************************************)
open Client_commands
let run cctxt ?max_priority ~delay ?min_date delegates ~endorsement ~denunciation ~baking =
let run (cctxt : Client_commands.full_context) ?max_priority ~delay ?min_date delegates ~endorsement ~denunciation ~baking =
(* TODO really detach... *)
let endorsement =
if endorsement then
Client_baking_blocks.monitor
cctxt.rpc_config ?min_date ~min_heads:1 () >>=? fun block_stream ->
cctxt ?min_date ~min_heads:1 () >>=? fun block_stream ->
Client_baking_endorsement.create cctxt ~delay delegates block_stream >>= fun () ->
return ()
else
@ -23,7 +21,7 @@ let run cctxt ?max_priority ~delay ?min_date delegates ~endorsement ~denunciatio
let denunciation =
if denunciation then
Client_baking_operations.monitor_endorsement
cctxt.rpc_config >>=? fun endorsement_stream ->
cctxt >>=? fun endorsement_stream ->
Client_baking_denunciation.create cctxt endorsement_stream >>= fun () ->
return ()
else
@ -32,9 +30,9 @@ let run cctxt ?max_priority ~delay ?min_date delegates ~endorsement ~denunciatio
let forge =
if baking then begin
Client_baking_blocks.monitor
cctxt.rpc_config ?min_date ~min_heads:1 () >>=? fun block_stream ->
cctxt ?min_date ~min_heads:1 () >>=? fun block_stream ->
Client_baking_operations.monitor_endorsement
cctxt.rpc_config >>=? fun endorsement_stream ->
cctxt >>=? fun endorsement_stream ->
Client_baking_forge.create cctxt
?max_priority delegates block_stream endorsement_stream >>=? fun () ->
return ()

2
lib_embedded_client_alpha/client_baking_daemon.mli
View File

@ -8,7 +8,7 @@
(**************************************************************************)
val run:
Client_commands.context ->
Client_commands.full_context ->
?max_priority: int ->
delay: int ->
?min_date: Time.t ->

2
lib_embedded_client_alpha/client_baking_denunciation.mli
View File

@ -8,6 +8,6 @@
(**************************************************************************)
val create:
Client_commands.context ->
Client_commands.full_context ->
Client_baking_operations.valid_endorsement tzresult Lwt_stream.t ->
unit Lwt.t

84
lib_embedded_client_alpha/client_baking_endorsement.ml
View File

@ -8,18 +8,17 @@
(**************************************************************************)
open Logging.Client.Endorsement
open Client_commands
module State : sig
val get_endorsement:
Client_commands.context ->
#Client_commands.wallet ->
Raw_level.t ->
int ->
(Block_hash.t * Operation_hash.t) option tzresult Lwt.t
val record_endorsement:
Client_commands.context ->
#Client_commands.wallet ->
Raw_level.t ->
Block_hash.t ->
int -> Operation_hash.t -> unit tzresult Lwt.t
@ -45,46 +44,21 @@ end = struct
(req "block" Block_hash.encoding)
(req "operation" Operation_hash.encoding))))))
let filename cctxt =
Client_commands.(Filename.concat cctxt.config.base_dir "endorsements")
let name =
"endorsements"
let load cctxt =
let filename = filename cctxt in
if not (Sys.file_exists filename) then return LevelMap.empty else
Data_encoding_ezjsonm.read_file filename >>= function
| Error _ ->
cctxt.Client_commands.error
"couldn't to read the endorsement file"
| Ok json ->
match Data_encoding.Json.destruct encoding json with
| exception _ -> (* TODO print_error *)
cctxt.Client_commands.error
"didn't understand the endorsement file"
| map ->
return map
let load (wallet : #Client_commands.wallet) =
wallet#load name encoding ~default:LevelMap.empty
let save cctxt map =
Lwt.catch
(fun () ->
let dirname = Client_commands.(cctxt.config.base_dir) in
(if not (Sys.file_exists dirname) then Lwt_utils.create_dir dirname
else Lwt.return ()) >>= fun () ->
let filename = filename cctxt in
let json = Data_encoding.Json.construct encoding map in
Data_encoding_ezjsonm.write_file filename json >>= function
| Error _ -> failwith "Json.write_file"
| Ok () -> return ())
(fun exn ->
cctxt.Client_commands.error
"could not write the endorsement file: %s."
(Printexc.to_string exn))
let save (wallet : #Client_commands.wallet) map =
wallet#write name encoding map
let lock = Lwt_mutex.create ()
let get_endorsement cctxt level slot =
let get_endorsement (wallet : #Client_commands.wallet) level slot =
Lwt_mutex.with_lock lock
(fun () ->
load cctxt >>=? fun map ->
load wallet >>=? fun map ->
try
let _, block, op =
LevelMap.find level map
@ -92,15 +66,16 @@ end = struct
return (Some (block, op))
with Not_found -> return None)
let record_endorsement cctxt level hash slot oph =
let record_endorsement (wallet : #Client_commands.wallet) level hash slot oph =
Lwt_mutex.with_lock lock
(fun () ->
load cctxt >>=? fun map ->
load wallet >>=? fun map ->
let previous =
try LevelMap.find level map
with Not_found -> [] in
save cctxt
(LevelMap.add level ((slot, hash, oph) :: previous) map))
wallet#write name
(LevelMap.add level ((slot, hash, oph) :: previous) map)
encoding)
end
@ -113,12 +88,12 @@ let get_signing_slots cctxt ?max_priority block delegate level =
@@ List.filter (fun (l, _) -> l = level) possibilities in
return slots
let inject_endorsement cctxt
let inject_endorsement (cctxt : Client_commands.full_context)
block level ?async ?force
src_sk source slot =
let block = Client_rpcs.last_baked_block block in
Client_node_rpcs.Blocks.info cctxt.rpc_config block >>=? fun bi ->
Client_proto_rpcs.Helpers.Forge.Delegate.endorsement cctxt.rpc_config
Client_node_rpcs.Blocks.info cctxt block >>=? fun bi ->
Client_proto_rpcs.Helpers.Forge.Delegate.endorsement cctxt
block
~branch:bi.hash
~source
@ -127,8 +102,7 @@ let inject_endorsement cctxt
() >>=? fun bytes ->
let signed_bytes = Ed25519.Signature.append src_sk bytes in
Client_node_rpcs.inject_operation
cctxt.rpc_config ?force ?async ~net_id:bi.net_id
signed_bytes >>=? fun oph ->
cctxt ?force ?async ~net_id:bi.net_id signed_bytes >>=? fun oph ->
State.record_endorsement cctxt level bi.hash slot oph >>=? fun () ->
return oph
@ -147,20 +121,20 @@ let check_endorsement cctxt level slot =
Block_hash.pp_short block Raw_level.pp level slot
let forge_endorsement cctxt
let forge_endorsement (cctxt : Client_commands.full_context)
block ?(force = false)
~src_sk ?slot ?max_priority src_pk =
let block = Client_rpcs.last_baked_block block in
let src_pkh = Ed25519.Public_key.hash src_pk in
Client_proto_rpcs.Context.next_level cctxt.rpc_config block >>=? fun { level } ->
Client_proto_rpcs.Context.next_level cctxt block >>=? fun { level } ->
begin
match slot with
| Some slot -> return slot
| None ->
get_signing_slots
cctxt.rpc_config ?max_priority block src_pkh level >>=? function
cctxt ?max_priority block src_pkh level >>=? function
| slot::_ -> return slot
| [] -> cctxt.error "No slot found at level %a" Raw_level.pp level
| [] -> cctxt#error "No slot found at level %a" Raw_level.pp level
end >>=? fun slot ->
begin
if force then return ()
@ -213,14 +187,14 @@ let drop_old_endorsement ~before state =
(fun { block } -> Fitness.compare before block.fitness <= 0)
state.to_endorse
let schedule_endorsements cctxt state bis =
let schedule_endorsements (cctxt : Client_commands.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"
Block_hash.pp_short block.hash name >>= fun () ->
let b = `Hash block.hash in
let level = Raw_level.succ block.level.level in
get_signing_slots cctxt.rpc_config b delegate level >>=? fun slots ->
get_signing_slots cctxt b delegate level >>=? fun slots ->
lwt_debug "Found slots for %a/%s (%d)"
Block_hash.pp_short block.hash name (List.length slots) >>= fun () ->
iter_p
@ -283,7 +257,7 @@ let schedule_endorsements cctxt state bis =
bis)
delegates
let schedule_endorsements cctxt state bis =
let schedule_endorsements (cctxt : Client_commands.full_context) state bis =
schedule_endorsements cctxt state bis >>= function
| Error exns ->
lwt_log_error
@ -318,7 +292,7 @@ let endorse cctxt state =
inject_endorsement cctxt
b level ~async:true ~force:true
sk pk slot >>=? fun oph ->
cctxt.message
cctxt#message
"Injected endorsement for block '%a' \
\ (level %a, slot %d, contract %s) '%a'"
Block_hash.pp_short hash
@ -338,11 +312,11 @@ let compute_timeout state =
else
Lwt_unix.sleep (Int64.to_float delay)
let create cctxt ~delay contracts block_stream =
let create (cctxt : Client_commands.full_context) ~delay contracts block_stream =
lwt_log_info "Starting endorsement daemon" >>= fun () ->
Lwt_stream.get block_stream >>= function
| None | Some (Ok []) | Some (Error _) ->
cctxt.Client_commands.error "Can't fetch the current block head."
cctxt#error "Can't fetch the current block head."
| Some (Ok (bi :: _ as initial_heads)) ->
let last_get_block = ref None in
let get_block () =

11
lib_embedded_client_alpha/client_baking_endorsement.mli
View File

@ -8,7 +8,7 @@
(**************************************************************************)
val forge_endorsement:
Client_commands.context ->
Client_commands.full_context ->
Client_proto_rpcs.block ->
?force:bool ->
src_sk:secret_key ->
@ -17,9 +17,8 @@ val forge_endorsement:
public_key ->
Operation_hash.t tzresult Lwt.t
val create:
Client_commands.context ->
delay: int ->
val create :
Client_commands.full_context ->
delay:int ->
public_key_hash list ->
Client_baking_blocks.block_info list tzresult Lwt_stream.t ->
unit Lwt.t
Client_baking_blocks.block_info list tzresult Lwt_stream.t -> unit Lwt.t

80
lib_embedded_client_alpha/client_baking_forge.ml
View File

@ -7,7 +7,6 @@
(* *)
(**************************************************************************)
open Client_commands
open Logging.Client.Baking
let generate_proof_of_work_nonce () =
@ -200,11 +199,11 @@ let forge_block cctxt block
module State : sig
val get_block:
Client_commands.context ->
#Client_commands.wallet ->
Raw_level.t -> Block_hash.t list tzresult Lwt.t
val record_block:
Client_commands.context ->
#Client_commands.wallet ->
Raw_level.t -> Block_hash.t -> Nonce.t -> unit tzresult Lwt.t
end = struct
@ -224,41 +223,18 @@ end = struct
(req "level" Raw_level.encoding)
(req "blocks" (list Block_hash.encoding))))
let filename cctxt =
Client_commands.(Filename.concat cctxt.config.base_dir "blocks")
let name =
"blocks"
let load cctxt =
let filename = filename cctxt in
if not (Sys.file_exists filename) then return LevelMap.empty else
Data_encoding_ezjsonm.read_file filename >>= function
| Error _ ->
failwith "couldn't to read the block file"
| Ok json ->
match Data_encoding.Json.destruct encoding json with
| exception _ -> (* TODO print_error *)
failwith "didn't understand the block file"
| map ->
return map
let load (wallet : #Client_commands.wallet) =
wallet#load name ~default:LevelMap.empty encoding
let save cctxt map =
Lwt.catch
(fun () ->
let dirname = Client_commands.(cctxt.config.base_dir) in
(if not (Sys.file_exists dirname) then Lwt_utils.create_dir dirname
else Lwt.return ()) >>= fun () ->
let filename = filename cctxt in
let json = Data_encoding.Json.construct encoding map in
Data_encoding_ezjsonm.write_file filename json >>= function
| Error _ -> failwith "Json.write_file"
| Ok () -> return ())
(fun exn ->
failwith
"could not write the block file: %s."
(Printexc.to_string exn))
let save (wallet : #Client_commands.wallet) map =
wallet#write name map encoding
let lock = Lwt_mutex.create ()
let get_block cctxt level =
let get_block (cctxt : #Client_commands.wallet) level =
Lwt_mutex.with_lock lock
(fun () ->
load cctxt >>=? fun map ->
@ -350,33 +326,33 @@ let compute_timeout { future_slots } =
else
Lwt_unix.sleep (Int64.to_float delay)
let get_unrevealed_nonces cctxt ?(force = false) block =
Client_proto_rpcs.Context.next_level cctxt.rpc_config block >>=? fun level ->
let get_unrevealed_nonces (cctxt : Client_commands.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
| None -> return []
| Some cycle ->
Client_baking_blocks.blocks_from_cycle
cctxt.rpc_config block cycle >>=? fun blocks ->
cctxt block cycle >>=? fun blocks ->
filter_map_s (fun hash ->
Client_proto_nonces.find cctxt hash >>= function
Client_proto_nonces.find cctxt hash >>=? function
| None -> return None
| Some nonce ->
Client_proto_rpcs.Context.level
cctxt.rpc_config (`Hash hash) >>=? fun level ->
cctxt (`Hash hash) >>=? fun level ->
if force then
return (Some (hash, (level.level, nonce)))
else
Client_proto_rpcs.Context.Nonce.get
cctxt.rpc_config block level.level >>=? function
cctxt block level.level >>=? function
| Missing nonce_hash
when Nonce.check_hash nonce nonce_hash ->
cctxt.warning "Found nonce for %a (level: %a)@."
cctxt#warning "Found nonce for %a (level: %a)@."
Block_hash.pp_short hash
Level.pp level >>= fun () ->
return (Some (hash, (level.level, nonce)))
| Missing _nonce_hash ->
cctxt.error "Incoherent nonce for level %a"
cctxt#error "Incoherent nonce for level %a"
Raw_level.pp level.level >>= fun () ->
return None
| Forgotten -> return None
@ -398,7 +374,7 @@ let get_delegates cctxt state =
| _ :: _ as delegates -> return delegates
let insert_block
cctxt ?max_priority state (bi: Client_baking_blocks.block_info) =
(cctxt : Client_commands.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
@ -410,7 +386,7 @@ let insert_block
~before:(Time.add state.best.timestamp (-1800L)) state ;
end ;
get_delegates cctxt state >>=? fun delegates ->
get_baking_slot cctxt.rpc_config ?max_priority bi delegates >>= function
get_baking_slot cctxt ?max_priority bi delegates >>= function
| None ->
lwt_debug
"Can't compute slot for %a" Block_hash.pp_short bi.hash >>= fun () ->
@ -443,7 +419,7 @@ let insert_blocks cctxt ?max_priority state bis =
Format.eprintf "Error: %a" pp_print_error err ;
Lwt.return_unit
let bake cctxt state =
let bake (cctxt : Client_commands.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
@ -459,7 +435,7 @@ let bake cctxt state =
lwt_debug "Try baking after %a (slot %d) for %s (%a)"
Block_hash.pp_short bi.hash
priority name Time.pp_hum timestamp >>= fun () ->
Client_node_rpcs.Blocks.pending_operations cctxt.rpc_config
Client_node_rpcs.Blocks.pending_operations cctxt
block >>=? fun (res, ops) ->
let operations =
List.map snd @@
@ -469,7 +445,7 @@ let bake cctxt state =
let request = List.length operations in
let proto_header =
forge_faked_proto_header ~priority ~seed_nonce_hash in
Client_node_rpcs.Blocks.preapply cctxt.rpc_config block
Client_node_rpcs.Blocks.preapply cctxt block
~timestamp ~sort:true ~proto_header operations >>= function
| Error errs ->
lwt_log_error "Error while prevalidating operations:\n%a"
@ -502,12 +478,12 @@ let bake cctxt state =
(Fitness.compare state.best.fitness shell_header.fitness = 0 &&
Time.compare shell_header.timestamp state.best.timestamp < 0) -> begin
let level = Raw_level.succ bi.level.level in
cctxt.message
cctxt#message
"Select candidate block after %a (slot %d) fitness: %a"
Block_hash.pp_short bi.hash priority
Fitness.pp shell_header.fitness >>= fun () ->
Client_keys.get_key cctxt delegate >>=? fun (_,_,src_sk) ->
inject_block cctxt.rpc_config
inject_block cctxt
~force:true ~net_id:bi.net_id
~shell_header ~priority ~seed_nonce_hash ~src_sk
[List.map snd operations.applied]
@ -515,7 +491,7 @@ let bake cctxt state =
State.record_block cctxt level block_hash seed_nonce
|> trace_exn (Failure "Error while recording block") >>=? fun () ->
Client_keys.Public_key_hash.name cctxt delegate >>=? fun name ->
cctxt.message
cctxt#message
"Injected block %a for %s after %a \
\ (level %a, slot %d, fitness %a, operations %d)"
Block_hash.pp_short block_hash
@ -531,16 +507,16 @@ let bake cctxt state =
return ()
let create
cctxt ?max_priority delegates
(cctxt : Client_commands.full_context) ?max_priority delegates
(block_stream:
Client_baking_blocks.block_info list tzresult Lwt_stream.t)
(endorsement_stream:
Client_baking_operations.valid_endorsement tzresult Lwt_stream.t) =
Lwt_stream.get block_stream >>= function
| None | Some (Ok [] | Error _) ->
cctxt.Client_commands.error "Can't fetch the current block head."
cctxt#error "Can't fetch the current block head."
| Some (Ok (bi :: _ as initial_heads)) ->
Client_node_rpcs.Blocks.hash cctxt.rpc_config `Genesis >>=? fun genesis_hash ->
Client_node_rpcs.Blocks.hash cctxt `Genesis >>=? fun genesis_hash ->
let last_get_block = ref None in
let get_block () =
match !last_get_block with

12
lib_embedded_client_alpha/client_baking_forge.mli
View File

@ -14,7 +14,7 @@ val generate_seed_nonce: unit -> Nonce.t
reveal the aforementionned nonce during the next cycle. *)
val inject_block:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
?force:bool ->
?net_id:Net_id.t ->
shell_header:Block_header.shell_header ->
@ -33,7 +33,7 @@ type error +=
| Failed_to_preapply of Tezos_base.Operation.t * error list
val forge_block:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
Client_proto_rpcs.block ->
?force:bool ->
?operations:Tezos_base.Operation.t list ->
@ -65,15 +65,15 @@ val forge_block:
module State : sig
val get_block:
Client_commands.context ->
Client_commands.full_context ->
Raw_level.t -> Block_hash.t list tzresult Lwt.t
val record_block:
Client_commands.context ->
Client_commands.full_context ->
Raw_level.t -> Block_hash.t -> Nonce.t -> unit tzresult Lwt.t
end
val create:
Client_commands.context ->
Client_commands.full_context ->
?max_priority: int ->
public_key_hash list ->
Client_baking_blocks.block_info list tzresult Lwt_stream.t ->
@ -81,7 +81,7 @@ val create:
unit tzresult Lwt.t
val get_unrevealed_nonces:
Client_commands.context ->
Client_commands.full_context ->
?force:bool ->
Client_proto_rpcs.block ->
(Block_hash.t * (Raw_level.t * Nonce.t)) list tzresult Lwt.t

97
lib_embedded_client_alpha/client_baking_lib.ml Normal file
View File

@ -0,0 +1,97 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
let bake_block (cctxt : Client_commands.full_context) block
?force ?max_priority ?(free_baking=false) ?src_sk delegate =
begin
match src_sk with
| None ->
Client_keys.get_key cctxt delegate >>=? fun (_, _, src_sk) ->
return src_sk
| Some sk -> return sk
end >>=? fun src_sk ->
Client_proto_rpcs.Context.level cctxt block >>=? fun level ->
let level = Raw_level.succ level.level in
let seed_nonce = Client_baking_forge.generate_seed_nonce () in
let seed_nonce_hash = Nonce.hash seed_nonce in
Client_baking_forge.forge_block cctxt
~timestamp:(Time.now ())
?force
~seed_nonce_hash ~src_sk block
~priority:(`Auto (delegate, max_priority, free_baking)) () >>=? fun block_hash ->
Client_baking_forge.State.record_block cctxt level block_hash seed_nonce
|> trace_exn (Failure "Error while recording block") >>=? fun () ->
cctxt#message "Injected block %a" Block_hash.pp_short block_hash >>= fun () ->
return ()
let endorse_block cctxt ?force ?max_priority delegate =
Client_keys.get_key cctxt delegate >>=? fun (_src_name, src_pk, src_sk) ->
Client_baking_endorsement.forge_endorsement cctxt
cctxt#block ?force ?max_priority ~src_sk src_pk >>=? fun oph ->
cctxt#answer "Operation successfully injected in the node." >>= fun () ->
cctxt#answer "Operation hash is '%a'." Operation_hash.pp oph >>= fun () ->
return ()
let get_predecessor_cycle (cctxt : #Client_commands.logger) cycle =
match Cycle.pred cycle with
| None ->
if Cycle.(cycle = root) then
cctxt#error "No predecessor for the first cycle"
else
cctxt#error
"Cannot compute the predecessor of cycle %a"
Cycle.pp cycle
| Some cycle -> Lwt.return cycle
let do_reveal cctxt ?force block blocks =
let nonces = List.map snd blocks in
Client_baking_revelation.forge_seed_nonce_revelation cctxt
block ?force nonces >>=? fun () ->
Client_proto_nonces.dels cctxt (List.map fst blocks) >>=? fun () ->
return ()
let reveal_block_nonces (cctxt : Client_commands.full_context) ?force block_hashes =
Lwt_list.filter_map_p
(fun hash ->
Lwt.catch
(fun () ->
Client_baking_blocks.info cctxt (`Hash hash) >>= function
| Ok bi -> Lwt.return (Some bi)
| Error _ ->
Lwt.fail Not_found)
(fun _ ->
cctxt#warning
"Cannot find block %a in the chain. (ignoring)@."
Block_hash.pp_short hash >>= fun () ->
Lwt.return_none))
block_hashes >>= fun block_infos ->
filter_map_s (fun (bi : Client_baking_blocks.block_info) ->
Client_proto_nonces.find cctxt bi.hash >>=? function
| None ->
cctxt#warning "Cannot find nonces for block %a (ignoring)@."
Block_hash.pp_short bi.hash >>= fun () ->
return None
| Some nonce ->
return (Some (bi.hash, (bi.level.level, nonce))))
block_infos >>=? fun blocks ->
do_reveal cctxt ?force cctxt#block blocks
let reveal_nonces cctxt ?force () =
let block = Client_rpcs.last_baked_block cctxt#block in
Client_baking_forge.get_unrevealed_nonces
cctxt ?force block >>=? fun nonces ->
do_reveal cctxt ?force cctxt#block nonces
let run_daemon cctxt ?max_priority ~endorsement_delay delegates ~endorsement ~baking ~denunciation =
Client_baking_daemon.run cctxt
?max_priority
~delay:endorsement_delay
~min_date:((Time.add (Time.now ()) (Int64.neg 1800L)))
~endorsement ~baking ~denunciation
(List.map snd delegates)

58
lib_embedded_client_alpha/client_baking_lib.mli Normal file
View File

@ -0,0 +1,58 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
(** Mine a block *)
val bake_block:
Client_commands.full_context ->
Client_proto_rpcs.block ->
?force:bool ->
?max_priority: int ->
?free_baking: bool ->
?src_sk:secret_key ->
public_key_hash ->
unit tzresult Lwt.t
(** Endorse a block *)
val endorse_block:
Client_commands.full_context ->
?force:bool ->
?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 ->
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 ->
?force:bool ->
Block_hash.t list ->
unit Error_monad.tzresult Lwt.t
(** Reveal all unrevealed nonces *)
val reveal_nonces :
Client_commands.full_context ->
?force:bool ->
unit ->
unit Error_monad.tzresult Lwt.t
(** Initialize the baking daemon *)
val run_daemon:
Client_commands.full_context ->
?max_priority:int ->
endorsement_delay:int ->
('a * Tezos_embedded_raw_protocol_alpha.Tezos_context.public_key_hash) list ->
endorsement:bool ->
baking:bool ->
denunciation:bool ->
unit Error_monad.tzresult Lwt.t

100
lib_embedded_client_alpha/client_baking_main.ml
View File

@ -7,98 +7,8 @@
(* *)
(**************************************************************************)
open Client_commands
let bake_block cctxt block
?force ?max_priority ?(free_baking=false) ?src_sk delegate =
begin
match src_sk with
| None ->
Client_keys.get_key cctxt delegate >>=? fun (_, _, src_sk) ->
return src_sk
| Some sk -> return sk
end >>=? fun src_sk ->
Client_proto_rpcs.Context.level cctxt.rpc_config block >>=? fun level ->
let level = Raw_level.succ level.level in
let seed_nonce = Client_baking_forge.generate_seed_nonce () in
let seed_nonce_hash = Nonce.hash seed_nonce in
Client_baking_forge.forge_block cctxt.rpc_config
~timestamp:(Time.now ())
?force
~seed_nonce_hash ~src_sk block
~priority:(`Auto (delegate, max_priority, free_baking)) () >>=? fun block_hash ->
Client_baking_forge.State.record_block cctxt level block_hash seed_nonce
|> trace_exn (Failure "Error while recording block") >>=? fun () ->
cctxt.message "Injected block %a" Block_hash.pp_short block_hash >>= fun () ->
return ()
let endorse_block cctxt ?force ?max_priority delegate =
Client_keys.get_key cctxt delegate >>=? fun (_src_name, src_pk, src_sk) ->
Client_baking_endorsement.forge_endorsement cctxt
cctxt.config.block ?force ?max_priority ~src_sk src_pk >>=? fun oph ->
cctxt.answer "Operation successfully injected in the node." >>= fun () ->
cctxt.answer "Operation hash is '%a'." Operation_hash.pp oph >>= fun () ->
return ()
let get_predecessor_cycle cctxt cycle =
match Cycle.pred cycle with
| None ->
if Cycle.(cycle = root) then
cctxt.Client_commands.error "No predecessor for the first cycle"
else
cctxt.error
"Cannot compute the predecessor of cycle %a"
Cycle.pp cycle
| Some cycle -> Lwt.return cycle
let do_reveal cctxt ?force block blocks =
let nonces = List.map snd blocks in
Client_baking_revelation.forge_seed_nonce_revelation cctxt
block ?force nonces >>=? fun () ->
Client_proto_nonces.dels cctxt (List.map fst blocks) >>=? fun () ->
return ()
let reveal_block_nonces cctxt ?force block_hashes =
Lwt_list.filter_map_p
(fun hash ->
Lwt.catch
(fun () ->
Client_baking_blocks.info cctxt.rpc_config (`Hash hash) >>= function
| Ok bi -> Lwt.return (Some bi)
| Error _ ->
Lwt.fail Not_found)
(fun _ ->
cctxt.warning
"Cannot find block %a in the chain. (ignoring)@."
Block_hash.pp_short hash >>= fun () ->
Lwt.return_none))
block_hashes >>= fun block_infos ->
filter_map_s (fun (bi : Client_baking_blocks.block_info) ->
Client_proto_nonces.find cctxt bi.hash >>= function
| None ->
cctxt.warning "Cannot find nonces for block %a (ignoring)@."
Block_hash.pp_short bi.hash >>= fun () ->
return None
| Some nonce ->
return (Some (bi.hash, (bi.level.level, nonce))))
block_infos >>=? fun blocks ->
do_reveal cctxt ?force cctxt.config.block blocks
let reveal_nonces cctxt ?force () =
let block = Client_rpcs.last_baked_block cctxt.config.block in
Client_baking_forge.get_unrevealed_nonces
cctxt ?force block >>=? fun nonces ->
do_reveal cctxt ?force cctxt.config.block nonces
open Client_proto_args
let run_daemon cctxt max_priority endorsement_delay delegates ~endorsement ~baking ~denunciation =
Client_baking_daemon.run cctxt
?max_priority
~delay:endorsement_delay
~min_date:((Time.add (Time.now ()) (Int64.neg 1800L)))
~endorsement ~baking ~denunciation
(List.map snd delegates)
open Client_baking_lib
let group =
{ Cli_entries.name = "delegate" ;
@ -117,7 +27,7 @@ let commands () =
if (not endorsement) && (not baking) && (not denunciation)
then (true, true, true)
else (endorsement, baking, denunciation) in
run_daemon cctxt max_priority endorsement_delay ~endorsement ~baking ~denunciation delegates) ;
run_daemon cctxt ?max_priority ~endorsement_delay ~endorsement ~baking ~denunciation delegates) ;
command ~group ~desc: "Forge and inject an endorsement operation"
(args2 force_switch max_priority_arg)
(prefixes [ "endorse"; "for" ]
@ -134,7 +44,7 @@ let commands () =
~name:"baker" ~desc: "name of the delegate owning the baking right"
@@ stop)
(fun (max_priority, force, free_baking) (_, delegate) cctxt ->
bake_block cctxt cctxt.config.block
bake_block cctxt cctxt#block
~force ?max_priority ~free_baking delegate) ;
command ~group ~desc: "Forge and inject a seed-nonce revelation operation"
(args1 force_switch)
@ -150,7 +60,3 @@ let commands () =
(fun force cctxt ->
reveal_nonces cctxt ~force ()) ;
]
let () =
Client_commands.register Client_proto_main.protocol @@
commands ()

10
lib_embedded_client_alpha/client_baking_main.mli
View File

@ -7,14 +7,4 @@
(* *)
(**************************************************************************)
val bake_block:
Client_commands.context ->
Client_proto_rpcs.block ->
?force:bool ->
?max_priority: int ->
?free_baking: bool ->
?src_sk:secret_key ->
public_key_hash ->
unit tzresult Lwt.t
val commands: unit -> Client_commands.command list

10
lib_embedded_client_alpha/client_baking_operations.mli
View File

@ -13,7 +13,7 @@ type operation = {
}
val monitor:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
?contents:bool -> ?check:bool -> unit ->
operation list tzresult Lwt_stream.t tzresult Lwt.t
@ -24,13 +24,7 @@ type valid_endorsement = {
slots: int list ;
}
(*
val filter_valid_endorsement:
Client_rpcs.config ->
operation -> valid_endorsement option Lwt.t
*)
val monitor_endorsement:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
valid_endorsement tzresult Lwt_stream.t tzresult Lwt.t

12
lib_embedded_client_alpha/client_baking_revelation.ml
View File

@ -24,20 +24,20 @@ let inject_seed_nonce_revelation rpc_config block ?force ?async nonces =
return oph
let forge_seed_nonce_revelation
(cctxt: Client_commands.context)
(cctxt: Client_commands.full_context)
block ?(force = false) nonces =
Client_node_rpcs.Blocks.hash cctxt.rpc_config block >>=? fun hash ->
Client_node_rpcs.Blocks.hash cctxt block >>=? fun hash ->
match nonces with
| [] ->
cctxt.message "No nonce to reveal for block %a"
cctxt#message "No nonce to reveal for block %a"
Block_hash.pp_short hash >>= fun () ->
return ()
| _ ->
inject_seed_nonce_revelation cctxt.rpc_config block ~force nonces >>=? fun oph ->
cctxt.answer
inject_seed_nonce_revelation cctxt block ~force nonces >>=? fun oph ->
cctxt#answer
"Operation successfully injected %d revelation(s) for %a."
(List.length nonces)
Block_hash.pp_short hash >>= fun () ->
cctxt.answer "Operation hash is '%a'."
cctxt#answer "Operation hash is '%a'."
Operation_hash.pp_short oph >>= fun () ->
return ()

4
lib_embedded_client_alpha/client_baking_revelation.mli
View File

@ -8,7 +8,7 @@
(**************************************************************************)
val inject_seed_nonce_revelation:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
Client_proto_rpcs.block ->
?force:bool ->
?async:bool ->
@ -16,7 +16,7 @@ val inject_seed_nonce_revelation:
Operation_hash.t tzresult Lwt.t
val forge_seed_nonce_revelation:
Client_commands.context ->
Client_commands.full_context ->
Client_proto_rpcs.block ->
?force:bool ->
(Raw_level.t * Nonce.t) list ->

2
lib_embedded_client_alpha/client_proto_args.ml
View File

@ -54,7 +54,7 @@ let tez_sym =
"\xEA\x9C\xA9"
let string_parameter =
parameter (fun _ x -> return x)
parameter (fun (_ : Client_commands.full_context) x -> return x)
let init_arg =
default_arg

38
lib_embedded_client_alpha/client_proto_args.mli
View File

@ -10,36 +10,36 @@
val tez_sym: string
open Cli_entries
val init_arg: (string, Client_commands.context) arg
val fee_arg: (Tez.t, Client_commands.context) arg
val arg_arg: (string, Client_commands.context) arg
val source_arg: (string option, Client_commands.context) arg
val init_arg: (string, Client_commands.full_context) arg
val fee_arg: (Tez.t, Client_commands.full_context) arg
val arg_arg: (string, Client_commands.full_context) arg
val source_arg: (string option, Client_commands.full_context) arg
val delegate_arg: (string option, Client_commands.context) arg
val delegatable_switch: (bool, Client_commands.context) arg
val spendable_switch: (bool, Client_commands.context) arg
val max_priority_arg: (int option, Client_commands.context) arg
val free_baking_switch: (bool, Client_commands.context) arg
val force_switch: (bool, Client_commands.context) arg
val endorsement_delay_arg: (int, Client_commands.context) arg
val delegate_arg: (string option, Client_commands.full_context) arg
val delegatable_switch: (bool, Client_commands.full_context) arg
val spendable_switch: (bool, Client_commands.full_context) arg
val max_priority_arg: (int option, Client_commands.full_context) arg
val free_baking_switch: (bool, Client_commands.full_context) arg
val force_switch: (bool, Client_commands.full_context) arg
val endorsement_delay_arg: (int, Client_commands.full_context) arg
val no_print_source_flag : (bool, Client_commands.context) arg
val no_print_source_flag : (bool, Client_commands.full_context) arg
val tez_arg :
default:string ->
parameter:string ->
doc:string ->
(Tez.t, Client_commands.context) arg
(Tez.t, Client_commands.full_context) arg
val tez_param :
name:string ->
desc:string ->
('a, Client_commands.context, 'ret) Cli_entries.params ->
(Tez.t -> 'a, Client_commands.context, 'ret) Cli_entries.params
('a, Client_commands.full_context, 'ret) Cli_entries.params ->
(Tez.t -> 'a, Client_commands.full_context, 'ret) Cli_entries.params
module Daemon : sig
val baking_switch: (bool, Client_commands.context) arg
val endorsement_switch: (bool, Client_commands.context) arg
val denunciation_switch: (bool, Client_commands.context) arg
val baking_switch: (bool, Client_commands.full_context) arg
val endorsement_switch: (bool, Client_commands.full_context) arg
val denunciation_switch: (bool, Client_commands.full_context) arg
end
val string_parameter : (string, Client_commands.context) Cli_entries.parameter
val string_parameter : (string, Client_commands.full_context) Cli_entries.parameter

408
lib_embedded_client_alpha/client_proto_context.ml
View File

@ -8,17 +8,14 @@
(**************************************************************************)
open Tezos_micheline
open Client_proto_args
open Client_proto_contracts
open Client_proto_programs
open Client_keys
open Client_commands
let get_balance cctxt block contract =
Client_proto_rpcs.Context.Contract.balance cctxt block contract
let get_balance (rpc : #Client_rpcs.rpc_sig) block contract =
Client_proto_rpcs.Context.Contract.balance rpc block contract
let get_storage cctxt block contract =
Client_proto_rpcs.Context.Contract.storage cctxt block contract
let get_storage (rpc : #Client_rpcs.rpc_sig) block contract =
Client_proto_rpcs.Context.Contract.storage rpc block contract
let rec find_predecessor rpc_config h n =
if n <= 0 then
@ -92,39 +89,36 @@ let originate rpc_config ?force ?net_id ~block ?signature bytes =
"The origination introduced %d contracts instead of one."
(List.length contracts)
let originate_account rpc_config
block ?force ?branch
let operation_submitted_message (cctxt : #Client_commands.logger) ?(force=false) ?(contracts = []) oph =
begin
if not force then
cctxt#message "Operation successfully injected in the node."
else
Lwt.return_unit
end >>= fun () ->
cctxt#message "Operation hash is '%a'." Operation_hash.pp oph >>= fun () ->
Lwt_list.iter_s
(fun c ->
cctxt#message
"New contract %a originated from a smart contract."
Contract.pp c)
contracts >>= return
let originate_account ?(force=false) ?branch
~source ~src_pk ~src_sk ~manager_pkh
?delegatable ?spendable ?delegate ~balance ~fee () =
?delegatable ?delegate ~balance ~fee block rpc_config () =
get_branch rpc_config block branch >>=? fun (net_id, branch) ->
Client_proto_rpcs.Context.Contract.counter
rpc_config block source >>=? fun pcounter ->
let counter = Int32.succ pcounter in
Client_proto_rpcs.Helpers.Forge.Manager.origination rpc_config block
~branch ~source ~sourcePubKey:src_pk ~managerPubKey:manager_pkh
~counter ~balance ?spendable
~counter ~balance ~spendable:true
?delegatable ?delegatePubKey:delegate ~fee () >>=? fun bytes ->
let signature = Ed25519.sign src_sk bytes in
originate rpc_config ?force ~block ~net_id ~signature bytes
originate rpc_config ~force ~block ~net_id ~signature bytes
let originate_contract rpc_config
block ?force ?branch
~source ~src_pk ~src_sk ~manager_pkh ~balance ?delegatable ?delegatePubKey
~code ~init ~fee ~spendable () =
parse_expression init >>=? fun { expanded = storage } ->
Client_proto_rpcs.Context.Contract.counter
rpc_config block source >>=? fun pcounter ->
let counter = Int32.succ pcounter in
get_branch rpc_config block branch >>=? fun (net_id, branch) ->
Client_proto_rpcs.Helpers.Forge.Manager.origination rpc_config block
~branch ~source ~sourcePubKey:src_pk ~managerPubKey:manager_pkh
~counter ~balance ~spendable:spendable
?delegatable ?delegatePubKey
~script:{ code ; storage } ~fee () >>=? fun bytes ->
let signature = Ed25519.sign src_sk bytes in
originate rpc_config ?force ~net_id ~block ~signature bytes
let faucet rpc_config block ?force ?branch ~manager_pkh () =
let faucet ?force ?branch ~manager_pkh block rpc_config () =
get_branch rpc_config block branch >>=? fun (net_id, branch) ->
Client_proto_rpcs.Helpers.Forge.Anonymous.faucet
rpc_config block ~branch ~id:manager_pkh () >>=? fun bytes ->
@ -149,9 +143,9 @@ let delegate_contract rpc_config
assert (Operation_hash.equal oph injected_oph) ;
return oph
let list_contract_labels cctxt block =
let list_contract_labels (cctxt : Client_commands.full_context) block =
Client_proto_rpcs.Context.Contract.list
cctxt.rpc_config block >>=? fun contracts ->
cctxt block >>=? fun contracts ->
map_s (fun h ->
begin match Contract.is_default h with
| Some m -> begin
@ -175,50 +169,16 @@ let list_contract_labels cctxt block =
return (nm, h_b58, kind))
contracts
let message_injection cctxt ~force ?(contracts = []) oph =
begin
if not force then
cctxt.message "Operation successfully injected in the node."
else
Lwt.return_unit
end >>= fun () ->
cctxt.message "Operation hash is '%a'." Operation_hash.pp oph >>= fun () ->
Lwt_list.iter_s
(fun c ->
cctxt.message
"New contract %a originated from a smart contract."
Contract.pp c)
contracts >>= fun () ->
Lwt.return_unit
let message_added_contract (cctxt : Client_commands.full_context) name =
cctxt#message "Contract memorized as %s." name
let message_added_contract cctxt name =
cctxt.message "Contract memorized as %s." name
let check_contract cctxt new_contract =
RawContractAlias.mem cctxt new_contract >>=? function
| true ->
failwith "contract '%s' already exists" new_contract
| false ->
return ()
let get_delegate_pkh cctxt = function
| None ->
return None
| Some delegate ->
Public_key_hash.find_opt cctxt delegate
let get_manager cctxt source =
let get_manager (cctxt : Client_commands.full_context) block source =
Client_proto_contracts.get_manager
cctxt.rpc_config cctxt.config.block source >>=? fun src_pkh ->
cctxt block source >>=? fun src_pkh ->
Client_keys.get_key cctxt src_pkh >>=? fun (src_name, src_pk, src_sk) ->
cctxt.message "Got the source's manager keys (%s)." src_name >>= fun () ->
return (src_name, src_pkh, src_pk, src_sk)
let group =
{ Cli_entries.name = "context" ;
title = "Block contextual commands (see option -block)" }
let dictate rpc_config ?force block command seckey =
let dictate rpc_config block command seckey =
let block = Client_rpcs.last_baked_block block in
Client_node_rpcs.Blocks.info
rpc_config block >>=? fun { net_id ; hash = branch } ->
@ -228,274 +188,50 @@ let dictate rpc_config ?force block command seckey =
let signed_bytes = Ed25519.Signature.concat bytes signature in
let oph = Operation_hash.hash_bytes [ signed_bytes ] in
Client_node_rpcs.inject_operation
rpc_config ?force ~net_id signed_bytes >>=? fun injected_oph ->
rpc_config ~net_id signed_bytes >>=? fun injected_oph ->
assert (Operation_hash.equal oph injected_oph) ;
return oph
let default_fee =
match Tez.of_cents 5L with
| None -> raise (Failure "internal error: Could not parse default_fee literal")
| Some fee -> fee
let set_delegate (cctxt : #Client_rpcs.rpc_sig) block ~fee contract ~src_pk ~manager_sk opt_delegate =
delegate_contract
cctxt block ~source:contract
~src_pk ~manager_sk ~fee opt_delegate
let commands () =
let open Cli_entries in
let open Client_commands in
[
command ~group ~desc: "access the timestamp of the block"
no_options
(fixed [ "get" ; "timestamp" ])
begin fun () cctxt ->
Client_node_rpcs.Blocks.timestamp
cctxt.rpc_config cctxt.config.block >>=? fun v ->
cctxt.message "%s" (Time.to_notation v) >>= fun () ->
return ()
end ;
let source_to_keys (wallet : #Client_commands.full_context) block source =
get_manager wallet block source >>=? fun (_src_name, _src_pkh, src_pk, src_sk) ->
return (src_pk, src_sk)
command ~group ~desc: "lists all non empty contracts of the block"
no_options
(fixed [ "list" ; "contracts" ])
begin fun () cctxt ->
list_contract_labels cctxt cctxt.config.block >>=? fun contracts ->
Lwt_list.iter_s
(fun (alias, hash, kind) -> cctxt.message "%s%s%s" hash kind alias)
contracts >>= fun () ->
return ()
end ;
let save_contract ~force cctxt alias_name contract =
RawContractAlias.add ~force cctxt alias_name contract >>=? fun () ->
message_added_contract cctxt alias_name >>= fun () ->
return ()
command ~group ~desc: "get the balance of a contract"
no_options
(prefixes [ "get" ; "balance" ; "for" ]
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@@ stop)
begin fun () (_, contract) cctxt ->
get_balance cctxt.rpc_config cctxt.config.block contract >>=? fun amount ->
cctxt.answer "%a %s" Tez.pp amount tez_sym >>= fun () ->
return ()
end ;
command ~group ~desc: "get the storage of a contract"
no_options
(prefixes [ "get" ; "storage" ; "for" ]
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@@ stop)
begin fun () (_, contract) cctxt ->
get_storage cctxt.rpc_config cctxt.config.block contract >>=? function
| None ->
cctxt.error "This is not a smart contract."
| Some storage ->
cctxt.answer "%a" Michelson_v1_printer.print_expr_unwrapped storage >>= fun () ->
return ()
end ;
command ~group ~desc: "get the manager of a contract"
no_options
(prefixes [ "get" ; "manager" ; "for" ]
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@@ stop)
begin fun () (_, contract) cctxt ->
Client_proto_contracts.get_manager
cctxt.rpc_config cctxt.config.block contract >>=? fun manager ->
Public_key_hash.rev_find cctxt manager >>=? fun mn ->
Public_key_hash.to_source cctxt manager >>=? fun m ->
cctxt.message "%s (%s)" m
(match mn with None -> "unknown" | Some n -> "known as " ^ n) >>= fun () ->
return ()
end ;
command ~group ~desc: "get the delegate of a contract"
no_options
(prefixes [ "get" ; "delegate" ; "for" ]
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@@ stop)
begin fun () (_, contract) cctxt ->
Client_proto_contracts.get_delegate
cctxt.rpc_config cctxt.config.block contract >>=? fun delegate ->
Public_key_hash.rev_find cctxt delegate >>=? fun mn ->
Public_key_hash.to_source cctxt delegate >>=? fun m ->
cctxt.message "%s (%s)" m
(match mn with None -> "unknown" | Some n -> "known as " ^ n) >>= fun () ->
return ()
end ;
command ~group ~desc: "set the delegate of a contract"
(args2 fee_arg force_switch)
(prefixes [ "set" ; "delegate" ; "for" ]
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@@ prefix "to"
@@ Public_key_hash.alias_param
~name: "mgr" ~desc: "New delegate of the contract"
@@ stop)
begin fun (fee, force) (_, contract) (_, delegate) cctxt ->
get_manager cctxt contract >>=? fun (_src_name, _src_pkh, src_pk, src_sk) ->
delegate_contract
cctxt.rpc_config cctxt.config.block ~source:contract
~src_pk ~manager_sk:src_sk ~fee (Some delegate)
>>=? fun oph ->
message_injection cctxt ~force:force oph >>= fun () ->
return ()
end ;
command ~group ~desc: "open a new account"
(args4 fee_arg delegate_arg delegatable_switch force_switch)
(prefixes [ "originate" ; "account" ]
@@ RawContractAlias.fresh_alias_param
~name: "new" ~desc: "name of the new contract"
@@ prefix "for"
@@ Public_key_hash.alias_param
~name: "mgr" ~desc: "manager of the new contract"
@@ prefix "transferring"
@@ tez_param
~name: "qty" ~desc: "amount taken from source"
@@ prefix "from"
@@ ContractAlias.alias_param
~name:"src" ~desc: "name of the source contract"
@@ stop)
begin fun (fee, delegate, delegatable, force)
new_contract (_, manager) balance (_, source) cctxt ->
RawContractAlias.of_fresh cctxt force new_contract >>=? fun new_contract ->
check_contract cctxt new_contract >>=? fun () ->
get_delegate_pkh cctxt delegate >>=? fun delegate ->
get_manager cctxt source >>=? fun (_src_name, _src_pkh, src_pk, src_sk) ->
originate_account cctxt.rpc_config cctxt.config.block ~force:force
~source ~src_pk ~src_sk ~manager_pkh:manager ~balance ~fee
~delegatable:delegatable ~spendable:true ?delegate:delegate
() >>=? fun (oph, contract) ->
message_injection cctxt
~force:force ~contracts:[contract] oph >>= fun () ->
RawContractAlias.add ~force cctxt new_contract contract >>=? fun () ->
message_added_contract cctxt new_contract >>= fun () ->
return ()
end ;
command ~group ~desc: "Launch a smart contract on the blockchain"
(args7
fee_arg delegate_arg force_switch
delegatable_switch spendable_switch init_arg no_print_source_flag)
(prefixes [ "originate" ; "contract" ]
@@ RawContractAlias.fresh_alias_param
~name: "new" ~desc: "name of the new contract"
@@ prefix "for"
@@ Public_key_hash.alias_param
~name: "mgr" ~desc: "manager of the new contract"
@@ prefix "transferring"
@@ tez_param
~name: "qty" ~desc: "amount taken from source"
@@ prefix "from"
@@ ContractAlias.alias_param
~name:"src" ~desc: "name of the source contract"
@@ prefix "running"
@@ Program.source_param
~name:"prg" ~desc: "script of the account\n\
combine with -init if the storage type is not unit"
@@ stop)
begin fun (fee, delegate, force, delegatable, spendable, init, no_print_source)
new_contract (_, manager) balance (_, source) program cctxt ->
RawContractAlias.of_fresh cctxt force new_contract >>=? fun new_contract ->
check_contract cctxt new_contract >>=? fun () ->
Lwt.return (Micheline_parser.no_parsing_error program) >>=? fun { expanded = code } ->
get_delegate_pkh cctxt delegate >>=? fun delegate ->
get_manager cctxt source >>=? fun (_src_name, _src_pkh, src_pk, src_sk) ->
originate_contract cctxt.rpc_config cctxt.config.block ~force:force
~source ~src_pk ~src_sk ~manager_pkh:manager ~balance ~fee
~delegatable:delegatable ?delegatePubKey:delegate ~code
~init
~spendable:spendable
() >>=function
| Error errs ->
cctxt.warning "%a"
(Michelson_v1_error_reporter.report_errors
~details:(not no_print_source)
~show_source: (not no_print_source)
?parsed:None) errs >>= fun () ->
cctxt.error "origination simulation failed"
| Ok (oph, contract) ->
message_injection cctxt
~force:force ~contracts:[contract] oph >>= fun () ->
RawContractAlias.add ~force cctxt new_contract contract >>=? fun () ->
message_added_contract cctxt new_contract >>= fun () ->
return ()
end ;
command ~group ~desc: "open a new (free) account"
(args1 force_switch)
(prefixes [ "originate" ; "free" ; "account" ]
@@ RawContractAlias.fresh_alias_param
~name: "new" ~desc: "name of the new contract"
@@ prefix "for"
@@ Public_key_hash.alias_param
~name: "mgr" ~desc: "manager of the new contract"
@@ stop)
begin fun force new_contract (_, manager) cctxt ->
RawContractAlias.of_fresh cctxt force new_contract >>=? fun new_contract ->
check_contract cctxt new_contract >>=? fun () ->
faucet cctxt.rpc_config cctxt.config.block
~force:force ~manager_pkh:manager () >>=? fun (oph, contract) ->
message_injection cctxt
~force:force ~contracts:[contract] oph >>= fun () ->
RawContractAlias.add ~force cctxt new_contract contract >>=? fun () ->
message_added_contract cctxt new_contract >>= fun () ->
return ()
end;
command ~group ~desc: "transfer tokens"
(args4 fee_arg arg_arg force_switch no_print_source_flag)
(prefixes [ "transfer" ]
@@ tez_param
~name: "qty" ~desc: "amount taken from source"
@@ prefix "from"
@@ ContractAlias.alias_param
~name: "src" ~desc: "name of the source contract"
@@ prefix "to"
@@ ContractAlias.destination_param
~name: "dst" ~desc: "name/literal of the destination contract"
@@ stop)
begin fun (fee, arg, force, no_print_source) amount (_, source) (_, destination) cctxt ->
get_manager cctxt source >>=? fun (_src_name, _src_pkh, src_pk, src_sk) ->
transfer cctxt.rpc_config cctxt.config.block ~force:force
~source ~src_pk ~src_sk ~destination
~arg ~amount ~fee () >>= function
| Error errs ->
cctxt.warning "%a"
(Michelson_v1_error_reporter.report_errors
~details: false
~show_source:(not no_print_source)
?parsed:None) errs >>= fun () ->
cctxt.error "transfer simulation failed"
| Ok (oph, contracts) ->
message_injection cctxt ~force:force ~contracts oph >>= fun () ->
return ()
end;
command ~desc: "Activate a protocol"
(args1 force_switch)
(prefixes [ "activate" ; "protocol" ]
@@ Protocol_hash.param ~name:"version"
~desc:"Protocol version (b58check)"
@@ prefixes [ "with" ; "key" ]
@@ Ed25519.Secret_key.param
~name:"password" ~desc:"Dictator's key"
@@ stop)
begin fun force hash seckey cctxt ->
dictate cctxt.rpc_config cctxt.config.block
(Activate hash) seckey >>=? fun oph ->
message_injection cctxt ~force:force oph >>= fun () ->
return ()
end ;
command ~desc: "Fork a test protocol"
(args1 force_switch)
(prefixes [ "fork" ; "test" ; "protocol" ]
@@ Protocol_hash.param ~name:"version"
~desc:"Protocol version (b58check)"
@@ prefixes [ "with" ; "key" ]
@@ Ed25519.Secret_key.param
~name:"password" ~desc:"Dictator's key"
@@ stop)
begin fun force hash seckey cctxt ->
dictate cctxt.rpc_config cctxt.config.block
(Activate_testnet hash) seckey >>=? fun oph ->
message_injection cctxt ~force:force oph >>= fun () ->
return ()
end ;
]
let originate_contract
~fee
~delegate
?(force=false)
?(delegatable=true)
?(spendable=false)
~initial_storage
~manager
~balance
~source
~src_pk
~src_sk
~code
(cctxt : Client_commands.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 } ->
let block = cctxt#block in
Client_proto_rpcs.Context.Contract.counter
cctxt block source >>=? fun pcounter ->
let counter = Int32.succ pcounter in
get_branch cctxt block None >>=? fun (_net_id, branch) ->
Client_proto_rpcs.Helpers.Forge.Manager.origination cctxt block
~branch ~source ~sourcePubKey:src_pk ~managerPubKey:manager
~counter ~balance ~spendable:spendable
~delegatable ?delegatePubKey:delegate
~script:{ code ; storage } ~fee () >>=? fun bytes ->
let signature = Ed25519.sign src_sk bytes in
originate cctxt ~force ~block ~signature bytes

152
lib_embedded_client_alpha/client_proto_context.mli
View File

@ -9,70 +9,122 @@
open Environment
val list_contract_labels :
Client_commands.full_context ->
Client_proto_rpcs.block ->
(string * string * string) list tzresult Lwt.t
val get_storage :
#Client_rpcs.rpc_sig ->
Client_proto_rpcs.block ->
Contract.t ->
Script.expr option tzresult Lwt.t
val get_manager :
Client_commands.full_context ->
Client_proto_rpcs.block ->
Contract.t ->
(string * public_key_hash * public_key * secret_key) tzresult Lwt.t
val get_balance:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
Client_proto_rpcs.block ->
Contract.t ->
Tez.t tzresult Lwt.t
val transfer:
Client_rpcs.config ->
val set_delegate :
#Client_rpcs.rpc_sig ->
Client_proto_rpcs.block ->
fee:Tez.tez ->
Contract.t ->
src_pk:public_key ->
manager_sk:secret_key ->
public_key_hash option ->
Operation_list_hash.elt tzresult Lwt.t
val operation_submitted_message :
#Client_commands.logger ->
?force:bool ->
Operation_hash.t ->
unit tzresult Lwt.t
val source_to_keys:
Client_commands.full_context ->
Client_proto_rpcs.block ->
Contract.t ->
(public_key * secret_key) tzresult Lwt.t
val originate_account :
?force:bool ->
?branch:int ->
source:Contract.t ->
src_pk:public_key ->
src_sk:Ed25519.Secret_key.t ->
manager_pkh:public_key_hash ->
?delegatable:bool ->
?delegate:public_key_hash ->
balance:Tez.tez ->
fee:Tez.tez ->
Client_rpcs.block ->
#Client_rpcs.rpc_sig ->
unit -> (Operation_list_hash.elt * Contract.t) tzresult Lwt.t
val save_contract :
force:bool ->
Client_commands.full_context ->
string ->
Contract.t ->
unit tzresult Lwt.t
val operation_submitted_message :
#Client_commands.logger ->
?force:bool ->
?contracts:Contract.t list ->
Operation_hash.t ->
unit tzresult Lwt.t
val originate_contract:
fee:Tez.t ->
delegate:public_key_hash option ->
?force:bool ->
?delegatable:bool ->
?spendable:bool ->
initial_storage:string ->
manager:public_key_hash ->
balance:Tez.t ->
source:Contract.t ->
src_pk:public_key ->
src_sk:Ed25519.Secret_key.t ->
code:Script.expr ->
Client_commands.full_context ->
(Operation_hash.t * Contract.t) tzresult Lwt.t
val faucet :
?force:bool ->
?branch:int ->
manager_pkh:public_key_hash ->
Client_rpcs.block ->
#Client_rpcs.rpc_sig ->
unit -> (Operation_list_hash.elt * Contract.t) tzresult Lwt.t
val transfer :
#Client_rpcs.rpc_sig ->
Client_proto_rpcs.block ->
?force:bool ->
?branch:int ->
source:Contract.t ->
src_pk:public_key ->
src_sk:secret_key ->
src_sk:Ed25519.Secret_key.t ->
destination:Contract.t ->
?arg:string ->
amount:Tez.t ->
fee:Tez.t ->
unit -> (Operation_hash.t * Contract.t list) tzresult Lwt.t
unit ->
(Operation_hash.t * Contract.t list) tzresult Lwt.t
val originate_account:
Client_rpcs.config ->
val dictate :
#Client_rpcs.rpc_sig ->
Client_proto_rpcs.block ->
?force:bool ->
?branch:int ->
source:Contract.t ->
src_pk:public_key ->
src_sk:secret_key ->
manager_pkh:public_key_hash ->
?delegatable:bool ->
?spendable:bool ->
?delegate:public_key_hash ->
balance:Tez.t ->
fee:Tez.t ->
unit -> (Operation_hash.t * Contract.t) tzresult Lwt.t
val originate_contract:
Client_rpcs.config ->
Client_proto_rpcs.block ->
?force:bool ->
?branch:int ->
source:Contract.t ->
src_pk:public_key ->
src_sk:secret_key ->
manager_pkh:public_key_hash ->
balance:Tez.t ->
?delegatable:bool ->
?delegatePubKey:public_key_hash ->
code:Script.expr ->
init:string ->
fee:Tez.t ->
spendable:bool ->
unit -> (Operation_hash.t * Contract.t) tzresult Lwt.t
val delegate_contract:
Client_rpcs.config ->
Client_proto_rpcs.block ->
?force:bool ->
?branch:int ->
source:Contract.t ->
?src_pk:public_key ->
manager_sk:secret_key ->
fee:Tez.t ->
public_key_hash option ->
dictator_operation ->
secret_key ->
Operation_hash.t tzresult Lwt.t
val commands: unit -> Client_commands.command list

275
lib_embedded_client_alpha/client_proto_context_commands.ml Normal file
View File

@ -0,0 +1,275 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
open Tezos_micheline
open Client_proto_context
open Client_proto_contracts
open Client_proto_programs
open Client_keys
open Client_proto_args
let get_pkh cctxt = function
| None -> return None
| Some x -> Public_key_hash.find_opt cctxt x
let report_michelson_errors ?(no_print_source=false) ~msg (cctxt : #Client_commands.logger) = function
| Error errs ->
cctxt#warning "%a"
(Michelson_v1_error_reporter.report_errors
~details:(not no_print_source)
~show_source: (not no_print_source)
?parsed:None) errs >>= fun () ->
cctxt#error "%s" msg >>= fun () ->
Lwt.return None
| Ok data ->
Lwt.return (Some data)
let group =
{ Cli_entries.name = "context" ;
title = "Block contextual commands (see option -block)" }
let commands () =
let open Cli_entries in
let open Client_commands in
[
command ~group ~desc: "access the timestamp of the block"
no_options
(fixed [ "get" ; "timestamp" ])
begin fun () (cctxt : Client_commands.full_context) ->
Client_node_rpcs.Blocks.timestamp
cctxt cctxt#block >>=? fun v ->
cctxt#message "%s" (Time.to_notation v) >>= fun () ->
return ()
end ;
command ~group ~desc: "lists all non empty contracts of the block"
no_options
(fixed [ "list" ; "contracts" ])
begin fun () (cctxt : Client_commands.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)
contracts >>= fun () ->
return ()
end ;
command ~group ~desc: "get the balance of a contract"
no_options
(prefixes [ "get" ; "balance" ; "for" ]
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@@ stop)
begin fun () (_, contract) (cctxt : Client_commands.full_context) ->
get_balance cctxt cctxt#block contract >>=? fun amount ->
cctxt#answer "%a %s" Tez.pp amount Client_proto_args.tez_sym >>= fun () ->
return ()
end ;
command ~group ~desc: "get the storage of a contract"
no_options
(prefixes [ "get" ; "storage" ; "for" ]
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@@ stop)
begin fun () (_, contract) (cctxt : Client_commands.full_context) ->
get_storage cctxt cctxt#block contract >>=? function
| None ->
cctxt#error "This is not a smart contract."
| Some storage ->
cctxt#answer "%a" Michelson_v1_printer.print_expr_unwrapped storage >>= fun () ->
return ()
end ;
command ~group ~desc: "get the manager of a contract"
no_options
(prefixes [ "get" ; "manager" ; "for" ]
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@@ stop)
begin fun () (_, contract) (cctxt : Client_commands.full_context) ->
Client_proto_contracts.get_manager
cctxt cctxt#block contract >>=? fun manager ->
Public_key_hash.rev_find cctxt manager >>=? fun mn ->
Public_key_hash.to_source cctxt manager >>=? fun m ->
cctxt#message "%s (%s)" m
(match mn with None -> "unknown" | Some n -> "known as " ^ n) >>= fun () ->
return ()
end ;
command ~group ~desc: "get the delegate of a contract"
no_options
(prefixes [ "get" ; "delegate" ; "for" ]
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@@ stop)
begin fun () (_, contract) (cctxt : Client_commands.full_context) ->
Client_proto_contracts.get_delegate
cctxt cctxt#block contract >>=? fun delegate ->
Public_key_hash.rev_find cctxt delegate >>=? fun mn ->
Public_key_hash.to_source cctxt delegate >>=? fun m ->
cctxt#message "%s (%s)" m
(match mn with None -> "unknown" | Some n -> "known as " ^ n) >>= fun () ->
return ()
end ;
command ~group ~desc: "set the delegate of a contract"
(args2 fee_arg force_switch)
(prefixes [ "set" ; "delegate" ; "for" ]
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@@ prefix "to"
@@ Public_key_hash.alias_param
~name: "mgr" ~desc: "New delegate of the contract"
@@ stop)
begin fun (fee, force) (_, contract) (_, delegate) cctxt ->
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 ~force oph
end ;
command ~group ~desc:"open a new account"
(args4 fee_arg delegate_arg delegatable_switch force_switch)
(prefixes [ "originate" ; "account" ]
@@ RawContractAlias.fresh_alias_param
~name: "new" ~desc: "name of the new contract"
@@ prefix "for"
@@ Public_key_hash.alias_param
~name: "mgr" ~desc: "manager of the new contract"
@@ prefix "transferring"
@@ tez_param
~name: "qty" ~desc: "amount taken from source"
@@ prefix "from"
@@ ContractAlias.alias_param
~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) ->
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 ->
originate_account
~fee
?delegate
~delegatable
~force
~manager_pkh
~balance
~source
~src_pk
~src_sk
cctxt#block
cctxt
() >>=? fun (oph, contract) ->
save_contract ~force cctxt alias_name contract >>=? fun () ->
operation_submitted_message ~force ~contracts:[ contract ] cctxt oph
end ;
command ~group ~desc: "Launch a smart contract on the blockchain"
(args7
fee_arg delegate_arg force_switch
delegatable_switch spendable_switch init_arg no_print_source_flag)
(prefixes [ "originate" ; "contract" ]
@@ RawContractAlias.fresh_alias_param
~name: "new" ~desc: "name of the new contract"
@@ prefix "for"
@@ Public_key_hash.alias_param
~name: "mgr" ~desc: "manager of the new contract"
@@ prefix "transferring"
@@ tez_param
~name: "qty" ~desc: "amount taken from source"
@@ prefix "from"
@@ ContractAlias.alias_param
~name:"src" ~desc: "name of the source contract"
@@ prefix "running"
@@ Program.source_param
~name:"prg" ~desc: "script of the account\n\
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) ->
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) ->
get_pkh cctxt delegate >>=? fun delegate ->
originate_contract ~fee ~delegate ~force ~delegatable ~spendable ~initial_storage
~manager ~balance ~source ~src_pk ~src_sk ~code cctxt >>= fun errors ->
report_michelson_errors ~no_print_source ~msg:"origination simulation failed" cctxt errors >>= function
| None -> return ()
| Some (oph, contract) ->
save_contract ~force cctxt alias_name contract >>=? fun () ->
operation_submitted_message cctxt
~force ~contracts:[contract] oph
end ;
command ~group ~desc: "open a new (free) account"
(args1 force_switch)
(prefixes [ "originate" ; "free" ; "account" ]
@@ RawContractAlias.fresh_alias_param
~name: "new" ~desc: "name of the new contract"
@@ prefix "for"
@@ Public_key_hash.alias_param
~name: "mgr" ~desc: "manager of the new contract"
@@ stop)
begin fun force alias_name (_, manager_pkh) cctxt ->
RawContractAlias.of_fresh cctxt force alias_name >>=? fun alias_name ->
faucet ~force ~manager_pkh cctxt#block cctxt () >>=? fun (oph, contract) ->
operation_submitted_message cctxt
~force ~contracts:[contract] oph >>=? fun () ->
save_contract ~force cctxt alias_name contract
end;
command ~group ~desc: "transfer tokens"
(args4 fee_arg arg_arg force_switch no_print_source_flag)
(prefixes [ "transfer" ]
@@ tez_param
~name: "qty" ~desc: "amount taken from source"
@@ prefix "from"
@@ ContractAlias.alias_param
~name: "src" ~desc: "name of the source contract"
@@ prefix "to"
@@ ContractAlias.destination_param
~name: "dst" ~desc: "name/literal of the destination contract"
@@ stop)
begin fun (fee, arg, force, no_print_source) amount (_, source) (_, destination) cctxt ->
source_to_keys cctxt cctxt#block source >>=? fun (src_pk, src_sk) ->
transfer ~force cctxt ~fee cctxt#block
~source ~src_pk ~src_sk ~destination ~arg ~amount () >>=
report_michelson_errors ~no_print_source ~msg:"transfer simulation failed" cctxt >>= function
| None -> return ()
| Some (oph, contracts) ->
operation_submitted_message cctxt ~force ~contracts oph
end;
command ~desc: "Activate a protocol"
(args1 force_switch)
(prefixes [ "activate" ; "protocol" ]
@@ Protocol_hash.param ~name:"version"
~desc:"Protocol version (b58check)"
@@ prefixes [ "with" ; "key" ]
@@ Environment.Ed25519.Secret_key.param
~name:"password" ~desc:"Dictator's key"
@@ stop)
begin fun force hash seckey cctxt ->
dictate cctxt cctxt#block
(Activate hash) seckey >>=? fun oph ->
operation_submitted_message cctxt ~force:force oph
end ;
command ~desc: "Fork a test protocol"
(args1 force_switch)
(prefixes [ "fork" ; "test" ; "protocol" ]
@@ Protocol_hash.param ~name:"version"
~desc:"Protocol version (b58check)"
@@ prefixes [ "with" ; "key" ]
@@ Environment.Ed25519.Secret_key.param
~name:"password" ~desc:"Dictator's key"
@@ stop)
begin fun force hash seckey cctxt ->
dictate cctxt cctxt#block
(Activate_testnet hash) seckey >>=? fun oph ->
operation_submitted_message cctxt ~force:force oph
end ;
]

95
lib_embedded_client_alpha/client_proto_contracts.ml
View File

@ -112,7 +112,6 @@ module Contract_tags = Client_tags.Tags (struct
end)
let list_contracts cctxt =
(* List contracts *)
RawContractAlias.load cctxt >>=? fun raw_contracts ->
Lwt_list.map_s
(fun (n, v) -> Lwt.return ("", n, v))
@ -166,97 +165,3 @@ let check_public_key cctxt block ?src_pk src_pk_hash =
return (Some key)
end
| Ok _ -> return None
let group =
{ Cli_entries.name = "contracts" ;
title = "Commands for managing the record of known contracts" }
let commands () =
let open Cli_entries in
let open Client_commands in
[
command ~group ~desc: "add a contract to the wallet"
(args1 Client_commands.force_switch)
(prefixes [ "remember" ; "contract" ]
@@ RawContractAlias.fresh_alias_param
@@ RawContractAlias.source_param
@@ stop)
(fun force name hash cctxt ->
RawContractAlias.of_fresh cctxt force name >>=? fun name ->
RawContractAlias.add ~force cctxt name hash) ;
command ~group ~desc: "remove a contract from the wallet"
no_options
(prefixes [ "forget" ; "contract" ]
@@ RawContractAlias.alias_param
@@ stop)
(fun () (name, _) cctxt -> RawContractAlias.del cctxt name) ;
command ~group ~desc: "lists all known contracts"
no_options
(fixed [ "list" ; "known" ; "contracts" ])
(fun () cctxt ->
list_contracts cctxt >>=? fun contracts ->
iter_s
(fun (prefix, alias, contract) ->
cctxt.message "%s%s: %s" prefix alias
(Contract.to_b58check contract) >>= fun () ->
return ())
contracts) ;
command ~group ~desc: "forget all known contracts"
(args1 Client_commands.force_switch)
(fixed [ "forget" ; "all" ; "contracts" ])
(fun force cctxt ->
fail_unless
force
(failure "this can only used with option -force true") >>=? fun () ->
RawContractAlias.save cctxt []) ;
command ~group ~desc: "display a contract from the wallet"
no_options
(prefixes [ "show" ; "known" ; "contract" ]
@@ RawContractAlias.alias_param
@@ stop)
(fun () (_, contract) cctxt ->
cctxt.message "%a\n%!" Contract.pp contract >>= fun () ->
return ()) ;
command ~group ~desc: "tag a contract in the wallet"
no_options
(prefixes [ "tag" ; "contract" ]
@@ RawContractAlias.alias_param
@@ prefixes [ "with" ]
@@ Contract_tags.tag_param
@@ stop)
(fun () (alias, _contract) new_tags cctxt ->
Contract_tags.find_opt cctxt alias >>=? fun tags ->
let new_tags =
match tags with
| None -> new_tags
| Some tags -> List.merge2 tags new_tags in
Contract_tags.update cctxt alias new_tags) ;
command ~group ~desc: "remove tag(s) from a contract in the wallet"
no_options
(prefixes [ "untag" ; "contract" ]
@@ RawContractAlias.alias_param
@@ prefixes [ "with" ]
@@ Contract_tags.tag_param
@@ stop)
(fun () (alias, _contract) new_tags cctxt ->
Contract_tags.find_opt cctxt alias >>=? fun tags ->
let new_tags =
match tags with
| None -> []
| Some tags ->
List.merge_filter2
~f:(fun x1 x2 -> match x1, x2 with
| None, None -> assert false
| None, Some _ -> None
| Some t1, Some t2 when t1 = t2 -> None
| Some t1, _ -> Some t1) tags new_tags in
Contract_tags.update cctxt alias new_tags) ;
]

30
lib_embedded_client_alpha/client_proto_contracts.mli
View File

@ -12,48 +12,50 @@ module RawContractAlias :
module ContractAlias : sig
val get_contract:
Client_commands.context ->
#Client_commands.wallet ->
string -> (string * Contract.t) tzresult Lwt.t
val alias_param:
?name:string ->
?desc:string ->
('a, Client_commands.context, 'ret) Cli_entries.params ->
(Lwt_io.file_name * Contract.t -> 'a, Client_commands.context, 'ret) Cli_entries.params
('a, (#Client_commands.wallet as 'wallet), 'ret) Cli_entries.params ->
(Lwt_io.file_name * Contract.t -> 'a, 'wallet, 'ret) Cli_entries.params
val destination_param:
?name:string ->
?desc:string ->
('a, Client_commands.context, 'ret) Cli_entries.params ->
(Lwt_io.file_name * Contract.t -> 'a, Client_commands.context, 'ret) Cli_entries.params
('a, (#Client_commands.wallet as 'wallet), 'ret) Cli_entries.params ->
(Lwt_io.file_name * Contract.t -> 'a, 'wallet, 'ret) Cli_entries.params
val rev_find:
Client_commands.context ->
#Client_commands.wallet ->
Contract.t -> string option tzresult Lwt.t
val name:
Client_commands.context ->
#Client_commands.wallet ->
Contract.t -> string tzresult Lwt.t
val autocomplete: Client_commands.context -> string list tzresult Lwt.t
val autocomplete: #Client_commands.wallet -> string list tzresult Lwt.t
end
val list_contracts:
Client_commands.context ->
(string * string * Contract.t) list tzresult Lwt.t
#Client_commands.wallet ->
(string * string * RawContractAlias.t) list tzresult Lwt.t
val get_manager:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
Client_proto_rpcs.block ->
Contract.t ->
public_key_hash tzresult Lwt.t
val get_delegate:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
Client_proto_rpcs.block ->
Contract.t ->
public_key_hash tzresult Lwt.t
val check_public_key :
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
Client_proto_rpcs.block ->
?src_pk:public_key ->
public_key_hash ->
public_key option tzresult Lwt.t
val commands: unit -> Client_commands.command list
module Contract_tags : module type of Client_tags.Tags (struct
let name = "contract"
end)

94
lib_embedded_client_alpha/client_proto_contracts_commands.ml Normal file
View File

@ -0,0 +1,94 @@
open Client_proto_contracts
let group =
{ Cli_entries.name = "contracts" ;
title = "Commands for managing the record of known contracts" }
let commands () =
let open Cli_entries in
[
command ~group ~desc: "add a contract to the wallet"
(args1 Client_commands.force_switch)
(prefixes [ "remember" ; "contract" ]
@@ RawContractAlias.fresh_alias_param
@@ RawContractAlias.source_param
@@ stop)
(fun force name hash cctxt ->
RawContractAlias.of_fresh cctxt force name >>=? fun name ->
RawContractAlias.add ~force cctxt name hash) ;
command ~group ~desc: "remove a contract from the wallet"
no_options
(prefixes [ "forget" ; "contract" ]
@@ RawContractAlias.alias_param
@@ stop)
(fun () (name, _) cctxt ->
RawContractAlias.del cctxt name) ;
command ~group ~desc: "lists all known contracts"
no_options
(fixed [ "list" ; "known" ; "contracts" ])
(fun () (cctxt : Client_commands.full_context) ->
list_contracts cctxt >>=? fun contracts ->
iter_s
(fun (prefix, alias, contract) ->
cctxt#message "%s%s: %s" prefix alias
(Contract.to_b58check contract) >>= return)
contracts) ;
command ~group ~desc: "forget all known contracts"
(args1 Client_commands.force_switch)
(fixed [ "forget" ; "all" ; "contracts" ])
(fun force cctxt ->
fail_unless
force
(failure "this can only used with option -force") >>=? fun () ->
RawContractAlias.set cctxt []) ;
command ~group ~desc: "display a contract from the wallet"
no_options
(prefixes [ "show" ; "known" ; "contract" ]
@@ RawContractAlias.alias_param
@@ stop)
(fun () (_, contract) (cctxt : Client_commands.full_context) ->
cctxt#message "%a\n%!" Contract.pp contract >>= fun () ->
return ()) ;
command ~group ~desc: "tag a contract in the wallet"
no_options
(prefixes [ "tag" ; "contract" ]
@@ RawContractAlias.alias_param
@@ prefixes [ "with" ]
@@ Contract_tags.tag_param
@@ stop)
(fun () (alias, _contract) new_tags cctxt ->
Contract_tags.find_opt cctxt alias >>=? fun tags ->
let new_tags =
match tags with
| None -> new_tags
| Some tags -> List.merge2 tags new_tags in
Contract_tags.update cctxt alias new_tags) ;
command ~group ~desc: "remove tag(s) from a contract in the wallet"
no_options
(prefixes [ "untag" ; "contract" ]
@@ RawContractAlias.alias_param
@@ prefixes [ "with" ]
@@ Contract_tags.tag_param
@@ stop)
(fun () (alias, _contract) new_tags cctxt ->
Contract_tags.find_opt cctxt alias >>=? fun tags ->
let new_tags =
match tags with
| None -> []
| Some tags ->
List.merge_filter2
~f:(fun x1 x2 -> match x1, x2 with
| None, None -> assert false
| None, Some _ -> None
| Some t1, Some t2 when t1 = t2 -> None
| Some t1, _ -> Some t1) tags new_tags in
Contract_tags.update cctxt alias new_tags) ;
]

7
lib_embedded_client_alpha/client_proto_main.ml
View File

@ -13,6 +13,7 @@ let protocol =
let () =
Client_commands.register protocol @@
Client_proto_programs.commands () @
Client_proto_contracts.commands () @
Client_proto_context.commands ()
Client_proto_programs_commands.commands () @
Client_proto_contracts_commands.commands () @
Client_proto_context_commands.commands () @
Client_baking_main.commands ()

68
lib_embedded_client_alpha/client_proto_nonces.ml
View File

@ -18,65 +18,35 @@ let encoding : t Data_encoding.t =
(req "block" Block_hash.encoding)
(req "nonce" Nonce.encoding))
let filename cctxt =
Client_commands.(Filename.concat cctxt.config.base_dir "nonces")
let name = "nonces"
let load cctxt =
let filename = filename cctxt in
if not (Sys.file_exists filename) then
Lwt.return []
else
Data_encoding_ezjsonm.read_file filename >>= function
| Error _ ->
cctxt.Client_commands.error "couldn't to read the nonces file"
| Ok json ->
match Data_encoding.Json.destruct encoding json with
| exception _ -> (* TODO print_error *)
cctxt.Client_commands.error "didn't understand the nonces file"
| list ->
Lwt.return list
let load (wallet : #Client_commands.wallet) =
wallet#load ~default:[] name encoding
let check_dir dirname =
if not (Sys.file_exists dirname) then
Lwt_utils.create_dir dirname
else
Lwt.return ()
let save (wallet : #Client_commands.wallet) list =
wallet#write name list encoding
let save cctxt list =
Lwt.catch
(fun () ->
let dirname = Client_commands.(cctxt.config.base_dir) in
check_dir dirname >>= fun () ->
let filename = filename cctxt in
let json = Data_encoding.Json.construct encoding list in
Data_encoding_ezjsonm.write_file filename json >>= function
| Error _ -> failwith "Json.write_file"
| Ok () -> return ())
(fun exn ->
cctxt.Client_commands.error
"could not write the nonces file: %s." (Printexc.to_string exn))
let mem cctxt block_hash =
load cctxt >|= fun data ->
let mem (wallet : #Client_commands.wallet) block_hash =
load wallet >>|? fun data ->
List.mem_assoc block_hash data
let find cctxt block_hash =
load cctxt >|= fun data ->
let find wallet block_hash =
load wallet >>|? fun data ->
try Some (List.assoc block_hash data)
with Not_found -> None
let add cctxt block_hash nonce =
load cctxt >>= fun data ->
save cctxt ((block_hash, nonce) ::
List.remove_assoc block_hash data)
let add wallet block_hash nonce =
load wallet >>=? fun data ->
save wallet ((block_hash, nonce) ::
List.remove_assoc block_hash data)
let del cctxt block_hash =
load cctxt >>= fun data ->
save cctxt (List.remove_assoc block_hash data)
let del wallet block_hash =
load wallet >>=? fun data ->
save wallet (List.remove_assoc block_hash data)
let dels cctxt hashes =
load cctxt >>= fun data ->
save cctxt @@
let dels wallet hashes =
load wallet >>=? fun data ->
save wallet @@
List.fold_left
(fun data hash -> List.remove_assoc hash data)
data hashes

14
lib_embedded_client_alpha/client_proto_nonces.mli
View File

@ -8,17 +8,17 @@
(**************************************************************************)
val mem:
Client_commands.context ->
Block_hash.t -> bool Lwt.t
#Client_commands.wallet ->
Block_hash.t -> bool tzresult Lwt.t
val find:
Client_commands.context ->
Block_hash.t -> Nonce.t option Lwt.t
#Client_commands.wallet ->
Block_hash.t -> Nonce.t option tzresult Lwt.t
val add:
Client_commands.context ->
#Client_commands.wallet ->
Block_hash.t -> Nonce.t -> unit tzresult Lwt.t
val del:
Client_commands.context ->
#Client_commands.wallet ->
Block_hash.t -> unit tzresult Lwt.t
val dels:
Client_commands.context ->
#Client_commands.wallet ->
Block_hash.t list -> unit tzresult Lwt.t

330
lib_embedded_client_alpha/client_proto_programs.ml
View File

@ -8,7 +8,6 @@
(**************************************************************************)
open Tezos_micheline
open Client_proto_args
open Michelson_v1_printer
@ -25,239 +24,112 @@ module Program = Client_aliases.Alias (struct
let name = "program"
end)
let group =
{ Cli_entries.name = "programs" ;
title = "Commands for managing the record of known programs" }
let print_errors (cctxt : #Client_commands.logger) errs ~show_source ~parsed =
cctxt#warning "%a"
(Michelson_v1_error_reporter.report_errors
~details:false
~show_source
~parsed) errs >>= fun () ->
cctxt#error "error running program" >>= fun () ->
return ()
let data_parameter =
Cli_entries.parameter (fun _ data -> return (Michelson_v1_parser.parse_expression data))
let print_run_result (cctxt : #Client_commands.logger) ~show_source ~parsed = function
| Ok (storage, output) ->
cctxt#message "@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>output@,%a@]@]@."
print_expr storage
print_expr output >>= fun () ->
return ()
| Error errs ->
print_errors cctxt errs ~show_source ~parsed
let commands () =
let open Cli_entries in
let show_types_switch =
switch
~parameter:"-details"
~doc:"Show the types of each instruction" in
let emacs_mode_switch =
switch
~parameter:"-emacs"
~doc:"Output in michelson-mode.el compatible format" in
let trace_stack_switch =
switch
~parameter:"-trace-stack"
~doc:"Show the stack after each step" in
let amount_arg =
Client_proto_args.tez_arg
~parameter:"-amount"
~doc:"The amount of the transfer in \xEA\x9C\xA9."
~default:"0.05" in
[
let print_trace_result (cctxt : #Client_commands.logger) ~show_source ~parsed =
function
| Ok (storage, output, trace) ->
cctxt#message
"@[<v 0>@[<v 2>storage@,%a@]@,\
@[<v 2>output@,%a@]@,@[<v 2>trace@,%a@]@]@."
print_expr storage
print_expr output
(Format.pp_print_list
(fun ppf (loc, gas, stack) ->
Format.fprintf ppf
"- @[<v 0>location: %d (remaining gas: %d)@,\
[ @[<v 0>%a ]@]@]"
loc gas
(Format.pp_print_list print_expr)
stack))
trace >>= fun () ->
return ()
| Error errs ->
print_errors cctxt errs ~show_source ~parsed
command ~group ~desc: "lists all known programs"
no_options
(fixed [ "list" ; "known" ; "programs" ])
(fun () cctxt ->
Program.load cctxt >>=? fun list ->
Lwt_list.iter_s (fun (n, _) -> cctxt.message "%s" n) list >>= fun () ->
return ()) ;
let run
?(amount = Tez.default_fee)
~(program : Michelson_v1_parser.parsed)
~(storage : Michelson_v1_parser.parsed)
~(input : Michelson_v1_parser.parsed)
block
(cctxt : #Client_rpcs.rpc_sig) =
Client_proto_rpcs.Helpers.run_code cctxt
block program.expanded (storage.expanded, input.expanded, amount)
command ~group ~desc: "remember a program under some name"
(args1 Client_commands.force_switch)
(prefixes [ "remember" ; "program" ]
@@ Program.fresh_alias_param
@@ Program.source_param
@@ stop)
(fun force name program cctxt ->
Program.of_fresh cctxt force name >>=? fun name ->
Lwt.return (Micheline_parser.no_parsing_error program) >>=? fun program ->
Program.add ~force cctxt name (program, [])) ;
let trace
?(amount = Tez.default_fee)
~(program : Michelson_v1_parser.parsed)
~(storage : Michelson_v1_parser.parsed)
~(input : Michelson_v1_parser.parsed)
block
(cctxt : #Client_rpcs.rpc_sig) =
Client_proto_rpcs.Helpers.trace_code cctxt
block program.expanded (storage.expanded, input.expanded, amount)
command ~group ~desc: "forget a remembered program"
no_options
(prefixes [ "forget" ; "program" ]
@@ Program.alias_param
@@ stop)
(fun () (name, _) cctxt -> Program.del cctxt name) ;
let hash_and_sign (data : Michelson_v1_parser.parsed) key block cctxt =
Client_proto_rpcs.Helpers.hash_data cctxt block (data.expanded) >>=? fun hash ->
let signature = Ed25519.sign key (MBytes.of_string hash) in
return (hash,
signature |>
Data_encoding.Binary.to_bytes Ed25519.Signature.encoding |>
Hex_encode.hex_of_bytes)
command ~group ~desc: "display a program"
no_options
(prefixes [ "show" ; "known" ; "program" ]
@@ Program.alias_param
@@ stop)
(fun () (_, program) cctxt ->
Lwt.return (Micheline_parser.no_parsing_error program) >>=? fun program ->
cctxt.message "%s\n" program.source >>= fun () ->
return ()) ;
let typecheck_data
~(data : Michelson_v1_parser.parsed)
~(ty : Michelson_v1_parser.parsed)
block cctxt =
Client_proto_rpcs.Helpers.typecheck_data cctxt block (data.expanded, ty.expanded)
command ~group ~desc: "ask the node to run a program"
(args3 trace_stack_switch amount_arg no_print_source_flag)
(prefixes [ "run" ; "program" ]
@@ Program.source_param
@@ prefixes [ "on" ; "storage" ]
@@ Cli_entries.param ~name:"storage" ~desc:"the storage data"
data_parameter
@@ prefixes [ "and" ; "input" ]
@@ Cli_entries.param ~name:"storage" ~desc:"the input data"
data_parameter
@@ stop)
(fun (trace_stack, amount, no_print_source) program storage input cctxt ->
Lwt.return (Micheline_parser.no_parsing_error program) >>=? fun program ->
Lwt.return (Micheline_parser.no_parsing_error storage) >>=? fun storage ->
Lwt.return (Micheline_parser.no_parsing_error input) >>=? fun input ->
let print_errors errs =
cctxt.warning "%a"
(Michelson_v1_error_reporter.report_errors
~details:false
~show_source: (not no_print_source)
~parsed: program) errs >>= fun () ->
cctxt.error "error running program" >>= fun () ->
return () in
begin
if trace_stack then
Client_proto_rpcs.Helpers.trace_code cctxt.rpc_config
cctxt.config.block program.expanded
(storage.expanded, input.expanded, amount) >>=? fun (storage, output, trace) ->
cctxt.message
"@[<v 0>@[<v 2>storage@,%a@]@,\
@[<v 2>output@,%a@]@,@[<v 2>trace@,%a@]@]@."
print_expr storage
print_expr output
(Format.pp_print_list
(fun ppf (loc, gas, stack) ->
Format.fprintf ppf
"- @[<v 0>location: %d (remaining gas: %d)@,\
[ @[<v 0>%a ]@]@]"
loc gas
(Format.pp_print_list print_expr)
stack))
trace >>= fun () ->
return ()
else
Client_proto_rpcs.Helpers.run_code cctxt.rpc_config
cctxt.config.block program.expanded
(storage.expanded, input.expanded, amount) >>=? fun (storage, output) ->
cctxt.message "@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>output@,%a@]@]@."
print_expr storage
print_expr output >>= fun () ->
return ()
end >>= function
| Ok () -> return ()
| Error errs ->
print_errors errs);
let typecheck_program (program : Michelson_v1_parser.parsed) block cctxt =
Client_proto_rpcs.Helpers.typecheck_code cctxt block program.expanded
command ~group ~desc: "ask the node to typecheck a program"
(args3 show_types_switch emacs_mode_switch no_print_source_flag)
(prefixes [ "typecheck" ; "program" ]
@@ Program.source_param
@@ stop)
(fun (show_types, emacs_mode, no_print_source) (program, errors) cctxt ->
begin match errors with
| [] ->
Client_proto_rpcs.Helpers.typecheck_code
cctxt.rpc_config cctxt.config.block program.expanded
| errors -> Lwt.return (Error errors)
end >>= fun res ->
if emacs_mode then
let type_map, errs = match res with
| Ok type_map -> type_map, []
| Error (Environment.Ecoproto_error
(Script_ir_translator.Ill_typed_contract (_, type_map ) :: _)
:: _ as errs) ->
type_map, errs
| Error errs ->
[], errs in
cctxt.message
"(@[<v 0>(types . %a)@ (errors . %a)@])"
Michelson_v1_emacs.print_type_map (program, type_map)
Michelson_v1_emacs.report_errors (program, errs) >>= fun () ->
return ()
else
match res with
| Ok type_map ->
let program = inject_types type_map program in
cctxt.message "Well typed" >>= fun () ->
if show_types then
cctxt.message "%a" Micheline_printer.print_expr program >>= fun () ->
return ()
else return ()
| Error errs ->
cctxt.warning "%a"
(Michelson_v1_error_reporter.report_errors
~details: show_types
~show_source: (not no_print_source)
~parsed:program) errs >>= fun () ->
cctxt.error "ill-typed program") ;
command ~group ~desc: "ask the node to typecheck a data expression"
(args1 no_print_source_flag)
(prefixes [ "typecheck" ; "data" ]
@@ Cli_entries.param ~name:"data" ~desc:"the data to typecheck"
data_parameter
@@ prefixes [ "against" ; "type" ]
@@ Cli_entries.param ~name:"type" ~desc:"the expected type"
data_parameter
@@ stop)
(fun no_print_source data exp_ty cctxt ->
Lwt.return (Micheline_parser.no_parsing_error data) >>=? fun data ->
Lwt.return (Micheline_parser.no_parsing_error exp_ty) >>=? fun exp_ty ->
Client_proto_rpcs.Helpers.typecheck_data cctxt.Client_commands.rpc_config
cctxt.config.block (data.expanded, exp_ty.expanded) >>= function
| Ok () ->
cctxt.message "Well typed" >>= fun () ->
return ()
| Error errs ->
cctxt.warning "%a"
(Michelson_v1_error_reporter.report_errors
~details:false
~show_source:(not no_print_source)
?parsed:None) errs >>= fun () ->
cctxt.error "ill-typed data") ;
command ~group
~desc: "ask the node to compute the hash of a data expression \
using the same algorithm as script instruction H"
no_options
(prefixes [ "hash" ; "data" ]
@@ Cli_entries.param ~name:"data" ~desc:"the data to hash"
data_parameter
@@ stop)
(fun () data cctxt ->
Lwt.return (Micheline_parser.no_parsing_error data) >>=? fun data ->
Client_proto_rpcs.Helpers.hash_data cctxt.Client_commands.rpc_config
cctxt.config.block (data.expanded) >>= function
| Ok hash ->
cctxt.message "%S" hash >>= fun () ->
return ()
| Error errs ->
cctxt.warning "%a" pp_print_error errs >>= fun () ->
cctxt.error "ill-formed data") ;
command ~group
~desc: "ask the node to compute the hash of a data expression \
using the same algorithm as script instruction H, sign it using \
a given secret key, and display it using the format expected by \
script instruction CHECK_SIGNATURE"
no_options
(prefixes [ "hash" ; "and" ; "sign" ; "data" ]
@@ Cli_entries.param ~name:"data" ~desc:"the data to hash"
data_parameter
@@ prefixes [ "for" ]
@@ Client_keys.Secret_key.alias_param
@@ stop)
(fun () data (_, key) cctxt ->
Lwt.return (Micheline_parser.no_parsing_error data) >>=? fun data ->
Client_proto_rpcs.Helpers.hash_data cctxt.rpc_config
cctxt.config.block (data.expanded) >>= function
| Ok hash ->
let signature = Ed25519.sign key (MBytes.of_string hash) in
cctxt.message "Hash: %S@.Signature: %S"
hash
(signature |>
Data_encoding.Binary.to_bytes Ed25519.Signature.encoding |>
Hex_encode.hex_of_bytes) >>= fun () ->
return ()
| Error errs ->
cctxt.warning "%a" pp_print_error errs >>= fun () ->
cctxt.error "ill-formed data") ;
]
let print_typecheck_result
~emacs ~show_types ~print_source_on_error
program res (cctxt : #Client_commands.logger) =
if emacs then
let type_map, errs = match res with
| Ok type_map -> type_map, []
| Error (Environment.Ecoproto_error
(Script_ir_translator.Ill_typed_contract (_, type_map ) :: _)
:: _ as errs) ->
type_map, errs
| Error errs ->
[], errs in
cctxt#message
"(@[<v 0>(types . %a)@ (errors . %a)@])"
Michelson_v1_emacs.print_type_map (program, type_map)
Michelson_v1_emacs.report_errors (program, errs) >>= fun () ->
return ()
else
match res with
| Ok type_map ->
let program = Michelson_v1_printer.inject_types type_map program in
cctxt#message "Well typed" >>= fun () ->
if show_types then
cctxt#message "%a" Micheline_printer.print_expr program >>= fun () ->
return ()
else return ()
| Error errs ->
cctxt#warning "%a"
(Michelson_v1_error_reporter.report_errors
~details: show_types
~show_source:print_source_on_error
~parsed:program) errs >>= fun () ->
cctxt#error "ill-typed program"

62
lib_embedded_client_alpha/client_proto_programs.mli
View File

@ -12,4 +12,64 @@ open Tezos_micheline
module Program : Client_aliases.Alias
with type t = Michelson_v1_parser.parsed Micheline_parser.parsing_result
val commands: unit -> Client_commands.command list
val run :
?amount:Tez.t ->
program:Michelson_v1_parser.parsed ->
storage:Michelson_v1_parser.parsed ->
input:Michelson_v1_parser.parsed ->
Client_rpcs.block ->
#Client_rpcs.rpc_sig ->
(Script.expr * Script.expr) tzresult Lwt.t
val trace :
?amount:Tez.t ->
program:Michelson_v1_parser.parsed ->
storage:Michelson_v1_parser.parsed ->
input:Michelson_v1_parser.parsed ->
Client_rpcs.block ->
#Client_rpcs.rpc_sig ->
(Script.expr * Script.expr * (int * int * Script.expr list) list) tzresult Lwt.t
val print_trace_result :
#Client_commands.logger ->
show_source:bool ->
parsed:Michelson_v1_parser.parsed ->
(Script_repr.expr * Script_repr.expr *
(int * int * Script_repr.expr list) list)
tzresult -> unit tzresult Lwt.t
val print_run_result :
#Client_commands.logger ->
show_source:bool ->
parsed:Michelson_v1_parser.parsed ->
(Script.expr * Script.expr) tzresult ->
unit tzresult Lwt.t
val hash_and_sign :
Michelson_v1_parser.parsed ->
Ed25519.Secret_key.t ->
Client_proto_rpcs.block ->
#Client_rpcs.rpc_sig ->
(string * string) tzresult Lwt.t
val typecheck_data :
data:Michelson_v1_parser.parsed ->
ty:Michelson_v1_parser.parsed ->
Client_proto_rpcs.block ->
#Client_rpcs.rpc_sig ->
unit tzresult Lwt.t
val typecheck_program :
Michelson_v1_parser.parsed ->
Client_proto_rpcs.block ->
#Client_rpcs.rpc_sig ->
Script_ir_translator.type_map tzresult Lwt.t
val print_typecheck_result :
emacs:bool ->
show_types:bool ->
print_source_on_error:bool ->
Michelson_v1_parser.parsed ->
(Script_ir_translator.type_map, error list) result ->
#Client_commands.logger ->
unit tzresult Lwt.t

176
lib_embedded_client_alpha/client_proto_programs_commands.ml Normal file
View File

@ -0,0 +1,176 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
let group =
{ Cli_entries.name = "programs" ;
title = "Commands for managing the record of known programs" }
open Tezos_micheline
open Client_proto_programs
open Client_proto_args
let commands () =
let open Cli_entries in
let show_types_switch =
switch
~parameter:"-details"
~doc:"Show the types of each instruction" in
let emacs_mode_switch =
switch
~parameter:"-emacs"
~doc:"Output in michelson-mode.el compatible format" in
let trace_stack_switch =
switch
~parameter:"-trace-stack"
~doc:"Show the stack after each step" in
let amount_arg =
Client_proto_args.tez_arg
~parameter:"-amount"
~doc:"The amount of the transfer in \xEA\x9C\xA9."
~default:"0.05" in
let data_parameter =
Cli_entries.parameter (fun _ data ->
Lwt.return (Micheline_parser.no_parsing_error
@@ Michelson_v1_parser.parse_expression data)) in
[
command ~group ~desc: "lists all known programs"
no_options
(fixed [ "list" ; "known" ; "programs" ])
(fun () (cctxt : Client_commands.full_context) ->
Program.load cctxt >>=? fun list ->
Lwt_list.iter_s (fun (n, _) -> cctxt#message "%s" n) list >>= fun () ->
return ()) ;
command ~group ~desc: "remember a program under some name"
(args1 Client_commands.force_switch)
(prefixes [ "remember" ; "program" ]
@@ Program.fresh_alias_param
@@ Program.source_param
@@ stop)
(fun force name hash (cctxt : Client_commands.full_context) ->
Program.of_fresh cctxt force name >>=? fun name ->
Program.add ~force cctxt name hash) ;
command ~group ~desc: "forget a remembered program"
no_options
(prefixes [ "forget" ; "program" ]
@@ Program.alias_param
@@ stop)
(fun () (name, _) cctxt -> Program.del cctxt name) ;
command ~group ~desc: "display a program"
no_options
(prefixes [ "show" ; "known" ; "program" ]
@@ Program.alias_param
@@ stop)
(fun () (_, program) (cctxt : Client_commands.full_context) ->
Program.to_source cctxt program >>=? fun source ->
cctxt#message "%s\n" source >>= fun () ->
return ()) ;
command ~group ~desc: "ask the node to run a program"
(args3 trace_stack_switch amount_arg no_print_source_flag)
(prefixes [ "run" ; "program" ]
@@ Program.source_param
@@ prefixes [ "on" ; "storage" ]
@@ Cli_entries.param ~name:"storage" ~desc:"the storage data"
data_parameter
@@ prefixes [ "and" ; "input" ]
@@ Cli_entries.param ~name:"storage" ~desc:"the input data"
data_parameter
@@ stop)
(fun (trace_exec, amount, no_print_source) program storage input cctxt ->
Lwt.return @@ Micheline_parser.no_parsing_error program >>=? fun program ->
let show_source = not no_print_source in
(if trace_exec then
trace ~amount ~program ~storage ~input cctxt#block cctxt >>= fun res ->
print_trace_result cctxt ~show_source ~parsed:program res
else
run ~amount ~program ~storage ~input cctxt#block cctxt >>= fun res ->
print_run_result cctxt ~show_source ~parsed:program res)) ;
command ~group ~desc: "ask the node to typecheck a program"
(args3 show_types_switch emacs_mode_switch no_print_source_flag)
(prefixes [ "typecheck" ; "program" ]
@@ Program.source_param
@@ stop)
(fun (show_types, emacs_mode, no_print_source) program cctxt ->
Lwt.return @@ Micheline_parser.no_parsing_error program >>=? fun program ->
typecheck_program program cctxt#block cctxt >>= fun res ->
print_typecheck_result
~emacs:emacs_mode
~show_types
~print_source_on_error:(not no_print_source)
program
res
cctxt) ;
command ~group ~desc: "ask the node to typecheck a data expression"
(args1 no_print_source_flag)
(prefixes [ "typecheck" ; "data" ]
@@ Cli_entries.param ~name:"data" ~desc:"the data to typecheck"
data_parameter
@@ prefixes [ "against" ; "type" ]
@@ Cli_entries.param ~name:"type" ~desc:"the expected type"
data_parameter
@@ stop)
(fun no_print_source data ty cctxt ->
Client_proto_programs.typecheck_data ~data ~ty cctxt#block cctxt >>= function
| Ok () ->
cctxt#message "Well typed" >>= fun () ->
return ()
| Error errs ->
cctxt#warning "%a"
(Michelson_v1_error_reporter.report_errors
~details:false
~show_source:(not no_print_source)
?parsed:None) errs >>= fun () ->
cctxt#error "ill-typed data") ;
command ~group
~desc: "ask the node to compute the hash of a data expression \
using the same algorithm as script instruction H"
no_options
(prefixes [ "hash" ; "data" ]
@@ Cli_entries.param ~name:"data" ~desc:"the data to hash"
data_parameter
@@ stop)
(fun () data cctxt ->
Client_proto_rpcs.Helpers.hash_data cctxt
cctxt#block (data.expanded) >>= function
| Ok hash ->
cctxt#message "%S" hash >>= fun () ->
return ()
| Error errs ->
cctxt#warning "%a" pp_print_error errs >>= fun () ->
cctxt#error "ill-formed data") ;
command ~group
~desc: "ask the node to compute the hash of a data expression \
using the same algorithm as script instruction H, sign it using \
a given secret key, and display it using the format expected by \
script instruction CHECK_SIGNATURE"
no_options
(prefixes [ "hash" ; "and" ; "sign" ; "data" ]
@@ Cli_entries.param ~name:"data" ~desc:"the data to hash"
data_parameter
@@ prefixes [ "for" ]
@@ Client_keys.Secret_key.alias_param
@@ stop)
(fun () data (_, key) cctxt ->
Client_proto_programs.hash_and_sign data key cctxt#block cctxt >>= begin function
|Ok (hash, signature) ->
cctxt#message "Hash: %S@.Signature: %S" hash signature
| Error errs ->
cctxt#warning "%a" pp_print_error errs >>= fun () ->
cctxt#error "ill-formed data"
end >>= return) ;
]

10
lib_embedded_client_alpha/client_proto_programs_commands.mli Normal file
View File

@ -0,0 +1,10 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
val commands: unit -> Client_commands.command list

4
lib_embedded_client_alpha/client_proto_rpcs.ml
View File

@ -10,11 +10,11 @@
let string_of_errors exns =
Format.asprintf " @[<v>%a@]" pp_print_error exns
let handle_error cctxt = function
let handle_error (cctxt : #Client_commands.logger) = function
| Ok res -> Lwt.return res
| Error exns ->
pp_print_error Format.err_formatter exns ;
cctxt.Client_commands.error "%s" "cannot continue"
cctxt#error "%s" "cannot continue"
let call_service0 cctxt s block =
Client_rpcs.call_service0 cctxt

116
lib_embedded_client_alpha/client_proto_rpcs.mli
View File

@ -8,94 +8,94 @@
(**************************************************************************)
val string_of_errors: error list -> string
val handle_error: Client_commands.context -> 'a tzresult -> 'a Lwt.t
val handle_error: Client_commands.full_context -> 'a tzresult -> 'a Lwt.t
type block = Node_rpc_services.Blocks.block
val header:
Client_rpcs.config -> block -> Block_header.t tzresult Lwt.t
Client_rpcs.rpc -> block -> Block_header.t tzresult Lwt.t
module Header : sig
val priority:
Client_rpcs.config -> block -> int tzresult Lwt.t
Client_rpcs.rpc -> block -> int tzresult Lwt.t
val seed_nonce_hash:
Client_rpcs.config -> block -> Nonce_hash.t tzresult Lwt.t
Client_rpcs.rpc -> block -> Nonce_hash.t tzresult Lwt.t
end
module Constants : sig
val errors:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block -> Json_schema.schema tzresult Lwt.t
val cycle_length:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block -> int32 tzresult Lwt.t
val voting_period_length:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block -> int32 tzresult Lwt.t
val time_before_reward:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block -> Period.t tzresult Lwt.t
val slot_durations:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block -> (Period.t list) tzresult Lwt.t
val first_free_baking_slot:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block -> int tzresult Lwt.t
val max_signing_slot:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block -> int tzresult Lwt.t
val instructions_per_transaction:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block -> int tzresult Lwt.t
val stamp_threshold:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block -> int64 tzresult Lwt.t
end
module Context : sig
val level:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block -> Level.t tzresult Lwt.t
(** [level cctxt blk] returns the (protocol view of the) level of
[blk]. *)
val next_level:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block -> Level.t tzresult Lwt.t
(** [next_level cctxt blk] returns the (protocol view of the) level
of the successor of [blk]. *)
val voting_period_kind:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block -> Voting_period.kind tzresult Lwt.t
(** [voting_period_kind cctxt blk] returns the voting period kind
of [blk]. *)
module Nonce : sig
val hash:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block -> Nonce_hash.t tzresult Lwt.t
type nonce_info =
| Revealed of Nonce.t
| Missing of Nonce_hash.t
| Forgotten
val get:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block -> Raw_level.t -> nonce_info tzresult Lwt.t
end
module Key : sig
val get :
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block ->
public_key_hash -> (public_key_hash * public_key) tzresult Lwt.t
val list :
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block ->
((public_key_hash * public_key) list) tzresult Lwt.t
end
module Contract : sig
val list:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block -> Contract.t list tzresult Lwt.t
type info = {
manager: public_key_hash ;
@ -106,91 +106,91 @@ module Context : sig
counter: int32 ;
}
val get:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block -> Contract.t -> info tzresult Lwt.t
val balance:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block -> Contract.t ->
Tez.t tzresult Lwt.t
val manager:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block -> Contract.t ->
public_key_hash tzresult Lwt.t
val delegate:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block -> Contract.t ->
public_key_hash option tzresult Lwt.t
val counter:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block -> Contract.t ->
int32 tzresult Lwt.t
val spendable:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block -> Contract.t ->
bool tzresult Lwt.t
val delegatable:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block -> Contract.t ->
bool tzresult Lwt.t
val script:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block -> Contract.t -> Script.t option tzresult Lwt.t
val storage:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block -> Contract.t -> Script.expr option tzresult Lwt.t
end
end
module Helpers : sig
val minimal_time:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block -> ?prio:int -> unit -> Time.t tzresult Lwt.t
(** [minimal_time cctxt blk ?prio ()] is the minimal acceptable
timestamp for the successor of [blk]. [?prio] defaults to
[0]. *)
val apply_operation:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block -> Block_hash.t -> Operation_hash.t -> MBytes.t -> Ed25519.Signature.t option ->
(Contract.t list) tzresult Lwt.t
val run_code:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block -> Script.expr ->
(Script.expr * Script.expr * Tez.t) ->
(Script.expr * Script.expr) tzresult Lwt.t
val trace_code:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block -> Script.expr ->
(Script.expr * Script.expr * Tez.t) ->
(Script.expr * Script.expr *
(Script.location * int * Script.expr list) list) tzresult Lwt.t
val typecheck_code:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block -> Script.expr -> Script_ir_translator.type_map tzresult Lwt.t
val typecheck_data:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block -> Script.expr * Script.expr -> unit tzresult Lwt.t
val hash_data:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block -> Script.expr -> string tzresult Lwt.t
val level:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block -> ?offset:int32 -> Raw_level.t -> Level.t tzresult Lwt.t
val levels:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block -> Cycle.t -> (Raw_level.t * Raw_level.t) tzresult Lwt.t
module Rights : sig
type baking_slot = Raw_level.t * int * Time.t
type endorsement_slot = Raw_level.t * int
val baking_rights_for_delegate:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block -> public_key_hash ->
?max_priority:int -> ?first_level:Raw_level.t ->
?last_level:Raw_level.t -> unit ->
(baking_slot list) tzresult Lwt.t
val endorsement_rights_for_delegate:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block -> public_key_hash ->
?max_priority:int -> ?first_level:Raw_level.t -> ?last_level:Raw_level.t -> unit ->
(endorsement_slot list) tzresult Lwt.t
@ -199,7 +199,7 @@ module Helpers : sig
module Forge : sig
module Manager : sig
val operations:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block ->
branch:Block_hash.t ->
source:Contract.t ->
@ -209,7 +209,7 @@ module Helpers : sig
manager_operation list ->
MBytes.t tzresult Lwt.t
val transaction:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block ->
branch:Block_hash.t ->
source:Contract.t ->
@ -221,7 +221,7 @@ module Helpers : sig
fee:Tez.t ->
unit -> MBytes.t tzresult Lwt.t
val origination:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block ->
branch:Block_hash.t ->
source:Contract.t ->
@ -237,7 +237,7 @@ module Helpers : sig
unit ->
MBytes.t tzresult Lwt.t
val delegation:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block ->
branch:Block_hash.t ->
source:Contract.t ->
@ -249,19 +249,19 @@ module Helpers : sig
end
module Dictator : sig
val operation:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block ->
branch:Block_hash.t ->
dictator_operation ->
MBytes.t tzresult Lwt.t
val activate:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block ->
branch:Block_hash.t ->
Protocol_hash.t ->
MBytes.t tzresult Lwt.t
val activate_testnet:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block ->
branch:Block_hash.t ->
Protocol_hash.t ->
@ -269,14 +269,14 @@ module Helpers : sig
end
module Delegate : sig
val operations:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block ->
branch:Block_hash.t ->
source:public_key ->
delegate_operation list ->
MBytes.t tzresult Lwt.t
val endorsement:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block ->
branch:Block_hash.t ->
source:public_key ->
@ -284,7 +284,7 @@ module Helpers : sig
slot:int ->
unit -> MBytes.t tzresult Lwt.t
val proposals:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block ->
branch:Block_hash.t ->
source:public_key ->
@ -292,7 +292,7 @@ module Helpers : sig
proposals:Protocol_hash.t list ->
unit -> MBytes.t tzresult Lwt.t
val ballot:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block ->
branch:Block_hash.t ->
source:public_key ->
@ -303,27 +303,27 @@ module Helpers : sig
end
module Anonymous : sig
val operations:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block ->
branch:Block_hash.t ->
anonymous_operation list ->
MBytes.t tzresult Lwt.t
val seed_nonce_revelation:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block ->
branch:Block_hash.t ->
level:Raw_level.t ->
nonce:Nonce.t ->
unit -> MBytes.t tzresult Lwt.t
val faucet:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block ->
branch:Block_hash.t ->
id:public_key_hash ->
unit -> MBytes.t tzresult Lwt.t
end
val block_proto_header:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block ->
priority: int ->
seed_nonce_hash: Nonce_hash.t ->
@ -333,11 +333,11 @@ module Helpers : sig
module Parse : sig
val operations:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block -> ?check:bool -> Operation.raw list ->
Operation.t list tzresult Lwt.t
val block:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
block -> Block_header.shell_header -> MBytes.t ->
Block_header.proto_header tzresult Lwt.t
end

14
lib_embedded_client_genesis/client_proto_main.ml
View File

@ -7,7 +7,6 @@
(* *)
(**************************************************************************)
open Client_commands
open Tezos_embedded_raw_protocol_genesis
let protocol =
@ -84,13 +83,12 @@ let commands () =
@@ Client_keys.Secret_key.source_param
~name:"password" ~desc:"Dictator's key"
@@ stop)
begin fun timestamp hash fitness validation_passes seckey cctxt ->
begin fun timestamp hash fitness validation_passes seckey (cctxt : Client_commands.full_context) ->
let fitness =
Tezos_embedded_raw_protocol_alpha.Fitness_repr.from_int64 fitness in
bake cctxt.rpc_config ?timestamp cctxt.config.block
(Activate { protocol = hash ; validation_passes })
fitness seckey >>=? fun hash ->
cctxt.answer "Injected %a" Block_hash.pp_short hash >>= fun () ->
bake cctxt ?timestamp cctxt#block
(Activate { protocol = hash ; validation_passes }) fitness seckey >>=? fun hash ->
cctxt#answer "Injected %a" Block_hash.pp_short hash >>= fun () ->
return ()
end ;
@ -113,12 +111,12 @@ let commands () =
begin fun timestamp hash fitness validation_passes seckey cctxt ->
let fitness =
Tezos_embedded_raw_protocol_alpha.Fitness_repr.from_int64 fitness in
bake cctxt.rpc_config ?timestamp cctxt.config.block
bake cctxt ?timestamp cctxt#block
(Activate_testnet { protocol = hash ;
validation_passes ;
delay = Int64.mul 24L 3600L })
fitness seckey >>=? fun hash ->
cctxt.answer "Injected %a" Block_hash.pp_short hash >>= fun () ->
cctxt#answer "Injected %a" Block_hash.pp_short hash >>= fun () ->
return ()
end ;

2
lib_embedded_client_genesis/client_proto_main.mli
View File

@ -10,7 +10,7 @@
open Tezos_embedded_raw_protocol_genesis
val bake:
Client_rpcs.config ->
#Client_rpcs.rpc_sig ->
?timestamp: Time.t ->
Client_node_rpcs.Blocks.block ->
Data.Command.t ->

8
lib_embedded_protocol_alpha/src/tezos_context.ml
View File

@ -17,7 +17,13 @@ module type BASIC_DATA = sig
val pp: Format.formatter -> t -> unit
end
module Tez = Tez_repr
module Tez = struct
include Tez_repr
let default_fee =
match of_cents 5L with
| None -> raise (Failure "internal error: Could not parse default_fee literal")
| Some fee -> fee
end
module Period = Period_repr
module Timestamp = struct

2
lib_embedded_protocol_alpha/src/tezos_context.mli
View File

@ -47,6 +47,8 @@ module Tez : sig
val of_cents: int64 -> tez option
val to_cents: tez -> int64
val default_fee : t
end
module Period : sig

89
test/proto_alpha/proto_alpha_helpers.ml
View File

@ -20,6 +20,19 @@ let rpc_config = ref {
logger = Client_rpcs.null_logger ;
}
(* Context that does not write to alias files *)
let no_write_context config block : Client_commands.full_context = object
inherit Client_rpcs.rpc config
inherit Client_commands.logger (fun _ _ -> Lwt.return_unit)
method load : type a. string -> default:a -> a Data_encoding.encoding -> a Error_monad.tzresult Lwt.t =
fun _ ~default _ -> return default
method write : type a. string ->
a ->
a Data_encoding.encoding -> unit Error_monad.tzresult Lwt.t =
fun _ _ _ -> return ()
method block = block
end
let dictator_sk =
Ed25519.Secret_key.of_b58check_exn
"edskRhxswacLW6jF6ULavDdzwqnKJVS4UcDTNiCyiH6H8ZNnn2pmNviL7\
@ -28,8 +41,8 @@ let dictator_sk =
let activate_alpha () =
let fitness = Fitness_repr.from_int64 0L in
Tezos_embedded_client_genesis.Client_proto_main.bake
!rpc_config (`Head 0)
(Activate { protocol = Client_proto_main.protocol ; validation_passes = 1})
(new Client_rpcs.rpc !rpc_config) (`Head 0)
(Activate { protocol = Client_proto_main.protocol ; validation_passes = 1})
fitness dictator_sk
let init ?(sandbox = "sandbox.json") ?rpc_port () =
@ -54,7 +67,7 @@ let init ?(sandbox = "sandbox.json") ?rpc_port () =
return (pid, hash)
let level block =
Client_proto_rpcs.Context.level !rpc_config block
Client_proto_rpcs.Context.level (new Client_rpcs.rpc !rpc_config) block
module Account = struct
@ -183,7 +196,7 @@ module Account = struct
~amount () =
let amount = match Tez.of_cents amount with None -> Tez.zero | Some a -> a in
let fee = match Tez.of_cents fee with None -> Tez.zero | Some a -> a in
Client_proto_context.transfer !rpc_config
Client_proto_context.transfer (new Client_rpcs.rpc !rpc_config)
block
~source:account.contract
~src_pk:account.pk
@ -198,7 +211,6 @@ module Account = struct
?(fee=5L)
~(src:t)
~manager_pkh
~spendable
~balance
() =
let fee = match Tez.of_cents fee with
@ -210,41 +222,45 @@ module Account = struct
let delegatable, delegate = match delegate with
| None -> false, None
| Some delegate -> true, Some delegate in
Client_proto_context.originate_account !rpc_config block
Client_proto_context.originate_account
~source:src.contract
~src_pk:src.pk
~src_sk:src.sk
~manager_pkh
~spendable
~balance
~delegatable
?delegate
~fee ()
~fee
block
(new Client_rpcs.rpc !rpc_config)
()
let set_delegate
?(block = `Prevalidation)
?(fee = 5L)
?src_pk
~contract
~manager_sk
~src_pk
delegate_opt =
let fee = match Tez.of_cents fee with
| None -> Tez.zero
| Some amount -> amount in
Client_proto_context.delegate_contract !rpc_config block
~source:contract
~manager_sk
Client_proto_context.set_delegate
(new Client_rpcs.rpc !rpc_config)
block
~fee
?src_pk
contract
~src_pk
~manager_sk
delegate_opt
let balance ?(block = `Prevalidation) (account : t) =
Client_proto_rpcs.Context.Contract.balance !rpc_config
Client_proto_rpcs.Context.Contract.balance (new Client_rpcs.rpc !rpc_config)
block account.contract
(* TODO: gather contract related functions in a Contract module? *)
let delegate ?(block = `Prevalidation) (contract : Contract.t) =
Client_proto_rpcs.Context.Contract.delegate !rpc_config
Client_proto_rpcs.Context.Contract.delegate (new Client_rpcs.rpc !rpc_config)
block contract
end
@ -254,12 +270,12 @@ module Protocol = struct
open Account
let voting_period_kind ?(block = `Prevalidation) () =
Client_proto_rpcs.Context.voting_period_kind !rpc_config block
Client_proto_rpcs.Context.voting_period_kind (new Client_rpcs.rpc !rpc_config) block
let proposals ?(block = `Prevalidation) ~src:({ pk; sk } : Account.t) proposals =
Client_node_rpcs.Blocks.info !rpc_config block >>=? fun block_info ->
Client_proto_rpcs.Context.next_level !rpc_config block >>=? fun next_level ->
Client_proto_rpcs.Helpers.Forge.Delegate.proposals !rpc_config block
Client_node_rpcs.Blocks.info (new Client_rpcs.rpc !rpc_config) block >>=? fun block_info ->
Client_proto_rpcs.Context.next_level (new Client_rpcs.rpc !rpc_config) block >>=? fun next_level ->
Client_proto_rpcs.Helpers.Forge.Delegate.proposals (new Client_rpcs.rpc !rpc_config) block
~branch:block_info.hash
~source:pk
~period:next_level.voting_period
@ -269,9 +285,10 @@ module Protocol = struct
return (Tezos_base.Operation.of_bytes_exn signed_bytes)
let ballot ?(block = `Prevalidation) ~src:({ pk; sk } : Account.t) ~proposal ballot =
Client_node_rpcs.Blocks.info !rpc_config block >>=? fun block_info ->
Client_proto_rpcs.Context.next_level !rpc_config block >>=? fun next_level ->
Client_proto_rpcs.Helpers.Forge.Delegate.ballot !rpc_config block
let rpc = new Client_rpcs.rpc !rpc_config in
Client_node_rpcs.Blocks.info rpc block >>=? fun block_info ->
Client_proto_rpcs.Context.next_level rpc block >>=? fun next_level ->
Client_proto_rpcs.Helpers.Forge.Delegate.ballot rpc block
~branch:block_info.hash
~source:pk
~period:next_level.voting_period
@ -402,7 +419,7 @@ module Assert = struct
end
let check_protocol ?msg ~block h =
Client_node_rpcs.Blocks.protocol !rpc_config block >>=? fun block_proto ->
Client_node_rpcs.Blocks.protocol (new Client_rpcs.rpc !rpc_config) block >>=? fun block_proto ->
return @@ Assert.equal
?msg:(Assert.format_msg msg)
~prn:Protocol_hash.to_b58check
@ -410,7 +427,7 @@ module Assert = struct
block_proto h
let check_voting_period_kind ?msg ~block kind =
Client_proto_rpcs.Context.voting_period_kind !rpc_config block
Client_proto_rpcs.Context.voting_period_kind (new Client_rpcs.rpc !rpc_config) block
>>=? fun current_kind ->
return @@ Assert.equal
?msg:(Assert.format_msg msg)
@ -428,7 +445,7 @@ module Baking = struct
| Ok nonce -> nonce in
let seed_nonce_hash = Nonce.hash seed_nonce in
Client_baking_forge.forge_block
!rpc_config
(new Client_rpcs.rpc !rpc_config)
block
~operations
~force:true
@ -440,7 +457,7 @@ module Baking = struct
()
let endorsement_reward block =
Client_proto_rpcs.Header.priority !rpc_config block >>=? fun prio ->
Client_proto_rpcs.Header.priority (new Client_rpcs.rpc !rpc_config) block >>=? fun prio ->
Baking.endorsement_reward ~block_priority:prio >|=
Environment.wrap_error >>|?
Tez.to_cents
@ -455,8 +472,9 @@ module Endorse = struct
source
slot =
let block = Client_rpcs.last_baked_block block in
Client_node_rpcs.Blocks.info !rpc_config block >>=? fun { hash } ->
Client_proto_rpcs.Helpers.Forge.Delegate.endorsement !rpc_config
let rpc = new Client_rpcs.rpc !rpc_config in
Client_node_rpcs.Blocks.info rpc block >>=? fun { hash ; _ } ->
Client_proto_rpcs.Helpers.Forge.Delegate.endorsement rpc
block
~branch:hash
~source
@ -472,7 +490,7 @@ module Endorse = struct
delegate
level =
Client_proto_rpcs.Helpers.Rights.endorsement_rights_for_delegate
!rpc_config ~max_priority ~first_level:level ~last_level:level
(new Client_rpcs.rpc !rpc_config) ~max_priority ~first_level:level ~last_level:level
block delegate () >>=? fun possibilities ->
let slots =
List.map (fun (_,slot) -> slot)
@ -483,7 +501,7 @@ module Endorse = struct
?slot
(contract : Account.t)
block =
Client_proto_rpcs.Context.next_level !rpc_config block >>=? fun { level } ->
Client_proto_rpcs.Context.next_level (new Client_rpcs.rpc !rpc_config) block >>=? fun { level } ->
begin
match slot with
| Some slot -> return slot
@ -502,7 +520,7 @@ module Endorse = struct
let endorsers_list block =
let get_endorser_list result (account : Account.t) level block =
Client_proto_rpcs.Helpers.Rights.endorsement_rights_for_delegate
!rpc_config block account.pkh
(new Client_rpcs.rpc !rpc_config) block account.pkh
~max_priority:16
~first_level:level
~last_level:level () >>|? fun slots ->
@ -510,7 +528,7 @@ module Endorse = struct
in
let { Account.b1 ; b2 ; b3 ; b4 ; b5 } = Account.bootstrap_accounts in
let result = Array.make 16 b1 in
Client_proto_rpcs.Context.level !rpc_config block >>=? fun level ->
Client_proto_rpcs.Context.level (new Client_rpcs.rpc !rpc_config) block >>=? fun level ->
let level = Raw_level.succ @@ level.level in
get_endorser_list result b1 level block >>=? fun () ->
get_endorser_list result b2 level block >>=? fun () ->
@ -522,11 +540,12 @@ module Endorse = struct
let endorsement_rights
?(max_priority = 1024)
(contract : Account.t) block =
Client_proto_rpcs.Context.level !rpc_config block >>=? fun level ->
let rpc = new Client_rpcs.rpc !rpc_config in
Client_proto_rpcs.Context.level rpc block >>=? fun level ->
let delegate = contract.pkh in
let level = level.level in
Client_proto_rpcs.Helpers.Rights.endorsement_rights_for_delegate
!rpc_config
rpc
~max_priority
~first_level:level
~last_level:level
@ -535,6 +554,6 @@ module Endorse = struct
end
let display_level block =
Client_proto_rpcs.Context.level !rpc_config block >>=? fun lvl ->
Client_proto_rpcs.Context.level (new Client_rpcs.rpc !rpc_config) block >>=? fun lvl ->
Format.eprintf "Level: %a@." Level.pp_full lvl ;
return ()

3
test/proto_alpha/proto_alpha_helpers.mli
View File

@ -71,16 +71,15 @@ module Account : sig
?fee:int64 ->
src:t ->
manager_pkh:public_key_hash ->
spendable:bool ->
balance:int64 ->
unit -> (Operation_hash.t * Contract.t) tzresult Lwt.t
val set_delegate :
?block:Client_proto_rpcs.block ->
?fee:int64 ->
?src_pk:public_key ->
contract:Contract.t ->
manager_sk:secret_key ->
src_pk:public_key ->
public_key_hash option ->
Operation_hash.t tzresult Lwt.t

11
test/proto_alpha/test_origination.ml
View File

@ -19,7 +19,6 @@ let run blkid ({ b1 ; b2 ; _ } : Helpers.Account.bootstrap_accounts) =
Helpers.Account.originate
~src:foo
~manager_pkh:foo.pkh
~spendable:true
~balance:0L () >>= fun result ->
Assert.unknown_contract ~msg:__LOC__ result ;
@ -27,7 +26,6 @@ let run blkid ({ b1 ; b2 ; _ } : Helpers.Account.bootstrap_accounts) =
Helpers.Account.originate
~src:b1
~manager_pkh:foo.pkh
~spendable:true
~balance:50L () >>= fun result ->
Assert.initial_amount_too_low ~msg:__LOC__ result ;
@ -35,7 +33,6 @@ let run blkid ({ b1 ; b2 ; _ } : Helpers.Account.bootstrap_accounts) =
Helpers.Account.originate
~src:b1
~manager_pkh:foo.pkh
~spendable:true
~balance:99L () >>= fun result ->
Assert.initial_amount_too_low ~msg:__LOC__ result ;
@ -43,7 +40,6 @@ let run blkid ({ b1 ; b2 ; _ } : Helpers.Account.bootstrap_accounts) =
Helpers.Account.originate
~src:b1
~manager_pkh:foo.pkh
~spendable:true
~balance:100L () >>= fun _result ->
(* TODO: test if new contract exists *)
@ -51,30 +47,29 @@ let run blkid ({ b1 ; b2 ; _ } : Helpers.Account.bootstrap_accounts) =
Helpers.Account.originate
~src:b1
~manager_pkh:b1.pkh
~spendable:true
~balance:500L () >>=? fun (_oph, nd_contract) ->
(* Delegatable contract *)
Helpers.Account.originate
~src:b1
~manager_pkh:b1.pkh
~spendable:true
~delegate:b1.pkh
~balance:500L () >>=? fun (_oph, d_contract) ->
(* Change delegate of a non-delegatable contract *)
Helpers.Account.set_delegate
~src_pk:b1.pk
~fee:5L
~contract:nd_contract
~manager_sk:b1.sk
~src_pk:b1.pk
(Some b2.pkh) >>= fun result ->
Assert.non_delegatable ~msg:__LOC__ result ;
(* Change delegate of a delegatable contract *)
Helpers.Account.set_delegate
~src_pk:b1.pk
~contract:d_contract
~manager_sk:b1.sk
~src_pk:b1.pk
(Some b2.pkh) >>= fun _result ->
Assert.delegate_equal ~msg:__LOC__ d_contract (Some b2.pkh) >>=? fun () ->

16
test/proto_alpha/test_transaction.ml
View File

@ -49,26 +49,10 @@ let run blkid ({ b1 ; b2 ; b3 ; _ } : Helpers.Account.bootstrap_accounts) =
~amount:1000_00L () >>= fun result ->
Assert.balance_too_low ~msg:__LOC__ result ;
(* Check non-spendability of a non-spendable contract *)
(* TODO: Unspecified economic error: should be more specific. *)
Helpers.Account.originate
~src:foo
~manager_pkh:foo.pkh
~spendable:false
~balance:50_00L () >>=? fun (_oph, non_spendable) ->
Format.printf "Created non-spendable contract %a@." Contract.pp non_spendable ;
let account = { foo with contract = non_spendable } in
Helpers.Account.transfer
~account
~destination:bar.contract
~amount:10_00L () >>= fun result ->
Assert.non_spendable ~msg:__LOC__ result ;
(* Check spendability of a spendable contract *)
Helpers.Account.originate
~src:foo
~manager_pkh:foo.pkh
~spendable:true
~balance:50_00L () >>=? fun (_oph, spendable) ->
Format.printf "Created contract %a@." Contract.pp spendable ;
let account = { foo with contract = spendable } in