diff --git a/src/client/client_aliases.ml b/src/client/client_aliases.ml index a1acaabf1..62921e2fa 100644 --- a/src/client/client_aliases.ml +++ b/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 diff --git a/src/client/client_config.ml b/src/client/client_config.ml index 9f98b1046..26501664c 100644 --- a/src/client/client_config.ml +++ b/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 -> - Format.kasprintf (fun s -> raise (Arg.Help s)) "%a" pp_print_error err + | `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 -> (res, !parsed_args) - | `Fail err -> - Format.kasprintf (fun s -> raise (Arg.Help s)) "%a" pp_print_error err + | `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 = List.hd (Utils.split '\000' msg) in - raise (Arg.Help (msg ^ usage all_args ^ "\n")) + 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")) - diff --git a/src/client/client_generic_rpcs.ml b/src/client/client_generic_rpcs.ml index e2e45cc95..d53c024f3 100644 --- a/src/client/client_generic_rpcs.ml +++ b/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%!" - (Data_encoding_ezjsonm.to_string (Json_schema.to_json input)) - (Data_encoding_ezjsonm.to_string (Json_schema.to_json output)) >>= fun () -> + let json = `O [ "input", Json_schema.to_json input ; + "output", Json_schema.to_json output ] in + 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 + "@[\ + @[Input format:@,%a@]@,\ + @[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 - "Output:\n%s\n%!" (Data_encoding_ezjsonm.to_string json) >>= fun () -> + cctxt.message "%a" + 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 - "Output:\n%s\n%!" (Data_encoding_ezjsonm.to_string json) >>= fun () -> + cctxt.message "%a" + 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 ] diff --git a/src/client/client_rpcs.ml b/src/client/client_rpcs.ml index 15f2a756c..c05323dc4 100644 --- a/src/client/client_rpcs.ml +++ b/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 "@[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 "@[RPC request returned malformed JSON:@,\ + Path: %a@,\ + Error: %s@,\ + @[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 "@[RPC request returned unexpected JSON:@,\ + Path: %a@,\ + @[Error:@,%a@]@,\ + @[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 -> - let msg = match e with + end begin fun exn -> + 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 diff --git a/src/client/embedded/alpha/client_proto_contracts.ml b/src/client/embedded/alpha/client_proto_contracts.ml index c3deb98d3..1a55f60f5 100644 --- a/src/client/embedded/alpha/client_proto_contracts.ml +++ b/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 _ -> - ContractEntity.of_source cctxt s >>=? fun v -> - return (s, v) + | Error k_errs -> + ContractEntity.of_source cctxt s >>= function + | Ok v -> return (s, v) + | Error c_errs -> Lwt.return (Error (k_errs @ c_errs)) end) next diff --git a/src/client_main.ml b/src/client_main.ml index 2f826d97d..c6726db6b 100644 --- a/src/client_main.ml +++ b/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.@." - pp_print_error err ; + "@[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 = @@ -64,51 +64,42 @@ let main () = Client_protocols.commands () @ Client_helpers.commands () @ commands_for_version in - let (command, parsed_args) = - Client_config.parse_args - (Cli_entries.usage ~commands) - (Cli_entries.inline_dispatch commands) - Sys.argv in - 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 - rpc_config - in - command (cctxt config rpc_config) >>= function + (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 + rpc_config + in + 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 ; + | Error errs -> + Format.eprintf "@[Fatal error:@,%a@.\ + Try `-help` for a list of options and commands.@." + (Format.pp_print_list Error_monad.pp) errs ; 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@." diff --git a/src/utils/cli_entries.ml b/src/utils/cli_entries.ml index 1018a65cd..561416657 100644 --- a/src/utils/cli_entries.ml +++ b/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 += Command_failed of string +type error += Bad_argument of int * 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)) - | exn -> fail (Exn exn)) >>=? fun v -> + | 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 @@ -103,8 +126,9 @@ let exec Lwt.catch (fun () -> f last p) (function - | Failure msg -> fail (Bad_argument (i, p, msg)) - | exn -> fail (Exn exn)) >>=? fun v -> + | 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 diff --git a/src/utils/cli_entries.mli b/src/utils/cli_entries.mli index caebb1eb9..b232ae6a8 100644 --- a/src/utils/cli_entries.mli +++ b/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 += Command_failed of string +type error += Bad_argument of int * string type ('a, 'arg, 'ret) params type ('arg, 'ret) command