Client: minor client output fixes and enhancements.

src/client/client_aliases.ml

@@ -264,10 +264,16 @@ module Alias = functor (Entity : Entity) -> struct
            | _ ->
                find cctxt s >>= function
                | Ok v -> return v
-               | Error _ ->
+               | Error a_errs ->
                    read s >>= function
                    | Ok v -> return v
-                   | Error _ -> of_source cctxt s
+                   | Error r_errs ->
+                       of_source cctxt s >>= function
+                       | Ok v -> return v
+                       | Error s_errs ->
+                           let all_errs =
+                             List.flatten [ a_errs ; r_errs ; s_errs ] in
+                           Lwt.return (Error all_errs)
          end)
       next
 

src/client/client_config.ml

@@ -173,6 +173,8 @@ let default_cli_args = {
   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
@@ -215,24 +217,22 @@ let parse_args usage dispatcher argv =
     let anon dispatch n = match dispatch (`Arg n) with
       | `Nop -> ()
       | `Args nargs -> args := nargs @ !args
-      | `Fail err ->
+      | `Fail err -> raise (Bad 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)
+    | `Res res -> return (res, !parsed_args)
-    | `Fail err ->
+    | `Fail err -> Lwt.return (Error err)
-        Format.kasprintf (fun s -> raise (Arg.Help s)) "%a" pp_print_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 = List.hd (Utils.split '\000' msg) in
+      let msg = String.trim (List.hd (Utils.split '\000' msg)) in
-      raise (Arg.Help (msg ^ usage all_args ^ "\n"))
+      Error_monad.failwith "%s" msg
   | Arg.Help _ ->
       raise (Arg.Help (usage all_args ^ "\n"))
-

src/client/client_generic_rpcs.ml

@@ -288,9 +288,27 @@ let schema url cctxt =
   let open RPC.Description in
   Client_node_rpcs.describe cctxt.rpc_config ~recurse:false args >>=? function
   | Static { service = Some { input ; output } } ->
-      cctxt.message "Input schema:\n%s\nOutput schema:\n%s\n%!"
+      let json = `O [ "input", Json_schema.to_json input ;
-        (Data_encoding_ezjsonm.to_string (Json_schema.to_json input))
+                      "output", Json_schema.to_json output ] in
-        (Data_encoding_ezjsonm.to_string (Json_schema.to_json output)) >>= fun () ->
+      cctxt.message "%a" Json_repr.(pp (module Ezjsonm)) json >>= fun () ->
+      return ()
+  | _ ->
+      cctxt.message
+        "No service found at this URL (but this is a valid prefix)\n%!" >>= fun () ->
+      return ()
+
+let format url cctxt =
+  let args = Utils.split '/' url in
+  let open RPC.Description in
+  Client_node_rpcs.describe cctxt.rpc_config ~recurse:false args >>=? function
+  | Static { service = Some { input ; output } } ->
+      cctxt.message
+        "@[<v 0>\
+         @[<v 2>Input format:@,%a@]@,\
+         @[<v 2>Output format:@,%a@]@,\
+         @]"
+        Json_schema.pp input
+        Json_schema.pp output >>= fun () ->
       return ()
   | _ ->
       cctxt.message
@@ -315,8 +333,8 @@ let call url cctxt =
           return ()
       | Ok json ->
           Client_rpcs.get_json cctxt.rpc_config `POST args json >>=? fun json ->
-          cctxt.message
+          cctxt.message "%a"
-            "Output:\n%s\n%!" (Data_encoding_ezjsonm.to_string json) >>= fun () ->
+            Json_repr.(pp (module Ezjsonm)) json >>= fun () ->
           return ()
     end
   | _ ->
@@ -334,8 +352,8 @@ let call_with_json url json (cctxt: Client_commands.context) =
   | Ok json ->
       let open RPC.Description in
       Client_rpcs.get_json cctxt.rpc_config `POST args json >>=? fun json ->
-      cctxt.message
+      cctxt.message "%a"
-        "Output:\n%s\n%!" (Data_encoding_ezjsonm.to_string json) >>= fun () ->
+        Json_repr.(pp (module Ezjsonm)) json >>= fun () ->
       return ()
 
 let group =
@@ -360,17 +378,21 @@ let commands = [
     (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"
+  command ~group ~desc: "get the input and output JSON schemas of an RPC"
     (prefixes [ "rpc" ; "schema" ] @@ string ~name: "url" ~desc: "the RPC's URL" @@ stop)
     schema ;
 
+  command ~group ~desc: "get the humanoid readable input and output formats of an RPC"
+    (prefixes [ "rpc" ; "format" ] @@ string ~name: "url" ~desc: "the RPC's URL" @@ stop)
+    format ;
+
   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)
+     @@ prefix "with" @@ string ~name:"input" ~desc:"the JSON input to the RPC" @@ stop)
     call_with_json
 
 ]

src/client/client_rpcs.ml

@@ -32,6 +32,16 @@ let null_logger =
     log_error = (fun _ _ _ -> Lwt.return_unit) ;
   }
 
+let config_encoding =
+  let open Data_encoding in
+  conv
+    (fun { host ; port ; tls } -> (host, port, tls))
+    (fun (host, port, tls) -> { host ; port ; tls ; logger = null_logger})
+    (obj3
+       (req "host" string)
+       (req "port" uint16)
+       (req "tls" bool))
+
 let timings_logger ppf =
   Logger {
     log_request = begin fun url _body ->
@@ -73,7 +83,7 @@ let full_logger ppf =
       Format.fprintf ppf "<<<<%d: %s\n%s@." id code body ;
       Lwt.return_unit
     end ;
-}
+  }
 
 let default_config = {
   host = "localhost" ;
@@ -90,6 +100,88 @@ type rpc_error =
 
 type error += RPC_error of config * rpc_error
 
+let rpc_error_encoding =
+  let open Data_encoding in
+  union
+    [ case ~tag: 1
+        (obj2
+           (req "rpc_error_kind" (constant "cannot_connect"))
+           (req "message" string))
+        (function Cannot_connect_to_RPC_server msg -> Some ((), msg) | _ -> None)
+        (function (), msg -> Cannot_connect_to_RPC_server msg) ;
+    case ~tag: 2
+        (obj3
+           (req "rpc_error_kind" (constant "request_failed"))
+           (req "path" (list string))
+           (req "http_code" (conv Cohttp.Code.code_of_status Cohttp.Code.status_of_code uint16)))
+        (function Request_failed (path, code) -> Some ((), path, code) | _ -> None)
+        (function (), path, code -> Request_failed (path, code)) ;
+    case ~tag: 3
+        (obj4
+           (req "rpc_error_kind" (constant "malformed_json"))
+           (req "path" (list string))
+           (req "message" string)
+           (req "text" string))
+        (function Malformed_json (path, json, msg) -> Some ((), path, msg, json) | _ -> None)
+        (function (), path, msg, json -> Malformed_json (path, json, msg)) ;
+    case ~tag: 4
+        (obj4
+           (req "rpc_error_kind" (constant "unexpected_json"))
+           (req "path" (list string))
+           (req "message" string)
+           (req "json" json))
+        (function Unexpected_json (path, json, msg) -> Some ((), path, msg, json) | _ -> None)
+        (function (), path, msg, json -> Unexpected_json (path, json, msg)) ]
+
+let pp_error ppf (config, err) =
+  let pp_path ppf path =
+    Format.fprintf ppf "%s://%s:%d/%s"
+      (if config.tls then "https" else "http")
+      config.host config.port
+      (String.concat "/" path) in
+  match err with
+  | Cannot_connect_to_RPC_server msg ->
+      Format.fprintf ppf "Cannot contact RPC server: %s" msg
+  | Request_failed (path, code) ->
+      let code = Cohttp.Code.code_of_status code in
+      Format.fprintf ppf "@[<v 2>RPC Request failed:@,\
+                          Path: %a@,\
+                          HTTP status: %d (%s)@]"
+        pp_path path
+        code (Cohttp.Code.reason_phrase_of_code code)
+  | Malformed_json (path, json, msg) ->
+      Format.fprintf ppf "@[<v 2>RPC request returned malformed JSON:@,\
+                          Path: %a@,\
+                          Error: %s@,\
+                          @[<v 2>JSON data:@,%a@]@]"
+        pp_path path
+        msg
+        (Format.pp_print_list
+           (fun ppf s -> Format.fprintf ppf "> %s" s))
+        (Utils.split '\n' json)
+  | Unexpected_json (path, json, msg) ->
+      Format.fprintf ppf "@[<v 2>RPC request returned unexpected JSON:@,\
+                          Path: %a@,\
+                          @[<v 2>Error:@,%a@]@,\
+                          @[<v 2>JSON data:@,%a@]@]"
+        pp_path path
+        (Format.pp_print_list (fun ppf s -> Format.fprintf ppf "%s" s))
+        (Utils.split '\n' msg)
+        Json_repr.(pp (module Ezjsonm)) json
+
+let () =
+  register_error_kind
+    `Branch
+    ~id: "client_rpc"
+    ~title: "Client side RPC error"
+    ~description: "An RPC call failed"
+    ~pp: pp_error
+    Data_encoding.(obj2
+                     (req "config" config_encoding)
+                     (req "error" rpc_error_encoding))
+    (function RPC_error (config, err) -> Some (config, err) | _ -> None)
+    (fun (config, err) -> RPC_error (config, err))
+
 let fail config err = fail (RPC_error (config, err))
 
 let make_request config log_request meth service json =
@@ -103,8 +195,8 @@ let make_request config log_request meth service json =
     Cohttp_lwt_unix.Client.call meth ~body uri >>= fun (code, ansbody) ->
     log_request uri json >>= fun reqid ->
     return (reqid, code.Cohttp.Response.status, ansbody)
-  end begin fun e ->
+  end begin fun exn ->
-    let msg = match e with
+    let msg = match exn with
       | Unix.Unix_error (e, _, _) -> Unix.error_message e
       | e -> Printexc.to_string e in
     fail config (Cannot_connect_to_RPC_server msg)
@@ -166,7 +258,7 @@ let get_json config meth service json =
 
 let parse_answer config service path json =
   match RPC.read_answer service json with
-  | Error msg -> (* TODO print_error *)
+  | Error msg ->
       fail config (Unexpected_json (path, json, msg))
   | Ok v -> return v
 
@@ -196,7 +288,7 @@ let call_streamed_service0 cctxt service arg =
         | Ok v -> push (Some (Ok v)) ; loop ()
         | Error _ as err ->
             push (Some err) ; push None ; Lwt.return_unit
-        end
+      end
     | Some (Error _) as v ->
         push v ; push None ; Lwt.return_unit
     | None -> push None ; Lwt.return_unit

src/client/embedded/alpha/client_proto_contracts.ml

@@ -34,7 +34,7 @@ module ContractAlias = struct
         | Some v ->
             return (s, Contract.default_contract v)
         | None ->
-            failwith "no contract alias nor key alias names %s" s
+            failwith "no contract or key named %s" s
 
   let find_key cctxt name =
     Client_keys.Public_key_hash.find cctxt name >>=? fun v ->
@@ -79,11 +79,12 @@ module ContractAlias = struct
                Client_keys.Public_key_hash.find cctxt text >>=? fun v ->
                return (s, Contract.default_contract v)
            | _ ->
-               find  cctxt s >>= function
+               find cctxt s >>= function
                | Ok v -> return v
-               | Error _ ->
+               | Error k_errs ->
-                   ContractEntity.of_source cctxt s >>=? fun v ->
+                   ContractEntity.of_source cctxt s >>= function
-                   return (s, v)
+                   | Ok v -> return (s, v)
+                   | Error c_errs -> Lwt.return (Error (k_errs @ c_errs))
          end)
       next
 

src/client_main.ml

@@ -51,10 +51,10 @@ let main () =
       Client_node_rpcs.Blocks.protocol rpc_config block >>= function
       | Ok version ->
           Lwt.return (Some version, Client_commands.commands_for_version version)
-      | Error err ->
+      | Error errs ->
           Format.eprintf
-            "Failed to acquire the protocol version from the node: %a.@."
+            "@[<v 2>Ignored error:@,Failed to acquire the protocol version from the node@,%a@."
-            pp_print_error err ;
+            (Format.pp_print_list pp) errs ;
           Lwt.return (None, [])
     end >>= fun (_version, commands_for_version)  ->
     let commands =
@@ -64,51 +64,42 @@ let main () =
       Client_protocols.commands () @
       Client_helpers.commands () @
       commands_for_version in
-    let (command, parsed_args) =
+    (Client_config.parse_args
-      Client_config.parse_args
+       (Cli_entries.usage ~commands)
-        (Cli_entries.usage ~commands)
+       (Cli_entries.inline_dispatch commands)
-        (Cli_entries.inline_dispatch commands)
+       Sys.argv >>=? fun (command, parsed_args) ->
-        Sys.argv in
+     let config : Client_commands.cfg = {
-    let config : Client_commands.cfg = {
+       base_dir = parsed_config_file.base_dir ;
-      base_dir = parsed_config_file.base_dir ;
+       force = parsed_args.force ;
-      force = parsed_args.force ;
+       block ;
-      block ;
+       web_port = Client_commands.default_cfg.web_port ;
-      web_port = Client_commands.default_cfg.web_port ;
+     } in
-    } in
+     let rpc_config =
-    let rpc_config =
+       if parsed_args.print_timings then
-      if parsed_args.print_timings then
+         { rpc_config with
-        { rpc_config with
+           logger = Client_rpcs.timings_logger Format.err_formatter }
-          logger = Client_rpcs.timings_logger Format.err_formatter }
+       else
-      else
+         rpc_config
-        rpc_config
+     in
-    in
+     command (cctxt config rpc_config)) >>= function
-    command (cctxt config rpc_config) >>= function
     | Ok () ->
         Lwt.return 0
-    | Error [Cli_entries.Command_not_found] ->
+    | Error errs ->
-        Format.eprintf "Unknown command, try `-help`.@." ;
+        Format.eprintf "@[<v 2>Fatal error:@,%a@.\
-        Lwt.return 1
+                        Try `-help` for a list of options and commands.@."
-    | Error [Cli_entries.Bad_argument (idx, _n, v)] ->
+          (Format.pp_print_list Error_monad.pp) errs ;
-        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
   end begin function
     | Arg.Help help ->
         Format.printf "%s%!" help ;
         Lwt.return 0
-    | Arg.Bad help ->
-        Format.eprintf "%s%!" help ;
-        Lwt.return 1
     |  Client_commands.Version_not_found ->
         Format.eprintf "Unknown protocol version, try `list versions`.@." ;
         Lwt.return 1
     | Failure message ->
-        Format.eprintf "Fatal error: %s@." message ;
+        Format.eprintf
+          "Fatal error: %s@.\
+           Try `-help` for a list of options and commands.@." message ;
         Lwt.return 1
     | exn ->
         Format.printf "Fatal internal error: %s@."

src/utils/cli_entries.ml

@@ -14,9 +14,31 @@ open Lwt.Infix
 
 (* User catchable exceptions *)
 type error += Command_not_found
-type error += Bad_argument of int * string * string
+type error += Bad_argument of int * string
-type error += Command_failed 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))
 
 (* A simple structure for command interpreters.
    This is more generic than the exported one, see end of file. *)
@@ -91,8 +113,9 @@ let exec
               Lwt.catch
                 (fun () -> f last p)
                 (function
-                  | Failure msg -> fail (Bad_argument (i, p, msg))
+                  | Failure msg -> Error_monad.failwith "%s" msg
-                  | exn -> fail (Exn exn)) >>=? fun v ->
+                  | 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
@@ -103,8 +126,9 @@ let exec
         Lwt.catch
           (fun () -> f last p)
           (function
-            | Failure msg -> fail (Bad_argument (i, p, msg))
+            | Failure msg -> Error_monad.failwith "%s" msg
-            | exn -> fail (Exn exn)) >>=? fun v ->
+            | 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

src/utils/cli_entries.mli

@@ -13,8 +13,7 @@ open Error_monad
 (* Only used in the client. *)
 
 type error += Command_not_found
-type error += Bad_argument of int * string * string
+type error += Bad_argument of int * string
-type error += Command_failed of string
 
 type ('a, 'arg, 'ret) params
 type ('arg, 'ret) command