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 *) (* 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 let (//) = Filename.concat
module Cfg_file = struct module Cfg_file = struct
@ -37,18 +64,18 @@ module Cfg_file = struct
(base_dir, Some node_addr, Some node_port, (base_dir, Some node_addr, Some node_port,
Some tls, Some web_port)) Some tls, Some web_port))
(fun (base_dir, node_addr, node_port, tls, web_port) -> (fun (base_dir, node_addr, node_port, tls, web_port) ->
let open Utils in let open Utils in
let node_addr = unopt ~default:default.node_addr node_addr in let node_addr = unopt ~default:default.node_addr node_addr in
let node_port = unopt ~default:default.node_port node_port in let node_port = unopt ~default:default.node_port node_port in
let tls = unopt ~default:default.tls tls in let tls = unopt ~default:default.tls tls in
let web_port = unopt ~default:default.web_port web_port in let web_port = unopt ~default:default.web_port web_port in
{ base_dir ; node_addr ; node_port ; tls ; web_port }) { base_dir ; node_addr ; node_port ; tls ; web_port })
(obj5 (obj5
(req "base_dir" string) (req "base_dir" string)
(opt "node_addr" string) (opt "node_addr" string)
(opt "node_port" int16) (opt "node_port" int16)
(opt "tls" bool) (opt "tls" bool)
(opt "web_port" int16)) (opt "web_port" int16))
let from_json json = let from_json json =
Data_encoding.Json.destruct encoding json Data_encoding.Json.destruct encoding json
@ -64,31 +91,104 @@ module Cfg_file = struct
end 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 = let default_cli_args = {
try block = Client_commands.default_cfg.block ;
for i = 0 to Array.length argv - 2 do print_timings = false ;
if argv.(i) = name then raise (Found argv.(i+1)) log_requests = false ;
done ; force = false ;
None }
with Found s -> Some s
let preparse_bool name argv = open Cli_entries
try
for i = 0 to Array.length argv - 1 do
if argv.(i) = name then raise (Found "")
done ;
false
with Found _ -> true
let preparse_args argv = (* Command-line only args (not in config file) *)
let base_dir = let base_dir_arg =
match preparse "-base-dir" argv with default_arg
| None -> Client_commands.default_base_dir ~parameter:"-base-dir"
| Some base_dir -> base_dir in ~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 = let config_file =
match preparse "-config-file" argv with match config_file with
| None -> base_dir // "config" | None -> base_dir // "config"
| Some config_file -> config_file in | Some config_file -> config_file in
let config_dir = Filename.dirname 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@." "Error: can't parse the configuration file: %s\n%a@."
config_file (fun ppf exn -> Json_encoding.print_error ppf exn) exn ; config_file (fun ppf exn -> Json_encoding.print_error ppf exn) exn ;
exit 1 in exit 1 in
let tls = cfg.tls || preparse_bool "-tls" argv in let tls = cfg.tls || tls 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 cfg = { cfg with tls ; node_port ; node_addr } 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 if Sys.file_exists base_dir && not (Sys.is_directory base_dir) then begin
Format.eprintf "Error: %s is not a directory.@." base_dir ; Format.eprintf "Error: %s is not a directory.@." base_dir ;
@ -157,87 +233,4 @@ let preparse_args argv =
end ; end ;
IO.mkdir config_dir ; IO.mkdir config_dir ;
if not (Sys.file_exists config_file) then Cfg_file.write config_file cfg ; if not (Sys.file_exists config_file) then Cfg_file.write config_file cfg ;
(cfg, block) (cfg, { block ; print_timings = timings ; log_requests ; force }, remaining)
(* 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"))

21
src/client/client_generic_rpcs.ml
View File

@ -363,36 +363,43 @@ let group =
let commands = [ let commands = [
command ~desc: "list all understood protocol versions" command ~desc: "list all understood protocol versions"
no_options
(fixed [ "list" ; "versions" ]) (fixed [ "list" ; "versions" ])
(fun cctxt -> (fun () cctxt ->
Lwt_list.iter_s Lwt_list.iter_s
(fun (ver, _) -> cctxt.Client_commands.message "%a" Protocol_hash.pp_short ver) (fun (ver, _) -> cctxt.Client_commands.message "%a" Protocol_hash.pp_short ver)
(Client_commands.get_versions ()) >>= fun () -> (Client_commands.get_versions ()) >>= fun () ->
return ()) ; return ()) ;
command ~group ~desc: "list available RPCs (low level command for advanced users)" command ~group ~desc: "list available RPCs (low level command for advanced users)"
no_options
(prefixes [ "rpc" ; "list" ] @@ stop) (prefixes [ "rpc" ; "list" ] @@ stop)
(list "/"); (fun () -> (list "/"));
command ~group ~desc: "list available RPCs (low level command for advanced users)" 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) (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" 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) (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" 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) (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)" 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) (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)" 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" (prefixes [ "rpc" ; "call" ] @@ string ~name: "url" ~desc: "the RPC's URL"
@@ prefix "with" @@ string ~name:"input" ~desc:"the JSON input to the RPC" @@ stop) @@ 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_commands
open Client_config open Client_config
let unique = ref false let unique_switch =
let unique_arg = Cli_entries.switch
"-unique", ~parameter:"-unique"
Arg.Set unique, ~doc:"Fail when there is more than one possible completion."
"Fail when there is more than one possible completion."
let commands () = Cli_entries.[ let commands () = Cli_entries.[
command command
@ -22,27 +21,27 @@ let commands () = Cli_entries.[
given prefix of Base58Check-encoded hash. This actually \ given prefix of Base58Check-encoded hash. This actually \
works only for blocks, operations, public key and contract \ works only for blocks, operations, public key and contract \
identifiers." identifiers."
~args: [unique_arg] (args1 unique_switch)
(prefixes [ "complete" ] @@ (prefixes [ "complete" ] @@
string string
~name: "prefix" ~name: "prefix"
~desc: "the prefix of the Base58Check-encoded hash to be completed" @@ ~desc: "the prefix of the Base58Check-encoded hash to be completed" @@
stop) stop)
(fun prefix cctxt -> (fun unique prefix cctxt ->
Client_node_rpcs.complete Client_node_rpcs.complete
cctxt.rpc_config ~block:cctxt.config.block prefix >>=? fun completions -> cctxt.rpc_config ~block:cctxt.config.block prefix >>=? fun completions ->
match completions with match completions with
| [] -> Pervasives.exit 3 | [] -> Pervasives.exit 3
| _ :: _ :: _ when !unique -> Pervasives.exit 3 | _ :: _ :: _ when unique -> Pervasives.exit 3
| completions -> | completions ->
List.iter print_endline completions ; List.iter print_endline completions ;
return ()) ; return ()) ;
command command
~desc: "Wait for the node to be bootstrapped." ~desc: "Wait for the node to be bootstrapped."
~args: [] no_options
(prefixes [ "bootstrapped" ] @@ (prefixes [ "bootstrapped" ] @@
stop) stop)
(fun cctxt -> (fun () cctxt ->
Client_node_rpcs.bootstrapped cctxt.rpc_config >>=? fun stream -> Client_node_rpcs.bootstrapped cctxt.rpc_config >>=? fun stream ->
Lwt_stream.iter_s (function Lwt_stream.iter_s (function
| Ok (hash, time) -> | Ok (hash, time) ->

33
src/client/client_keys.ml
View File

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

3
src/client/client_network.ml
View File

@ -16,7 +16,8 @@ let group =
let commands () = [ let commands () = [
let open Cli_entries in let open Cli_entries in
command ~group ~desc: "show global network status" 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.stat cctxt.rpc_config >>=? fun stat ->
Client_node_rpcs.Network.connections cctxt.rpc_config >>=? fun conns -> Client_node_rpcs.Network.connections cctxt.rpc_config >>=? fun conns ->
Client_node_rpcs.Network.peers cctxt.rpc_config >>=? fun peers -> 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" command ~group ~desc: "list known protocols"
no_options
(prefixes [ "list" ; "protocols" ] stop) (prefixes [ "list" ; "protocols" ] stop)
(fun cctxt -> (fun () cctxt ->
Client_node_rpcs.Protocols.list cctxt.rpc_config ~contents:false () >>=? fun protos -> 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 () -> Lwt_list.iter_s (fun (ph, _p) -> cctxt.message "%a" Protocol_hash.pp ph) protos >>= fun () ->
return () return ()
); );
command ~group ~desc: "inject a new protocol to the shell database" command ~group ~desc: "inject a new protocol to the shell database"
no_options
(prefixes [ "inject" ; "protocol" ] (prefixes [ "inject" ; "protocol" ]
@@ param ~name:"dir" ~desc:"directory containing a protocol" check_dir @@ param ~name:"dir" ~desc:"directory containing a protocol" check_dir
@@ stop) @@ stop)
(fun dirname cctxt -> (fun () dirname cctxt ->
Lwt.catch Lwt.catch
(fun () -> (fun () ->
let proto = Tezos_compiler.read_dir dirname in let proto = Tezos_compiler.read_dir dirname in
@ -54,10 +56,11 @@ let commands () =
); );
command ~group ~desc: "dump a protocol from the shell database" command ~group ~desc: "dump a protocol from the shell database"
no_options
(prefixes [ "dump" ; "protocol" ] (prefixes [ "dump" ; "protocol" ]
@@ Protocol_hash.param ~name:"protocol hash" ~desc:"" @@ Protocol_hash.param ~name:"protocol hash" ~desc:""
@@ stop) @@ stop)
(fun ph cctxt -> (fun () ph cctxt ->
Client_node_rpcs.Protocols.contents cctxt.rpc_config ph >>=? fun proto -> Client_node_rpcs.Protocols.contents cctxt.rpc_config ph >>=? fun proto ->
Updater.extract "" ph proto >>= fun () -> Updater.extract "" 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 () ->

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

@ -10,10 +10,10 @@
open Client_commands open Client_commands
open Logging.Client.Mining 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... *) (* TODO really detach... *)
let endorsement = let endorsement =
if Client_proto_args.Daemon.(!all || !endorsement) then if endorsement then
Client_mining_blocks.monitor Client_mining_blocks.monitor
cctxt.rpc_config ?min_date ~min_heads:1 () >>=? fun block_stream -> cctxt.rpc_config ?min_date ~min_heads:1 () >>=? fun block_stream ->
Client_mining_endorsement.create cctxt ~delay delegates block_stream >>= fun () -> Client_mining_endorsement.create cctxt ~delay delegates block_stream >>= fun () ->
@ -22,7 +22,7 @@ let run cctxt ?max_priority ~delay ?min_date delegates =
return () return ()
in in
let denunciation = let denunciation =
if Client_proto_args.Daemon.(!all || !denunciation) then if denunciation then
Client_mining_operations.monitor_endorsement Client_mining_operations.monitor_endorsement
cctxt.rpc_config >>=? fun endorsement_stream -> cctxt.rpc_config >>=? fun endorsement_stream ->
Client_mining_denunciation.create cctxt endorsement_stream >>= fun () -> Client_mining_denunciation.create cctxt endorsement_stream >>= fun () ->
@ -31,7 +31,7 @@ let run cctxt ?max_priority ~delay ?min_date delegates =
return () return ()
in in
let forge = let forge =
if Client_proto_args.Daemon.(!all || !mining) then begin if mining then begin
Client_mining_blocks.monitor Client_mining_blocks.monitor
cctxt.rpc_config ?min_date ~min_heads:1 () >>=? fun block_stream -> cctxt.rpc_config ?min_date ~min_heads:1 () >>=? fun block_stream ->
Client_mining_operations.monitor_endorsement 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 -> ?max_priority: int ->
delay: int -> delay: int ->
?min_date: Time.t -> ?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 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 Client_mining_daemon.run cctxt
?max_priority:!max_priority ?max_priority
~delay:!endorsement_delay ~delay:endorsement_delay
~min_date:((Time.add (Time.now ()) (Int64.neg 1800L))) ~min_date:((Time.add (Time.now ()) (Int64.neg 1800L)))
~endorsement ~mining ~denunciation
(List.map snd delegates) (List.map snd delegates)
let group = let group =
@ -109,43 +110,47 @@ let commands () =
let open Cli_entries in let open Cli_entries in
[ [
command ~group ~desc: "Launch a daemon that handles delegate operations." command ~group ~desc: "Launch a daemon that handles delegate operations."
~args: [endorsement_delay_arg; max_priority_arg; (args5 max_priority_arg endorsement_delay_arg
Daemon.mining_arg ; Daemon.endorsement_arg ; Daemon.denunciation_arg] Daemon.mining_switch Daemon.endorsement_switch Daemon.denunciation_switch)
(prefixes [ "launch" ; "daemon" ] (prefixes [ "launch" ; "daemon" ]
@@ seq_of_param Client_keys.Public_key_hash.alias_param ) @@ seq_of_param Client_keys.Public_key_hash.alias_param)
(fun delegates cctxt -> (fun (max_priority, endorsement_delay, mining, endorsement, denunciation) delegates cctxt ->
run_daemon cctxt delegates) ; 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" command ~group ~desc: "Forge and inject an endorsement operation"
~args: [ force_arg ] (args2 force_switch max_priority_arg)
(prefixes [ "endorse"; "for" ] (prefixes [ "endorse"; "for" ]
@@ Client_keys.Public_key_hash.alias_param @@ Client_keys.Public_key_hash.alias_param
~name:"miner" ~desc: "name of the delegate owning the endorsement right" ~name:"miner" ~desc: "name of the delegate owning the endorsement right"
@@ stop) @@ stop)
(fun (_, delegate) cctxt -> (fun (force, max_priority) (_, delegate) cctxt ->
endorse_block 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" 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" ] (prefixes [ "mine"; "for" ]
@@ Client_keys.Public_key_hash.alias_param @@ Client_keys.Public_key_hash.alias_param
~name:"miner" ~desc: "name of the delegate owning the mining right" ~name:"miner" ~desc: "name of the delegate owning the mining right"
@@ stop) @@ stop)
(fun (_, delegate) cctxt -> (fun (max_priority, force, free_mining) (_, delegate) cctxt ->
mine_block cctxt cctxt.config.block 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" command ~group ~desc: "Forge and inject a seed-nonce revelation operation"
~args: [ force_arg ] (args1 force_switch)
(prefixes [ "reveal"; "nonce"; "for" ] (prefixes [ "reveal"; "nonce"; "for" ]
@@ Cli_entries.seq_of_param Block_hash.param) @@ seq_of_param Block_hash.param)
(fun block_hashes cctxt -> (fun force block_hashes cctxt ->
reveal_block_nonces cctxt reveal_block_nonces cctxt
~force:!force block_hashes) ; ~force block_hashes) ;
command ~group ~desc: "Forge and inject redemption operations" command ~group ~desc: "Forge and inject redemption operations"
~args: [ force_arg ] (args1 force_switch)
(prefixes [ "reveal"; "nonces" ] (prefixes [ "reveal"; "nonces" ]
@@ stop) @@ stop)
(fun cctxt -> (fun force cctxt ->
reveal_nonces cctxt ~force:!force ()) ; reveal_nonces cctxt ~force ()) ;
] ]
let () = let () =

213
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 = let tez_sym =
"\xEA\x9C\xA9" "\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 = let init_arg =
"-init", default_arg
Arg.Set_string init, ~parameter:"-init"
"The initial value of the contract's storage.\n\ ~doc:"The initial value of the contract's storage."
default: unit" ~default:"Unit"
(fun _ s -> return s)
let arg = ref None
let arg_arg = let arg_arg =
"-arg", default_arg
Arg.String (fun a -> arg := Some a), ~parameter:"-arg"
"The argument passed to the contract's script, if needed.\n\ ~doc:"The argument passed to the contract's script, if needed."
default: no argument" ~default:"Unit"
(fun _ a -> return a)
let delegate = ref None
let delegate_arg = let delegate_arg =
"-delegate", arg
Arg.String (fun s -> delegate := Some s), ~parameter:"-delegate"
"Set the delegate of the contract.\n\ ~doc:"Set the delegate of the contract.\
Must be a known identity." Must be a known identity."
(fun _ s -> return s)
let source = ref None
let source_arg = let source_arg =
"-source", arg
Arg.String (fun s -> source := Some s), ~parameter:"-source"
"Set the source of the bonds to be paid.\n\ ~doc:"Set the source of the bonds to be paid.\
Must be a known identity." Must be a known identity."
(fun _ s -> return s)
let spendable = ref true let non_spendable_switch =
let spendable_args = switch
[ "-spendable", ~parameter:"-non-spendable"
Arg.Set spendable, ~doc:"Set the created contract to be non spendable"
"Set the created contract to be spendable (default)" ;
"-non-spendable",
Arg.Clear spendable,
"Set the created contract to be non spendable" ]
let force = ref false let force_switch =
let force_arg = switch
"-force", ~parameter:"-force"
Arg.Set force, ~doc:"Force the injection of branch-invalid operation or force \
"Force the injection of branch-invalid operation or force \ \ the injection of block without a fitness greater than the \
\ the injection of bleck without a fitness greater than the \ \ current head."
\ current head."
let delegatable = ref false let delegatable_switch =
let delegatable_args = switch
[ "-delegatable", ~parameter:"-delegatable"
Arg.Set delegatable, ~doc:"Set the created contract to be delegatable"
"Set the created contract to be delegatable" ;
"-non-delegatable",
Arg.Clear delegatable,
"Set the created contract to be non delegatable (default)" ]
let tez_format = "text format: D,DDD,DDD.DD (centiles are optional, commas are optional)" let tez_format = "text format: D,DDD,DDD.DD (centiles are optional, commas are optional)"
let tez_arg ~name ~desc ~default = let tez_arg ~default ~parameter ~doc =
let ref_cell = ref (tez_of_string default) in default_arg ~parameter ~doc ~default
(ref_cell, (fun _ s ->
(name, match Tez.of_string s with
Arg.String (fun s -> | Some tez -> return tez
try ref_cell := tez_of_string s | None -> fail (Bad_tez_arg (parameter, 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_param ~name ~desc next = let tez_param ~name ~desc next =
Cli_entries.param Cli_entries.param
name name
(desc ^ " in \xEA\x9C\xA9\n" ^ tez_format) (desc ^ " in \xEA\x9C\xA9\n" ^ tez_format)
(fun _ s -> (fun _ s ->
try return (tez_of_string s) match Tez.of_string s with
with _ -> failwith "invalid \xEA\x9C\xA9 notation") | None -> fail (Bad_tez_arg (name, s))
| Some tez -> return tez)
next next
let fee, fee_arg = let fee_arg =
tez_arg tez_arg
~name:"-fee"
~desc:"The fee in \xEA\x9C\xA9 to pay to the miner."
~default:"0.05" ~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 = let max_priority_arg =
"-max-priority", arg
Arg.String (fun s -> ~parameter:"-max-priority"
try max_priority := Some (int_of_string s) ~doc:"Set the max_priority used when looking for mining slot."
with _ -> raise (Arg.Bad "invalid priority in -max-priority")), (fun _ s ->
"Set the max_priority used when looking for mining slot." try return (int_of_string s)
with _ -> fail (Bad_max_priority s))
let free_mining = ref false let free_mining_switch =
let free_mining_arg = switch
"-free-mining", Arg.Set free_mining, "Only consider free mining slots." ~parameter:"-free-mining"
~doc:"Only consider free mining slots."
let endorsement_delay = ref 15
let endorsement_delay_arg = let endorsement_delay_arg =
"-endorsement-delay", default_arg
Arg.String (fun s -> ~parameter:"-endorsement-delay"
try endorsement_delay := int_of_string s ~doc:"Set the delay used before to endorse the current block."
with _ -> raise (Arg.Bad "invalid priority in -endorsement-delay")), ~default:"15"
"Set the delay used before to endorse the current block." (fun _ s ->
try return (int_of_string s)
with _ -> fail (Bad_endorsement_delay s))
module Daemon = struct module Daemon = struct
let all = ref true let mining_switch =
let arg r = Arg.Unit (fun () -> all := false; r := true) switch
let mining = ref false ~parameter:"-mining"
let mining_arg = ~doc:"Run the mining daemon"
"-mining", arg mining, "Run the mining daemon" let endorsement_switch =
let endorsement = ref false switch
let endorsement_arg = ~parameter:"-endorsement"
"-endorsement", arg endorsement, "Run the endorsement daemon" ~doc:"Run the endorsement daemon"
let denunciation = ref false let denunciation_switch =
let denunciation_arg = switch
"-denunciation", arg denunciation, "Run the denunciation daemon" ~parameter:"-denunciation"
~doc:"Run the denunciation daemon"
end end

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

@ -9,47 +9,33 @@
val tez_sym: string val tez_sym: string
val init_arg: string * Arg.spec * string open Cli_entries
val fee_arg: string * Arg.spec * string val init_arg: (string, Client_commands.context) arg
val arg_arg: string * Arg.spec * string val fee_arg: (Tez.t, Client_commands.context) arg
val source_arg: string * Arg.spec * string val arg_arg: (string, Client_commands.context) arg
val delegate_arg: string * Arg.spec * string val source_arg: (string option, Client_commands.context) arg
val delegatable_args: (string * Arg.spec * string) list
val spendable_args: (string * Arg.spec * string) list val delegate_arg: (string option, Client_commands.context) arg
val max_priority_arg: string * Arg.spec * string val delegatable_switch: (bool, Client_commands.context) arg
val free_mining_arg: string * Arg.spec * string val non_spendable_switch: (bool, Client_commands.context) arg
val force_arg: string * Arg.spec * string val max_priority_arg: (int option, Client_commands.context) arg
val endorsement_delay_arg: string * Arg.spec * string 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 : val tez_arg :
name:string ->
desc:string ->
default:string -> default:string ->
Tez.tez ref * (string * Arg.spec * string) parameter:string ->
doc:string ->
(Tez.t, Client_commands.context) arg
val tez_param : val tez_param :
name:string -> name:string ->
desc:string -> desc:string ->
('a, Client_commands.context, 'ret) Cli_entries.params -> ('a, Client_commands.context, 'ret) Cli_entries.params ->
(Tez.t -> '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 module Daemon : sig
val mining_arg: string * Arg.spec * string val mining_switch: (bool, Client_commands.context) arg
val endorsement_arg: string * Arg.spec * string val endorsement_switch: (bool, Client_commands.context) arg
val denunciation_arg: string * Arg.spec * string val denunciation_switch: (bool, Client_commands.context) arg
val all: bool ref
val mining: bool ref
val endorsement: bool ref
val denunciation: bool ref
end 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 let transfer rpc_config
block ?force ?branch block ?force ?branch
~source ~src_pk ~src_sk ~destination ?arg ~amount ~fee () = ~source ~src_pk ~src_sk ~destination ?arg ~amount ~fee () =
let open Cli_entries in
get_branch rpc_config block branch >>=? fun (net_id, branch) -> get_branch rpc_config block branch >>=? fun (net_id, branch) ->
begin match arg with begin match arg with
| Some arg -> | Some arg ->
@ -106,7 +105,7 @@ let originate_account rpc_config
let originate_contract rpc_config let originate_contract rpc_config
block ?force ?branch block ?force ?branch
~source ~src_pk ~src_sk ~manager_pkh ~balance ?delegatable ?delegatePubKey ~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 -> Client_proto_programs.parse_data init >>=? fun storage ->
let storage = Script.{ storage=storage.ast ; storage_type = code.storage_type } in let storage = Script.{ storage=storage.ast ; storage_type = code.storage_type } in
Client_proto_rpcs.Context.Contract.counter 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) -> get_branch rpc_config block branch >>=? fun (net_id, branch) ->
Client_proto_rpcs.Helpers.Forge.Manager.origination rpc_config block Client_proto_rpcs.Helpers.Forge.Manager.origination rpc_config block
~net_id ~branch ~source ~sourcePubKey:src_pk ~managerPubKey:manager_pkh ~net_id ~branch ~source ~sourcePubKey:src_pk ~managerPubKey:manager_pkh
~counter ~balance ~spendable:!spendable ~counter ~balance ~spendable:spendable
?delegatable ?delegatePubKey ?delegatable ?delegatePubKey
~script:{ code ; storage } ~fee () >>=? fun bytes -> ~script:{ code ; storage } ~fee () >>=? fun bytes ->
let signature = Ed25519.sign src_sk bytes in 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) ; assert (Operation_hash.equal oph injected_oph) ;
return 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 commands () =
let open Cli_entries in let open Cli_entries in
let open Client_commands 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 command ~group ~desc: "lists all non empty contracts of the block"
fixed [ "get" ; "timestamp" ] no_options
end begin fun cctxt -> (fixed [ "list" ; "contracts" ])
Client_node_rpcs.Blocks.timestamp begin fun () cctxt ->
cctxt.rpc_config cctxt.config.block >>=? fun v -> list_contract_labels cctxt cctxt.config.block >>=? fun contracts ->
cctxt.message "%s" (Time.to_notation v) >>= fun () -> Lwt_list.iter_s
return () (fun (alias, hash, kind) -> cctxt.message "%s%s%s" hash kind alias)
end ; contracts >>= fun () ->
return ()
end ;
command ~group ~desc: "lists all non empty contracts of the block" begin command ~group ~desc: "get the balance of a contract"
fixed [ "list" ; "contracts" ] no_options
end begin fun cctxt -> (prefixes [ "get" ; "balance" ; "for" ]
list_contract_labels cctxt cctxt.config.block >>=? fun contracts -> @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
Lwt_list.iter_s @@ stop)
(fun (alias, hash, kind) -> cctxt.message "%s%s%s" hash kind alias) begin fun () (_, contract) cctxt ->
contracts >>= fun () -> get_balance cctxt.rpc_config cctxt.config.block contract >>=? fun amount ->
return () cctxt.answer "%a %s" Tez.pp amount tez_sym >>= fun () ->
end ; return ()
end ;
command ~group ~desc: "get the balance of a contract" begin command ~group ~desc: "get the storage of a contract"
prefixes [ "get" ; "balance" ; "for" ] no_options
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract" (prefixes [ "get" ; "storage" ; "for" ]
@@ stop @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
end begin fun (_, contract) cctxt -> @@ stop)
get_balance cctxt.rpc_config cctxt.config.block contract >>=? fun amount -> begin fun () (_, contract) cctxt ->
cctxt.answer "%a %s" Tez.pp amount tez_sym >>= fun () -> get_storage cctxt.rpc_config cctxt.config.block contract >>=? function
return () | None ->
end ; 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 command ~group ~desc: "get the manager of a contract"
prefixes [ "get" ; "storage" ; "for" ] no_options
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract" (prefixes [ "get" ; "manager" ; "for" ]
@@ stop @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
end begin fun (_, contract) cctxt -> @@ stop)
get_storage cctxt.rpc_config cctxt.config.block contract >>=? function begin fun () (_, contract) cctxt ->
| None -> Client_proto_contracts.get_manager
cctxt.error "This is not a smart contract." cctxt.rpc_config cctxt.config.block contract >>=? fun manager ->
| Some storage -> Public_key_hash.rev_find cctxt manager >>=? fun mn ->
cctxt.answer "%a" Client_proto_programs.print_storage storage >>= fun () -> Public_key_hash.to_source cctxt manager >>=? fun m ->
return () cctxt.message "%s (%s)" m
end ; (match mn with None -> "unknown" | Some n -> "known as " ^ n) >>= fun () ->
return ()
end ;
command ~group ~desc: "get the manager of a contract" begin command ~group ~desc: "get the delegate of a contract"
prefixes [ "get" ; "manager" ; "for" ] no_options
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract" (prefixes [ "get" ; "delegate" ; "for" ]
@@ stop @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
end begin fun (_, contract) cctxt -> @@ stop)
Client_proto_contracts.get_manager begin fun () (_, contract) cctxt ->
cctxt.rpc_config cctxt.config.block contract >>=? fun manager -> Client_proto_contracts.get_delegate
Public_key_hash.rev_find cctxt manager >>=? fun mn -> cctxt.rpc_config cctxt.config.block contract >>=? fun delegate ->
Public_key_hash.to_source cctxt manager >>=? fun m -> Public_key_hash.rev_find cctxt delegate >>=? fun mn ->
cctxt.message "%s (%s)" m Public_key_hash.to_source cctxt delegate >>=? fun m ->
(match mn with None -> "unknown" | Some n -> "known as " ^ n) >>= fun () -> cctxt.message "%s (%s)" m
return () (match mn with None -> "unknown" | Some n -> "known as " ^ n) >>= fun () ->
end ; 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: "set the delegate of a contract" command ~group ~desc: "set the delegate of a contract"
~args: ([ fee_arg ; force_arg ]) begin (args2 fee_arg force_switch)
prefixes [ "set" ; "delegate" ; "for" ] (prefixes [ "set" ; "delegate" ; "for" ]
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract" @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@@ prefix "to" @@ prefix "to"
@@ Public_key_hash.alias_param @@ Public_key_hash.alias_param
~name: "mgr" ~desc: "new delegate of the contract" ~name: "mgr" ~desc: "new delegate of the contract"
@@ stop @@ stop)
end begin fun (_, contract) (_, delegate) cctxt -> begin fun (fee, force) (_, contract) (_, delegate) cctxt ->
get_manager cctxt contract >>=? fun (_src_name, _src_pkh, src_pk, src_sk) -> get_manager cctxt contract >>=? fun (_src_name, _src_pkh, src_pk, src_sk) ->
delegate_contract delegate_contract
cctxt.rpc_config cctxt.config.block ~source:contract cctxt.rpc_config cctxt.config.block ~source:contract
~src_pk ~manager_sk:src_sk ~fee:!fee (Some delegate) ~src_pk ~manager_sk:src_sk ~fee (Some delegate)
>>=? fun oph -> >>=? fun oph ->
message_injection cctxt ~force:!force oph >>= fun () -> message_injection cctxt ~force:force oph >>= fun () ->
return () return ()
end ; end ;
command ~group ~desc: "open a new account" command ~group ~desc: "open a new account"
~args: ([ fee_arg ; delegate_arg ; force_arg ] (args5 fee_arg delegate_arg delegatable_switch
@ delegatable_args @ spendable_args) begin force_switch non_spendable_switch)
prefixes [ "originate" ; "account" ] (prefixes [ "originate" ; "account" ]
@@ RawContractAlias.fresh_alias_param @@ RawContractAlias.fresh_alias_param
~name: "new" ~desc: "name of the new contract" ~name: "new" ~desc: "name of the new contract"
@@ prefix "for" @@ prefix "for"
@@ Public_key_hash.alias_param @@ Public_key_hash.alias_param
~name: "mgr" ~desc: "manager of the new contract" ~name: "mgr" ~desc: "manager of the new contract"
@@ prefix "transferring" @@ prefix "transferring"
@@ tez_param @@ tez_param
~name: "qty" ~desc: "amount taken from source" ~name: "qty" ~desc: "amount taken from source"
@@ prefix "from" @@ prefix "from"
@@ ContractAlias.alias_param @@ ContractAlias.alias_param
~name:"src" ~desc: "name of the source contract" ~name:"src" ~desc: "name of the source contract"
@@ stop @@ stop)
end begin fun neu (_, manager) balance (_, source) cctxt -> begin fun (fee, delegate, delegatable, force, non_spendable)
check_contract cctxt neu >>=? fun () -> neu (_, manager) balance (_, source) cctxt ->
get_delegate_pkh cctxt !delegate >>=? fun delegate -> check_contract cctxt neu >>=? fun () ->
get_manager cctxt source >>=? fun (_src_name, _src_pkh, src_pk, src_sk) -> get_delegate_pkh cctxt delegate >>=? fun delegate ->
originate_account cctxt.rpc_config cctxt.config.block ~force:!force get_manager cctxt source >>=? fun (_src_name, _src_pkh, src_pk, src_sk) ->
~source ~src_pk ~src_sk ~manager_pkh:manager ~balance ~fee:!fee originate_account cctxt.rpc_config cctxt.config.block ~force:force
~delegatable:!delegatable ~spendable:!spendable ?delegate:delegate ~source ~src_pk ~src_sk ~manager_pkh:manager ~balance ~fee
() >>=? fun (oph, contract) -> ~delegatable:delegatable ~spendable:(not non_spendable) ?delegate:delegate
message_injection cctxt () >>=? fun (oph, contract) ->
~force:!force ~contracts:[contract] oph >>= fun () -> message_injection cctxt
RawContractAlias.add cctxt neu contract >>=? fun () -> ~force:force ~contracts:[contract] oph >>= fun () ->
message_added_contract cctxt neu >>= fun () -> RawContractAlias.add cctxt neu contract >>=? fun () ->
return () message_added_contract cctxt neu >>= fun () ->
end ; return ()
end ;
command ~group ~desc: "open a new scripted account" command ~group ~desc: "open a new scripted account"
~args: ([ fee_arg ; delegate_arg ; force_arg ] @ (args6
delegatable_args @ spendable_args @ [ init_arg ]) begin fee_arg delegate_arg force_switch
prefixes [ "originate" ; "contract" ] delegatable_switch non_spendable_switch init_arg)
@@ RawContractAlias.fresh_alias_param (prefixes [ "originate" ; "contract" ]
~name: "new" ~desc: "name of the new contract" @@ RawContractAlias.fresh_alias_param
@@ prefix "for" ~name: "new" ~desc: "name of the new contract"
@@ Public_key_hash.alias_param @@ prefix "for"
~name: "mgr" ~desc: "manager of the new contract" @@ Public_key_hash.alias_param
@@ prefix "transferring" ~name: "mgr" ~desc: "manager of the new contract"
@@ tez_param @@ prefix "transferring"
~name: "qty" ~desc: "amount taken from source" @@ tez_param
@@ prefix "from" ~name: "qty" ~desc: "amount taken from source"
@@ ContractAlias.alias_param @@ prefix "from"
~name:"src" ~desc: "name of the source contract" @@ ContractAlias.alias_param
@@ prefix "running" ~name:"src" ~desc: "name of the source contract"
@@ Program.source_param @@ prefix "running"
~name:"prg" ~desc: "script of the account\n\ @@ Program.source_param
combine with -init if the storage type is not unit" ~name:"prg" ~desc: "script of the account\n\
@@ stop combine with -init if the storage type is not unit"
end begin fun neu (_, manager) balance (_, source) { ast = code } cctxt -> @@ stop)
check_contract cctxt neu >>=? fun () -> begin fun (fee, delegate, force, delegatable, non_spendable, init)
get_delegate_pkh cctxt !delegate >>=? fun delegate -> neu (_, manager) balance (_, source) { ast = code } cctxt ->
get_manager cctxt source >>=? fun (_src_name, _src_pkh, src_pk, src_sk) -> check_contract cctxt neu >>=? fun () ->
originate_contract cctxt.rpc_config cctxt.config.block ~force:!force get_delegate_pkh cctxt delegate >>=? fun delegate ->
~source ~src_pk ~src_sk ~manager_pkh:manager ~balance ~fee:!fee get_manager cctxt source >>=? fun (_src_name, _src_pkh, src_pk, src_sk) ->
~delegatable:!delegatable ?delegatePubKey:delegate ~code ~init:!init originate_contract cctxt.rpc_config cctxt.config.block ~force:force
() >>=function ~source ~src_pk ~src_sk ~manager_pkh:manager ~balance ~fee
| Error errs -> ~delegatable:delegatable ?delegatePubKey:delegate ~code
Client_proto_programs.report_errors cctxt errs >>= fun () -> ~init
cctxt.error "origination simulation failed" ~spendable:(not non_spendable)
| Ok (oph, contract) -> () >>=function
message_injection cctxt | Error errs ->
~force:!force ~contracts:[contract] oph >>= fun () -> Client_proto_programs.report_errors cctxt errs >>= fun () ->
RawContractAlias.add cctxt neu contract >>=? fun () -> cctxt.error "origination simulation failed"
message_added_contract cctxt neu >>= fun () -> | Ok (oph, contract) ->
return () message_injection cctxt
end ; ~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" command ~group ~desc: "open a new (free) account"
~args: ([ fee_arg ; delegate_arg ; force_arg ] (args1 force_switch)
@ delegatable_args @ spendable_args) begin (prefixes [ "originate" ; "free" ; "account" ]
prefixes [ "originate" ; "free" ; "account" ] @@ RawContractAlias.fresh_alias_param
@@ RawContractAlias.fresh_alias_param ~name: "new" ~desc: "name of the new contract"
~name: "new" ~desc: "name of the new contract" @@ prefix "for"
@@ prefix "for" @@ Public_key_hash.alias_param
@@ Public_key_hash.alias_param ~name: "mgr" ~desc: "manager of the new contract"
~name: "mgr" ~desc: "manager of the new contract" @@ stop)
@@ stop end begin fun force neu (_, manager) cctxt ->
begin fun neu (_, manager) cctxt ->
check_contract cctxt neu >>=? fun () -> check_contract cctxt neu >>=? fun () ->
faucet cctxt.rpc_config cctxt.config.block 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 message_injection cctxt
~force:!force ~contracts:[contract] oph >>= fun () -> ~force:force ~contracts:[contract] oph >>= fun () ->
RawContractAlias.add cctxt neu contract >>=? fun () -> RawContractAlias.add cctxt neu contract >>=? fun () ->
message_added_contract cctxt neu >>= fun () -> message_added_contract cctxt neu >>= fun () ->
return () return ()
end; end;
command ~group ~desc: "transfer tokens" command ~group ~desc: "transfer tokens"
~args: [ fee_arg ; arg_arg ; force_arg ] begin (args3 fee_arg arg_arg force_switch)
prefixes [ "transfer" ] (prefixes [ "transfer" ]
@@ tez_param @@ tez_param
~name: "qty" ~desc: "amount taken from source" ~name: "qty" ~desc: "amount taken from source"
@@ prefix "from" @@ prefix "from"
@@ ContractAlias.alias_param @@ ContractAlias.alias_param
~name: "src" ~desc: "name of the source contract" ~name: "src" ~desc: "name of the source contract"
@@ prefix "to" @@ prefix "to"
@@ ContractAlias.destination_param @@ ContractAlias.destination_param
~name: "dst" ~desc: "name/literal of the destination contract" ~name: "dst" ~desc: "name/literal of the destination contract"
@@ stop @@ stop)
end begin fun amount (_, source) (_, destination) cctxt -> begin fun (fee, arg, force) amount (_, source) (_, destination) cctxt ->
get_manager cctxt source >>=? fun (_src_name, _src_pkh, src_pk, src_sk) -> get_manager cctxt source >>=? fun (_src_name, _src_pkh, src_pk, src_sk) ->
transfer cctxt.rpc_config cctxt.config.block ~force:!force transfer cctxt.rpc_config cctxt.config.block ~force:force
~source ~src_pk ~src_sk ~destination ~source ~src_pk ~src_sk ~destination
?arg:!arg ~amount ~fee:!fee () >>= function ~arg ~amount ~fee () >>= function
| Error errs -> | Error errs ->
Client_proto_programs.report_errors cctxt errs >>= fun () -> Client_proto_programs.report_errors cctxt errs >>= fun () ->
cctxt.error "transfer simulation failed" cctxt.error "transfer simulation failed"
| Ok (oph, contracts) -> | Ok (oph, contracts) ->
message_injection cctxt ~force:!force ~contracts oph >>= fun () -> message_injection cctxt ~force:force ~contracts oph >>= fun () ->
return () return ()
end; end;
command ~desc: "Activate a protocol" begin command ~desc: "Activate a protocol"
prefixes [ "activate" ; "protocol" ] @@ (args1 force_switch)
Protocol_hash.param ~name:"version" ~desc:"Protocol version (b58check)" @@ (prefixes [ "activate" ; "protocol" ]
prefixes [ "with" ; "key" ] @@ @@ Protocol_hash.param ~name:"version"
Environment.Ed25519.Secret_key.param ~desc:"Protocol version (b58check)"
~name:"password" ~desc:"Dictator's key" @@ @@ prefixes [ "with" ; "key" ]
stop @@ Environment.Ed25519.Secret_key.param
end begin fun hash seckey cctxt -> ~name:"password" ~desc:"Dictator's key"
dictate cctxt.rpc_config cctxt.config.block @@ stop)
(Activate hash) seckey >>=? fun oph -> begin fun force hash seckey cctxt ->
message_injection cctxt ~force:!force oph >>= fun () -> dictate cctxt.rpc_config cctxt.config.block
return () (Activate hash) seckey >>=? fun oph ->
end ; message_injection cctxt ~force:force oph >>= fun () ->
return ()
end ;
command ~desc: "Fork a test protocol" begin command ~desc: "Fork a test protocol"
prefixes [ "fork" ; "test" ; "protocol" ] @@ (args1 force_switch)
Protocol_hash.param ~name:"version" ~desc:"Protocol version (b58check)" @@ (prefixes [ "fork" ; "test" ; "protocol" ]
prefixes [ "with" ; "key" ] @@ @@ Protocol_hash.param ~name:"version"
Environment.Ed25519.Secret_key.param ~desc:"Protocol version (b58check)"
~name:"password" ~desc:"Dictator's key" @@ @@ prefixes [ "with" ; "key" ]
stop @@ Environment.Ed25519.Secret_key.param
end begin fun hash seckey cctxt -> ~name:"password" ~desc:"Dictator's key"
dictate cctxt.rpc_config cctxt.config.block @@ stop)
(Activate_testnet hash) seckey >>=? fun oph -> begin fun force hash seckey cctxt ->
message_injection cctxt ~force:!force oph >>= fun () -> dictate cctxt.rpc_config cctxt.config.block
return () (Activate_testnet hash) seckey >>=? fun oph ->
end ; 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 -> code:Script.code ->
init:string -> init:string ->
fee:Tez.t -> fee:Tez.t ->
spendable:bool ->
unit -> (Operation_hash.t * Contract.t) tzresult Lwt.t unit -> (Operation_hash.t * Contract.t) tzresult Lwt.t
val delegate_contract: 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" command ~group ~desc: "add a contract to the wallet"
no_options
(prefixes [ "remember" ; "contract" ] (prefixes [ "remember" ; "contract" ]
@@ RawContractAlias.fresh_alias_param @@ RawContractAlias.fresh_alias_param
@@ RawContractAlias.source_param @@ RawContractAlias.source_param
@@ stop) @@ stop)
(fun name hash cctxt -> (fun () name hash cctxt ->
RawContractAlias.add cctxt name hash) ; RawContractAlias.add cctxt name hash) ;
command ~group ~desc: "remove a contract from the wallet" command ~group ~desc: "remove a contract from the wallet"
no_options
(prefixes [ "forget" ; "contract" ] (prefixes [ "forget" ; "contract" ]
@@ RawContractAlias.alias_param @@ RawContractAlias.alias_param
@@ stop) @@ stop)
(fun (name, _) cctxt -> RawContractAlias.del cctxt name) ; (fun () (name, _) cctxt -> RawContractAlias.del cctxt name) ;
command ~group ~desc: "lists all known contracts" command ~group ~desc: "lists all known contracts"
no_options
(fixed [ "list" ; "known" ; "contracts" ]) (fixed [ "list" ; "known" ; "contracts" ])
(fun cctxt -> (fun () cctxt ->
list_contracts cctxt >>=? fun contracts -> list_contracts cctxt >>=? fun contracts ->
iter_s iter_s
(fun (prefix, alias, contract) -> (fun (prefix, alias, contract) ->
@ -191,28 +194,31 @@ let commands () =
contracts) ; contracts) ;
command ~group ~desc: "forget all known contracts" command ~group ~desc: "forget all known contracts"
no_options
(fixed [ "forget" ; "all" ; "contracts" ]) (fixed [ "forget" ; "all" ; "contracts" ])
(fun cctxt -> (fun () cctxt ->
fail_unless fail_unless
cctxt.config.force cctxt.config.force
(failure "this can only used with option -force true") >>=? fun () -> (failure "this can only used with option -force true") >>=? fun () ->
RawContractAlias.save cctxt []) ; RawContractAlias.save cctxt []) ;
command ~group ~desc: "display a contract from the wallet" command ~group ~desc: "display a contract from the wallet"
no_options
(prefixes [ "show" ; "known" ; "contract" ] (prefixes [ "show" ; "known" ; "contract" ]
@@ RawContractAlias.alias_param @@ RawContractAlias.alias_param
@@ stop) @@ stop)
(fun (_, contract) cctxt -> (fun () (_, contract) cctxt ->
cctxt.message "%a\n%!" Contract.pp contract >>= fun () -> cctxt.message "%a\n%!" Contract.pp contract >>= fun () ->
return ()) ; return ()) ;
command ~group ~desc: "tag a contract in the wallet" command ~group ~desc: "tag a contract in the wallet"
no_options
(prefixes [ "tag" ; "contract" ] (prefixes [ "tag" ; "contract" ]
@@ RawContractAlias.alias_param @@ RawContractAlias.alias_param
@@ prefixes [ "with" ] @@ prefixes [ "with" ]
@@ Contract_tags.tag_param @@ Contract_tags.tag_param
@@ stop) @@ stop)
(fun (alias, _contract) new_tags cctxt -> (fun () (alias, _contract) new_tags cctxt ->
Contract_tags.find_opt cctxt alias >>=? fun tags -> Contract_tags.find_opt cctxt alias >>=? fun tags ->
let new_tags = let new_tags =
match tags with match tags with
@ -221,12 +227,13 @@ let commands () =
Contract_tags.update cctxt alias new_tags) ; Contract_tags.update cctxt alias new_tags) ;
command ~group ~desc: "remove tag(s) from a contract in the wallet" command ~group ~desc: "remove tag(s) from a contract in the wallet"
no_options
(prefixes [ "untag" ; "contract" ] (prefixes [ "untag" ; "contract" ]
@@ RawContractAlias.alias_param @@ RawContractAlias.alias_param
@@ prefixes [ "with" ] @@ prefixes [ "with" ]
@@ Contract_tags.tag_param @@ Contract_tags.tag_param
@@ stop) @@ stop)
(fun (alias, _contract) new_tags cctxt -> (fun () (alias, _contract) new_tags cctxt ->
Contract_tags.find_opt cctxt alias >>=? fun tags -> Contract_tags.find_opt cctxt alias >>=? fun tags ->
let new_tags = let new_tags =
match tags with 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 | None -> Format.fprintf ppf "%s" name
| Some _ as l -> Format.fprintf ppf "%s%a" name print_location_mark l | Some _ as l -> Format.fprintf ppf "%s%a" name print_location_mark l
end 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]") Format.fprintf ppf (if emacs then "%s%a %a" else "@[<hov 2>%s%a@ %a]")
name print_location_mark (locations loc) print_annotation annot name print_location_mark (locations loc) print_annotation annot
| Script.Prim (loc, name, args, annot) -> | Script.Prim (loc, name, args, annot) ->
@ -698,59 +698,60 @@ let group =
let commands () = let commands () =
let open Cli_entries in let open Cli_entries in
let show_types = ref false in let show_types_switch =
let show_types_arg = switch
"-details", ~parameter:"-details"
Arg.Set show_types, ~doc:"Show the types of each instruction" in
"Show the types of each instruction" in let emacs_mode_switch =
let emacs_mode = ref false in switch
let emacs_mode_arg = ~parameter:"-emacs"
"-emacs", ~doc:"Output in michelson-mode.el compatible format" in
Arg.Set emacs_mode, let trace_stack_switch =
"Output in michelson-mode.el compatible format" in switch
let trace_stack = ref false in ~parameter:"-trace-stack"
let trace_stack_arg = ~doc:"Show the stack after each step" in
"-trace-stack", let amount_arg =
Arg.Set trace_stack,
"Show the stack after each step" in
let amount, amount_arg =
Client_proto_args.tez_arg Client_proto_args.tez_arg
~name:"-amount" ~parameter:"-amount"
~desc:"The amount of the transfer in \xEA\x9C\xA9." ~doc:"The amount of the transfer in \xEA\x9C\xA9."
~default: "0.00" in ~default:"0.05" in
[ [
command ~group ~desc: "lists all known programs" command ~group ~desc: "lists all known programs"
no_options
(fixed [ "list" ; "known" ; "programs" ]) (fixed [ "list" ; "known" ; "programs" ])
(fun cctxt -> (fun () cctxt ->
Program.load cctxt >>=? fun list -> Program.load cctxt >>=? fun list ->
Lwt_list.iter_s (fun (n, _) -> cctxt.message "%s" n) list >>= fun () -> Lwt_list.iter_s (fun (n, _) -> cctxt.message "%s" n) list >>= fun () ->
return ()) ; return ()) ;
command ~group ~desc: "remember a program under some name" command ~group ~desc: "remember a program under some name"
no_options
(prefixes [ "remember" ; "program" ] (prefixes [ "remember" ; "program" ]
@@ Program.fresh_alias_param @@ Program.fresh_alias_param
@@ Program.source_param @@ Program.source_param
@@ stop) @@ 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" command ~group ~desc: "forget a remembered program"
no_options
(prefixes [ "forget" ; "program" ] (prefixes [ "forget" ; "program" ]
@@ Program.alias_param @@ Program.alias_param
@@ stop) @@ stop)
(fun (name, _) cctxt -> Program.del cctxt name) ; (fun () (name, _) cctxt -> Program.del cctxt name) ;
command ~group ~desc: "display a program" command ~group ~desc: "display a program"
no_options
(prefixes [ "show" ; "known" ; "program" ] (prefixes [ "show" ; "known" ; "program" ]
@@ Program.alias_param @@ Program.alias_param
@@ stop) @@ stop)
(fun (_, program) cctxt -> (fun () (_, program) cctxt ->
Program.to_source cctxt program >>=? fun source -> Program.to_source cctxt program >>=? fun source ->
cctxt.message "%s\n" source >>= fun () -> cctxt.message "%s\n" source >>= fun () ->
return ()) ; return ()) ;
command ~group ~desc: "ask the node to run a program" 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" ] (prefixes [ "run" ; "program" ]
@@ Program.source_param @@ Program.source_param
@@ prefixes [ "on" ; "storage" ] @@ prefixes [ "on" ; "storage" ]
@ -760,15 +761,15 @@ let commands () =
@@ Cli_entries.param ~name:"storage" ~desc:"the input data" @@ Cli_entries.param ~name:"storage" ~desc:"the input data"
(fun _cctxt data -> parse_data data) (fun _cctxt data -> parse_data data)
@@ stop) @@ stop)
(fun program storage input cctxt -> (fun (trace_stack, amount) program storage input cctxt ->
let open Data_encoding in let open Data_encoding in
let print_errors errs = let print_errors errs =
report_errors cctxt errs >>= fun () -> report_errors cctxt errs >>= fun () ->
cctxt.error "error running program" >>= fun () -> cctxt.error "error running program" >>= fun () ->
return () in return () in
if !trace_stack then if trace_stack then
Client_proto_rpcs.Helpers.trace_code cctxt.rpc_config 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) -> | Ok (storage, output, trace) ->
cctxt.message cctxt.message
"@[<v 0>@[<v 2>storage@,%a@]@,\ "@[<v 0>@[<v 2>storage@,%a@]@,\
@ -788,7 +789,7 @@ let commands () =
| Error errs -> print_errors errs | Error errs -> print_errors errs
else else
Client_proto_rpcs.Helpers.run_code cctxt.rpc_config 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) -> | Ok (storage, output) ->
cctxt.message "@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>output@,%a@]@]@." cctxt.message "@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>output@,%a@]@]@."
(print_expr no_locations) storage (print_expr no_locations) storage
@ -798,15 +799,15 @@ let commands () =
print_errors errs); print_errors errs);
command ~group ~desc: "ask the node to typecheck a program" 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" ] (prefixes [ "typecheck" ; "program" ]
@@ Program.source_param @@ Program.source_param
@@ stop) @@ stop)
(fun program cctxt -> (fun (show_types, emacs_mode) program cctxt ->
let open Data_encoding in let open Data_encoding in
Client_proto_rpcs.Helpers.typecheck_code Client_proto_rpcs.Helpers.typecheck_code
cctxt.rpc_config cctxt.config.block program.ast >>= fun res -> cctxt.rpc_config cctxt.config.block program.ast >>= fun res ->
if !emacs_mode then if emacs_mode then
let emacs_type_map type_map = let emacs_type_map type_map =
(Utils.filter_map (Utils.filter_map
(fun (n, loc) -> (fun (n, loc) ->
@ -857,7 +858,7 @@ let commands () =
| Ok type_map -> | Ok type_map ->
let type_map, program = unexpand_macros type_map program.ast in let type_map, program = unexpand_macros type_map program.ast in
cctxt.message "Well typed" >>= fun () -> cctxt.message "Well typed" >>= fun () ->
if !show_types then if show_types then
cctxt.message "%a" (print_program no_locations) (program, type_map) >>= fun () -> cctxt.message "%a" (print_program no_locations) (program, type_map) >>= fun () ->
return () return ()
else return () else return ()
@ -866,6 +867,7 @@ let commands () =
cctxt.error "ill-typed program") ; cctxt.error "ill-typed program") ;
command ~group ~desc: "ask the node to typecheck a data expression" command ~group ~desc: "ask the node to typecheck a data expression"
no_options
(prefixes [ "typecheck" ; "data" ] (prefixes [ "typecheck" ; "data" ]
@@ Cli_entries.param ~name:"data" ~desc:"the data to typecheck" @@ Cli_entries.param ~name:"data" ~desc:"the data to typecheck"
(fun _cctxt data -> parse_data data) (fun _cctxt data -> parse_data data)
@ -873,7 +875,7 @@ let commands () =
@@ Cli_entries.param ~name:"type" ~desc:"the expected type" @@ Cli_entries.param ~name:"type" ~desc:"the expected type"
(fun _cctxt data -> parse_data data) (fun _cctxt data -> parse_data data)
@@ stop) @@ stop)
(fun data exp_ty cctxt -> (fun () data exp_ty cctxt ->
let open Data_encoding in let open Data_encoding in
Client_proto_rpcs.Helpers.typecheck_data cctxt.Client_commands.rpc_config Client_proto_rpcs.Helpers.typecheck_data cctxt.Client_commands.rpc_config
cctxt.config.block (data.ast, exp_ty.ast) >>= function cctxt.config.block (data.ast, exp_ty.ast) >>= function
@ -887,11 +889,12 @@ let commands () =
command ~group command ~group
~desc: "ask the node to compute the hash of a data expression \ ~desc: "ask the node to compute the hash of a data expression \
using the same algorithm as script instruction H" using the same algorithm as script instruction H"
no_options
(prefixes [ "hash" ; "data" ] (prefixes [ "hash" ; "data" ]
@@ Cli_entries.param ~name:"data" ~desc:"the data to hash" @@ Cli_entries.param ~name:"data" ~desc:"the data to hash"
(fun _cctxt data -> parse_data data) (fun _cctxt data -> parse_data data)
@@ stop) @@ stop)
(fun data cctxt -> (fun () data cctxt ->
let open Data_encoding in let open Data_encoding in
Client_proto_rpcs.Helpers.hash_data cctxt.Client_commands.rpc_config Client_proto_rpcs.Helpers.hash_data cctxt.Client_commands.rpc_config
cctxt.config.block (data.ast) >>= function cctxt.config.block (data.ast) >>= function
@ -907,13 +910,14 @@ let commands () =
using the same algorithm as script instruction H, sign it using \ using the same algorithm as script instruction H, sign it using \
a given secret key, and display it using the format expected by \ a given secret key, and display it using the format expected by \
script instruction CHECK_SIGNATURE" script instruction CHECK_SIGNATURE"
no_options
(prefixes [ "hash" ; "and" ; "sign" ; "data" ] (prefixes [ "hash" ; "and" ; "sign" ; "data" ]
@@ Cli_entries.param ~name:"data" ~desc:"the data to hash" @@ Cli_entries.param ~name:"data" ~desc:"the data to hash"
(fun _cctxt data -> parse_data data) (fun _cctxt data -> parse_data data)
@@ prefixes [ "for" ] @@ prefixes [ "for" ]
@@ Client_keys.Secret_key.alias_param @@ Client_keys.Secret_key.alias_param
@@ stop) @@ stop)
(fun data (_, key) cctxt -> (fun () data (_, key) cctxt ->
let open Data_encoding in let open Data_encoding in
Client_proto_rpcs.Helpers.hash_data cctxt.rpc_config Client_proto_rpcs.Helpers.hash_data cctxt.rpc_config
cctxt.config.block (data.ast) >>= function 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 let group = {name = "demo" ; title = "Some demo command" } in
[ [
command ~group ~desc: "A demo command" command ~group ~desc: "A demo command"
no_options
(fixed [ "demo" ]) (fixed [ "demo" ])
(fun cctxt -> demo cctxt) ; (fun () cctxt -> demo cctxt) ;
command ~group ~desc: "A failing command" command ~group ~desc: "A failing command"
no_options
(fixed [ "fail" ]) (fixed [ "fail" ])
(fun _cctxt -> (fun () _cctxt ->
Error.demo_error 101010 Error.demo_error 101010
>|= wrap_error) ; >|= wrap_error) ;
command ~group ~desc: "Mine an empty block" command ~group ~desc: "Mine an empty block"
no_options
(fixed [ "mine" ]) (fixed [ "mine" ])
(fun cctxt -> mine cctxt) ; (fun () cctxt -> mine cctxt) ;
] ]
let () = 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 [[]] Client_node_rpcs.inject_block rpc_config signed_blk [[]]
let commands () = 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 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 command ~desc: "Activate a protocol"
prefixes [ "activate" ; "protocol" ] @@ args
Protocol_hash.param ~name:"version" ~desc:"Protocol version (b58check)" @@ (prefixes [ "activate" ; "protocol" ]
prefixes [ "with" ; "fitness" ] @@ @@ Protocol_hash.param ~name:"version" ~desc:"Protocol version (b58check)"
param ~name:"fitness" @@ prefixes [ "with" ; "fitness" ]
~desc:"Hardcoded fitness of the first block (integer)" @@ param ~name:"fitness"
(fun _ p -> ~desc:"Hardcoded fitness of the first block (integer)"
try return (Int64.of_string p) (fun _ p ->
with _ -> failwith "Cannot read int64") @@ try return (Int64.of_string p)
prefixes [ "and" ; "key" ] @@ with _ -> failwith "Cannot read int64")
Client_keys.Secret_key.source_param @@ prefixes [ "and" ; "key" ]
~name:"password" ~desc:"Dictator's key" @@ @@ Client_keys.Secret_key.source_param
stop ~name:"password" ~desc:"Dictator's key"
end begin fun hash fitness seckey cctxt -> @@ stop)
let timestamp = !timestamp in begin fun timestamp hash fitness seckey cctxt ->
let fitness = let fitness =
Client_embedded_proto_alpha.Fitness_repr.from_int64 fitness in Client_embedded_proto_alpha.Fitness_repr.from_int64 fitness in
mine cctxt.rpc_config ?timestamp cctxt.config.block mine cctxt.rpc_config ?timestamp cctxt.config.block
(Activate hash) fitness seckey >>=? fun hash -> (Activate hash) 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 () return ()
end ; end ;
command ~args ~desc: "Fork a test protocol" begin command ~desc: "Fork a test protocol"
prefixes [ "fork" ; "test" ; "protocol" ] @@ args
Protocol_hash.param ~name:"version" ~desc:"Protocol version (b58check)" @@ (prefixes [ "fork" ; "test" ; "protocol" ]
prefixes [ "with" ; "fitness" ] @@ @@ Protocol_hash.param ~name:"version" ~desc:"Protocol version (b58check)"
param ~name:"fitness" @@ prefixes [ "with" ; "fitness" ]
~desc:"Hardcoded fitness of the first block (integer)" @@ param ~name:"fitness"
(fun _ p -> ~desc:"Hardcoded fitness of the first block (integer)"
try return (Int64.of_string p) (fun _ p ->
with _ -> failwith "Cannot read int64") @@ try return (Int64.of_string p)
prefixes [ "and" ; "key" ] @@ with _ -> failwith "Cannot read int64")
Environment.Ed25519.Secret_key.param @@ prefixes [ "and" ; "key" ]
~name:"password" ~desc:"Dictator's key" @@ @@ Environment.Ed25519.Secret_key.param
stop ~name:"password" ~desc:"Dictator's key"
end begin fun hash fitness seckey cctxt -> @@ stop)
let timestamp = !timestamp in begin fun timestamp hash fitness seckey cctxt ->
let fitness = let fitness =
Client_embedded_proto_alpha.Fitness_repr.from_int64 fitness in Client_embedded_proto_alpha.Fitness_repr.from_int64 fitness in
mine cctxt.rpc_config ?timestamp cctxt.config.block mine cctxt.rpc_config ?timestamp cctxt.config.block
(Activate_testnet (hash, Int64.mul 24L 3600L)) (Activate_testnet (hash, Int64.mul 24L 3600L))
fitness seckey >>=? fun hash -> 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 () return ()
end ; end ;
] ]

103
src/client_main.ml
View File

@ -40,54 +40,60 @@ let main () =
Random.self_init () ; Random.self_init () ;
Sodium.Random.stir () ; Sodium.Random.stir () ;
Lwt.catch begin fun () -> 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 begin
Client_node_rpcs.Blocks.protocol rpc_config block >>= function Client_config.parse_config_args Client_commands.default_cfg (List.tl (Array.to_list Sys.argv))
| Ok version -> >>=? fun (parsed_config_file, parsed_args, remaining) ->
Lwt.return (Some version, Client_commands.commands_for_version version) let rpc_config : Client_rpcs.config = {
| Error errs -> Client_rpcs.default_config with
Format.eprintf host = parsed_config_file.node_addr ;
"@[<v 2>Ignored error:@,Failed to acquire the protocol version from the node@,%a@." port = parsed_config_file.node_port ;
(Format.pp_print_list pp) errs ; tls = parsed_config_file.tls ;
Lwt.return (None, []) } in
end >>= fun (_version, commands_for_version) -> begin
let commands = Client_node_rpcs.Blocks.protocol rpc_config parsed_args.block >>= function
Client_generic_rpcs.commands @ | Ok version ->
Client_network.commands () @ return (Some version, Client_commands.commands_for_version version)
Client_keys.commands () @ | Error errs ->
Client_protocols.commands () @ Format.eprintf
Client_helpers.commands () @ "@[<v 2>Ignored error:@,Failed to acquire the protocol version from the node@,%a@."
commands_for_version in (Format.pp_print_list pp) errs ;
(Client_config.parse_args return (None, [])
(Cli_entries.usage ~commands) end >>=? fun (_version, commands_for_version) ->
(Cli_entries.inline_dispatch commands) let commands =
Sys.argv >>=? fun (command, parsed_args) -> Client_generic_rpcs.commands @
let config : Client_commands.cfg = { Client_network.commands () @
base_dir = parsed_config_file.base_dir ; Client_keys.commands () @
force = parsed_args.force ; Client_protocols.commands () @
block ; Client_helpers.commands () @
web_port = Client_commands.default_cfg.web_port ; commands_for_version in
} in let config : Client_commands.cfg = {
let rpc_config = base_dir = parsed_config_file.base_dir ;
if parsed_args.print_timings then force = parsed_args.force ;
{ rpc_config with block = parsed_args.block ;
logger = Client_rpcs.timings_logger Format.err_formatter } web_port = Client_commands.default_cfg.web_port ;
else if parsed_args.log_requests } in
then {rpc_config with logger = Client_rpcs.full_logger Format.err_formatter } let rpc_config =
else rpc_config if parsed_args.print_timings then
in { rpc_config with
command (cctxt config rpc_config)) >>= function logger = Client_rpcs.timings_logger Format.err_formatter }
| Ok () -> else if parsed_args.log_requests
Lwt.return 0 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 -> | Error errs ->
Format.eprintf "@[<v 2>Fatal error:@,%a@.\ Format.eprintf "@[<v 2>Fatal error:@,%a@."
Try `-help` for a list of options and commands.@."
(Format.pp_print_list Error_monad.pp) errs ; (Format.pp_print_list Error_monad.pp) errs ;
Lwt.return 1 Lwt.return 1
end begin function end begin function
@ -95,12 +101,11 @@ let main () =
Format.printf "%s%!" help ; Format.printf "%s%!" help ;
Lwt.return 0 Lwt.return 0
| Client_commands.Version_not_found -> | Client_commands.Version_not_found ->
Format.eprintf "Unknown protocol version, try `list versions`.@." ; Format.eprintf "Unknown protocol version.@." ;
Lwt.return 1 Lwt.return 1
| Failure message -> | Failure message ->
Format.eprintf Format.eprintf
"Fatal error: %s@.\ "Fatal error: %s@." message ;
Try `-help` for a list of options and commands.@." message ;
Lwt.return 1 Lwt.return 1
| exn -> | exn ->
Format.printf "Fatal internal error: %s@." 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 *) (* Tezos: a small Command Line Parsing library *)
(* Only used in the client. *) (* Only used in the client. *)
type error += Command_not_found (** {2 Flags and Options } *)
type error += Bad_argument of int * string
type ('a, 'arg, 'ret) params (** {3 Options and Switches } *)
type ('arg, 'ret) command (** 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: val param:
name: string -> name: string ->
desc: string -> desc: string ->
('arg -> string -> 'a tzresult Lwt.t) -> ('ctx -> string -> 'a tzresult Lwt.t) ->
('b, 'arg, 'ret) params -> ('b, 'ctx, 'ret) params ->
('a -> 'b, 'arg, 'ret) params ('a -> 'b, 'ctx, 'ret) params
(** A word in a command line.
Should be descriptive. *)
val prefix: val prefix:
string -> string ->
('a, 'arg, 'ret) params -> ('a, 'ctx, 'ret) params ->
('a, 'arg, 'ret) params ('a, 'ctx, 'ret) params
(** Multiple words given in sequence for a command line *)
val prefixes: val prefixes:
string list -> string list ->
('a, 'arg, 'ret) params -> ('a, 'ctx, 'ret) params ->
('a, 'arg, 'ret) params ('a, 'ctx, 'ret) params
(** A fixed series of words that trigger a command. *)
val fixed: val fixed:
string list -> 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: val stop:
('arg -> 'ret tzresult Lwt.t, 'arg, 'ret) params ('ctx -> 'ret tzresult Lwt.t, 'ctx, 'ret) params
val seq:
name: string ->
desc: string ->
('arg -> string -> 'p tzresult Lwt.t) ->
('p list -> 'arg -> 'ret tzresult Lwt.t, 'arg, '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: val string:
name: string -> name: string ->
desc: string -> desc: string ->
('a, 'arg, 'ret) params -> ('a, 'ctx, 'ret) params ->
(string -> 'a, 'arg, 'ret) params (string -> 'a, 'ctx, 'ret) params
val seq_of_param: (** {2 Commands } *)
(('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
(** 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 = type group =
{ name : string ; { name : string ;
title : string } title : string }
(** A complete command, with documentation, a specification of its options, parameters, and handler function *)
val command: val command:
?group: group -> ?group: group ->
?args: (Arg.key * Arg.spec * Arg.doc) list ->
desc: string -> desc: string ->
('a, 'arg, 'ret) params -> 'a -> ('arg, 'ret) command ('b, 'ctx) options ->
('a, 'ctx, 'ret) params ->
('b -> 'a) ->
('ctx, 'ret) command
val usage: (** {2 Parsing and error reporting} *)
commands: ('arg, 'ret) command list ->
(string * Arg.spec * string) list -> string
val inline_dispatch: (** Print readable descriptions for CLI parsing errors.
('arg, 'ret) command list -> unit -> This function must be used for help printing to work. *)
[ `Arg of string | `End ] -> val handle_cli_errors:
[ `Args of (Arg.key * Arg.spec * Arg.doc) list stdout: Format.formatter ->
| `Fail of error list stderr: Format.formatter ->
| `Nop global_options:(_, _) options ->
| `Res of 'arg -> 'ret tzresult Lwt.t ] '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: 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