From 166801fc7721794d8616962bb59145b0bcb96772 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Wed, 5 Apr 2017 10:22:41 +0200 Subject: [PATCH] Client: more `Error_monad` in `Cli_entries`. --- src/Makefile | 2 +- src/client/client_aliases.ml | 14 ++-- src/client/client_commands.ml | 2 +- src/client/client_commands.mli | 2 +- src/client/client_config.ml | 6 +- src/client/client_generic_rpcs.ml | 7 ++ src/client/client_protocols.ml | 11 +-- src/client/client_tags.ml | 4 +- .../embedded/alpha/client_proto_args.ml | 4 +- .../embedded/alpha/client_proto_context.ml | 29 ++++---- .../embedded/alpha/client_proto_contracts.ml | 9 +-- .../embedded/alpha/client_proto_programs.ml | 71 ++++++++++--------- .../embedded/alpha/client_proto_programs.mli | 12 +--- .../embedded/genesis/client_proto_main.ml | 19 ++--- src/client_main.ml | 20 +++--- src/node/updater/environment.ml | 9 +++ src/utils/cli_entries.ml | 46 ++++++------ src/utils/cli_entries.mli | 30 ++++---- src/utils/hash.ml | 8 ++- src/utils/hash.mli | 14 ++-- 20 files changed, 164 insertions(+), 155 deletions(-) diff --git a/src/Makefile b/src/Makefile index 6c41afadf..5cff833b9 100644 --- a/src/Makefile +++ b/src/Makefile @@ -225,9 +225,9 @@ UTILS_LIB_INTFS := \ UTILS_LIB_IMPLS := \ utils/base58.ml \ - utils/cli_entries.ml \ utils/error_monad_sig.ml \ utils/error_monad.ml \ + utils/cli_entries.ml \ utils/data_encoding_ezjsonm.ml \ utils/time.ml \ utils/hash.ml \ diff --git a/src/client/client_aliases.ml b/src/client/client_aliases.ml index 6e2f7fe0a..a1acaabf1 100644 --- a/src/client/client_aliases.ml +++ b/src/client/client_aliases.ml @@ -208,9 +208,8 @@ module Alias = functor (Entity : Entity) -> struct ?(name = "name") ?(desc = "existing " ^ Entity.name ^ " alias") next = param ~name ~desc (fun cctxt s -> - find cctxt s >>= function - | Ok v -> Lwt.return (s, v) - | Error err -> cctxt.error "%a" pp_print_error err) + find cctxt s >>=? fun v -> + return (s, v)) next let fresh_alias_param @@ -233,9 +232,8 @@ module Alias = functor (Entity : Entity) -> struct return ()) list end - end >>= function - | Ok () -> Lwt.return s - | Error err -> cctxt.error "%a" pp_print_error err) + end >>=? fun () -> + return s) next let source_param ?(name = "src") ?(desc = "source " ^ Entity.name) next = @@ -270,9 +268,7 @@ module Alias = functor (Entity : Entity) -> struct read s >>= function | Ok v -> return v | Error _ -> of_source cctxt s - end >>= function - | Ok s -> Lwt.return s - | Error err -> cctxt.error "%a" pp_print_error err) + end) next let name cctxt d = diff --git a/src/client/client_commands.ml b/src/client/client_commands.ml index 13285c0e6..13fe24e28 100644 --- a/src/client/client_commands.ml +++ b/src/client/client_commands.ml @@ -32,7 +32,7 @@ type context = { log : 'a. string -> ('a, unit) lwt_format -> 'a ; } -type command = (context, unit tzresult) Cli_entries.command +type command = (context, unit) Cli_entries.command (* Default config *) diff --git a/src/client/client_commands.mli b/src/client/client_commands.mli index 158094a20..98c06604c 100644 --- a/src/client/client_commands.mli +++ b/src/client/client_commands.mli @@ -55,7 +55,7 @@ val ignore_context : context (** [ignore_context] is a context whose logging callbacks do nothing, and whose [error] function calls [Lwt.fail_with]. *) -type command = (context, unit tzresult) Cli_entries.command +type command = (context, unit) Cli_entries.command exception Version_not_found diff --git a/src/client/client_config.ml b/src/client/client_config.ml index 90cfc0c4a..9f98b1046 100644 --- a/src/client/client_config.ml +++ b/src/client/client_config.ml @@ -215,14 +215,16 @@ let parse_args usage dispatcher argv = let anon dispatch n = match dispatch (`Arg n) with | `Nop -> () | `Args nargs -> args := nargs @ !args - | `Fail exn -> raise exn + | `Fail err -> + Format.kasprintf (fun s -> raise (Arg.Help s)) "%a" pp_print_error 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 -> (res, !parsed_args) - | `Fail exn -> raise exn + | `Fail err -> + Format.kasprintf (fun s -> raise (Arg.Help s)) "%a" pp_print_error err | `Nop | `Args _ -> assert false with | Arg.Bad msg -> diff --git a/src/client/client_generic_rpcs.ml b/src/client/client_generic_rpcs.ml index f275ee565..e2e45cc95 100644 --- a/src/client/client_generic_rpcs.ml +++ b/src/client/client_generic_rpcs.ml @@ -343,6 +343,7 @@ let group = title = "Commands for the low level RPC layer" } let commands = [ + command ~desc: "list all understood protocol versions" (fixed [ "list" ; "versions" ]) (fun cctxt -> @@ -350,20 +351,26 @@ let commands = [ (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)" (prefixes [ "rpc" ; "list" ] @@ stop) (list "/"); + command ~group ~desc: "list available RPCs (low level command for advanced users)" (prefixes [ "rpc" ; "list" ] @@ string ~name:"url" ~desc: "the RPC's prefix to be described" @@ stop) list ; + command ~group ~desc: "get the schemas of an RPC" (prefixes [ "rpc" ; "schema" ] @@ string ~name: "url" ~desc: "the RPC's URL" @@ stop) schema ; + command ~group ~desc: "call an RPC (low level command for advanced users)" (prefixes [ "rpc" ; "call" ] @@ string ~name: "url" ~desc: "the RPC's URL" @@ stop) call ; + command ~group ~desc: "call an RPC (low level command for advanced users)" (prefixes [ "rpc" ; "call" ] @@ string ~name: "url" ~desc: "the RPC's URL" @@ prefix "with" @@ string ~name:"" ~desc:"" @@ stop) call_with_json + ] diff --git a/src/client/client_protocols.ml b/src/client/client_protocols.ml index 795d68125..0d110620d 100644 --- a/src/client/client_protocols.ml +++ b/src/client/client_protocols.ml @@ -17,12 +17,11 @@ let commands () = let open Cli_entries in let check_dir _ dn = if Sys.is_directory dn then - Lwt.return dn + return dn else - Lwt.fail_with (dn ^ " is not a directory") in - let check_hash _ ph = - Lwt.wrap1 Protocol_hash.of_b58check_exn ph in + failwith "%s is not a directory" dn in [ + command ~group ~desc: "list known protocols" (prefixes [ "list" ; "protocols" ] stop) (fun cctxt -> @@ -30,6 +29,7 @@ let commands () = 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" (prefixes [ "inject" ; "protocol" ] @@ param ~name:"dir" ~desc:"directory containing a protocol" check_dir @@ -52,9 +52,10 @@ let commands () = dirname Error_monad.pp_print_error [Error_monad.Exn exn] >>= fun () -> return ()) ); + command ~group ~desc: "dump a protocol from the shell database" (prefixes [ "dump" ; "protocol" ] - @@ param ~name:"protocol hash" ~desc:"" check_hash + @@ Protocol_hash.param ~name:"protocol hash" ~desc:"" @@ stop) (fun ph cctxt -> Client_node_rpcs.Protocols.contents cctxt.rpc_config ph >>=? fun proto -> diff --git a/src/client/client_tags.ml b/src/client/client_tags.ml index 9eaa7ed26..b245ea5fc 100644 --- a/src/client/client_tags.ml +++ b/src/client/client_tags.ml @@ -65,9 +65,7 @@ module Tags (Entity : Entity) = struct desc ^ "\n" ^ "can be one or multiple tags separated by commas" in Cli_entries.param ~name ~desc - (fun cctxt s -> of_source cctxt s >>= function - | Ok r -> Lwt.return r - | Error err -> cctxt.error "%a" pp_print_error err) + (fun cctxt s -> of_source cctxt s) next let rev_find_by_tag cctxt tag = diff --git a/src/client/embedded/alpha/client_proto_args.ml b/src/client/embedded/alpha/client_proto_args.ml index 8a398a458..db394523c 100644 --- a/src/client/embedded/alpha/client_proto_args.ml +++ b/src/client/embedded/alpha/client_proto_args.ml @@ -85,8 +85,8 @@ let tez_param ~name ~desc next = (desc ^ " in \xEA\x9C\xA9\n\ text format: D,DDD,DDD.DD (centiles and comas are optional)") (fun _ s -> - try Lwt.return (tez_of_string s) - with _ -> Lwt.fail_with "invalid \xEA\x9C\xA9 notation") + try return (tez_of_string s) + with _ -> failwith "invalid \xEA\x9C\xA9 notation") next let max_priority = ref None diff --git a/src/client/embedded/alpha/client_proto_context.ml b/src/client/embedded/alpha/client_proto_context.ml index d940af3b8..38bcaaa78 100644 --- a/src/client/embedded/alpha/client_proto_context.ml +++ b/src/client/embedded/alpha/client_proto_context.ml @@ -86,10 +86,10 @@ let transfer cctxt Client_node_rpcs.Blocks.net cctxt.rpc_config block >>=? fun net -> begin match arg with | Some arg -> - Client_proto_programs.parse_data cctxt arg >>= fun arg -> - Lwt.return (Some arg) - | None -> Lwt.return None - end >>= fun parameters -> + Client_proto_programs.parse_data arg >>=? fun arg -> + return (Some arg) + | None -> return None + end >>=? fun parameters -> Client_proto_rpcs.Context.Contract.counter cctxt.rpc_config block source >>=? fun pcounter -> let counter = Int32.succ pcounter in cctxt.message "Acquired the source's sequence counter (%ld -> %ld)." @@ -148,7 +148,7 @@ let originate_contract cctxt block ?force ~source ~src_pk ~src_sk ~manager_pkh ~balance ?delegatable ?delegatePubKey ~(code:Script.code) ~init ~fee () = - Client_proto_programs.parse_data cctxt init >>= fun storage -> + Client_proto_programs.parse_data init >>=? fun storage -> let storage = Script.{ storage ; storage_type = code.storage_type } in Client_proto_rpcs.Context.Contract.counter cctxt.rpc_config block source >>=? fun pcounter -> let counter = Int32.succ pcounter in @@ -358,12 +358,10 @@ let commands () = command ~desc: "Activate a protocol" begin prefixes [ "activate" ; "protocol" ] @@ - param ~name:"version" ~desc:"Protocol version (b58check)" - (fun _ p -> Lwt.return @@ Protocol_hash.of_b58check_exn p) @@ + Protocol_hash.param ~name:"version" ~desc:"Protocol version (b58check)" @@ prefixes [ "with" ; "key" ] @@ - param ~name:"password" ~desc:"Dictator's key" - (fun _ key -> - Lwt.return (Environment.Ed25519.Secret_key.of_b58check_exn key)) + Environment.Ed25519.Secret_key.param + ~name:"password" ~desc:"Dictator's key" @@ stop end (fun hash seckey cctxt -> @@ -371,14 +369,13 @@ let commands () = command ~desc: "Fork a test protocol" begin prefixes [ "fork" ; "test" ; "protocol" ] @@ - param ~name:"version" ~desc:"Protocol version (b58check)" - (fun _ p -> Lwt.return (Protocol_hash.of_b58check_exn p)) @@ + Protocol_hash.param ~name:"version" ~desc:"Protocol version (b58check)" @@ prefixes [ "with" ; "key" ] @@ - param ~name:"password" ~desc:"Dictator's key" - (fun _ key -> - Lwt.return (Environment.Ed25519.Secret_key.of_b58check_exn key)) - stop + Environment.Ed25519.Secret_key.param + ~name:"password" ~desc:"Dictator's key" @@ + stop end (fun hash seckey cctxt -> dictate cctxt cctxt.config.block (Activate_testnet hash) seckey) ; + ] diff --git a/src/client/embedded/alpha/client_proto_contracts.ml b/src/client/embedded/alpha/client_proto_contracts.ml index 25d9d359b..c3deb98d3 100644 --- a/src/client/embedded/alpha/client_proto_contracts.ml +++ b/src/client/embedded/alpha/client_proto_contracts.ml @@ -61,10 +61,7 @@ module ContractAlias = struct ^ "can be an contract alias or a key alias (autodetected in this order)\n\ use 'key:name' to force the later" in Cli_entries.param ~name ~desc - (fun cctxt p -> - get_contract cctxt p >>= function - | Ok v -> Lwt.return v - | Error err -> cctxt.error "%a" pp_print_error err) + (fun cctxt p -> get_contract cctxt p) next let destination_param ?(name = "dst") ?(desc = "destination contract") next = @@ -87,9 +84,7 @@ module ContractAlias = struct | Error _ -> ContractEntity.of_source cctxt s >>=? fun v -> return (s, v) - end >>= function - | Ok v -> Lwt.return v - | Error err -> cctxt.error "%a" pp_print_error err) + end) next let name cctxt contract = diff --git a/src/client/embedded/alpha/client_proto_programs.ml b/src/client/embedded/alpha/client_proto_programs.ml index f39e75b56..dbae08196 100644 --- a/src/client/embedded/alpha/client_proto_programs.ml +++ b/src/client/embedded/alpha/client_proto_programs.ml @@ -10,7 +10,7 @@ module Ed25519 = Environment.Ed25519 open Client_proto_args -let report_parse_error cctxt _prefix exn _lexbuf = +let report_parse_error _prefix exn _lexbuf = let open Lexing in let open Script_located_ir in let print_loc ppf ((sl, sc), (el, ec)) = @@ -29,15 +29,15 @@ let report_parse_error cctxt _prefix exn _lexbuf = sl sc el ec in match exn with | Missing_program_field n -> - cctxt.Client_commands.error "missing script %s" n + failwith "missing script %s" n | Illegal_character (loc, c) -> - cctxt.Client_commands.error "%a, illegal character %C" print_loc loc c + failwith "%a, illegal character %C" print_loc loc c | Illegal_escape (loc, c) -> - cctxt.Client_commands.error "%a, illegal escape sequence %S" print_loc loc c + failwith "%a, illegal escape sequence %S" print_loc loc c | Failure s -> - cctxt.Client_commands.error "%s" s + failwith "%s" s | exn -> - cctxt.Client_commands.error "%s" @@ Printexc.to_string exn + failwith "%s" @@ Printexc.to_string exn let print_location_mark ppf = function | None -> () @@ -435,10 +435,10 @@ let report_typechecking_errors cctxt errs = | err -> cctxt.warning "%a" pp_print_error [ err ]) errs -let parse_program cctxt s = +let parse_program s = let lexbuf = Lexing.from_string s in try - Lwt.return + return (Concrete_parser.tree Concrete_lexer.(token (init_state ())) lexbuf |> List.map Script_located_ir.strip_locations |> fun fields -> let rec get_field n = function @@ -451,25 +451,25 @@ let parse_program cctxt s = storage_type = get_field "storage" fields } ) with - | exn -> report_parse_error cctxt "program: " exn lexbuf + | exn -> report_parse_error "program: " exn lexbuf -let parse_data cctxt s = +let parse_data s = let lexbuf = Lexing.from_string s in try match Concrete_parser.tree Concrete_lexer.(token (init_state ())) lexbuf with - | [node] -> Lwt.return (Script_located_ir.strip_locations node) - | _ -> cctxt.Client_commands.error "single data expression expected" + | [node] -> return (Script_located_ir.strip_locations node) + | _ -> failwith "single data expression expected" with - | exn -> report_parse_error cctxt "data: " exn lexbuf + | exn -> report_parse_error "data: " exn lexbuf -let parse_data_type cctxt s = +let parse_data_type s = let lexbuf = Lexing.from_string s in try match Concrete_parser.tree Concrete_lexer.(token (init_state ())) lexbuf with - | [node] -> Lwt.return (Script_located_ir.strip_locations node) - | _ -> cctxt.Client_commands.error "single type expression expected" + | [node] -> return (Script_located_ir.strip_locations node) + | _ -> failwith "single type expression expected" with - | exn -> report_parse_error cctxt "data_type: " exn lexbuf + | exn -> report_parse_error "data_type: " exn lexbuf let unexpand_macros type_map (program : Script.code) = let open Script in @@ -513,9 +513,7 @@ let unexpand_macros type_map (program : Script.code) = module Program = Client_aliases.Alias (struct type t = Script.code let encoding = Script.code_encoding - let of_source cctxt s = - parse_program cctxt s >>= fun code -> - return code + let of_source _cctxt s = parse_program s let to_source _ p = return (Format.asprintf "%a" (print_program no_locations) (p, [])) let name = "program" @@ -573,9 +571,11 @@ let commands () = (prefixes [ "run" ; "program" ] @@ Program.source_param @@ prefixes [ "on" ; "storage" ] - @@ Cli_entries.param ~name:"storage" ~desc:"the storage data" parse_data + @@ Cli_entries.param ~name:"storage" ~desc:"the storage data" + (fun _cctxt data -> parse_data data) @@ prefixes [ "and" ; "input" ] - @@ Cli_entries.param ~name:"storage" ~desc:"the input data" parse_data + @@ Cli_entries.param ~name:"storage" ~desc:"the input data" + (fun _cctxt data -> parse_data data) @@ stop) (fun program storage input cctxt -> let open Data_encoding in @@ -632,43 +632,44 @@ let commands () = else return () | Error errs -> report_typechecking_errors cctxt errs >>= fun () -> - cctxt.error "ill-typed program") ; + failwith "ill-typed program") ; command ~group ~desc: "ask the node to typecheck a data expression" (prefixes [ "typecheck" ; "data" ] - @@ Cli_entries.param ~name:"data" ~desc:"the data to typecheck" parse_data + @@ Cli_entries.param ~name:"data" ~desc:"the data to typecheck" + (fun _cctxt data -> parse_data data) @@ prefixes [ "against" ; "type" ] - @@ Cli_entries.param ~name:"type" ~desc:"the expected type" parse_data + @@ Cli_entries.param ~name:"type" ~desc:"the expected type" + (fun _cctxt data -> parse_data data) @@ stop) (fun data exp_ty cctxt -> let open Data_encoding in - Client_proto_rpcs.Helpers.typecheck_data cctxt.rpc_config + Client_proto_rpcs.Helpers.typecheck_data cctxt.Client_commands.rpc_config cctxt.config.block (data, exp_ty) >>= function | Ok () -> cctxt.message "Well typed" >>= fun () -> return () | Error errs -> report_typechecking_errors cctxt errs >>= fun () -> - cctxt.error "ill-typed data" >>= fun () -> - return ()) ; + failwith "ill-typed data") ; command ~group ~desc: "ask the node to compute the hash of a data expression \ using the same algorithm as script instruction H" (prefixes [ "hash" ; "data" ] - @@ Cli_entries.param ~name:"data" ~desc:"the data to hash" parse_data + @@ Cli_entries.param ~name:"data" ~desc:"the data to hash" + (fun _cctxt data -> parse_data data) @@ stop) (fun data cctxt -> let open Data_encoding in - Client_proto_rpcs.Helpers.hash_data cctxt.rpc_config + Client_proto_rpcs.Helpers.hash_data cctxt.Client_commands.rpc_config cctxt.config.block data >>= function | Ok hash -> cctxt.message "%S" hash >>= fun () -> return () | Error errs -> cctxt.warning "%a" pp_print_error errs >>= fun () -> - cctxt.error "ill-formed data" >>= fun () -> - return ()) ; + failwith "ill-formed data") ; command ~group ~desc: "ask the node to compute the hash of a data expression \ @@ -676,7 +677,8 @@ let commands () = a given secret key, and display it using the format expected by \ script instruction CHECK_SIGNATURE" (prefixes [ "hash" ; "and" ; "sign" ; "data" ] - @@ Cli_entries.param ~name:"data" ~desc:"the data to hash" parse_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) @@ -694,7 +696,6 @@ let commands () = return () | Error errs -> cctxt.warning "%a" pp_print_error errs >>= fun () -> - cctxt.error "ill-formed data" >>= fun () -> - return ()) ; + failwith "ill-formed data") ; ] diff --git a/src/client/embedded/alpha/client_proto_programs.mli b/src/client/embedded/alpha/client_proto_programs.mli index 760f07473..eacca02fc 100644 --- a/src/client/embedded/alpha/client_proto_programs.mli +++ b/src/client/embedded/alpha/client_proto_programs.mli @@ -7,15 +7,9 @@ (* *) (**************************************************************************) -val parse_program: - Client_commands.context -> - string -> Script.code Lwt.t -val parse_data: - Client_commands.context -> - string -> Script.expr Lwt.t -val parse_data_type: - Client_commands.context -> - string -> Script.expr Lwt.t +val parse_program: string -> Script.code tzresult Lwt.t +val parse_data: string -> Script.expr tzresult Lwt.t +val parse_data_type: string -> Script.expr tzresult Lwt.t module Program : Client_aliases.Alias with type t = Script.code diff --git a/src/client/embedded/genesis/client_proto_main.ml b/src/client/embedded/genesis/client_proto_main.ml index 8867c54a5..cc3e197c3 100644 --- a/src/client/embedded/genesis/client_proto_main.ml +++ b/src/client/embedded/genesis/client_proto_main.ml @@ -56,12 +56,13 @@ let commands () = command ~args ~desc: "Activate a protocol" begin prefixes [ "activate" ; "protocol" ] @@ - param ~name:"version" ~desc:"Protocol version (b58check)" - (fun _ p -> Lwt.return @@ Protocol_hash.of_b58check_exn p) @@ + 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 -> Lwt.return (Int64.of_string p)) @@ + (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" @@ @@ -76,16 +77,16 @@ let commands () = command ~args ~desc: "Fork a test protocol" begin prefixes [ "fork" ; "test" ; "protocol" ] @@ - param ~name:"version" ~desc:"Protocol version (b58check)" - (fun _ p -> Lwt.return (Protocol_hash.of_b58check_exn p)) @@ + 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 -> Lwt.return (Int64.of_string p)) @@ + (fun _ p -> + try return (Int64.of_string p) + with _ -> failwith "Cannot read int64") @@ prefixes [ "and" ; "key" ] @@ - param ~name:"password" ~desc:"Dictator's key" - (fun _ key -> - Lwt.return (Environment.Ed25519.Secret_key.of_b58check_exn key)) @@ + Environment.Ed25519.Secret_key.param + ~name:"password" ~desc:"Dictator's key" @@ stop end begin fun hash fitness seckey cctxt -> let timestamp = !timestamp in diff --git a/src/client_main.ml b/src/client_main.ml index 4e6ecb3d0..2f826d97d 100644 --- a/src/client_main.ml +++ b/src/client_main.ml @@ -85,6 +85,15 @@ let main () = command (cctxt config rpc_config) >>= function | Ok () -> Lwt.return 0 + | Error [Cli_entries.Command_not_found] -> + Format.eprintf "Unknown command, try `-help`.@." ; + Lwt.return 1 + | Error [Cli_entries.Bad_argument (idx, _n, v)] -> + Format.eprintf "There's a problem with argument %d, %s.@." idx v ; + Lwt.return 1 + | Error [Cli_entries.Command_failed message] -> + Format.eprintf "Command failed, %s.@." message ; + Lwt.return 1 | Error err -> Format.eprintf "Error: %a@." pp_print_error err ; Lwt.return 1 @@ -95,18 +104,9 @@ let main () = | Arg.Bad help -> Format.eprintf "%s%!" help ; Lwt.return 1 - | Cli_entries.Command_not_found -> - Format.eprintf "Unknown command, try `-help`.@." ; - Lwt.return 1 - | Client_commands.Version_not_found -> + | Client_commands.Version_not_found -> Format.eprintf "Unknown protocol version, try `list versions`.@." ; Lwt.return 1 - | Cli_entries.Bad_argument (idx, _n, v) -> - Format.eprintf "There's a problem with argument %d, %s.@." idx v ; - Lwt.return 1 - | Cli_entries.Command_failed message -> - Format.eprintf "Command failed, %s.@." message ; - Lwt.return 1 | Failure message -> Format.eprintf "Fatal error: %s@." message ; Lwt.return 1 diff --git a/src/node/updater/environment.ml b/src/node/updater/environment.ml index 4f251f563..e3f3e76bd 100644 --- a/src/node/updater/environment.ml +++ b/src/node/updater/environment.ml @@ -58,6 +58,9 @@ module Ed25519 = struct let of_bytes s = Sodium.Sign.Bytes.to_public_key s + let param ?(name="ed25519-public") ?(desc="Ed25519 public key (b58check-encoded)") t = + Cli_entries.param ~name ~desc (fun _ str -> Lwt.return (of_b58check str)) t + let () = Base58.check_encoded_prefix b58check_encoding "edpk" 54 @@ -117,6 +120,9 @@ module Ed25519 = struct let of_bytes s = Sodium.Sign.Bytes.to_secret_key s + let param ?(name="ed25519-secret") ?(desc="Ed25519 secret key (b58check-encoded)") t = + Cli_entries.param ~name ~desc (fun _ str -> Lwt.return (of_b58check str)) t + let () = Base58.check_encoded_prefix b58check_encoding "edsk" 98 @@ -173,6 +179,9 @@ module Ed25519 = struct let of_bytes s = MBytes.of_string (Bytes.to_string s) + let param ?(name="signature") ?(desc="Signature (b58check-encoded)") t = + Cli_entries.param ~name ~desc (fun _ str -> Lwt.return (of_b58check str)) t + let () = Base58.check_encoded_prefix b58check_encoding "edsig" 99 diff --git a/src/utils/cli_entries.ml b/src/utils/cli_entries.ml index fb7aaf559..1018a65cd 100644 --- a/src/utils/cli_entries.ml +++ b/src/utils/cli_entries.ml @@ -9,12 +9,14 @@ (* Tezos Command line interface - Command Line Parsing *) +open Error_monad open Lwt.Infix (* User catchable exceptions *) -exception Command_not_found -exception Bad_argument of int * string * string -exception Command_failed of string +type error += Command_not_found +type error += Bad_argument of int * string * string +type error += Command_failed of string + (* A simple structure for command interpreters. This is more generic than the exported one, see end of file. *) @@ -22,16 +24,16 @@ type ('a, 'arg, 'ret) params = | Prefix : string * ('a, 'arg, 'ret) params -> ('a, 'arg, 'ret) params | Param : string * string * - ('arg -> string -> 'p Lwt.t) * + ('arg -> string -> 'p tzresult Lwt.t) * ('a, 'arg, 'ret) params -> ('p -> 'a, 'arg, 'ret) params | Stop : - ('arg -> 'ret Lwt.t, 'arg, 'ret) params + ('arg -> 'ret tzresult Lwt.t, 'arg, 'ret) params | More : - (string list -> 'arg -> 'ret Lwt.t, 'arg, 'ret) params + (string list -> 'arg -> 'ret tzresult Lwt.t, 'arg, 'ret) params | Seq : string * string * - ('arg -> string -> 'p Lwt.t) -> - ('p list -> 'arg -> 'ret Lwt.t, 'arg, 'ret) params + ('arg -> string -> 'p tzresult Lwt.t) -> + ('p list -> 'arg -> 'ret tzresult Lwt.t, 'arg, 'ret) params (* A command group *) type group = @@ -70,29 +72,29 @@ let command ?group ?(args = []) ~desc params handler = (* Param combinators *) let string ~name ~desc next = - param name desc (fun _ s -> Lwt.return s) next + param name desc (fun _ s -> return s) next (* Command execution *) let exec (type arg) (type ret) (Command { params ; handler }) (last : arg) args = let rec exec - : type a. int -> (a, arg, ret) params -> a -> string list -> ret Lwt.t + : 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, _ -> Lwt.fail Command_not_found + | Stop, _ -> fail Command_not_found | Seq (_, _, f), seq -> let rec do_seq i acc = function - | [] -> Lwt.return (List.rev acc) + | [] -> return (List.rev acc) | p :: rest -> Lwt.catch (fun () -> f last p) (function - | Failure msg -> Lwt.fail (Bad_argument (i, p, msg)) - | exn -> Lwt.fail exn) >>= fun v -> + | Failure msg -> fail (Bad_argument (i, p, msg)) + | exn -> fail (Exn exn)) >>=? fun v -> do_seq (succ i) (v :: acc) rest in - do_seq i [] seq >>= fun parsed -> + do_seq i [] seq >>=? fun parsed -> cb parsed last | More, rest -> cb rest last | Prefix (n, next), p :: rest when n = p -> @@ -101,10 +103,10 @@ let exec Lwt.catch (fun () -> f last p) (function - | Failure msg -> Lwt.fail (Bad_argument (i, p, msg)) - | exn -> Lwt.fail exn) >>= fun v -> + | Failure msg -> fail (Bad_argument (i, p, msg)) + | exn -> fail (Exn exn)) >>=? fun v -> exec (succ i) next (cb v) rest - | _ -> Lwt.fail Command_not_found + | _ -> fail Command_not_found in exec 1 params handler args (* Command dispatch tree *) @@ -168,10 +170,10 @@ let tree_dispatch tree last args = begin try let t = List.assoc n prefix in loop (t, rest) - with Not_found -> Lwt.fail Command_not_found end + with Not_found -> fail Command_not_found end | TParam { tree }, _ :: rest -> loop (tree, rest) - | _, _ -> Lwt.fail Command_not_found + | _, _ -> fail Command_not_found in loop (tree, args) @@ -196,14 +198,14 @@ let inline_tree_dispatch tree () = | TStop (Command { args }) | TMore (Command { args }) -> `Args args | _ -> `Nop end - with Not_found -> `Fail Command_not_found 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 + | _, _ -> `Fail [Command_not_found] (* Try a list of commands on a list of arguments *) let dispatch commands = diff --git a/src/utils/cli_entries.mli b/src/utils/cli_entries.mli index 05d367069..caebb1eb9 100644 --- a/src/utils/cli_entries.mli +++ b/src/utils/cli_entries.mli @@ -7,12 +7,14 @@ (* *) (**************************************************************************) +open Error_monad + (* Tezos: a small Command Line Parsing library *) (* Only used in the client. *) -exception Command_not_found -exception Bad_argument of int * string * string -exception Command_failed of string +type error += Command_not_found +type error += Bad_argument of int * string * string +type error += Command_failed of string type ('a, 'arg, 'ret) params type ('arg, 'ret) command @@ -20,7 +22,7 @@ type ('arg, 'ret) command val param: name: string -> desc: string -> - ('arg -> string -> 'a Lwt.t) -> + ('arg -> string -> 'a tzresult Lwt.t) -> ('b, 'arg, 'ret) params -> ('a -> 'b, 'arg, 'ret) params val prefix: @@ -33,14 +35,14 @@ val prefixes: ('a, 'arg, 'ret) params val fixed: string list -> - ('arg -> 'ret Lwt.t, 'arg, 'ret) params + ('arg -> 'ret tzresult Lwt.t, 'arg, 'ret) params val stop: - ('arg -> 'ret Lwt.t, 'arg, 'ret) params + ('arg -> 'ret tzresult Lwt.t, 'arg, 'ret) params val seq: name: string -> desc: string -> - ('arg -> string -> 'p Lwt.t) -> - ('p list -> 'arg -> 'ret Lwt.t, 'arg, 'ret) params + ('arg -> string -> 'p tzresult Lwt.t) -> + ('p list -> 'arg -> 'ret tzresult Lwt.t, 'arg, 'ret) params val string: name: string -> @@ -49,9 +51,9 @@ val string: (string -> 'a, 'arg, 'ret) params val seq_of_param: - (('arg -> 'ret Lwt.t, 'arg, 'ret) params -> - ('a -> 'arg -> 'ret Lwt.t, 'arg, 'ret) params) -> - ('a list -> 'arg -> 'ret Lwt.t, 'arg, 'ret) params + (('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 type group = { name : string ; @@ -71,9 +73,9 @@ val inline_dispatch: ('arg, 'ret) command list -> unit -> [ `Arg of string | `End ] -> [ `Args of (Arg.key * Arg.spec * Arg.doc) list - | `Fail of exn + | `Fail of error list | `Nop - | `Res of 'arg -> 'ret Lwt.t ] + | `Res of 'arg -> 'ret tzresult Lwt.t ] val dispatch: - ('arg, 'ret) command list -> 'arg -> string list -> 'ret Lwt.t + ('arg, 'ret) command list -> 'arg -> string list -> 'ret tzresult Lwt.t diff --git a/src/utils/hash.ml b/src/utils/hash.ml index bdd873b5c..3c88e93cb 100644 --- a/src/utils/hash.ml +++ b/src/utils/hash.ml @@ -13,6 +13,7 @@ let (//) = Filename.concat let (>>=) = Lwt.bind let (>|=) = Lwt.(>|=) +open Error_monad open Utils let () = @@ -99,6 +100,11 @@ end module type INTERNAL_HASH = sig include HASH val of_b58check: string -> t tzresult + val param: + ?name:string -> + ?desc:string -> + ('a, 'arg, 'ret) Cli_entries.params -> + (t -> 'a, 'arg, 'ret) Cli_entries.params module Table : Hashtbl.S with type key = t end @@ -307,7 +313,7 @@ module Make_Blake2B (R : sig conv to_b58check (Data_encoding.Json.wrap_error of_b58check_exn) string) let param ?(name=K.name) ?(desc=K.title) t = - Cli_entries.param ~name ~desc (fun _ str -> Lwt.return (of_b58check_exn str)) t + Cli_entries.param ~name ~desc (fun _ str -> Lwt.return (of_b58check str)) t let pp ppf t = Format.pp_print_string ppf (to_b58check t) diff --git a/src/utils/hash.mli b/src/utils/hash.mli index 53748a1d2..f028101ca 100644 --- a/src/utils/hash.mli +++ b/src/utils/hash.mli @@ -91,6 +91,11 @@ end module type INTERNAL_HASH = sig include HASH val of_b58check: string -> t tzresult + val param: + ?name:string -> + ?desc:string -> + ('a, 'arg, 'ret) Cli_entries.params -> + (t -> 'a, 'arg, 'ret) Cli_entries.params module Table : Hashtbl.S with type key = t end @@ -156,14 +161,7 @@ module Make_Blake2B (** {2 Predefined Hashes } ****************************************************) (** Blocks hashes / IDs. *) -module Block_hash : sig - include INTERNAL_HASH - val param : - ?name:string -> - ?desc:string -> - ('a, 'arg, 'ret) Cli_entries.params -> - (t -> 'a, 'arg, 'ret) Cli_entries.params -end +module Block_hash : INTERNAL_HASH (** Operations hashes / IDs. *) module Operation_hash : INTERNAL_HASH