From b5e53191e223e336c24070305f8dc864f8d22a34 Mon Sep 17 00:00:00 2001 From: Milo Davis Date: Tue, 19 Sep 2017 11:31:35 +0200 Subject: [PATCH] CLI: New argument parsing and help messages --- src/client/client_config.ml | 275 +++-- src/client/client_generic_rpcs.ml | 21 +- src/client/client_helpers.ml | 19 +- src/client/client_keys.ml | 33 +- src/client/client_network.ml | 3 +- src/client/client_protocols.ml | 9 +- .../alpha/baker/client_mining_daemon.ml | 8 +- .../alpha/baker/client_mining_daemon.mli | 5 +- .../alpha/baker/client_mining_main.ml | 47 +- .../embedded/alpha/client_proto_args.ml | 213 ++-- .../embedded/alpha/client_proto_args.mli | 52 +- .../embedded/alpha/client_proto_context.ml | 439 ++++---- .../embedded/alpha/client_proto_context.mli | 1 + .../embedded/alpha/client_proto_contracts.ml | 21 +- .../embedded/alpha/client_proto_programs.ml | 76 +- src/client/embedded/demo/client_proto_main.ml | 9 +- .../embedded/genesis/client_proto_main.ml | 104 +- src/client_main.ml | 103 +- src/utils/cli_entries.ml | 985 +++++++++++++----- src/utils/cli_entries.mli | 193 +++- 20 files changed, 1644 insertions(+), 972 deletions(-) diff --git a/src/client/client_config.ml b/src/client/client_config.ml index ba142578d..6f547bfdb 100644 --- a/src/client/client_config.ml +++ b/src/client/client_config.ml @@ -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) diff --git a/src/client/client_generic_rpcs.ml b/src/client/client_generic_rpcs.ml index d53c024f3..b8d996eb5 100644 --- a/src/client/client_generic_rpcs.ml +++ b/src/client/client_generic_rpcs.ml @@ -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) ] diff --git a/src/client/client_helpers.ml b/src/client/client_helpers.ml index 0da3e6fa6..326f6036f 100644 --- a/src/client/client_helpers.ml +++ b/src/client/client_helpers.ml @@ -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) -> diff --git a/src/client/client_keys.ml b/src/client/client_keys.ml index 39bc44299..8dd05df88 100644 --- a/src/client/client_keys.ml +++ b/src/client/client_keys.ml @@ -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 () -> diff --git a/src/client/client_network.ml b/src/client/client_network.ml index deb12a365..8a22ebf06 100644 --- a/src/client/client_network.ml +++ b/src/client/client_network.ml @@ -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 -> diff --git a/src/client/client_protocols.ml b/src/client/client_protocols.ml index 4601e892b..cf58751e0 100644 --- a/src/client/client_protocols.ml +++ b/src/client/client_protocols.ml @@ -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 () -> diff --git a/src/client/embedded/alpha/baker/client_mining_daemon.ml b/src/client/embedded/alpha/baker/client_mining_daemon.ml index 6a62bfb5e..da56c0df9 100644 --- a/src/client/embedded/alpha/baker/client_mining_daemon.ml +++ b/src/client/embedded/alpha/baker/client_mining_daemon.ml @@ -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 diff --git a/src/client/embedded/alpha/baker/client_mining_daemon.mli b/src/client/embedded/alpha/baker/client_mining_daemon.mli index bbb3fa317..936311bb1 100644 --- a/src/client/embedded/alpha/baker/client_mining_daemon.mli +++ b/src/client/embedded/alpha/baker/client_mining_daemon.mli @@ -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 diff --git a/src/client/embedded/alpha/baker/client_mining_main.ml b/src/client/embedded/alpha/baker/client_mining_main.ml index fc262601d..75f8df442 100644 --- a/src/client/embedded/alpha/baker/client_mining_main.ml +++ b/src/client/embedded/alpha/baker/client_mining_main.ml @@ -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 () = diff --git a/src/client/embedded/alpha/client_proto_args.ml b/src/client/embedded/alpha/client_proto_args.ml index 87c51a582..ad295d871 100644 --- a/src/client/embedded/alpha/client_proto_args.ml +++ b/src/client/embedded/alpha/client_proto_args.ml @@ -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" - -let delegate = ref None + default_arg + ~parameter:"-arg" + ~doc:"The argument passed to the contract's script, if needed." + ~default:"Unit" + (fun _ a -> return a) + 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 diff --git a/src/client/embedded/alpha/client_proto_args.mli b/src/client/embedded/alpha/client_proto_args.mli index b5d992158..f4ed966a6 100644 --- a/src/client/embedded/alpha/client_proto_args.mli +++ b/src/client/embedded/alpha/client_proto_args.mli @@ -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 diff --git a/src/client/embedded/alpha/client_proto_context.ml b/src/client/embedded/alpha/client_proto_context.ml index 6ea794502..fa918aba4 100644 --- a/src/client/embedded/alpha/client_proto_context.ml +++ b/src/client/embedded/alpha/client_proto_context.ml @@ -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 ; ] diff --git a/src/client/embedded/alpha/client_proto_context.mli b/src/client/embedded/alpha/client_proto_context.mli index 7f9ba1142..fa967002e 100644 --- a/src/client/embedded/alpha/client_proto_context.mli +++ b/src/client/embedded/alpha/client_proto_context.mli @@ -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: diff --git a/src/client/embedded/alpha/client_proto_contracts.ml b/src/client/embedded/alpha/client_proto_contracts.ml index 1a55f60f5..a5aaeefec 100644 --- a/src/client/embedded/alpha/client_proto_contracts.ml +++ b/src/client/embedded/alpha/client_proto_contracts.ml @@ -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 diff --git a/src/client/embedded/alpha/client_proto_programs.ml b/src/client/embedded/alpha/client_proto_programs.ml index d7e4ee211..582becc14 100644 --- a/src/client/embedded/alpha/client_proto_programs.ml +++ b/src/client/embedded/alpha/client_proto_programs.ml @@ -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 "@[%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 "@[@[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 "@[@[storage@,%a@]@,@[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 diff --git a/src/client/embedded/demo/client_proto_main.ml b/src/client/embedded/demo/client_proto_main.ml index 1d94f9815..c71488c82 100644 --- a/src/client/embedded/demo/client_proto_main.ml +++ b/src/client/embedded/demo/client_proto_main.ml @@ -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 () = diff --git a/src/client/embedded/genesis/client_proto_main.ml b/src/client/embedded/genesis/client_proto_main.ml index 1f49fce67..9f6e09f8e 100644 --- a/src/client/embedded/genesis/client_proto_main.ml +++ b/src/client/embedded/genesis/client_proto_main.ml @@ -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 ; ] diff --git a/src/client_main.ml b/src/client_main.ml index 8666a34dc..b67a45670 100644 --- a/src/client_main.ml +++ b/src/client_main.ml @@ -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 - "@[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 + "@[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 "@[Fatal error:@,%a@.\ - Try `-help` for a list of options and commands.@." + Format.eprintf "@[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@." diff --git a/src/utils/cli_entries.ml b/src/utils/cli_entries.ml index 561416657..d041e6618 100644 --- a/src/utils/cli_entries.ml +++ b/src/utils/cli_entries.ml @@ -11,34 +11,202 @@ open Error_monad open Lwt.Infix +open Utils (* User catchable exceptions *) -type error += Command_not_found type error += Bad_argument of int * string +type error += Option_expected_argument of string +type error += Unknown_option of string +type error += Invalid_options_combination of string -let () = - register_error_kind - `Branch - ~id: "cli.command_not_found" - ~title: "Command not found" - ~description: "No command found to interpret the given command line" - ~pp: - (fun ppf () -> - Format.fprintf ppf "Command not found") - Data_encoding.empty - (function Command_not_found -> Some () | _ -> None) - (fun () -> Command_not_found) ; - register_error_kind - `Branch - ~id: "cli.bad_argument" - ~title: "Bad argument" - ~description: "Error in a command line argument" - ~pp: - (fun ppf (i, v) -> - Format.fprintf ppf "Error in command line argument %d (%s)" i v) - Data_encoding.(obj2 (req "index" uint8) (req "value" string)) - (function Bad_argument (i, v) -> Some (i, v) | _ -> None) - (fun (i, v) -> Bad_argument (i, v)) +type ('a, 'arg) arg = + | Arg : { doc : string ; + parameter : string ; + kind : 'arg -> string -> 'p tzresult Lwt.t } -> + ('p option, 'arg) arg + | DefArg : { doc : string ; + parameter : string ; + kind : 'arg -> string -> 'p tzresult Lwt.t ; + default : string } -> ('p, 'arg) arg + | Switch : { doc : string ; + parameter : string } -> + (bool, 'arg) arg + +let arg ~doc ~parameter kind = + Arg { doc ; + parameter ; + kind } + +let default_arg ~doc ~parameter ~default kind = + DefArg { doc ; + parameter ; + kind ; + default } + +let switch ~doc ~parameter = + Switch {doc ; parameter} + +type ('a, 'arg) args = + | NoArgs : (unit, 'args) args + | AddArg : ('a, 'args) arg * ('b, 'args) args -> + ('a * 'b, 'args) args + +let parse_arg : + type a ctx. (a, ctx) arg -> string option StringMap.t -> ctx -> a tzresult Lwt.t = + fun spec args_dict ctx -> + match spec with + | Arg { parameter ; kind } -> + begin + try + begin + match StringMap.find parameter args_dict with + | None -> return None + | Some s -> + (kind ctx s) >>|? fun x -> + Some x + end + with Not_found -> + return None + end + | DefArg { parameter ; kind ; default } -> + kind ctx default >>= fun default -> + begin match default with + | Ok x -> return x + | Error _ -> + invalid_arg + (Format.sprintf + "Value provided as default for '%s' could not be parsed by converter function." + parameter) end >>=? fun default -> + begin try + match StringMap.find parameter args_dict with + | None -> return default + | Some s -> kind ctx s + with Not_found -> return default + end + | Switch { parameter } -> + return (StringMap.mem parameter args_dict) + +(* Argument parsing *) +let rec parse_args : + type a ctx. (a, ctx) args -> string option StringMap.t -> ctx -> a tzresult Lwt.t = + fun spec args_dict ctx -> + match spec with + | NoArgs -> return () + | AddArg (arg, rest) -> + parse_arg arg args_dict ctx >>=? fun arg -> + parse_args rest args_dict ctx >>|? fun rest -> + (arg, rest) + +let empty_args_dict = StringMap.empty + +let rec make_arities_dict : + type a b. int StringMap.t -> (a, b) args -> int StringMap.t = + fun acc -> function + | NoArgs -> acc + | AddArg (arg, rest) -> + let recur parameter num = + make_arities_dict (StringMap.add parameter num acc) rest in + begin + match arg with + | Arg { parameter } -> recur parameter 1 + | DefArg { parameter } -> recur parameter 1 + | Switch { parameter } -> recur parameter 0 + end + + +let check_help_flag error = function + | ("-help" | "--help") :: _ -> fail error + | _ -> return () + +let make_args_dict_consume help_flag spec args = + let rec make_args_dict arities acc args = + check_help_flag help_flag args >>=? fun () -> + match args with + | [] -> return (acc, []) + | arg :: tl -> + if StringMap.mem arg arities + then let arity = StringMap.find arg arities in + check_help_flag help_flag tl >>=? fun () -> + match arity, tl with + | 0, tl' -> make_args_dict arities (StringMap.add arg None acc) tl' + | 1, value :: tl' -> + make_args_dict arities (StringMap.add arg (Some value) acc) tl' + | 1, [] -> + fail (Option_expected_argument arg) + | _, _ -> + raise (Failure "cli_entries: Arguments with arity not equal to 1 or 0 not supported") + else return (acc, args) + in make_args_dict (make_arities_dict StringMap.empty spec) StringMap.empty args + +let make_args_dict_filter help_flag spec args = + let rec make_args_dict arities (dict, other_args) args = + check_help_flag help_flag args >>=? fun () -> + match args with + | [] -> return (dict, other_args) + | arg :: tl -> + if StringMap.mem arg arities + then let arity = StringMap.find arg arities in + check_help_flag help_flag tl >>=? fun () -> + match arity, tl with + | 0, tl -> make_args_dict arities (StringMap.add arg None dict, other_args) tl + | 1, value :: tl' -> make_args_dict arities (StringMap.add arg (Some value) dict, other_args) tl' + | 1, [] -> fail (Option_expected_argument arg) + | _, _ -> + raise (Failure "cli_entries: Arguments with arity not equal to 1 or 0 not suppored") + else make_args_dict arities (dict, arg :: other_args) tl + in make_args_dict + (make_arities_dict StringMap.empty spec) + (StringMap.empty, []) + args >>|? fun (dict, remaining) -> + (dict, List.rev remaining) + +let make_args_dict help_handler spec args = + make_args_dict_consume help_handler spec args >>=? fun (args, remaining) -> + match remaining with + | [] -> return args + | hd :: _ -> fail (Unknown_option hd) + +type (_, _) options = + Argument : { spec : ('a, 'arg) args ; + converter : 'a -> 'b } -> ('b, 'arg) options +let (>>) arg1 arg2 = AddArg (arg1, arg2) +let args1 spec = + Argument { spec = spec >> NoArgs; + converter = fun (arg, ()) -> arg } +let args2 spec1 spec2 = + Argument { spec = spec1 >> (spec2 >> NoArgs) ; + converter = fun (arg1, (arg2, ())) -> arg1, arg2 } +let args3 spec1 spec2 spec3 = + Argument { spec = spec1 >> (spec2 >> (spec3 >> NoArgs)) ; + converter = fun (arg1, (arg2, (arg3, ()))) -> arg1, arg2, arg3 } +let args4 spec1 spec2 spec3 spec4 = + Argument { spec = spec1 >> (spec2 >> (spec3 >> (spec4 >> NoArgs))) ; + converter = fun (arg1, (arg2, (arg3, (arg4, ())))) -> arg1, arg2, arg3, arg4 } +let args5 spec1 spec2 spec3 spec4 spec5 = + Argument { spec = spec1 >> (spec2 >> (spec3 >> (spec4 >> (spec5 >> NoArgs)))) ; + converter = fun (arg1, (arg2, (arg3, (arg4, (arg5, ()))))) -> arg1, arg2, arg3, arg4, arg5 } +let args6 spec1 spec2 spec3 spec4 spec5 spec6 = + Argument { spec = spec1 >> (spec2 >> (spec3 >> (spec4 >> (spec5 >> (spec6 >> NoArgs))))) ; + converter = fun (arg1, (arg2, (arg3, (arg4, (arg5, (spec6, ())))))) -> + arg1, arg2, arg3, arg4, arg5, spec6 } +let args7 spec1 spec2 spec3 spec4 spec5 spec6 spec7 = + Argument { spec = spec1 >> (spec2 >> (spec3 >> (spec4 >> (spec5 >> (spec6 >> (spec7 >> NoArgs)))))) ; + converter = fun (arg1, (arg2, (arg3, (arg4, (arg5, (spec6, (spec7, ()))))))) -> + arg1, arg2, arg3, arg4, arg5, spec6, spec7 } +let args8 spec1 spec2 spec3 spec4 spec5 spec6 spec7 spec8 = + Argument { spec = spec1 >> (spec2 >> (spec3 >> (spec4 >> (spec5 >> (spec6 >> (spec7 >> (spec8 >> NoArgs))))))) ; + converter = fun (arg1, (arg2, (arg3, (arg4, (arg5, (spec6, (spec7, (spec8, ())))))))) -> + arg1, arg2, arg3, arg4, arg5, spec6, spec7, spec8 } +let args9 spec1 spec2 spec3 spec4 spec5 spec6 spec7 spec8 spec9 = + Argument + { spec = spec1 >> (spec2 >> (spec3 >> (spec4 >> (spec5 >> (spec6 >> (spec7 >> (spec8 >> (spec9 >> NoArgs)))))))) ; + converter = fun (arg1, (arg2, (arg3, (arg4, (arg5, (spec6, (spec7, (spec8, (spec9, ()))))))))) -> + arg1, arg2, arg3, arg4, arg5, spec6, spec7, spec8, spec9 } +let args10 spec1 spec2 spec3 spec4 spec5 spec6 spec7 spec8 spec9 spec10 = + Argument + { spec = spec1 >> (spec2 >> (spec3 >> (spec4 >> (spec5 >> (spec6 >> (spec7 >> (spec8 >> (spec9 >> (spec10 >> NoArgs))))))))) ; + converter = fun (arg1, (arg2, (arg3, (arg4, (arg5, (spec6, (spec7, (spec8, (spec9, (spec10, ())))))))))) -> + arg1, arg2, arg3, arg4, arg5, spec6, spec7, spec8, spec9, spec10 } (* A simple structure for command interpreters. This is more generic than the exported one, see end of file. *) @@ -51,8 +219,6 @@ type ('a, 'arg, 'ret) params = ('p -> 'a, 'arg, 'ret) params | Stop : ('arg -> 'ret tzresult Lwt.t, 'arg, 'ret) params - | More : - (string list -> 'arg -> 'ret tzresult Lwt.t, 'arg, 'ret) params | Seq : string * string * ('arg -> string -> 'p tzresult Lwt.t) -> ('p list -> 'arg -> 'ret tzresult Lwt.t, 'arg, 'ret) params @@ -65,13 +231,27 @@ type group = (* A command wraps a callback with its type and info *) type ('arg, 'ret) command = | Command - : { params: ('a, 'arg, 'ret) params ; - handler : 'a ; + : { params : ('a, 'arg, 'ret) params ; + options : ('b, 'arg) options ; + handler : 'b -> 'a ; desc : string ; - group : group option ; - args : (Arg.key * Arg.spec * Arg.doc) list } + group : group option } -> ('arg, 'ret) command +type error += Extra_arguments : string list * (_, _) command -> error +type error += Not_enough_args : string list * ('a, 'b) command list -> error +type error += Command_not_found : string list * ('a, 'b) command list -> error +type error += Help_flag : ('a, 'b) command list -> error (* when -help appears in input *) +type error += Help_cmd : string list * ('a, 'b) command list * bool * bool -> error (* ./tezos-client help *) +type error += Bare_help : error (* ./tezos-client or ./tezos-client -help *) + +let parse_initial_options : + type a ctx. (a, ctx) options -> ctx -> string list -> (a * string list) tzresult Lwt.t = + fun (Argument { spec ; converter }) ctx args -> + make_args_dict_consume Bare_help spec args >>=? fun (dict, remaining) -> + parse_args spec dict ctx >>|? fun nested -> + (converter nested, remaining) + (* Some combinators for writing commands concisely. *) let param ~name ~desc kind next = Param (name, desc, kind, next) let seq ~name ~desc kind = Seq (name, desc, kind) @@ -86,52 +266,107 @@ let rec fixed = let rec prefixes p next = match p with [] -> next | n :: r -> Prefix (n, prefixes r next) let stop = Stop -let more = More -let void = Stop -let any = More -let command ?group ?(args = []) ~desc params handler = - Command { params ; handler ; desc ; group ; args } +let no_options = Argument { spec=NoArgs ; converter=fun () -> () } +let command ?group ~desc options params handler = + Command { params ; options ; handler ; desc ; group } (* Param combinators *) let string ~name ~desc next = param name desc (fun _ s -> return s) next +(* Help commands *) +let help_group = + { name = "man" ; + title = "Access the documentation" } + +let rec string_contains ~needle ~haystack = + try + Some (Str.search_forward (Str.regexp_string needle) haystack 0) + with Not_found -> + None + +let rec search_params_prefix : type a arg ret. string -> (a, arg, ret) params -> bool = + fun prefix -> function + | Prefix (keyword, next) -> + begin + match string_contains ~needle:prefix ~haystack:keyword with + | None -> search_params_prefix prefix next + | Some _ -> true + end + | Param (_, _, _, next) -> search_params_prefix prefix next + | Stop -> false + | Seq _ -> false + +let search_command keyword (Command { params }) = + search_params_prefix keyword params + +let rec help_commands commands = + [ command + ~group:help_group + ~desc:"Print documentation of commands. \ + Add search keywords to narrow list. \ + Will display only the commands by default, \ + unless [-verbose] is passed or the list \ + of matching commands if less than 3." + (args2 + (switch + ~doc:"Print terse output, regardless of number of commands returned" + ~parameter:"-terse") + (switch + ~doc:"Print detailed output, regardless of number of commands returned" + ~parameter:"-verbose")) + (prefix "man" @@ seq_of_param (string ~name:"keyword" ~desc:"Keyword to search for")) + (fun (terse, details) keywords _ -> + if terse && details + then fail (Invalid_options_combination "Cannot specify both -verbose and -terse.") + else + fail (Help_cmd (keywords, + List.fold_left + (fun commands keyword -> List.filter (search_command keyword) commands) + (help_commands [] @ commands) + keywords, + terse, + details))) ] + (* Command execution *) let exec (type arg) (type ret) - (Command { params ; handler }) (last : arg) args = + (Command { options=(Argument { converter ; spec=options_spec }) ; + params=spec ; + handler }) + (ctx : arg) params args_dict = let rec exec : type a. int -> (a, arg, ret) params -> a -> string list -> ret tzresult Lwt.t - = fun i params cb args -> - match params, args with - | Stop, [] -> cb last - | Stop, _ -> fail Command_not_found - | Seq (_, _, f), seq -> - let rec do_seq i acc = function - | [] -> return (List.rev acc) - | p :: rest -> - Lwt.catch - (fun () -> f last p) - (function - | Failure msg -> Error_monad.failwith "%s" msg - | exn -> fail (Exn exn)) - |> trace (Bad_argument (i, p)) >>=? fun v -> - do_seq (succ i) (v :: acc) rest in - do_seq i [] seq >>=? fun parsed -> - cb parsed last - | More, rest -> cb rest last - | Prefix (n, next), p :: rest when n = p -> - exec (succ i) next cb rest - | Param (_, _, f, next), p :: rest -> - Lwt.catch - (fun () -> f last p) - (function - | Failure msg -> Error_monad.failwith "%s" msg - | exn -> fail (Exn exn)) - |> trace (Bad_argument (i, p)) >>=? fun v -> - exec (succ i) next (cb v) rest - | _ -> fail Command_not_found - in exec 1 params handler args + = fun i spec cb params -> + match spec, params with + | Stop, _ -> cb ctx + | Seq (_, _, f), seq -> + let rec do_seq i acc = function + | [] -> return (List.rev acc) + | p :: rest -> + Lwt.catch + (fun () -> f ctx p) + (function + | Failure msg -> Error_monad.failwith "%s" msg + | exn -> fail (Exn exn)) + |> trace (Bad_argument (i, p)) >>=? fun v -> + do_seq (succ i) (v :: acc) rest in + do_seq i [] seq >>=? fun parsed -> + cb parsed ctx + | Prefix (n, next), p :: rest when n = p -> + exec (succ i) next cb rest + | Param (_, _, f, next), p :: rest -> + Lwt.catch + (fun () -> f ctx p) + (function + | Failure msg -> Error_monad.failwith "%s" msg + | exn -> fail (Exn exn)) + |> trace (Bad_argument (i, p)) >>=? fun v -> + exec (succ i) next (cb v) rest + | _ -> raise (Failure ("cli_entries internal error: exec no case matched")) + in + parse_args options_spec args_dict ctx >>=? fun parsed_options -> + exec 1 spec (handler (converter parsed_options)) params (* Command dispatch tree *) type ('arg, 'ret) level = @@ -141,29 +376,37 @@ and ('arg, 'ret) param_level = { stop : ('arg, 'ret) command option ; tree : ('arg, 'ret) tree } and ('arg, 'ret) tree = - | TPrefix of ('arg, 'ret) level - | TParam of ('arg, 'ret) param_level - | TStop of ('arg, 'ret) command - | TMore of ('arg, 'ret) command - | TEmpty + | TPrefix : ('arg, 'ret) level -> ('arg, 'ret) tree + | TParam : ('arg, 'ret) param_level -> ('arg, 'ret) tree + | TStop : ('arg, 'ret) command -> ('arg, 'ret) tree + | TSeq : ('arg, 'ret) command -> ('arg, 'ret) tree + | TEmpty : ('arg, 'ret) tree + +let has_options : type ret ctx. (ctx, ret) command -> bool = + fun (Command { options=Argument { spec } }) -> + let args_help : type a. (a, ctx) args -> bool = function + | NoArgs -> false + | AddArg (_, _) -> true + in args_help spec let insert_in_dispatch_tree (type arg) (type ret) root (Command { params } as command) = let rec insert_tree - : type a. (arg, ret) tree -> (a, arg, ret) params -> (arg, ret) tree + : type a. (arg, ret) tree -> (a, arg, ret) params -> (_, _) tree = fun t c -> match t, c with | TEmpty, Stop -> TStop command - | TEmpty, More -> TMore command - | TEmpty, Seq _ -> TMore command + | TEmpty, Seq (_, _, _) -> TSeq command | TEmpty, Param (_, _, _, next) -> TParam { tree = insert_tree TEmpty next ; stop = None } | TEmpty, Prefix (n, next) -> TPrefix { stop = None ; prefix = [ (n, insert_tree TEmpty next) ] } - | TStop command, Param (_, _, _, next) -> - TParam { tree = insert_tree TEmpty next ; stop = Some command } - | TStop command, Prefix (n, next) -> - TPrefix { stop = Some command ; + | TStop cmd, Param (_, _, _, next) -> + if not (has_options cmd) + then TParam { tree = insert_tree TEmpty next ; stop = Some cmd } + else raise (Failure "Command cannot have both prefix and options") + | TStop cmd, Prefix (n, next) -> + TPrefix { stop = Some cmd ; prefix = [ (n, insert_tree TEmpty next) ] } | TParam t, Param (_, _, _, next) -> TParam { t with tree = insert_tree t.tree next } @@ -185,181 +428,421 @@ let insert_in_dispatch_tree let make_dispatch_tree commands = List.fold_left insert_in_dispatch_tree TEmpty commands -let tree_dispatch tree last args = - let rec loop = function - | TStop c, [] -> exec c last args - | TPrefix { stop = Some c }, [] -> exec c last args - | TMore c, _ -> exec c last args - | TPrefix { prefix }, n :: rest -> - begin try - let t = List.assoc n prefix in - loop (t, rest) - with Not_found -> fail Command_not_found end - | TParam { tree }, _ :: rest -> - loop (tree, rest) - | _, _ -> fail Command_not_found - in - loop (tree, args) +let rec gather_commands ?(acc=[]) tree = + match tree with + | TEmpty -> acc + | TSeq c + | TStop c -> c :: acc + | TPrefix { stop ; prefix } -> + gather_assoc ~acc:(match stop with + | None -> acc + | Some c -> c :: acc) + prefix + | TParam { tree ; stop } -> + gather_commands tree + ~acc:(match stop with + | None -> acc + | Some c -> c :: acc) +and gather_assoc ?(acc=[]) trees = + List.fold_left (fun acc (_, tree) -> gather_commands tree ~acc) acc trees -let inline_tree_dispatch tree () = - let state = ref (tree, []) in - fun arg -> match !state, arg with - | (( TStop c | - TMore c | - TPrefix { stop = Some c } | - TParam { stop = Some c}), acc), - `End -> - state := (TEmpty, []) ; - `Res (fun last -> exec c last (List.rev acc)) - | (TMore c, acc), `Arg n -> - state := (TMore c, n :: acc) ; - `Nop - | (TPrefix { prefix }, acc), `Arg n -> - begin try - let t = List.assoc n prefix in - state := (t, n :: acc) ; - begin match t with - | TStop (Command { args }) - | TMore (Command { args }) -> `Args args - | _ -> `Nop end - with Not_found -> `Fail [Command_not_found] end - | (TParam { tree }, acc), `Arg n -> - state := (tree, n :: acc) ; - begin match tree with - | TStop (Command { args }) - | TMore (Command { args }) -> `Args args - | _ -> `Nop end - | _, _ -> `Fail [Command_not_found] +let find_command tree initial_arguments = + let rec help tree arguments acc = + match tree, arguments with + | (TStop _ | TSeq _ + | TPrefix { stop = Some _ } + | TParam { stop = Some _ }), ("-help" | "--help") :: _ -> + fail (Help_flag ( gather_commands tree)) + | TStop c, [] -> return (c, empty_args_dict, initial_arguments) + | TStop (Command { options=Argument { spec }} as c), args -> + if not (has_options c) + then fail (Extra_arguments (List.rev acc, c)) + else make_args_dict (Help_flag [c]) spec args >>=? fun args_dict -> + return (c, args_dict, initial_arguments) + | TSeq (Command { options=Argument { spec }} as c), remaining -> + if List.exists (function "-help" | "--help" -> true | _ -> false) remaining then + fail (Help_flag ( gather_commands tree)) + else + make_args_dict_filter (Help_flag [c]) spec remaining >>|? fun (dict, remaining) -> + (c, dict, List.rev_append acc remaining) + | TPrefix { stop = Some cmd }, [] -> + return (cmd, empty_args_dict, initial_arguments) + | TPrefix { stop = None ; prefix }, ([] | ("-help" | "--help") :: _) -> + fail (Not_enough_args (initial_arguments, gather_assoc prefix)) + | TPrefix { prefix }, hd_arg :: tl -> + begin + try + return (List.assoc hd_arg prefix) + with Not_found -> fail (Command_not_found (List.rev acc, gather_assoc prefix)) + end >>=? fun tree' -> + help tree' tl (hd_arg :: acc) + | TParam { stop=None }, ([] | ("-help" | "--help") :: _) -> + fail (Not_enough_args (initial_arguments, gather_commands tree)) + | TParam { stop=Some c }, [] -> + return (c, empty_args_dict, initial_arguments) + | TParam { tree }, parameter :: arguments' -> + help tree arguments' (parameter :: acc) + | TEmpty, _ -> + fail (Command_not_found (List.rev acc, [])) + in help tree initial_arguments [] + +let trim s = (* config-file wokaround *) + Utils.split '\n' s |> + List.map String.trim |> + String.concat "\n" + +let print_options_detailed (type ctx) = + let help_option : type a.Format.formatter -> (a, ctx) arg -> unit = + fun ppf -> function + | Arg { parameter ; doc } -> + Format.fprintf ppf "@[%s _@,@[%a@]@]" + parameter Format.pp_print_text doc + | DefArg { parameter ; doc ; default } -> + Format.fprintf ppf "@[%s _ (default: %s)@,@[%a@]@]" + parameter default Format.pp_print_text doc + | Switch { parameter ; doc } -> + Format.fprintf ppf "@[%s@,@[%a@]@]" + parameter Format.pp_print_text doc + in let rec help : type b. Format.formatter -> (b, ctx) args -> unit = + fun ppf -> function + | NoArgs -> () + | AddArg (arg, NoArgs) -> + Format.fprintf ppf "%a" + help_option arg + | AddArg (arg, rest) -> + Format.fprintf ppf "%a@,%a" + help_option arg help rest + in help + +let has_args : type a ctx. (a, ctx) args -> bool = function + | NoArgs -> false + | AddArg (_,_) -> true + +let rec print_options_brief (type ctx) = + let help_option : + type a. Format.formatter -> (a, ctx) arg -> unit = + fun ppf -> function + | DefArg { parameter } -> + Format.fprintf ppf "[%s _]" parameter + | Arg { parameter } -> + Format.fprintf ppf "[%s _]" parameter + | Switch { parameter } -> + Format.fprintf ppf "[%s]" parameter + in let rec help : type b. Format.formatter -> (b, ctx) args -> unit = + fun ppf -> function + | NoArgs -> () + | AddArg (arg, NoArgs) -> + Format.fprintf ppf "%a" help_option arg + | AddArg (arg, rest) -> + Format.fprintf ppf "%a@ %a" + help_option arg help rest + in help + +let print_highlight highlight_strings formatter str = + let rec print_string = function + | [] -> Format.fprintf formatter "%s" str + | regex :: tl -> + begin match Str.full_split regex str with + | [] + | [ Str.Text _ ] -> print_string tl + | list -> + List.iter + (function + | Str.Text text -> Format.fprintf formatter "%s" text + | Str.Delim delimiter -> + Format.fprintf formatter "\x1b[103m%s\x1b[0m" delimiter) + list + end + in print_string (List.map Str.regexp highlight_strings) + +let print_commandline ppf (highlights, options, args) = + let rec print + : type a ctx ret. Format.formatter -> (a, ctx, ret) params -> unit = + fun ppf -> function + | Stop -> Format.fprintf ppf "%a" print_options_brief options + | Seq (n, _, _) when not (has_args options) -> + Format.fprintf ppf "[(%s)...]" n + | Seq (n, _, _) -> + Format.fprintf ppf "[(%s)...] %a" n print_options_brief options + | Prefix (n, Stop) when not (has_args options) -> + Format.fprintf ppf "%a" (print_highlight highlights) n + | Prefix (n, next) -> + Format.fprintf ppf "%a %a" + (print_highlight highlights) n print next + | Param (n, _, _, Stop) when not (has_args options) -> + Format.fprintf ppf "(%s)" n + | Param (n, _, _, next) -> + Format.fprintf ppf "(%s) %a" n print next in + Format.fprintf ppf "@[%a@]" print args + +let rec print_params_detailed + : type a b ctx ret. (b, ctx) args -> Format.formatter -> (a, ctx, ret) params -> unit + = fun spec ppf -> function + | Stop -> print_options_detailed ppf spec + | Seq (n, desc, _) -> + Format.fprintf ppf "@[(%s)@,@[%a@]@]" + n Format.pp_print_text (trim desc) ; + begin match spec with + | NoArgs -> () + | _ -> Format.fprintf ppf "@,%a" print_options_detailed spec + end + | Prefix (_, next) -> + print_params_detailed spec ppf next + | Param (n, desc, _, Stop) -> + Format.fprintf ppf "@[(%s)@,@[%a@]@]" + n Format.pp_print_text (trim desc); + begin match spec with + | NoArgs -> () + | _ -> Format.fprintf ppf "@,%a" print_options_detailed spec + end + | Param (n, desc, _, next) -> + Format.fprintf ppf "@[(%s)@,@[%a@]@]@,%a" + n Format.pp_print_text (trim desc) (print_params_detailed spec) next + +let contains_params_args : + type a b arg ctx. (a, arg, ctx) params -> (b, _) args -> bool + = fun params args -> + let rec help : (a, arg, ctx) params -> bool = function + | Stop -> has_args args + | Seq (_, _, _) -> true + | Prefix (_, next) -> help next + | Param (_, _, _, _) -> true + in help params + +let print_command : + type a ctx ret. ?prefix: string -> ?highlights:string list -> Format.formatter -> (ctx, ret) command -> unit + = fun ?(prefix = "") ?(highlights=[]) ppf (Command { params ; desc ; options=Argument { spec } }) -> + if contains_params_args params spec + then + Format.fprintf ppf "@[%s%a@,@[%a@]@,%a@]" + prefix + print_commandline (highlights, spec, params) + Format.pp_print_text desc + (print_params_detailed spec) params + else + Format.fprintf ppf "@[%s%a@,@[%a@]@]" + prefix + print_commandline (highlights, spec, params) + Format.pp_print_text desc + +let group_commands commands = + let (grouped, ungrouped) = + List.fold_left + (fun (grouped, ungrouped) (Command { group } as command) -> + match group with + | None -> + (grouped, command :: ungrouped) + | Some group -> + try + let ({ title }, r) = + List.find (fun ({ name }, _) -> group.name = name) grouped in + if title <> group.title then + invalid_arg "Cli_entries.usage: duplicate group name" ; + r := command :: !r ; + (grouped, ungrouped) + with Not_found -> + ((group, ref [ command ]) :: grouped, ungrouped)) + ([], []) + commands in + List.map (fun (g, c) -> (g, List.rev !c)) + (match ungrouped with + | [] -> grouped + | l -> (grouped @ + [ { name = "misc" ; + title = "Miscellaneous commands" }, + ref l ])) + +let print_group print_command ppf ({ title }, commands) = + Format.fprintf ppf "@[%s:@,%a@]" + title + (Format.pp_print_list print_command) commands + +let command_args_help ppf command = + Format.fprintf ppf + "%a" + (fun ppf (Command { params ; options=Argument { spec } }) -> + print_commandline ppf ([], spec, params)) + command + +let usage + (type ctx) (type ret) + ppf + ?global_options + ~details + ?(highlights=[]) commands = + let usage ppf (by_group, options) = + let print_groups = + Format.pp_print_list + ~pp_sep: (fun ppf () -> Format.fprintf ppf "@,@,") + (print_group (if details + then print_command ?prefix:None ~highlights + else + fun ppf (Command { params ; options=Argument { spec }}) -> + print_commandline ppf (highlights, spec, params))) in + match options with + | None -> + Format.fprintf ppf + "@[%a@]" + print_groups by_group + | Some (Argument { spec })-> + let exe = Filename.basename Sys.executable_name in + Format.fprintf ppf + "@[@[Usage:@,\ + %s [global options] command [command options]@,\ + %s -help (for global options)@,\ + %s [global options] command -help (for command options)@]@,@,\ + @[To browse the documentation:@,\ + %s [global options] man (for a list of commands)@,\ + %s [global options] man -details (for the full manual)@]@,@,\ + @[Global options (must come before the command):@,@[%a@]@]%a\ + %a@]" + exe exe exe exe exe + print_options_detailed spec + (fun ppf () -> if by_group <> [] then Format.fprintf ppf "@,@,") () + print_groups by_group in + Format.fprintf ppf "@[%a" usage (group_commands commands, global_options) ; + if not details then + Format.fprintf ppf "@,@,Use option [-verbose] for command options." ; + Format.fprintf ppf "@]" + +let command_usage + (type ctx) (type ret) ppf commands = + let exe = Filename.basename Sys.executable_name in + let prefix = exe ^ " [global options] " in + Format.fprintf ppf + "@[Command usage:@,\ + %a@,%s -help (for global options)@]" + (Format.pp_print_list (print_command ~prefix ~highlights:[])) + commands + exe + +let handle_cli_errors ~stdout ~stderr ~global_options = function + | Ok _ -> + return 0 + | Error [ e ] -> (* Should only be one error here *) + begin match e with + | Extra_arguments (_, cmd) -> + Format.fprintf stderr + "Extra arguments provided for command:@;<1 2>@[%a@]@." + (print_command ?prefix:None ~highlights:[]) cmd; + return 1 + | Not_enough_args (_, cmds) -> + Format.fprintf stderr + "@[Unterminated command, here are possible completions:@,%a@]@." + (Format.pp_print_list + (fun ppf (Command { params ; options=Argument { spec } }) -> + print_commandline ppf ([], spec, params))) cmds; + return 1 + | Command_not_found ([], _) -> + Format.fprintf stderr + "Unrecognized command. Try using the 'man' command to get more information.@." ; + return 1 + | Command_not_found (_, cmds) -> + Format.fprintf stderr + "@[Unrecognized command, did you mean one of the following:@,%a@]@." + (Format.pp_print_list + (fun ppf (Command { params ; options=Argument { spec } }) -> + print_commandline ppf ([], spec, params))) cmds; + return 1 + | Bad_argument (pos, arg) -> + Format.fprintf stderr + "The argument '%s' given in position %d was invalid.@." + arg + pos ; + return 1 + | Option_expected_argument option -> + Format.fprintf stderr + "The option '%s' expected an argument, but you did not provide one.@." + option ; + return 1 + | Unknown_option option -> + Format.fprintf stderr + "While parsing options, encountered unexpected argument '%s'.@." + option ; + return 1 + | Invalid_options_combination message -> + Format.fprintf stderr "%s@." message ; + return 1 + | Help_cmd ([ highlight ], [], _, _) -> + Format.fprintf stderr "No command found that match %s.@." highlight ; + return 0 + | Help_cmd (highlight :: highlights, [], _, _) -> + Format.fprintf stderr "No command found that match %a%s and %s.@." + (Format.pp_print_list + ~pp_sep:(fun ppf () -> Format.fprintf ppf ", ") + (fun ppf s -> Format.fprintf ppf "%s" s)) highlights + (match highlights with [ _ ] | [] -> "" | _::_ -> ",") + highlight ; + return 0 + | Help_cmd (highlights, commands, terse, details) -> + let details = + if terse || details then + details + else + List.length commands <= 3 in + let global_options = + if details && highlights = [] then Some global_options else None in + Format.fprintf stdout "%a@." + (usage ?global_options ~details ~highlights) commands; + return 0 + | Bare_help -> + Format.fprintf stdout "%a@." + (usage ~global_options ~details:true ?highlights:None) [] ; + return 0 + | Help_flag commands -> + Format.fprintf stdout "%a@." command_usage commands ; + return 0 + | e -> fail e + end + | (Error _) as errors -> Lwt.return errors (* Try a list of commands on a list of arguments *) -let dispatch commands = - let tree = make_dispatch_tree commands in - tree_dispatch tree +let dispatch commands ctx args = + let commands = help_commands commands @ commands in + match args with + | [] | [ "-help" | "--help" ] -> fail Bare_help + | _ -> + let tree = make_dispatch_tree commands in + find_command tree args >>=? fun (command, args_dict, filtered_args) -> + exec command ctx filtered_args args_dict -(* Argument-by-argument dispatcher to be used during argument parsing *) -let inline_dispatch commands = - let tree = make_dispatch_tree commands in - inline_tree_dispatch tree +let usage ppf ?global_options commands = + usage ppf ?highlights:None ~details:true ?global_options commands -(* Command line help for a set of commands *) -let usage - (type arg) (type ret) - ~commands options = - let trim s = (* config-file wokaround *) - Utils.split '\n' s |> - List.map String.trim |> - String.concat "\n" in - let rec help - : type a. Format.formatter -> (a, arg, ret) params -> unit - = fun ppf -> function - | Stop -> () - | More -> Format.fprintf ppf "..." - | Seq (n, "", _) -> Format.fprintf ppf "[ (%s) ...]" n - | Seq (_, desc, _) -> Format.fprintf ppf "[ (%s) ... ]" desc - | Prefix (n, Stop) -> Format.fprintf ppf "%s" n - | Param (n, "", _, Stop) -> Format.fprintf ppf "(%s)" n - | Param (_, desc, _, Stop) -> Format.fprintf ppf "(%s)" desc - | Prefix (n, next) -> Format.fprintf ppf "%s %a" n help next - | Param (n, "", _, next) -> Format.fprintf ppf "(%s) %a" n help next - | Param (_, desc, _, next) -> Format.fprintf ppf "(%s) %a" desc help next in - let rec help_sum - : type a. Format.formatter -> (a, arg, ret) params -> unit - = fun ppf -> function - | Stop -> () - | More -> Format.fprintf ppf "..." - | Seq (n, _, _) -> Format.fprintf ppf "[ (%s) ... ]" n - | Prefix (n, Stop) -> Format.fprintf ppf "%s" n - | Param (n, _, _, Stop) -> Format.fprintf ppf "(%s)" n - | Prefix (n, next) -> Format.fprintf ppf "%s %a" n help_sum next - | Param (n, _, _, next) -> Format.fprintf ppf "(%s) %a" n help_sum next in - let rec help_args - : type a. Format.formatter -> (a, arg, ret) params -> unit - = fun ppf -> function - | Stop -> () - | More -> Format.fprintf ppf "..." - | Seq (n, desc, _) -> - Format.fprintf ppf "(%s): @[%a@]" - n Format.pp_print_text (trim desc) - | Prefix (_, next) -> help_args ppf next - | Param (n, desc, _, Stop) -> - Format.fprintf ppf "(%s): @[%a@]" - n Format.pp_print_text (trim desc) - | Param (n, desc, _, next) -> - Format.fprintf ppf "(%s): @[%a@]@,%a" - n Format.pp_print_text (trim desc) help_args next in - let option_help ppf (n, opt, desc) = - Format.fprintf ppf "%s%s" n - Arg.(let rec example opt = match opt with - | Unit _ -> "" - | Bool _ -> " " - | Set _ -> "" - | Clear _ -> "" - | String _ -> " " - | Set_string _ -> " " - | Int _ -> " " - | Set_int _ -> " " - | Float _ -> " " - | Set_float _ -> " " - | Tuple opts -> List.map example opts |> String.concat "" - | Symbol (syms, _) -> " <" ^ String.concat " | " syms ^ ">" - | Rest _ -> "" in example opt) ; - if desc <> "" then - Format.fprintf ppf "@, @[%a@]" Format.pp_print_text (trim desc) in - let command_help ppf (Command { params ; desc ; args }) = - let small = Format.asprintf "@[%a@]" help params in - let desc = trim desc in - if String.length small < 50 then begin - Format.fprintf ppf "@[%s@,@[%a@]" - small Format.pp_print_text desc - end else begin - Format.fprintf ppf "@[%a@,@[%a@]@,%a" - help_sum params - Format.pp_print_text desc - help_args params ; - end ; - if args = [] then - Format.fprintf ppf "@]" - else - Format.fprintf ppf "@,%a@]" - (Format.pp_print_list option_help) - args in - let rec group_help ppf ({ title }, commands) = - Format.fprintf ppf "@[%s:@,%a@]" - title - (Format.pp_print_list command_help) commands in - let usage ppf (by_group, options) = - Format.fprintf ppf - "@[@[Usage:@,%s [ options ] command [ command options ]@]@,\ - @[Options:@,%a@]@,\ - %a@]" - Sys.argv.(0) - (Format.pp_print_list option_help) options - (Format.pp_print_list group_help) by_group in - let by_group = - let ungrouped = ref [] in - let grouped = - List.fold_left - (fun acc (Command { group } as command) -> - match group with - | None -> - ungrouped := command :: !ungrouped ; - acc - | Some group -> - try - let ({ title }, r) = - List.find (fun ({ name }, _) -> group.name = name) acc in - if title <> group.title then - invalid_arg "Cli_entries.usage: duplicate group name" ; - r := command :: !r ; - acc - with Not_found -> - (group, ref [ command ]) :: acc) - [] commands in - let misc = match !ungrouped with - | [] -> [] - | l -> - [ { name = "untitled" ; title = "Miscellaneous commands" }, - List.rev l ] - in - List.map (fun (g, c) -> (g, List.rev !c)) grouped @ misc in - Format.asprintf "%a" usage (by_group, options) +let () = + register_error_kind + `Branch + ~id: "cli.bad_argument" + ~title: "Bad argument" + ~description: "Error in a command line argument" + ~pp: + (fun ppf (i, v) -> + Format.fprintf ppf "Error in command line argument %d (%s)" i v) + Data_encoding.(obj2 (req "index" uint8) (req "value" string)) + (function Bad_argument (i, v) -> Some (i, v) | _ -> None) + (fun (i, v) -> Bad_argument (i, v)) ; + register_error_kind + `Branch + ~id: "cli.option_expected_argument" + ~title: "Option without argument" + ~description: "Option expected argument, but did not receive one" + ~pp: + (fun ppf arg -> + Format.fprintf ppf "The option '%s' expected an argument, but did not receive one" arg) + Data_encoding.(obj1 (req "arg" string)) + (function Option_expected_argument arg -> Some arg | _ -> None) + (fun arg -> Option_expected_argument arg) ; + register_error_kind + `Branch + ~id: "cli.unknown_option" + ~title: "Unknown option" + ~description: "While parsing options, encountered unknown option" + ~pp: + (fun ppf arg -> + Format.fprintf ppf + (if (String.length arg) > 0 && (String.get arg 0) = '-' + then "Encountered an unknown option '%s' while parsing the command" + else "Expected a flag, but instead encountered '%s'") arg) + Data_encoding.(obj1 (req "arg" string)) + (function Unknown_option arg -> Some arg | _ -> None) + (fun arg -> Unknown_option arg) diff --git a/src/utils/cli_entries.mli b/src/utils/cli_entries.mli index b232ae6a8..608e5b6b1 100644 --- a/src/utils/cli_entries.mli +++ b/src/utils/cli_entries.mli @@ -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