Client: more Error_monad in Cli_entries.

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 \

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
+         find cctxt s >>=? fun v ->
-         | Ok v -> Lwt.return (s, v)
+         return (s, v))
-         | Error err -> cctxt.error "%a" pp_print_error err)
       next
 
   let fresh_alias_param
@@ -233,9 +232,8 @@ module Alias = functor (Entity : Entity) -> struct
                       return ())
                  list
            end
-         end >>= function
+         end >>=? fun () ->
-         | Ok () -> Lwt.return s
+         return s)
-         | Error err -> cctxt.error "%a" pp_print_error err)
       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
+         end)
-         | Ok s -> Lwt.return s
-         | Error err -> cctxt.error "%a" pp_print_error err)
       next
 
    let name cctxt d =

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 *)
 

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
 

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 ->

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
+
 ]

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
+      failwith "%s is not a directory" dn in
-  let check_hash _ ph =
-    Lwt.wrap1 Protocol_hash.of_b58check_exn ph 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 ->

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
+      (fun cctxt s -> of_source cctxt s)
-         | Ok r -> Lwt.return r
-         | Error err -> cctxt.error "%a" pp_print_error err)
       next
 
   let rev_find_by_tag cctxt tag =

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)
+       try return (tez_of_string s)
-       with _ -> Lwt.fail_with "invalid \xEA\x9C\xA9 notation")
+       with _ -> failwith "invalid \xEA\x9C\xA9 notation")
     next
 
 let max_priority = ref None

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 ->
+        Client_proto_programs.parse_data arg >>=? fun arg ->
-        Lwt.return (Some arg)
+        return (Some arg)
-    | None -> Lwt.return None
+    | None -> return None
-  end >>= fun parameters ->
+  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)"
+      Protocol_hash.param ~name:"version" ~desc:"Protocol version (b58check)" @@
-        (fun _ p -> Lwt.return @@ Protocol_hash.of_b58check_exn p) @@
       prefixes [ "with" ; "key" ] @@
-      param ~name:"password" ~desc:"Dictator's key"
+      Environment.Ed25519.Secret_key.param
-        (fun _ key ->
+        ~name:"password" ~desc:"Dictator's key" @@
-           Lwt.return (Environment.Ed25519.Secret_key.of_b58check_exn 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)"
+      Protocol_hash.param ~name:"version" ~desc:"Protocol version (b58check)" @@
-        (fun _ p -> Lwt.return (Protocol_hash.of_b58check_exn p)) @@
       prefixes [ "with" ; "key" ] @@
-      param ~name:"password" ~desc:"Dictator's key"
+      Environment.Ed25519.Secret_key.param
-        (fun _ key ->
+        ~name:"password" ~desc:"Dictator's key" @@
-           Lwt.return (Environment.Ed25519.Secret_key.of_b58check_exn key))
+      stop
-        stop
     end
       (fun hash seckey cctxt ->
          dictate cctxt cctxt.config.block (Activate_testnet hash) seckey) ;
+
   ]

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 ->
+      (fun cctxt p -> get_contract cctxt p)
-         get_contract cctxt p >>= function
-         | Ok v -> Lwt.return v
-         | Error err -> cctxt.error "%a" pp_print_error err)
       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
+         end)
-         | Ok v -> Lwt.return v
-         | Error err -> cctxt.error "%a" pp_print_error err)
       next
 
    let name cctxt contract =

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)
+    | [node] -> return (Script_located_ir.strip_locations node)
-    | _ -> cctxt.Client_commands.error "single data expression expected"
+    | _ -> 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)
+    | [node] -> return (Script_located_ir.strip_locations node)
-    | _ -> cctxt.Client_commands.error "single type expression expected"
+    | _ -> 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 =
+    let of_source _cctxt s = parse_program s
-      parse_program cctxt s >>= fun code ->
-      return code
     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 () ->
+             failwith "ill-typed data") ;
-             return ()) ;
 
     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 () ->
+             failwith "ill-formed data") ;
-             return ()) ;
 
     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 () ->
+             failwith "ill-formed data") ;
-             return ()) ;
 
   ]

src/client/embedded/alpha/client_proto_programs.mli

@@ -7,15 +7,9 @@
 (*                                                                        *)
 (**************************************************************************)
 
-val parse_program:
+val parse_program: string -> Script.code tzresult Lwt.t
-  Client_commands.context ->
+val parse_data: string -> Script.expr tzresult Lwt.t
-  string -> Script.code Lwt.t
+val parse_data_type: string -> Script.expr tzresult 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
 
 module Program : Client_aliases.Alias with type t = Script.code
 

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)"
+      Protocol_hash.param ~name:"version" ~desc:"Protocol version (b58check)" @@
-        (fun _ p -> Lwt.return @@ Protocol_hash.of_b58check_exn p) @@
       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)"
+      Protocol_hash.param ~name:"version" ~desc:"Protocol version (b58check)" @@
-        (fun _ p -> Lwt.return (Protocol_hash.of_b58check_exn p)) @@
       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"
+      Environment.Ed25519.Secret_key.param
-        (fun _ key ->
+        ~name:"password" ~desc:"Dictator's key" @@
-           Lwt.return (Environment.Ed25519.Secret_key.of_b58check_exn key)) @@
       stop
     end begin fun hash fitness seckey cctxt ->
       let timestamp = !timestamp in

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 ->
+    |  Client_commands.Version_not_found ->
-        Format.eprintf "Unknown command, try `-help`.@." ;
-        Lwt.return 1
-    | 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

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
 

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
+type error += Command_not_found
-exception Bad_argument of int * string * string
+type error += Bad_argument of int * string * string
-exception Command_failed of 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) ->
+          ('arg -> string -> 'p tzresult Lwt.t) ->
-    ('p list -> 'arg -> 'ret Lwt.t, 'arg, 'ret) params
+    ('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))
+                  | Failure msg -> fail (Bad_argument (i, p, msg))
-                  | exn -> Lwt.fail exn) >>= fun v ->
+                  | 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))
+            | Failure msg -> fail (Bad_argument (i, p, msg))
-            | exn -> Lwt.fail exn) >>= fun v ->
+            | 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 =

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
+type error += Command_not_found
-exception Bad_argument of int * string * string
+type error += Bad_argument of int * string * string
-exception Command_failed of 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) ->
+  ('arg -> string -> 'p tzresult Lwt.t) ->
-  ('p list -> 'arg -> 'ret Lwt.t, 'arg, 'ret) params
+  ('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 ->
+  (('arg -> 'ret tzresult Lwt.t, 'arg, 'ret) params ->
-   ('a -> 'arg -> 'ret Lwt.t, 'arg, 'ret) params) ->
+   ('a -> 'arg -> 'ret tzresult Lwt.t, 'arg, 'ret) params) ->
-  ('a list -> 'arg -> 'ret 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

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)

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
+module Block_hash : INTERNAL_HASH
-  include INTERNAL_HASH
-  val param :
-    ?name:string ->
-    ?desc:string ->
-    ('a, 'arg, 'ret) Cli_entries.params ->
-    (t -> 'a, 'arg, 'ret) Cli_entries.params
-end
 
 (** Operations hashes / IDs. *)
 module Operation_hash : INTERNAL_HASH