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

CLI: New argument parsing and help messages

Browse Source
This commit is contained in:
Milo Davis 2017-09-19 11:31:35 +02:00
parent 31cede5582
commit b5e53191e2
20 changed files with 1644 additions and 972 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

275
src/client/client_config.ml
View File

@ -9,6 +9,33 @@
(* Tezos Command line interface - Configuration and Arguments Parsing *)
type error += Invalid_block_argument of string
type error += Invalid_port_arg of string
let () =
register_error_kind
`Branch
~id: "badBlocksArgument"
~title: "Bad Blocks Argument"
~description: "Blocks argument could not be parsed"
~pp:
(fun ppf s ->
Format.fprintf ppf "Value provided for -block flag (%s) could not be parsed" s)
Data_encoding.(obj1 (req "value" string))
(function Invalid_block_argument s -> Some s | _ -> None)
(fun s -> Invalid_block_argument s) ;
register_error_kind
`Branch
~id: "invalidPortArgument"
~title: "Bad Port Argument"
~description: "Port argument could not be parsed"
~pp:
(fun ppf s ->
Format.fprintf ppf "Value provided for -port flag (%s) could not be parsed" s)
Data_encoding.(obj1 (req "value" string))
(function Invalid_port_arg s -> Some s | _ -> None)
(fun s -> Invalid_port_arg s)
let (//) = Filename.concat
module Cfg_file = struct
@ -37,18 +64,18 @@ module Cfg_file = struct
(base_dir, Some node_addr, Some node_port,
Some tls, Some web_port))
(fun (base_dir, node_addr, node_port, tls, web_port) ->
let open Utils in
let node_addr = unopt ~default:default.node_addr node_addr in
let node_port = unopt ~default:default.node_port node_port in
let tls = unopt ~default:default.tls tls in
let web_port = unopt ~default:default.web_port web_port in
{ base_dir ; node_addr ; node_port ; tls ; web_port })
let open Utils in
let node_addr = unopt ~default:default.node_addr node_addr in
let node_port = unopt ~default:default.node_port node_port in
let tls = unopt ~default:default.tls tls in
let web_port = unopt ~default:default.web_port web_port in
{ base_dir ; node_addr ; node_port ; tls ; web_port })
(obj5
(req "base_dir" string)
(opt "node_addr" string)
(opt "node_port" int16)
(opt "tls" bool)
(opt "web_port" int16))
(req "base_dir" string)
(opt "node_addr" string)
(opt "node_port" int16)
(opt "tls" bool)
(opt "web_port" int16))
let from_json json =
Data_encoding.Json.destruct encoding json
@ -64,31 +91,104 @@ module Cfg_file = struct
end
exception Found of string
type cli_args = {
block: Node_rpc_services.Blocks.block ;
print_timings: bool ;
log_requests: bool ;
force: bool ;
}
let preparse name argv =
try
for i = 0 to Array.length argv - 2 do
if argv.(i) = name then raise (Found argv.(i+1))
done ;
None
with Found s -> Some s
let default_cli_args = {
block = Client_commands.default_cfg.block ;
print_timings = false ;
log_requests = false ;
force = false ;
}
let preparse_bool name argv =
try
for i = 0 to Array.length argv - 1 do
if argv.(i) = name then raise (Found "")
done ;
false
with Found _ -> true
open Cli_entries
let preparse_args argv =
let base_dir =
match preparse "-base-dir" argv with
| None -> Client_commands.default_base_dir
| Some base_dir -> base_dir in
(* Command-line only args (not in config file) *)
let base_dir_arg =
default_arg
~parameter:"-base-dir"
~doc:"The directory where the Tezos client will store all its data."
~default:Client_commands.default_base_dir
(fun _ x -> return x)
let config_file_arg =
arg
~parameter:"-config-file"
~doc:"The main configuration file."
(fun _ x -> return x)
let timings_switch =
switch
~parameter:"-timings"
~doc:"Show RPC request times if present."
let force_switch =
switch
~parameter:"-force"
~doc:"Show less courtesy than the average user."
let block_arg =
default_arg
~parameter:"-block"
~doc:"The block on which to apply contextual commands."
~default:(Node_rpc_services.Blocks.to_string default_cli_args.block)
(fun _ block -> match Node_rpc_services.Blocks.parse_block block with
| Error _ ->
fail (Invalid_block_argument block)
| Ok block -> return block)
let log_requests_switch =
switch
~parameter:"-log-requests"
~doc:"Causes all requests and responses to the node to be logged."
(* Command-line args which can be set in config file as well *)
let addr_arg =
default_arg
~parameter:"-addr"
~doc:"The IP address of the node."
~default:Cfg_file.default.node_addr
(fun _ x -> return x)
let port_arg =
default_arg
~parameter:"-port"
~doc:"The RPC port of the node."
~default:(string_of_int Cfg_file.default.node_port)
(fun _ x -> try
return (int_of_string x)
with Failure _ ->
fail (Invalid_port_arg x))
let tls_switch =
switch
~parameter:"-tls"
~doc:"Use TLS to connect to node."
let global_options =
args9 base_dir_arg
config_file_arg
force_switch
timings_switch
block_arg
log_requests_switch
addr_arg
port_arg
tls_switch
let parse_config_args (ctx : Client_commands.cfg) argv =
parse_initial_options
global_options
ctx
argv >>|?
fun ((base_dir,
config_file,
force,
timings,
block,
log_requests,
node_addr,
node_port,
tls), remaining) ->
let config_file =
match preparse "-config-file" argv with
match config_file with
| None -> base_dir // "config"
| Some config_file -> config_file in
let config_dir = Filename.dirname config_file in
@ -120,31 +220,7 @@ let preparse_args argv =
"Error: can't parse the configuration file: %s\n%a@."
config_file (fun ppf exn -> Json_encoding.print_error ppf exn) exn ;
exit 1 in
let tls = cfg.tls || preparse_bool "-tls" argv in
let node_addr =
match preparse "-addr" argv with
| None -> cfg.node_addr
| Some node_addr -> node_addr in
let node_port =
match preparse "-port" argv with
| None -> cfg.node_port
| Some port ->
try int_of_string port
with _ ->
Format.eprintf
"Error: can't parse the -port option: %S.@." port ;
exit 1 in
let block =
match preparse "-block" Sys.argv with
| None -> Client_commands.default_cfg.block
| Some block ->
match Node_rpc_services.Blocks.parse_block block with
| Error _ ->
Format.eprintf
"Error: can't parse the -block option: %S.@."
block ;
exit 1
| Ok block -> block in
let tls = cfg.tls || tls in
let cfg = { cfg with tls ; node_port ; node_addr } in
if Sys.file_exists base_dir && not (Sys.is_directory base_dir) then begin
Format.eprintf "Error: %s is not a directory.@." base_dir ;
@ -157,87 +233,4 @@ let preparse_args argv =
end ;
IO.mkdir config_dir ;
if not (Sys.file_exists config_file) then Cfg_file.write config_file cfg ;
(cfg, block)
(* Entry point *)
type cli_args = {
block: Node_rpc_services.Blocks.block ;
print_timings: bool ;
log_requests: bool ;
force: bool ;
}
let default_cli_args = {
block = Client_commands.default_cfg.block ;
print_timings = false ;
log_requests = false ;
force = false ;
}
exception Bad of Error_monad.error list
let parse_args usage dispatcher argv =
(* Init config reference which will be updated as args are parsed *)
let parsed_args = ref default_cli_args in
(* Command-line only args (not in config file) *)
let cli_args = [
"-base-dir", Arg.String (fun _ -> ( (* preparsed *) )),
"The directory where the Tezos client will store all its data.\n\
default: " ^ Client_commands.default_base_dir ;
"-config-file", Arg.String (fun _ -> ( (* preparsed *) )),
"The main configuration file.\n\
default: " ^ Client_commands.default_base_dir // "config" ;
"-timings",
Arg.Bool (fun x -> parsed_args := { !parsed_args with print_timings = x }),
"Show RPC request times.\n\
default: " ^ string_of_bool default_cli_args.print_timings ;
"-force",
Arg.Bool (fun x -> parsed_args := { !parsed_args with force = x }),
"Show less courtesy than the average user.\n\
default: " ^ string_of_bool default_cli_args.force ;
"-block", Arg.String (fun _ -> ( (* preparsed *) )),
"The block on which to apply contextual commands.\n\
default: " ^ Node_rpc_services.Blocks.to_string default_cli_args.block ;
"-log-requests",
Arg.Unit (fun () -> parsed_args := { !parsed_args with log_requests = true }),
"If set, this flag causes all requests and responses to the node to be logged."
] in
(* Command-line args which can be set in config file as well *)
let file_args = [
(* Network options *)
"-addr", Arg.String (fun _ -> ( (* preparsed *) )),
"The IP address at which the node's RPC server can be reached.\n\
default: " ^ Cfg_file.default.node_addr ;
"-port", Arg.Int (fun _ -> ( (* preparsed *) )),
"The TCP port at which the node's RPC server can be reached.\n\
default: " ^ string_of_int Cfg_file.default.node_port ;
"-tls", Arg.Bool (fun _ -> ( (* preparsed *) )),
"Use TLS to connect to node.\n\
default: " ^ string_of_bool Cfg_file.default.tls ;
] in
let all_args = cli_args @ file_args in
try
let args = ref all_args in
let anon dispatch n = match dispatch (`Arg n) with
| `Nop -> ()
| `Args nargs -> args := nargs @ !args
| `Fail err -> raise (Bad err)
| `Res _ -> assert false in
let dispatch = dispatcher () in
Arg.parse_argv_dynamic
~current:(ref 0) argv args (anon dispatch) "\000" ;
match dispatch `End with
| `Res res -> return (res, !parsed_args)
| `Fail err -> Lwt.return (Error err)
| `Nop | `Args _ -> assert false
with
| Bad err -> Lwt.return (Error err)
| Arg.Bad msg ->
(* FIXME: this is an ugly hack to circumvent [Arg]
spuriously printing options at the end of the error
message. *)
let msg = String.trim (List.hd (Utils.split '\000' msg)) in
Error_monad.failwith "%s" msg
| Arg.Help _ ->
raise (Arg.Help (usage all_args ^ "\n"))
(cfg, { block ; print_timings = timings ; log_requests ; force }, remaining)

21
src/client/client_generic_rpcs.ml
View File

@ -363,36 +363,43 @@ let group =
let commands = [
command ~desc: "list all understood protocol versions"
no_options
(fixed [ "list" ; "versions" ])
(fun cctxt ->
(fun () cctxt ->
Lwt_list.iter_s
(fun (ver, _) -> cctxt.Client_commands.message "%a" Protocol_hash.pp_short ver)
(Client_commands.get_versions ()) >>= fun () ->
return ()) ;
command ~group ~desc: "list available RPCs (low level command for advanced users)"
no_options
(prefixes [ "rpc" ; "list" ] @@ stop)
(list "/");
(fun () -> (list "/"));
command ~group ~desc: "list available RPCs (low level command for advanced users)"
no_options
(prefixes [ "rpc" ; "list" ] @@ string ~name:"url" ~desc: "the RPC's prefix to be described" @@ stop)
list ;
(fun () -> list) ;
command ~group ~desc: "get the input and output JSON schemas of an RPC"
no_options
(prefixes [ "rpc" ; "schema" ] @@ string ~name: "url" ~desc: "the RPC's URL" @@ stop)
schema ;
(fun () -> schema) ;
command ~group ~desc: "get the humanoid readable input and output formats of an RPC"
no_options
(prefixes [ "rpc" ; "format" ] @@ string ~name: "url" ~desc: "the RPC's URL" @@ stop)
format ;
(fun () -> format) ;
command ~group ~desc: "call an RPC (low level command for advanced users)"
no_options
(prefixes [ "rpc" ; "call" ] @@ string ~name: "url" ~desc: "the RPC's URL" @@ stop)
call ;
(fun () -> call) ;
command ~group ~desc: "call an RPC (low level command for advanced users)"
no_options
(prefixes [ "rpc" ; "call" ] @@ string ~name: "url" ~desc: "the RPC's URL"
@@ prefix "with" @@ string ~name:"input" ~desc:"the JSON input to the RPC" @@ stop)
call_with_json
(fun () -> call_with_json)
]

19
src/client/client_helpers.ml
View File

@ -10,11 +10,10 @@
open Client_commands
open Client_config
let unique = ref false
let unique_arg =
"-unique",
Arg.Set unique,
"Fail when there is more than one possible completion."
let unique_switch =
Cli_entries.switch
~parameter:"-unique"
~doc:"Fail when there is more than one possible completion."
let commands () = Cli_entries.[
command
@ -22,27 +21,27 @@ let commands () = Cli_entries.[
given prefix of Base58Check-encoded hash. This actually \
works only for blocks, operations, public key and contract \
identifiers."
~args: [unique_arg]
(args1 unique_switch)
(prefixes [ "complete" ] @@
string
~name: "prefix"
~desc: "the prefix of the Base58Check-encoded hash to be completed" @@
stop)
(fun prefix cctxt ->
(fun unique prefix cctxt ->
Client_node_rpcs.complete
cctxt.rpc_config ~block:cctxt.config.block prefix >>=? fun completions ->
match completions with
| [] -> Pervasives.exit 3
| _ :: _ :: _ when !unique -> Pervasives.exit 3
| _ :: _ :: _ when unique -> Pervasives.exit 3
| completions ->
List.iter print_endline completions ;
return ()) ;
command
~desc: "Wait for the node to be bootstrapped."
~args: []
no_options
(prefixes [ "bootstrapped" ] @@
stop)
(fun cctxt ->
(fun () cctxt ->
Client_node_rpcs.bootstrapped cctxt.rpc_config >>=? fun stream ->
Lwt_stream.iter_s (function
| Ok (hash, time) ->

33
src/client/client_keys.ml
View File

@ -124,25 +124,26 @@ let group =
let commands () =
let open Cli_entries in
let open Client_commands in
let show_private = ref false in
let show_private_arg =
"-show-secret",
Arg.Set show_private,
"Show the private key" in
let show_private_switch =
switch
~parameter:"-show-secret"
~doc:"Show the private key" in
[
command ~group ~desc: "generate a pair of keys"
no_options
(prefixes [ "gen" ; "keys" ]
@@ Secret_key.fresh_alias_param
@@ stop)
(fun name cctxt -> gen_keys cctxt name) ;
(fun () name cctxt -> gen_keys cctxt name) ;
command ~group ~desc: "add a secret key to the wallet"
no_options
(prefixes [ "add" ; "secret" ; "key" ]
@@ Secret_key.fresh_alias_param
@@ Secret_key.source_param
@@ stop)
(fun name sk cctxt ->
(fun () name sk cctxt ->
Public_key.find_opt cctxt name >>=? function
| None ->
let pk = Sodium.Sign.secret_key_to_public_key sk in
@ -159,25 +160,28 @@ let commands () =
Secret_key.add cctxt name sk) ;
command ~group ~desc: "add a public key to the wallet"
no_options
(prefixes [ "add" ; "public" ; "key" ]
@@ Public_key.fresh_alias_param
@@ Public_key.source_param
@@ stop)
(fun name key cctxt ->
(fun () name key cctxt ->
Public_key_hash.add cctxt
name (Ed25519.Public_key.hash key) >>=? fun () ->
Public_key.add cctxt name key) ;
command ~group ~desc: "add an ID a public key hash to the wallet"
no_options
(prefixes [ "add" ; "identity" ]
@@ Public_key_hash.fresh_alias_param
@@ Public_key_hash.source_param
@@ stop)
(fun name hash cctxt -> Public_key_hash.add cctxt name hash) ;
(fun () name hash cctxt -> Public_key_hash.add cctxt name hash) ;
command ~group ~desc: "list all public key hashes and associated keys"
no_options
(fixed [ "list" ; "known" ; "identities" ])
(fun cctxt ->
(fun () cctxt ->
list_keys cctxt >>=? fun l ->
iter_s
(fun (name, pkh, pkm, pks) ->
@ -189,11 +193,11 @@ let commands () =
l) ;
command ~group ~desc: "show the keys associated with an identity"
~args: [ show_private_arg ]
(args1 show_private_switch)
(prefixes [ "show" ; "identity"]
@@ Public_key_hash.alias_param
@@ stop)
(fun (name, _) cctxt ->
(fun show_private (name, _) cctxt ->
let ok_lwt x = x >>= (fun x -> return x) in
alias_keys cctxt name >>=? fun key_info ->
match key_info with
@ -206,7 +210,7 @@ let commands () =
| Some pub ->
Public_key.to_source cctxt pub >>=? fun pub ->
ok_lwt @@ cctxt.message "Public Key: %s" pub >>=? fun () ->
if !show_private then
if show_private then
match priv with
| None -> return ()
| Some priv ->
@ -215,8 +219,9 @@ let commands () =
else return ()) ;
command ~group ~desc: "forget all keys"
no_options
(fixed [ "forget" ; "all" ; "keys" ])
(fun cctxt ->
(fun () cctxt ->
fail_unless cctxt.config.force
(failure "this can only used with option -force true") >>=? fun () ->
Public_key.save cctxt [] >>=? fun () ->

3
src/client/client_network.ml
View File

@ -16,7 +16,8 @@ let group =
let commands () = [
let open Cli_entries in
command ~group ~desc: "show global network status"
(prefixes ["network" ; "stat"] stop) begin fun cctxt ->
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 ->

9
src/client/client_protocols.ml
View File

@ -23,18 +23,20 @@ let commands () =
[
command ~group ~desc: "list known protocols"
no_options
(prefixes [ "list" ; "protocols" ] stop)
(fun cctxt ->
(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 () ->
return ()
);
command ~group ~desc: "inject a new protocol to the shell database"
no_options
(prefixes [ "inject" ; "protocol" ]
@@ param ~name:"dir" ~desc:"directory containing a protocol" check_dir
@@ stop)
(fun dirname cctxt ->
(fun () dirname cctxt ->
Lwt.catch
(fun () ->
let proto = Tezos_compiler.read_dir dirname in
@ -54,10 +56,11 @@ let commands () =
);
command ~group ~desc: "dump a protocol from the shell database"
no_options
(prefixes [ "dump" ; "protocol" ]
@@ Protocol_hash.param ~name:"protocol hash" ~desc:""
@@ stop)
(fun ph cctxt ->
(fun () ph cctxt ->
Client_node_rpcs.Protocols.contents cctxt.rpc_config ph >>=? fun proto ->
Updater.extract "" ph proto >>= fun () ->
cctxt.message "Extracted protocol %a" Protocol_hash.pp_short ph >>= fun () ->

8
src/client/embedded/alpha/baker/client_mining_daemon.ml
View File

@ -10,10 +10,10 @@
open Client_commands
open Logging.Client.Mining
let run cctxt ?max_priority ~delay ?min_date delegates =
let run cctxt ?max_priority ~delay ?min_date delegates ~endorsement ~denunciation ~mining =
(* TODO really detach... *)
let endorsement =
if Client_proto_args.Daemon.(!all || !endorsement) then
if endorsement then
Client_mining_blocks.monitor
cctxt.rpc_config ?min_date ~min_heads:1 () >>=? fun block_stream ->
Client_mining_endorsement.create cctxt ~delay delegates block_stream >>= fun () ->
@ -22,7 +22,7 @@ let run cctxt ?max_priority ~delay ?min_date delegates =
return ()
in
let denunciation =
if Client_proto_args.Daemon.(!all || !denunciation) then
if denunciation then
Client_mining_operations.monitor_endorsement
cctxt.rpc_config >>=? fun endorsement_stream ->
Client_mining_denunciation.create cctxt endorsement_stream >>= fun () ->
@ -31,7 +31,7 @@ let run cctxt ?max_priority ~delay ?min_date delegates =
return ()
in
let forge =
if Client_proto_args.Daemon.(!all || !mining) then begin
if mining then begin
Client_mining_blocks.monitor
cctxt.rpc_config ?min_date ~min_heads:1 () >>=? fun block_stream ->
Client_mining_operations.monitor_endorsement

5
src/client/embedded/alpha/baker/client_mining_daemon.mli
View File

@ -12,4 +12,7 @@ val run:
?max_priority: int ->
delay: int ->
?min_date: Time.t ->
public_key_hash list -> unit tzresult Lwt.t
public_key_hash list ->
endorsement:bool ->
denunciation:bool ->
mining:bool -> unit tzresult Lwt.t

47
src/client/embedded/alpha/baker/client_mining_main.ml
View File

@ -94,11 +94,12 @@ let reveal_nonces cctxt ?force () =
open Client_proto_args
let run_daemon cctxt delegates =
let run_daemon cctxt max_priority endorsement_delay delegates ~endorsement ~mining ~denunciation =
Client_mining_daemon.run cctxt
?max_priority:!max_priority
~delay:!endorsement_delay
?max_priority
~delay:endorsement_delay
~min_date:((Time.add (Time.now ()) (Int64.neg 1800L)))
~endorsement ~mining ~denunciation
(List.map snd delegates)
let group =
@ -109,43 +110,47 @@ let commands () =
let open Cli_entries in
[
command ~group ~desc: "Launch a daemon that handles delegate operations."
~args: [endorsement_delay_arg; max_priority_arg;
Daemon.mining_arg ; Daemon.endorsement_arg ; Daemon.denunciation_arg]
(args5 max_priority_arg endorsement_delay_arg
Daemon.mining_switch Daemon.endorsement_switch Daemon.denunciation_switch)
(prefixes [ "launch" ; "daemon" ]
@@ seq_of_param Client_keys.Public_key_hash.alias_param )
(fun delegates cctxt ->
run_daemon cctxt delegates) ;
@@ seq_of_param Client_keys.Public_key_hash.alias_param)
(fun (max_priority, endorsement_delay, mining, endorsement, denunciation) delegates cctxt ->
let (endorsement, mining, denunciation) =
if (not endorsement) && (not mining) && (not denunciation)
then (true, true, true)
else (endorsement, mining, denunciation) in
run_daemon cctxt max_priority endorsement_delay ~endorsement ~mining ~denunciation delegates) ;
command ~group ~desc: "Forge and inject an endorsement operation"
~args: [ force_arg ]
(args2 force_switch max_priority_arg)
(prefixes [ "endorse"; "for" ]
@@ Client_keys.Public_key_hash.alias_param
~name:"miner" ~desc: "name of the delegate owning the endorsement right"
@@ stop)
(fun (_, delegate) cctxt ->
(fun (force, max_priority) (_, delegate) cctxt ->
endorse_block cctxt
~force:!force ?max_priority:!max_priority delegate) ;
~force ?max_priority delegate) ;
command ~group ~desc: "Forge and inject block using the delegate rights"
~args: [ max_priority_arg ; force_arg ; free_mining_arg ]
(args3 max_priority_arg force_switch free_mining_switch)
(prefixes [ "mine"; "for" ]
@@ Client_keys.Public_key_hash.alias_param
~name:"miner" ~desc: "name of the delegate owning the mining right"
@@ stop)
(fun (_, delegate) cctxt ->
(fun (max_priority, force, free_mining) (_, delegate) cctxt ->
mine_block cctxt cctxt.config.block
~force:!force ?max_priority:!max_priority ~free_mining:!free_mining delegate) ;
~force ?max_priority ~free_mining delegate) ;
command ~group ~desc: "Forge and inject a seed-nonce revelation operation"
~args: [ force_arg ]
(args1 force_switch)
(prefixes [ "reveal"; "nonce"; "for" ]
@@ Cli_entries.seq_of_param Block_hash.param)
(fun block_hashes cctxt ->
@@ seq_of_param Block_hash.param)
(fun force block_hashes cctxt ->
reveal_block_nonces cctxt
~force:!force block_hashes) ;
~force block_hashes) ;
command ~group ~desc: "Forge and inject redemption operations"
~args: [ force_arg ]
(args1 force_switch)
(prefixes [ "reveal"; "nonces" ]
@@ stop)
(fun cctxt ->
reveal_nonces cctxt ~force:!force ()) ;
(fun force cctxt ->
reveal_nonces cctxt ~force ()) ;
]
let () =

211
src/client/embedded/alpha/client_proto_args.ml
View File

@ -7,129 +7,156 @@
(* *)
(**************************************************************************)
open Cli_entries
type error += Bad_tez_arg of string * string (* Arg_name * value *)
type error += Bad_max_priority of string
type error += Bad_endorsement_delay of string
let () =
register_error_kind
`Permanent
~id:"badTezArg"
~title:"Bad Tez Arg"
~description:("Invalid \xEA\x9C\xA9 notation in parameter.")
~pp:(fun ppf (arg_name, literal) ->
Format.fprintf ppf
"Invalid \xEA\x9C\xA9 notation in parameter %s: '%s'"
arg_name literal)
Data_encoding.(obj2
(req "parameter" string)
(req "literal" string))
(function Bad_tez_arg (parameter, literal) -> Some (parameter, literal) | _ -> None)
(fun (parameter, literal) -> Bad_tez_arg (parameter, literal)) ;
register_error_kind
`Permanent
~id:"badMaxPriorityArg"
~title:"Bad -max-priority arg"
~description:("invalid priority in -max-priority")
~pp:(fun ppf literal ->
Format.fprintf ppf "invalid priority '%s'in -max-priority" literal)
Data_encoding.(obj1 (req "parameter" string))
(function Bad_max_priority parameter -> Some parameter | _ -> None)
(fun parameter -> Bad_max_priority parameter) ;
register_error_kind
`Permanent
~id:"badEndorsementDelayArg"
~title:"Bad -endorsement-delay arg"
~description:("invalid priority in -endorsement-delay")
~pp:(fun ppf literal ->
Format.fprintf ppf "Bad argument value for -endorsement-delay. Expected an integer, but given '%s'" literal)
Data_encoding.(obj1 (req "parameter" string))
(function Bad_endorsement_delay parameter -> Some parameter | _ -> None)
(fun parameter -> Bad_endorsement_delay parameter)
let tez_sym =
"\xEA\x9C\xA9"
let tez_of_string s =
match Tez.of_string s with
| None -> invalid_arg "tez_of_string"
| Some t -> t
let init = ref "Unit"
let init_arg =
"-init",
Arg.Set_string init,
"The initial value of the contract's storage.\n\
default: unit"
default_arg
~parameter:"-init"
~doc:"The initial value of the contract's storage."
~default:"Unit"
(fun _ s -> return s)
let arg = ref None
let arg_arg =
"-arg",
Arg.String (fun a -> arg := Some a),
"The argument passed to the contract's script, if needed.\n\
default: no argument"
default_arg
~parameter:"-arg"
~doc:"The argument passed to the contract's script, if needed."
~default:"Unit"
(fun _ a -> return a)
let delegate = ref None
let delegate_arg =
"-delegate",
Arg.String (fun s -> delegate := Some s),
"Set the delegate of the contract.\n\
Must be a known identity."
arg
~parameter:"-delegate"
~doc:"Set the delegate of the contract.\
Must be a known identity."
(fun _ s -> return s)
let source = ref None
let source_arg =
"-source",
Arg.String (fun s -> source := Some s),
"Set the source of the bonds to be paid.\n\
Must be a known identity."
arg
~parameter:"-source"
~doc:"Set the source of the bonds to be paid.\
Must be a known identity."
(fun _ s -> return s)
let spendable = ref true
let spendable_args =
[ "-spendable",
Arg.Set spendable,
"Set the created contract to be spendable (default)" ;
"-non-spendable",
Arg.Clear spendable,
"Set the created contract to be non spendable" ]
let non_spendable_switch =
switch
~parameter:"-non-spendable"
~doc:"Set the created contract to be non spendable"
let force = ref false
let force_arg =
"-force",
Arg.Set force,
"Force the injection of branch-invalid operation or force \
\ the injection of bleck without a fitness greater than the \
\ current head."
let force_switch =
switch
~parameter:"-force"
~doc:"Force the injection of branch-invalid operation or force \
\ the injection of block without a fitness greater than the \
\ current head."
let delegatable = ref false
let delegatable_args =
[ "-delegatable",
Arg.Set delegatable,
"Set the created contract to be delegatable" ;
"-non-delegatable",
Arg.Clear delegatable,
"Set the created contract to be non delegatable (default)" ]
let delegatable_switch =
switch
~parameter:"-delegatable"
~doc:"Set the created contract to be delegatable"
let tez_format = "text format: D,DDD,DDD.DD (centiles are optional, commas are optional)"
let tez_arg ~name ~desc ~default =
let ref_cell = ref (tez_of_string default) in
(ref_cell,
(name,
Arg.String (fun s ->
try ref_cell := tez_of_string s
with _ -> raise (Arg.Bad
("invalid \xEA\x9C\xA9 notation in parameter " ^ name))),
(Printf.sprintf
"%s\ndefault: \"%s\"\n%s"
desc
default
tez_format)))
let tez_arg ~default ~parameter ~doc =
default_arg ~parameter ~doc ~default
(fun _ s ->
match Tez.of_string s with
| Some tez -> return tez
| None -> fail (Bad_tez_arg (parameter, s)))
let tez_param ~name ~desc next =
Cli_entries.param
name
(desc ^ " in \xEA\x9C\xA9\n" ^ tez_format)
(fun _ s ->
try return (tez_of_string s)
with _ -> failwith "invalid \xEA\x9C\xA9 notation")
match Tez.of_string s with
| None -> fail (Bad_tez_arg (name, s))
| Some tez -> return tez)
next
let fee, fee_arg =
let fee_arg =
tez_arg
~name:"-fee"
~desc:"The fee in \xEA\x9C\xA9 to pay to the miner."
~default:"0.05"
~parameter:"-fee"
~doc:"The fee in \xEA\x9C\xA9 to pay to the miner."
let max_priority = ref None
let max_priority_arg =
"-max-priority",
Arg.String (fun s ->
try max_priority := Some (int_of_string s)
with _ -> raise (Arg.Bad "invalid priority in -max-priority")),
"Set the max_priority used when looking for mining slot."
arg
~parameter:"-max-priority"
~doc:"Set the max_priority used when looking for mining slot."
(fun _ s ->
try return (int_of_string s)
with _ -> fail (Bad_max_priority s))
let free_mining = ref false
let free_mining_arg =
"-free-mining", Arg.Set free_mining, "Only consider free mining slots."
let free_mining_switch =
switch
~parameter:"-free-mining"
~doc:"Only consider free mining slots."
let endorsement_delay = ref 15
let endorsement_delay_arg =
"-endorsement-delay",
Arg.String (fun s ->
try endorsement_delay := int_of_string s
with _ -> raise (Arg.Bad "invalid priority in -endorsement-delay")),
"Set the delay used before to endorse the current block."
default_arg
~parameter:"-endorsement-delay"
~doc:"Set the delay used before to endorse the current block."
~default:"15"
(fun _ s ->
try return (int_of_string s)
with _ -> fail (Bad_endorsement_delay s))
module Daemon = struct
let all = ref true
let arg r = Arg.Unit (fun () -> all := false; r := true)
let mining = ref false
let mining_arg =
"-mining", arg mining, "Run the mining daemon"
let endorsement = ref false
let endorsement_arg =
"-endorsement", arg endorsement, "Run the endorsement daemon"
let denunciation = ref false
let denunciation_arg =
"-denunciation", arg denunciation, "Run the denunciation daemon"
let mining_switch =
switch
~parameter:"-mining"
~doc:"Run the mining daemon"
let endorsement_switch =
switch
~parameter:"-endorsement"
~doc:"Run the endorsement daemon"
let denunciation_switch =
switch
~parameter:"-denunciation"
~doc:"Run the denunciation daemon"
end

52
src/client/embedded/alpha/client_proto_args.mli
View File

@ -9,47 +9,33 @@
val tez_sym: string
val init_arg: string * Arg.spec * string
val fee_arg: string * Arg.spec * string
val arg_arg: string * Arg.spec * string
val source_arg: string * Arg.spec * string
val delegate_arg: string * Arg.spec * string
val delegatable_args: (string * Arg.spec * string) list
val spendable_args: (string * Arg.spec * string) list
val max_priority_arg: string * Arg.spec * string
val free_mining_arg: string * Arg.spec * string
val force_arg: string * Arg.spec * string
val endorsement_delay_arg: string * Arg.spec * 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 delegate_arg: (string option, Client_commands.context) arg
val delegatable_switch: (bool, Client_commands.context) arg
val non_spendable_switch: (bool, Client_commands.context) arg
val max_priority_arg: (int option, Client_commands.context) arg
val free_mining_switch: (bool, Client_commands.context) arg
val force_switch: (bool, Client_commands.context) arg
val endorsement_delay_arg: (int, Client_commands.context) arg
val tez_arg :
name:string ->
desc:string ->
default:string ->
Tez.tez ref * (string * Arg.spec * string)
parameter:string ->
doc:string ->
(Tez.t, Client_commands.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
val delegate: string option ref
val source: string option ref
val delegatable: bool ref
val spendable: bool ref
val force: bool ref
val fee: Tez.t ref
val init: string ref
val arg: string option ref
val max_priority: int option ref
val free_mining: bool ref
val endorsement_delay: int ref
module Daemon : sig
val mining_arg: string * Arg.spec * string
val endorsement_arg: string * Arg.spec * string
val denunciation_arg: string * Arg.spec * string
val all: bool ref
val mining: bool ref
val endorsement: bool ref
val denunciation: bool ref
val mining_switch: (bool, Client_commands.context) arg
val endorsement_switch: (bool, Client_commands.context) arg
val denunciation_switch: (bool, Client_commands.context) arg
end

439
src/client/embedded/alpha/client_proto_context.ml
View File

@ -43,7 +43,6 @@ let get_branch rpc_config block branch =
let transfer rpc_config
block ?force ?branch
~source ~src_pk ~src_sk ~destination ?arg ~amount ~fee () =
let open Cli_entries in
get_branch rpc_config block branch >>=? fun (net_id, branch) ->
begin match arg with
| Some arg ->
@ -106,7 +105,7 @@ let originate_account rpc_config
let originate_contract rpc_config
block ?force ?branch
~source ~src_pk ~src_sk ~manager_pkh ~balance ?delegatable ?delegatePubKey
~(code:Script.code) ~init ~fee () =
~(code:Script.code) ~init ~fee ~spendable () =
Client_proto_programs.parse_data init >>=? fun storage ->
let storage = Script.{ storage=storage.ast ; storage_type = code.storage_type } in
Client_proto_rpcs.Context.Contract.counter
@ -115,7 +114,7 @@ let originate_contract rpc_config
get_branch rpc_config block branch >>=? fun (net_id, branch) ->
Client_proto_rpcs.Helpers.Forge.Manager.origination rpc_config block
~net_id ~branch ~source ~sourcePubKey:src_pk ~managerPubKey:manager_pkh
~counter ~balance ~spendable:!spendable
~counter ~balance ~spendable:spendable
?delegatable ?delegatePubKey
~script:{ code ; storage } ~fee () >>=? fun bytes ->
let signature = Ed25519.sign src_sk bytes in
@ -229,241 +228,259 @@ let dictate rpc_config block command seckey =
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 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 ;
command ~group ~desc: "access the timestamp of the block" begin
fixed [ "get" ; "timestamp" ]
end 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 ;
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 ;
command ~group ~desc: "lists all non empty contracts of the block" begin
fixed [ "list" ; "contracts" ]
end 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 ;
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 balance of a contract" begin
prefixes [ "get" ; "balance" ; "for" ]
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@@ stop
end 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" Client_proto_programs.print_storage storage >>= fun () ->
return ()
end ;
command ~group ~desc: "get the storage of a contract" begin
prefixes [ "get" ; "storage" ; "for" ]
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@@ stop
end 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" Client_proto_programs.print_storage 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 manager of a contract" begin
prefixes [ "get" ; "manager" ; "for" ]
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@@ stop
end 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" begin
prefixes [ "get" ; "delegate" ; "for" ]
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@@ stop
end 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: "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"
~args: ([ fee_arg ; force_arg ]) begin
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
end begin fun (_, 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:!fee (Some delegate)
>>=? fun oph ->
message_injection cctxt ~force:!force oph >>= fun () ->
return ()
end ;
(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"
~args: ([ fee_arg ; delegate_arg ; force_arg ]
@ delegatable_args @ spendable_args) begin
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
end begin fun neu (_, manager) balance (_, source) cctxt ->
check_contract cctxt neu >>=? 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:!fee
~delegatable:!delegatable ~spendable:!spendable ?delegate:delegate
() >>=? fun (oph, contract) ->
message_injection cctxt
~force:!force ~contracts:[contract] oph >>= fun () ->
RawContractAlias.add cctxt neu contract >>=? fun () ->
message_added_contract cctxt neu >>= fun () ->
return ()
end ;
(args5 fee_arg delegate_arg delegatable_switch
force_switch non_spendable_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, non_spendable)
neu (_, manager) balance (_, source) cctxt ->
check_contract cctxt neu >>=? 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:(not non_spendable) ?delegate:delegate
() >>=? fun (oph, contract) ->
message_injection cctxt
~force:force ~contracts:[contract] oph >>= fun () ->
RawContractAlias.add cctxt neu contract >>=? fun () ->
message_added_contract cctxt neu >>= fun () ->
return ()
end ;
command ~group ~desc: "open a new scripted account"
~args: ([ fee_arg ; delegate_arg ; force_arg ] @
delegatable_args @ spendable_args @ [ init_arg ]) begin
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
end begin fun neu (_, manager) balance (_, source) { ast = code } cctxt ->
check_contract cctxt neu >>=? fun () ->
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:!fee
~delegatable:!delegatable ?delegatePubKey:delegate ~code ~init:!init
() >>=function
| Error errs ->
Client_proto_programs.report_errors cctxt errs >>= fun () ->
cctxt.error "origination simulation failed"
| Ok (oph, contract) ->
message_injection cctxt
~force:!force ~contracts:[contract] oph >>= fun () ->
RawContractAlias.add cctxt neu contract >>=? fun () ->
message_added_contract cctxt neu >>= fun () ->
return ()
end ;
(args6
fee_arg delegate_arg force_switch
delegatable_switch non_spendable_switch init_arg)
(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, non_spendable, init)
neu (_, manager) balance (_, source) { ast = code } cctxt ->
check_contract cctxt neu >>=? fun () ->
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:(not non_spendable)
() >>=function
| Error errs ->
Client_proto_programs.report_errors cctxt errs >>= fun () ->
cctxt.error "origination simulation failed"
| Ok (oph, contract) ->
message_injection cctxt
~force:force ~contracts:[contract] oph >>= fun () ->
RawContractAlias.add cctxt neu contract >>=? fun () ->
message_added_contract cctxt neu >>= fun () ->
return ()
end ;
command ~group ~desc: "open a new (free) account"
~args: ([ fee_arg ; delegate_arg ; force_arg ]
@ delegatable_args @ spendable_args) begin
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 end
begin fun neu (_, manager) cctxt ->
(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 neu (_, manager) cctxt ->
check_contract cctxt neu >>=? fun () ->
faucet cctxt.rpc_config cctxt.config.block
~force:!force ~manager_pkh:manager () >>=? fun (oph, contract) ->
~force:force ~manager_pkh:manager () >>=? fun (oph, contract) ->
message_injection cctxt
~force:!force ~contracts:[contract] oph >>= fun () ->
~force:force ~contracts:[contract] oph >>= fun () ->
RawContractAlias.add cctxt neu contract >>=? fun () ->
message_added_contract cctxt neu >>= fun () ->
return ()
end;
command ~group ~desc: "transfer tokens"
~args: [ fee_arg ; arg_arg ; force_arg ] begin
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
end begin fun 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:!arg ~amount ~fee:!fee () >>= function
| Error errs ->
Client_proto_programs.report_errors cctxt errs >>= fun () ->
cctxt.error "transfer simulation failed"
| Ok (oph, contracts) ->
message_injection cctxt ~force:!force ~contracts oph >>= fun () ->
return ()
end;
(args3 fee_arg arg_arg force_switch)
(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) 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 ->
Client_proto_programs.report_errors cctxt 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" begin
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
end begin fun 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: "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.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" begin
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
end begin fun 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 ;
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.rpc_config cctxt.config.block
(Activate_testnet hash) seckey >>=? fun oph ->
message_injection cctxt ~force:force oph >>= fun () ->
return ()
end ;
]

1
src/client/embedded/alpha/client_proto_context.mli
View File

@ -60,6 +60,7 @@ val originate_contract:
code:Script.code ->
init:string ->
fee:Tez.t ->
spendable:bool ->
unit -> (Operation_hash.t * Contract.t) tzresult Lwt.t
val delegate_contract:

21
src/client/embedded/alpha/client_proto_contracts.ml
View File

@ -166,22 +166,25 @@ let commands () =
[
command ~group ~desc: "add a contract to the wallet"
no_options
(prefixes [ "remember" ; "contract" ]
@@ RawContractAlias.fresh_alias_param
@@ RawContractAlias.source_param
@@ stop)
(fun name hash cctxt ->
(fun () name hash cctxt ->
RawContractAlias.add 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) ;
(fun () (name, _) cctxt -> RawContractAlias.del cctxt name) ;
command ~group ~desc: "lists all known contracts"
no_options
(fixed [ "list" ; "known" ; "contracts" ])
(fun cctxt ->
(fun () cctxt ->
list_contracts cctxt >>=? fun contracts ->
iter_s
(fun (prefix, alias, contract) ->
@ -191,28 +194,31 @@ let commands () =
contracts) ;
command ~group ~desc: "forget all known contracts"
no_options
(fixed [ "forget" ; "all" ; "contracts" ])
(fun cctxt ->
(fun () cctxt ->
fail_unless
cctxt.config.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 ->
(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 ->
(fun () (alias, _contract) new_tags cctxt ->
Contract_tags.find_opt cctxt alias >>=? fun tags ->
let new_tags =
match tags with
@ -221,12 +227,13 @@ let commands () =
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 ->
(fun () (alias, _contract) new_tags cctxt ->
Contract_tags.find_opt cctxt alias >>=? fun tags ->
let new_tags =
match tags with

76
src/client/embedded/alpha/client_proto_programs.ml
View File

@ -100,7 +100,7 @@ let rec print_expr_unwrapped_help emacs locations ppf = function
| None -> Format.fprintf ppf "%s" name
| Some _ as l -> Format.fprintf ppf "%s%a" name print_location_mark l
end
| Script.Prim (loc, name, args, (Some _ as annot)) ->
| Script.Prim (loc, name, _, (Some _ as annot)) ->
Format.fprintf ppf (if emacs then "%s%a %a" else "@[<hov 2>%s%a@ %a]")
name print_location_mark (locations loc) print_annotation annot
| Script.Prim (loc, name, args, annot) ->
@ -698,59 +698,60 @@ let group =
let commands () =
let open Cli_entries in
let show_types = ref false in
let show_types_arg =
"-details",
Arg.Set show_types,
"Show the types of each instruction" in
let emacs_mode = ref false in
let emacs_mode_arg =
"-emacs",
Arg.Set emacs_mode,
"Output in michelson-mode.el compatible format" in
let trace_stack = ref false in
let trace_stack_arg =
"-trace-stack",
Arg.Set trace_stack,
"Show the stack after each step" in
let amount, amount_arg =
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
~name:"-amount"
~desc:"The amount of the transfer in \xEA\x9C\xA9."
~default: "0.00" in
~parameter:"-amount"
~doc:"The amount of the transfer in \xEA\x9C\xA9."
~default:"0.05" in
[
command ~group ~desc: "lists all known programs"
no_options
(fixed [ "list" ; "known" ; "programs" ])
(fun cctxt ->
(fun () cctxt ->
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"
no_options
(prefixes [ "remember" ; "program" ]
@@ Program.fresh_alias_param
@@ Program.source_param
@@ stop)
(fun name hash cctxt -> Program.add cctxt name hash) ;
(fun () name hash cctxt -> Program.add 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) ;
(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 ->
(fun () (_, program) cctxt ->
Program.to_source cctxt program >>=? fun source ->
cctxt.message "%s\n" source >>= fun () ->
return ()) ;
command ~group ~desc: "ask the node to run a program"
~args: [ trace_stack_arg ; amount_arg ]
(args2 trace_stack_switch amount_arg)
(prefixes [ "run" ; "program" ]
@@ Program.source_param
@@ prefixes [ "on" ; "storage" ]
@ -760,15 +761,15 @@ let commands () =
@@ Cli_entries.param ~name:"storage" ~desc:"the input data"
(fun _cctxt data -> parse_data data)
@@ stop)
(fun program storage input cctxt ->
(fun (trace_stack, amount) program storage input cctxt ->
let open Data_encoding in
let print_errors errs =
report_errors cctxt errs >>= fun () ->
cctxt.error "error running program" >>= fun () ->
return () in
if !trace_stack then
if trace_stack then
Client_proto_rpcs.Helpers.trace_code cctxt.rpc_config
cctxt.config.block program.ast (storage.ast, input.ast, !amount) >>= function
cctxt.config.block program.ast (storage.ast, input.ast, amount) >>= function
| Ok (storage, output, trace) ->
cctxt.message
"@[<v 0>@[<v 2>storage@,%a@]@,\
@ -788,7 +789,7 @@ let commands () =
| Error errs -> print_errors errs
else
Client_proto_rpcs.Helpers.run_code cctxt.rpc_config
cctxt.config.block program.ast (storage.ast, input.ast, !amount) >>= function
cctxt.config.block program.ast (storage.ast, input.ast, amount) >>= function
| Ok (storage, output) ->
cctxt.message "@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>output@,%a@]@]@."
(print_expr no_locations) storage
@ -798,15 +799,15 @@ let commands () =
print_errors errs);
command ~group ~desc: "ask the node to typecheck a program"
~args: [ show_types_arg ; emacs_mode_arg ]
(args2 show_types_switch emacs_mode_switch)
(prefixes [ "typecheck" ; "program" ]
@@ Program.source_param
@@ stop)
(fun program cctxt ->
(fun (show_types, emacs_mode) program cctxt ->
let open Data_encoding in
Client_proto_rpcs.Helpers.typecheck_code
cctxt.rpc_config cctxt.config.block program.ast >>= fun res ->
if !emacs_mode then
if emacs_mode then
let emacs_type_map type_map =
(Utils.filter_map
(fun (n, loc) ->
@ -857,7 +858,7 @@ let commands () =
| Ok type_map ->
let type_map, program = unexpand_macros type_map program.ast in
cctxt.message "Well typed" >>= fun () ->
if !show_types then
if show_types then
cctxt.message "%a" (print_program no_locations) (program, type_map) >>= fun () ->
return ()
else return ()
@ -866,6 +867,7 @@ let commands () =
cctxt.error "ill-typed program") ;
command ~group ~desc: "ask the node to typecheck a data expression"
no_options
(prefixes [ "typecheck" ; "data" ]
@@ Cli_entries.param ~name:"data" ~desc:"the data to typecheck"
(fun _cctxt data -> parse_data data)
@ -873,7 +875,7 @@ let commands () =
@@ Cli_entries.param ~name:"type" ~desc:"the expected type"
(fun _cctxt data -> parse_data data)
@@ stop)
(fun data exp_ty cctxt ->
(fun () data exp_ty cctxt ->
let open Data_encoding in
Client_proto_rpcs.Helpers.typecheck_data cctxt.Client_commands.rpc_config
cctxt.config.block (data.ast, exp_ty.ast) >>= function
@ -887,11 +889,12 @@ let commands () =
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"
(fun _cctxt data -> parse_data data)
@@ stop)
(fun data cctxt ->
(fun () data cctxt ->
let open Data_encoding in
Client_proto_rpcs.Helpers.hash_data cctxt.Client_commands.rpc_config
cctxt.config.block (data.ast) >>= function
@ -907,13 +910,14 @@ let commands () =
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"
(fun _cctxt data -> parse_data data)
@@ prefixes [ "for" ]
@@ Client_keys.Secret_key.alias_param
@@ stop)
(fun data (_, key) cctxt ->
(fun () data (_, key) cctxt ->
let open Data_encoding in
Client_proto_rpcs.Helpers.hash_data cctxt.rpc_config
cctxt.config.block (data.ast) >>= function

9
src/client/embedded/demo/client_proto_main.ml
View File

@ -71,16 +71,19 @@ let commands () =
let group = {name = "demo" ; title = "Some demo command" } in
[
command ~group ~desc: "A demo command"
no_options
(fixed [ "demo" ])
(fun cctxt -> demo cctxt) ;
(fun () cctxt -> demo cctxt) ;
command ~group ~desc: "A failing command"
no_options
(fixed [ "fail" ])
(fun _cctxt ->
(fun () _cctxt ->
Error.demo_error 101010
>|= wrap_error) ;
command ~group ~desc: "Mine an empty block"
no_options
(fixed [ "mine" ])
(fun cctxt -> mine cctxt) ;
(fun () cctxt -> mine cctxt) ;
]
let () =

104
src/client/embedded/genesis/client_proto_main.ml
View File

@ -45,60 +45,64 @@ let mine rpc_config ?timestamp block command fitness seckey =
Client_node_rpcs.inject_block rpc_config signed_blk [[]]
let commands () =
let timestamp = ref None in
let args =
[ "-timestamp",
Arg.String (fun t -> timestamp := Some (Time.of_notation_exn t)),
"Set the timestamp of the block (and initial time of the chain)" ] in
let open Cli_entries in
let args =
args1
(arg
~parameter:"-timestamp"
~doc:"Set the timestamp of the block (and initial time of the chain)"
(fun _ t ->
match (Time.of_notation t) with
| None -> Error_monad.failwith "Could not parse value provided to -timestamp option"
| Some t -> return t)) in
[
command ~args ~desc: "Activate a protocol" begin
prefixes [ "activate" ; "protocol" ] @@
Protocol_hash.param ~name:"version" ~desc:"Protocol version (b58check)" @@
prefixes [ "with" ; "fitness" ] @@
param ~name:"fitness"
~desc:"Hardcoded fitness of the first block (integer)"
(fun _ p ->
try return (Int64.of_string p)
with _ -> failwith "Cannot read int64") @@
prefixes [ "and" ; "key" ] @@
Client_keys.Secret_key.source_param
~name:"password" ~desc:"Dictator's key" @@
stop
end begin fun hash fitness seckey cctxt ->
let timestamp = !timestamp in
let fitness =
Client_embedded_proto_alpha.Fitness_repr.from_int64 fitness in
mine cctxt.rpc_config ?timestamp cctxt.config.block
(Activate hash) fitness seckey >>=? fun hash ->
cctxt.answer "Injected %a" Block_hash.pp_short hash >>= fun () ->
return ()
end ;
command ~desc: "Activate a protocol"
args
(prefixes [ "activate" ; "protocol" ]
@@ Protocol_hash.param ~name:"version" ~desc:"Protocol version (b58check)"
@@ prefixes [ "with" ; "fitness" ]
@@ param ~name:"fitness"
~desc:"Hardcoded fitness of the first block (integer)"
(fun _ p ->
try return (Int64.of_string p)
with _ -> failwith "Cannot read int64")
@@ prefixes [ "and" ; "key" ]
@@ Client_keys.Secret_key.source_param
~name:"password" ~desc:"Dictator's key"
@@ stop)
begin fun timestamp hash fitness seckey cctxt ->
let fitness =
Client_embedded_proto_alpha.Fitness_repr.from_int64 fitness in
mine cctxt.rpc_config ?timestamp cctxt.config.block
(Activate hash) fitness seckey >>=? fun hash ->
cctxt.answer "Injected %a" Block_hash.pp_short hash >>= fun () ->
return ()
end ;
command ~args ~desc: "Fork a test protocol" begin
prefixes [ "fork" ; "test" ; "protocol" ] @@
Protocol_hash.param ~name:"version" ~desc:"Protocol version (b58check)" @@
prefixes [ "with" ; "fitness" ] @@
param ~name:"fitness"
~desc:"Hardcoded fitness of the first block (integer)"
(fun _ p ->
try return (Int64.of_string p)
with _ -> failwith "Cannot read int64") @@
prefixes [ "and" ; "key" ] @@
Environment.Ed25519.Secret_key.param
~name:"password" ~desc:"Dictator's key" @@
stop
end begin fun hash fitness seckey cctxt ->
let timestamp = !timestamp in
let fitness =
Client_embedded_proto_alpha.Fitness_repr.from_int64 fitness in
mine cctxt.rpc_config ?timestamp cctxt.config.block
(Activate_testnet (hash, Int64.mul 24L 3600L))
fitness seckey >>=? fun hash ->
cctxt.answer "Injected %a" Block_hash.pp_short hash >>= fun () ->
return ()
end ;
command ~desc: "Fork a test protocol"
args
(prefixes [ "fork" ; "test" ; "protocol" ]
@@ Protocol_hash.param ~name:"version" ~desc:"Protocol version (b58check)"
@@ prefixes [ "with" ; "fitness" ]
@@ param ~name:"fitness"
~desc:"Hardcoded fitness of the first block (integer)"
(fun _ p ->
try return (Int64.of_string p)
with _ -> failwith "Cannot read int64")
@@ prefixes [ "and" ; "key" ]
@@ Environment.Ed25519.Secret_key.param
~name:"password" ~desc:"Dictator's key"
@@ stop)
begin fun timestamp hash fitness seckey cctxt ->
let fitness =
Client_embedded_proto_alpha.Fitness_repr.from_int64 fitness in
mine cctxt.rpc_config ?timestamp cctxt.config.block
(Activate_testnet (hash, Int64.mul 24L 3600L))
fitness seckey >>=? fun hash ->
cctxt.answer "Injected %a" Block_hash.pp_short hash >>= fun () ->
return ()
end ;
]

103
src/client_main.ml
View File

@ -40,54 +40,60 @@ let main () =
Random.self_init () ;
Sodium.Random.stir () ;
Lwt.catch begin fun () ->
let parsed_config_file, block = Client_config.preparse_args Sys.argv in
let rpc_config : Client_rpcs.config = {
Client_rpcs.default_config with
host = parsed_config_file.node_addr ;
port = parsed_config_file.node_port ;
tls = parsed_config_file.tls ;
} in
begin
Client_node_rpcs.Blocks.protocol rpc_config block >>= function
| Ok version ->
Lwt.return (Some version, Client_commands.commands_for_version version)
| Error errs ->
Format.eprintf
"@[<v 2>Ignored error:@,Failed to acquire the protocol version from the node@,%a@."
(Format.pp_print_list pp) errs ;
Lwt.return (None, [])
end >>= fun (_version, commands_for_version) ->
let commands =
Client_generic_rpcs.commands @
Client_network.commands () @
Client_keys.commands () @
Client_protocols.commands () @
Client_helpers.commands () @
commands_for_version in
(Client_config.parse_args
(Cli_entries.usage ~commands)
(Cli_entries.inline_dispatch commands)
Sys.argv >>=? fun (command, parsed_args) ->
let config : Client_commands.cfg = {
base_dir = parsed_config_file.base_dir ;
force = parsed_args.force ;
block ;
web_port = Client_commands.default_cfg.web_port ;
} 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 }
else rpc_config
in
command (cctxt config rpc_config)) >>= function
| Ok () ->
Lwt.return 0
Client_config.parse_config_args Client_commands.default_cfg (List.tl (Array.to_list Sys.argv))
>>=? fun (parsed_config_file, parsed_args, remaining) ->
let rpc_config : Client_rpcs.config = {
Client_rpcs.default_config with
host = parsed_config_file.node_addr ;
port = parsed_config_file.node_port ;
tls = parsed_config_file.tls ;
} in
begin
Client_node_rpcs.Blocks.protocol rpc_config parsed_args.block >>= function
| Ok version ->
return (Some version, Client_commands.commands_for_version version)
| Error errs ->
Format.eprintf
"@[<v 2>Ignored error:@,Failed to acquire the protocol version from the node@,%a@."
(Format.pp_print_list pp) errs ;
return (None, [])
end >>=? fun (_version, commands_for_version) ->
let commands =
Client_generic_rpcs.commands @
Client_network.commands () @
Client_keys.commands () @
Client_protocols.commands () @
Client_helpers.commands () @
commands_for_version in
let config : Client_commands.cfg = {
base_dir = parsed_config_file.base_dir ;
force = parsed_args.force ;
block = parsed_args.block ;
web_port = Client_commands.default_cfg.web_port ;
} 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 }
else rpc_config
in
let client_config = (cctxt config rpc_config) in
(Cli_entries.dispatch
commands
client_config
remaining) end >>=
Cli_entries.handle_cli_errors
~stdout: Format.std_formatter
~stderr: Format.err_formatter
~global_options:Client_config.global_options
>>= function
| Ok i ->
Lwt.return i
| Error errs ->
Format.eprintf "@[<v 2>Fatal error:@,%a@.\
Try `-help` for a list of options and commands.@."
Format.eprintf "@[<v 2>Fatal error:@,%a@."
(Format.pp_print_list Error_monad.pp) errs ;
Lwt.return 1
end begin function
@ -95,12 +101,11 @@ let main () =
Format.printf "%s%!" help ;
Lwt.return 0
| Client_commands.Version_not_found ->
Format.eprintf "Unknown protocol version, try `list versions`.@." ;
Format.eprintf "Unknown protocol version.@." ;
Lwt.return 1
| Failure message ->
Format.eprintf
"Fatal error: %s@.\
Try `-help` for a list of options and commands.@." message ;
"Fatal error: %s@." message ;
Lwt.return 1
| exn ->
Format.printf "Fatal internal error: %s@."

985
src/utils/cli_entries.ml
View File

File diff suppressed because it is too large Load Diff

193
src/utils/cli_entries.mli
View File

@ -12,69 +12,188 @@ open Error_monad
(* Tezos: a small Command Line Parsing library *)
(* Only used in the client. *)
type error += Command_not_found
type error += Bad_argument of int * string
(** {2 Flags and Options } *)
type ('a, 'arg, 'ret) params
type ('arg, 'ret) command
(** {3 Options and Switches } *)
(** Type for option or switch *)
type ('a, 'ctx) arg
(** [arg ~doc ~parameter converter] creates an argument to a command.
The [~parameter] argument should begin with a [-].
If the argument is not provided, [None] is returned *)
val arg : doc:string -> parameter:string ->
('ctx -> string -> 'p tzresult Lwt.t) ->
('p option, 'ctx) arg
(** Create an argument that will contain the [~default] value if it is not provided.
@see arg *)
val default_arg : doc:string -> parameter:string ->
default:string ->
('ctx -> string -> 'p tzresult Lwt.t) ->
('p, 'ctx) arg
(** Create a boolean switch.
The value will be set to [true] if the switch is provided and [false] if it is not. *)
val switch : doc:string -> parameter:string ->
(bool, 'ctx) arg
(** {3 Optional Argument Combinators} *)
(** To specify default arguments ([options]) for a command,
You need to use the following functions,
which allow you to specify how many arguments you have.
If you are not including any arguments, use [no_args]. *)
(** The type of a series of labeled arguments to a command *)
type ('a, 'ctx) options
(** Include no optional parameters *)
val no_options : (unit, 'ctx) options
(** Include 1 optional parameter *)
val args1 :
('a, 'ctx) arg ->
('a, 'ctx) options
(** Include 2 optional parameters *)
val args2 :
('a, 'ctx) arg ->
('b, 'ctx) arg ->
('a * 'b, 'ctx) options
(** Include 3 optional parameters *)
val args3 :
('a, 'ctx) arg ->
('b, 'ctx) arg ->
('c, 'ctx) arg ->
('a * 'b * 'c, 'ctx) options
(** Include 4 optional parameters *)
val args4 :
('a, 'ctx) arg ->
('b, 'ctx) arg ->
('c, 'ctx) arg ->
('d, 'ctx) arg ->
('a * 'b * 'c * 'd, 'ctx) options
(** Include 5 optional parameters *)
val args5 :
('a, 'ctx) arg ->
('b, 'ctx) arg ->
('c, 'ctx) arg ->
('d, 'ctx) arg ->
('e, 'ctx) arg ->
('a * 'b * 'c * 'd * 'e, 'ctx) options
(** Include 6 optional parameters *)
val args6 :
('a, 'ctx) arg ->
('b, 'ctx) arg ->
('c, 'ctx) arg ->
('d, 'ctx) arg ->
('e, 'ctx) arg ->
('f, 'ctx) arg ->
('a * 'b * 'c * 'd * 'e * 'f, 'ctx) options
(** Include 7 optional parameters *)
val args7 :
('a, 'ctx) arg ->
('b, 'ctx) arg ->
('c, 'ctx) arg ->
('d, 'ctx) arg ->
('e, 'ctx) arg -> ('f, 'ctx) arg -> ('g, 'ctx) arg ->
('a * 'b * 'c * 'd * 'e * 'f * 'g, 'ctx) options
(** Include 8 optional parameters *)
val args8 : ('a, 'ctx) arg -> ('b, 'ctx) arg -> ('c, 'ctx) arg -> ('d, 'ctx) arg ->
('e, 'ctx) arg -> ('f, 'ctx) arg -> ('g, 'ctx) arg -> ('h, 'ctx) arg ->
('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h, 'ctx) options
(** Include 9 optional parameters *)
val args9 : ('a, 'ctx) arg -> ('b, 'ctx) arg -> ('c, 'ctx) arg -> ('d, 'ctx) arg ->
('e, 'ctx) arg -> ('f, 'ctx) arg -> ('g, 'ctx) arg -> ('h, 'ctx) arg ->
('i, 'ctx) arg ->
('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i, 'ctx) options
(** Include 10 optional parameters *)
val args10 : ('a, 'ctx) arg -> ('b, 'ctx) arg -> ('c, 'ctx) arg -> ('d, 'ctx) arg ->
('e, 'ctx) arg -> ('f, 'ctx) arg -> ('g, 'ctx) arg -> ('h, 'ctx) arg ->
('i, 'ctx) arg -> ('j, 'ctx) arg ->
('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j, 'ctx) options
(** {2 Parameter based command lines } *)
(** Type of parameters for a command *)
type ('a, 'ctx, 'ret) params
(** A piece of data inside a command line *)
val param:
name: string ->
desc: string ->
('arg -> string -> 'a tzresult Lwt.t) ->
('b, 'arg, 'ret) params ->
('a -> 'b, 'arg, 'ret) params
('ctx -> string -> 'a tzresult Lwt.t) ->
('b, 'ctx, 'ret) params ->
('a -> 'b, 'ctx, 'ret) params
(** A word in a command line.
Should be descriptive. *)
val prefix:
string ->
('a, 'arg, 'ret) params ->
('a, 'arg, 'ret) params
('a, 'ctx, 'ret) params ->
('a, 'ctx, 'ret) params
(** Multiple words given in sequence for a command line *)
val prefixes:
string list ->
('a, 'arg, 'ret) params ->
('a, 'arg, 'ret) params
('a, 'ctx, 'ret) params ->
('a, 'ctx, 'ret) params
(** A fixed series of words that trigger a command. *)
val fixed:
string list ->
('arg -> 'ret tzresult Lwt.t, 'arg, 'ret) params
('ctx -> 'ret tzresult Lwt.t, 'ctx, 'ret) params
(** End the description of the command line *)
val stop:
('arg -> 'ret tzresult Lwt.t, 'arg, 'ret) params
val seq:
name: string ->
desc: string ->
('arg -> string -> 'p tzresult Lwt.t) ->
('p list -> 'arg -> 'ret tzresult Lwt.t, 'arg, 'ret) params
('ctx -> 'ret tzresult Lwt.t, 'ctx, 'ret) params
(** Take a sequence of parameters instead of only a single one.
Must be the last thing in the command line. *)
val seq_of_param:
(('ctx -> 'ret tzresult Lwt.t, 'ctx, 'ret) params ->
('a -> 'ctx -> 'ret tzresult Lwt.t, 'ctx, 'ret) params) ->
('a list -> 'ctx -> 'ret tzresult Lwt.t, 'ctx, 'ret) params
(** Parameter that expects a string *)
val string:
name: string ->
desc: string ->
('a, 'arg, 'ret) params ->
(string -> 'a, 'arg, 'ret) params
('a, 'ctx, 'ret) params ->
(string -> 'a, 'ctx, 'ret) params
val seq_of_param:
(('arg -> 'ret tzresult Lwt.t, 'arg, 'ret) params ->
('a -> 'arg -> 'ret tzresult Lwt.t, 'arg, 'ret) params) ->
('a list -> 'arg -> 'ret tzresult Lwt.t, 'arg, 'ret) params
(** {2 Commands } *)
(** Command, including a parameter specification, optional arguments, and handlers *)
type ('ctx, 'ret) command
(** Type of a group of commands.
Groups have their documentation printed together
and should include a descriptive title. *)
type group =
{ name : string ;
title : string }
(** A complete command, with documentation, a specification of its options, parameters, and handler function *)
val command:
?group: group ->
?args: (Arg.key * Arg.spec * Arg.doc) list ->
desc: string ->
('a, 'arg, 'ret) params -> 'a -> ('arg, 'ret) command
('b, 'ctx) options ->
('a, 'ctx, 'ret) params ->
('b -> 'a) ->
('ctx, 'ret) command
val usage:
commands: ('arg, 'ret) command list ->
(string * Arg.spec * string) list -> string
(** {2 Parsing and error reporting} *)
val inline_dispatch:
('arg, 'ret) command list -> unit ->
[ `Arg of string | `End ] ->
[ `Args of (Arg.key * Arg.spec * Arg.doc) list
| `Fail of error list
| `Nop
| `Res of 'arg -> 'ret tzresult Lwt.t ]
(** Print readable descriptions for CLI parsing errors.
This function must be used for help printing to work. *)
val handle_cli_errors:
stdout: Format.formatter ->
stderr: Format.formatter ->
global_options:(_, _) options ->
'a tzresult -> int tzresult Lwt.t
(** Find and call the applicable command on the series of arguments.
@raises [Failure] if the command list would be ambiguous. *)
val dispatch:
('arg, 'ret) command list -> 'arg -> string list -> 'ret tzresult Lwt.t
('ctx, 'ret) command list -> 'ctx -> string list -> 'ret tzresult Lwt.t
(** Parse the sequence of optional arguments that proceed a command *)
val parse_initial_options :
('a, 'ctx) options ->
'ctx ->
string list ->
('a * string list) tzresult Lwt.t