balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Client: minor client output fixes and enhancements.

Browse Source
This commit is contained in:
Benjamin Canou 2017-04-07 21:21:20 +02:00
parent c1e2d8eb25
commit 18e2edf6f4
8 changed files with 209 additions and 74 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
src/client/client_aliases.ml
View File

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

16
src/client/client_config.ml
View File

@ -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"))

40
src/client/client_generic_rpcs.ml
View File

@ -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
"@[<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
"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
]

98
src/client/client_rpcs.ml
View File

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

9
src/client/embedded/alpha/client_proto_contracts.ml
View File

@ -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 ->
@ -81,9 +81,10 @@ module ContractAlias = struct
| _ ->
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

35
src/client_main.ml
View File

@ -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 ;
"@[<v 2>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,11 +64,10 @@ 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.inline_dispatch commands)
Sys.argv in
Sys.argv >>=? fun (command, parsed_args) ->
let config : Client_commands.cfg = {
base_dir = parsed_config_file.base_dir ;
force = parsed_args.force ;
@ -82,33 +81,25 @@ let main () =
else
rpc_config
in
command (cctxt config rpc_config) >>= function
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 "@[<v 2>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@."

36
src/utils/cli_entries.ml
View File

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

3
src/utils/cli_entries.mli
View File

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