diff --git a/bin_client/main.ml b/bin_client/main.ml index e08ce9004..de668a3d9 100644 --- a/bin_client/main.ml +++ b/bin_client/main.ml @@ -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 -> diff --git a/lib_client_base/client_aliases.ml b/lib_client_base/client_aliases.ml index 7e79ba77b..41351edc4 100644 --- a/lib_client_base/client_aliases.ml +++ b/lib_client_base/client_aliases.ml @@ -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 "@[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 diff --git a/lib_client_base/client_aliases.mli b/lib_client_base/client_aliases.mli index eb25e342d..943185fe6 100644 --- a/lib_client_base/client_aliases.mli +++ b/lib_client_base/client_aliases.mli @@ -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 diff --git a/lib_client_base/client_commands.ml b/lib_client_base/client_commands.ml index 410fd6a68..4e8003b03 100644 --- a/lib_client_base/client_commands.ml +++ b/lib_client_base/client_commands.ml @@ -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 ()) diff --git a/lib_client_base/client_commands.mli b/lib_client_base/client_commands.mli index e6f01c552..4ebdb8fa9 100644 --- a/lib_client_base/client_commands.mli +++ b/lib_client_base/client_commands.mli @@ -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 diff --git a/lib_client_base/client_config.ml b/lib_client_base/client_config.ml index 342f1ccbb..7164b2444 100644 --- a/lib_client_base/client_config.ml +++ b/lib_client_base/client_config.ml @@ -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 diff --git a/lib_client_base/client_debug.ml b/lib_client_base/client_debug.ml index a6a1e9845..22e4bf21e 100644 --- a/lib_client_base/client_debug.ml +++ b/lib_client_base/client_debug.ml @@ -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 diff --git a/lib_client_base/client_debug.mli b/lib_client_base/client_debug.mli index 3ac41ba29..45d4b08e8 100644 --- a/lib_client_base/client_debug.mli +++ b/lib_client_base/client_debug.mli @@ -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 diff --git a/lib_client_base/client_generic_rpcs.ml b/lib_client_base/client_generic_rpcs.ml index e7584f5fa..51a6851cc 100644 --- a/lib_client_base/client_generic_rpcs.ml +++ b/lib_client_base/client_generic_rpcs.ml @@ -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 "@ @[Available services:@ @ %a@]@." + cctxt#message "@ @[Available services:@ @ %a@]@." display (args, args, tree) >>= fun () -> if !collected_args <> [] then begin - cctxt.message "@,@[Dynamic parameter description:@ @ %a@]@." + cctxt#message "@,@[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 "@[\ @[Input format:@,%a@]@,\ @[Output format:@,%a@]@,\ @@ -332,7 +331,7 @@ let format url cctxt = Json_schema.pp output >>= fun () -> return () | { input = None ; output } -> - cctxt.message + cctxt#message "@[\ @[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 ()) ; diff --git a/lib_client_base/client_helpers.ml b/lib_client_base/client_helpers.ml index f5c55e3ac..17d95961d 100644 --- a/lib_client_base/client_helpers.ml +++ b/lib_client_base/client_helpers.ml @@ -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 () ) ] diff --git a/lib_client_base/client_keys.ml b/lib_client_base/client_keys.ml index cf86366db..7397fce6a 100644 --- a/lib_client_base/client_keys.ml +++ b/lib_client_base/client_keys.ml @@ -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 []) ; ] diff --git a/lib_client_base/client_keys.mli b/lib_client_base/client_keys.mli index 9e183c276..5b68f470d 100644 --- a/lib_client_base/client_keys.mli +++ b/lib_client_base/client_keys.mli @@ -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 diff --git a/lib_client_base/client_network.ml b/lib_client_base/client_network.ml index a11e9afb3..bb4e04fdd 100644 --- a/lib_client_base/client_network.ml +++ b/lib_client_base/client_network.ml @@ -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 " ") diff --git a/lib_client_base/client_node_rpcs.ml b/lib_client_base/client_node_rpcs.ml index ae4680b7f..ab504f071 100644 --- a/lib_client_base/client_node_rpcs.ml +++ b/lib_client_base/client_node_rpcs.ml @@ -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 = diff --git a/lib_client_base/client_node_rpcs.mli b/lib_client_base/client_node_rpcs.mli index c0054f492..87aa768b6 100644 --- a/lib_client_base/client_node_rpcs.mli +++ b/lib_client_base/client_node_rpcs.mli @@ -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 diff --git a/lib_client_base/client_protocols.ml b/lib_client_base/client_protocols.ml index c46c0d93c..2e8aaaeaa 100644 --- a/lib_client_base/client_protocols.ml +++ b/lib_client_base/client_protocols.ml @@ -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); *) ] diff --git a/lib_client_base/client_rpcs.ml b/lib_client_base/client_rpcs.ml index d03f3f74b..afe655980 100644 --- a/lib_client_base/client_rpcs.ml +++ b/lib_client_base/client_rpcs.ml @@ -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 diff --git a/lib_client_base/client_rpcs.mli b/lib_client_base/client_rpcs.mli index 0a74f6443..9854dc7dc 100644 --- a/lib_client_base/client_rpcs.mli +++ b/lib_client_base/client_rpcs.mli @@ -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 diff --git a/lib_client_base/client_tags.mli b/lib_client_base/client_tags.mli index 48c6989a6..827288853 100644 --- a/lib_client_base/client_tags.mli +++ b/lib_client_base/client_tags.mli @@ -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 diff --git a/lib_embedded_client_alpha/alpha.ml b/lib_embedded_client_alpha/alpha.ml new file mode 100644 index 000000000..78dfbc638 --- /dev/null +++ b/lib_embedded_client_alpha/alpha.ml @@ -0,0 +1,16 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* 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 diff --git a/lib_embedded_client_alpha/alpha.mli b/lib_embedded_client_alpha/alpha.mli new file mode 100644 index 000000000..6564aa13b --- /dev/null +++ b/lib_embedded_client_alpha/alpha.mli @@ -0,0 +1,16 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* 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 diff --git a/lib_embedded_client_alpha/client_baking_blocks.mli b/lib_embedded_client_alpha/client_baking_blocks.mli index 661c9e81c..b5ca9dade 100644 --- a/lib_embedded_client_alpha/client_baking_blocks.mli +++ b/lib_embedded_client_alpha/client_baking_blocks.mli @@ -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 diff --git a/lib_embedded_client_alpha/client_baking_daemon.ml b/lib_embedded_client_alpha/client_baking_daemon.ml index 1a50d5ed9..2ffc2d5dd 100644 --- a/lib_embedded_client_alpha/client_baking_daemon.ml +++ b/lib_embedded_client_alpha/client_baking_daemon.ml @@ -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 () diff --git a/lib_embedded_client_alpha/client_baking_daemon.mli b/lib_embedded_client_alpha/client_baking_daemon.mli index c88ac1f29..7c6277ae4 100644 --- a/lib_embedded_client_alpha/client_baking_daemon.mli +++ b/lib_embedded_client_alpha/client_baking_daemon.mli @@ -8,7 +8,7 @@ (**************************************************************************) val run: - Client_commands.context -> + Client_commands.full_context -> ?max_priority: int -> delay: int -> ?min_date: Time.t -> diff --git a/lib_embedded_client_alpha/client_baking_denunciation.mli b/lib_embedded_client_alpha/client_baking_denunciation.mli index cd731c056..215d9edfb 100644 --- a/lib_embedded_client_alpha/client_baking_denunciation.mli +++ b/lib_embedded_client_alpha/client_baking_denunciation.mli @@ -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 diff --git a/lib_embedded_client_alpha/client_baking_endorsement.ml b/lib_embedded_client_alpha/client_baking_endorsement.ml index ec0c546a5..d524ff97c 100644 --- a/lib_embedded_client_alpha/client_baking_endorsement.ml +++ b/lib_embedded_client_alpha/client_baking_endorsement.ml @@ -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 () = diff --git a/lib_embedded_client_alpha/client_baking_endorsement.mli b/lib_embedded_client_alpha/client_baking_endorsement.mli index 760da3894..febc5a6ad 100644 --- a/lib_embedded_client_alpha/client_baking_endorsement.mli +++ b/lib_embedded_client_alpha/client_baking_endorsement.mli @@ -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 diff --git a/lib_embedded_client_alpha/client_baking_forge.ml b/lib_embedded_client_alpha/client_baking_forge.ml index 1d89dba3e..600aa2b20 100644 --- a/lib_embedded_client_alpha/client_baking_forge.ml +++ b/lib_embedded_client_alpha/client_baking_forge.ml @@ -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 diff --git a/lib_embedded_client_alpha/client_baking_forge.mli b/lib_embedded_client_alpha/client_baking_forge.mli index d5ba7d440..72723f170 100644 --- a/lib_embedded_client_alpha/client_baking_forge.mli +++ b/lib_embedded_client_alpha/client_baking_forge.mli @@ -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 diff --git a/lib_embedded_client_alpha/client_baking_lib.ml b/lib_embedded_client_alpha/client_baking_lib.ml new file mode 100644 index 000000000..268d95de9 --- /dev/null +++ b/lib_embedded_client_alpha/client_baking_lib.ml @@ -0,0 +1,97 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* 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) diff --git a/lib_embedded_client_alpha/client_baking_lib.mli b/lib_embedded_client_alpha/client_baking_lib.mli new file mode 100644 index 000000000..52f261540 --- /dev/null +++ b/lib_embedded_client_alpha/client_baking_lib.mli @@ -0,0 +1,58 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* 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 diff --git a/lib_embedded_client_alpha/client_baking_main.ml b/lib_embedded_client_alpha/client_baking_main.ml index 5eaeb5d75..0562e369d 100644 --- a/lib_embedded_client_alpha/client_baking_main.ml +++ b/lib_embedded_client_alpha/client_baking_main.ml @@ -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 () diff --git a/lib_embedded_client_alpha/client_baking_main.mli b/lib_embedded_client_alpha/client_baking_main.mli index d30f4c825..2e95c8027 100644 --- a/lib_embedded_client_alpha/client_baking_main.mli +++ b/lib_embedded_client_alpha/client_baking_main.mli @@ -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 diff --git a/lib_embedded_client_alpha/client_baking_operations.mli b/lib_embedded_client_alpha/client_baking_operations.mli index 00dce92d5..81fae35a3 100644 --- a/lib_embedded_client_alpha/client_baking_operations.mli +++ b/lib_embedded_client_alpha/client_baking_operations.mli @@ -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 diff --git a/lib_embedded_client_alpha/client_baking_revelation.ml b/lib_embedded_client_alpha/client_baking_revelation.ml index 7add3f1b5..0efbc91c7 100644 --- a/lib_embedded_client_alpha/client_baking_revelation.ml +++ b/lib_embedded_client_alpha/client_baking_revelation.ml @@ -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 () diff --git a/lib_embedded_client_alpha/client_baking_revelation.mli b/lib_embedded_client_alpha/client_baking_revelation.mli index f4862e199..7fac5a4b8 100644 --- a/lib_embedded_client_alpha/client_baking_revelation.mli +++ b/lib_embedded_client_alpha/client_baking_revelation.mli @@ -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 -> diff --git a/lib_embedded_client_alpha/client_proto_args.ml b/lib_embedded_client_alpha/client_proto_args.ml index 9243103be..5833c8192 100644 --- a/lib_embedded_client_alpha/client_proto_args.ml +++ b/lib_embedded_client_alpha/client_proto_args.ml @@ -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 diff --git a/lib_embedded_client_alpha/client_proto_args.mli b/lib_embedded_client_alpha/client_proto_args.mli index 45fd737ab..8182b9b58 100644 --- a/lib_embedded_client_alpha/client_proto_args.mli +++ b/lib_embedded_client_alpha/client_proto_args.mli @@ -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 diff --git a/lib_embedded_client_alpha/client_proto_context.ml b/lib_embedded_client_alpha/client_proto_context.ml index 859d08a0c..6f518d719 100644 --- a/lib_embedded_client_alpha/client_proto_context.ml +++ b/lib_embedded_client_alpha/client_proto_context.ml @@ -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 diff --git a/lib_embedded_client_alpha/client_proto_context.mli b/lib_embedded_client_alpha/client_proto_context.mli index c8c2abfe1..fc2a7a9b2 100644 --- a/lib_embedded_client_alpha/client_proto_context.mli +++ b/lib_embedded_client_alpha/client_proto_context.mli @@ -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 diff --git a/lib_embedded_client_alpha/client_proto_context_commands.ml b/lib_embedded_client_alpha/client_proto_context_commands.ml new file mode 100644 index 000000000..07cf62756 --- /dev/null +++ b/lib_embedded_client_alpha/client_proto_context_commands.ml @@ -0,0 +1,275 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* 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 ; + + ] diff --git a/lib_embedded_client_alpha/client_proto_contracts.ml b/lib_embedded_client_alpha/client_proto_contracts.ml index ddc569c03..6bee4e755 100644 --- a/lib_embedded_client_alpha/client_proto_contracts.ml +++ b/lib_embedded_client_alpha/client_proto_contracts.ml @@ -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) ; - - ] diff --git a/lib_embedded_client_alpha/client_proto_contracts.mli b/lib_embedded_client_alpha/client_proto_contracts.mli index 89e3282cd..86aa34869 100644 --- a/lib_embedded_client_alpha/client_proto_contracts.mli +++ b/lib_embedded_client_alpha/client_proto_contracts.mli @@ -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) diff --git a/lib_embedded_client_alpha/client_proto_contracts_commands.ml b/lib_embedded_client_alpha/client_proto_contracts_commands.ml new file mode 100644 index 000000000..0d0c64573 --- /dev/null +++ b/lib_embedded_client_alpha/client_proto_contracts_commands.ml @@ -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) ; + + ] diff --git a/lib_embedded_client_alpha/client_proto_main.ml b/lib_embedded_client_alpha/client_proto_main.ml index df1d1ae8c..79a67c81d 100644 --- a/lib_embedded_client_alpha/client_proto_main.ml +++ b/lib_embedded_client_alpha/client_proto_main.ml @@ -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 () diff --git a/lib_embedded_client_alpha/client_proto_nonces.ml b/lib_embedded_client_alpha/client_proto_nonces.ml index b36680715..c6d9fbb38 100644 --- a/lib_embedded_client_alpha/client_proto_nonces.ml +++ b/lib_embedded_client_alpha/client_proto_nonces.ml @@ -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 diff --git a/lib_embedded_client_alpha/client_proto_nonces.mli b/lib_embedded_client_alpha/client_proto_nonces.mli index 084765dfc..738c3b47d 100644 --- a/lib_embedded_client_alpha/client_proto_nonces.mli +++ b/lib_embedded_client_alpha/client_proto_nonces.mli @@ -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 diff --git a/lib_embedded_client_alpha/client_proto_programs.ml b/lib_embedded_client_alpha/client_proto_programs.ml index 2606e82cc..44faac229 100644 --- a/lib_embedded_client_alpha/client_proto_programs.ml +++ b/lib_embedded_client_alpha/client_proto_programs.ml @@ -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 "@[@[storage@,%a@]@,@[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 + "@[@[storage@,%a@]@,\ + @[output@,%a@]@,@[trace@,%a@]@]@." + print_expr storage + print_expr output + (Format.pp_print_list + (fun ppf (loc, gas, stack) -> + Format.fprintf ppf + "- @[location: %d (remaining gas: %d)@,\ + [ @[%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 - "@[@[storage@,%a@]@,\ - @[output@,%a@]@,@[trace@,%a@]@]@." - print_expr storage - print_expr output - (Format.pp_print_list - (fun ppf (loc, gas, stack) -> - Format.fprintf ppf - "- @[location: %d (remaining gas: %d)@,\ - [ @[%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 "@[@[storage@,%a@]@,@[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 - "(@[(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 + "(@[(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" diff --git a/lib_embedded_client_alpha/client_proto_programs.mli b/lib_embedded_client_alpha/client_proto_programs.mli index 137e141b3..f271737fb 100644 --- a/lib_embedded_client_alpha/client_proto_programs.mli +++ b/lib_embedded_client_alpha/client_proto_programs.mli @@ -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 diff --git a/lib_embedded_client_alpha/client_proto_programs_commands.ml b/lib_embedded_client_alpha/client_proto_programs_commands.ml new file mode 100644 index 000000000..68d17f0e6 --- /dev/null +++ b/lib_embedded_client_alpha/client_proto_programs_commands.ml @@ -0,0 +1,176 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* 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) ; + + ] diff --git a/lib_embedded_client_alpha/client_proto_programs_commands.mli b/lib_embedded_client_alpha/client_proto_programs_commands.mli new file mode 100644 index 000000000..2e95c8027 --- /dev/null +++ b/lib_embedded_client_alpha/client_proto_programs_commands.mli @@ -0,0 +1,10 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +val commands: unit -> Client_commands.command list diff --git a/lib_embedded_client_alpha/client_proto_rpcs.ml b/lib_embedded_client_alpha/client_proto_rpcs.ml index fc0a6a79d..e247af30c 100644 --- a/lib_embedded_client_alpha/client_proto_rpcs.ml +++ b/lib_embedded_client_alpha/client_proto_rpcs.ml @@ -10,11 +10,11 @@ let string_of_errors exns = Format.asprintf " @[%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 diff --git a/lib_embedded_client_alpha/client_proto_rpcs.mli b/lib_embedded_client_alpha/client_proto_rpcs.mli index ac3815074..6579b4102 100644 --- a/lib_embedded_client_alpha/client_proto_rpcs.mli +++ b/lib_embedded_client_alpha/client_proto_rpcs.mli @@ -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 diff --git a/lib_embedded_client_genesis/client_proto_main.ml b/lib_embedded_client_genesis/client_proto_main.ml index 5447e734d..5eeb7270a 100644 --- a/lib_embedded_client_genesis/client_proto_main.ml +++ b/lib_embedded_client_genesis/client_proto_main.ml @@ -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 ; diff --git a/lib_embedded_client_genesis/client_proto_main.mli b/lib_embedded_client_genesis/client_proto_main.mli index 56ff2d3a3..8c8143138 100644 --- a/lib_embedded_client_genesis/client_proto_main.mli +++ b/lib_embedded_client_genesis/client_proto_main.mli @@ -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 -> diff --git a/lib_embedded_protocol_alpha/src/tezos_context.ml b/lib_embedded_protocol_alpha/src/tezos_context.ml index 75c567050..a7b479ba1 100644 --- a/lib_embedded_protocol_alpha/src/tezos_context.ml +++ b/lib_embedded_protocol_alpha/src/tezos_context.ml @@ -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 diff --git a/lib_embedded_protocol_alpha/src/tezos_context.mli b/lib_embedded_protocol_alpha/src/tezos_context.mli index b21bcb8a8..eca1b515d 100644 --- a/lib_embedded_protocol_alpha/src/tezos_context.mli +++ b/lib_embedded_protocol_alpha/src/tezos_context.mli @@ -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 diff --git a/test/proto_alpha/proto_alpha_helpers.ml b/test/proto_alpha/proto_alpha_helpers.ml index 1a7e3ae98..32ae56ca2 100644 --- a/test/proto_alpha/proto_alpha_helpers.ml +++ b/test/proto_alpha/proto_alpha_helpers.ml @@ -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 () diff --git a/test/proto_alpha/proto_alpha_helpers.mli b/test/proto_alpha/proto_alpha_helpers.mli index f3b52005d..814fced1f 100644 --- a/test/proto_alpha/proto_alpha_helpers.mli +++ b/test/proto_alpha/proto_alpha_helpers.mli @@ -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 diff --git a/test/proto_alpha/test_origination.ml b/test/proto_alpha/test_origination.ml index c5da139eb..b09c54627 100644 --- a/test/proto_alpha/test_origination.ml +++ b/test/proto_alpha/test_origination.ml @@ -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 () -> diff --git a/test/proto_alpha/test_transaction.ml b/test/proto_alpha/test_transaction.ml index 75a8ead9f..84be46105 100644 --- a/test/proto_alpha/test_transaction.ml +++ b/test/proto_alpha/test_transaction.ml @@ -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