From 087a097cf7f1e9862b8861789cecf74e487c4b4b Mon Sep 17 00:00:00 2001 From: Benjamin Canou Date: Tue, 22 Nov 2016 14:23:40 +0100 Subject: [PATCH] Client: cli_entries module refactoring. --- src/client/client_aliases.ml | 101 +++-- src/client/client_aliases.mli | 6 +- src/client/client_generic_rpcs.ml | 4 +- src/client/client_node_rpcs.ml | 54 +-- src/client/client_protocols.ml | 9 +- .../embedded/bootstrap/client_proto_args.ml | 6 +- .../embedded/bootstrap/client_proto_args.mli | 2 +- .../bootstrap/client_proto_context.ml | 72 ++-- .../bootstrap/client_proto_contracts.ml | 60 +-- .../bootstrap/client_proto_contracts.mli | 4 +- .../bootstrap/client_proto_programs.ml | 13 +- .../bootstrap/mining/client_mining_main.ml | 8 +- src/client_main.ml | 25 +- src/utils/cli_entries.ml | 344 ++++++++++-------- src/utils/cli_entries.mli | 41 +-- 15 files changed, 401 insertions(+), 348 deletions(-) diff --git a/src/client/client_aliases.ml b/src/client/client_aliases.ml index cb5464cb6..19f2c45e7 100644 --- a/src/client/client_aliases.ml +++ b/src/client/client_aliases.ml @@ -33,16 +33,16 @@ module type Alias = sig val save : (Lwt_io.file_name * t) list -> unit Lwt.t val to_source : t -> string Lwt.t val alias_param : - ?n:string -> + ?name:string -> ?desc:string -> 'a Cli_entries.params -> (Lwt_io.file_name * t -> 'a) Cli_entries.params val fresh_alias_param : - ?n:string -> + ?name:string -> ?desc:string -> 'a Cli_entries.params -> (string -> 'a) Cli_entries.params val source_param : - ?n:string -> + ?name:string -> ?desc:string -> 'a Cli_entries.params -> (t -> 'a) Cli_entries.params end @@ -115,9 +115,8 @@ module Alias = functor (Entity : Entity) -> struct (if not Client_config.force#get then Lwt_list.iter_s (fun (n, v) -> if n = name && v = value then - (message "The %s alias %s already exists with the same value." Entity.name n ; - keep := true ; - return ()) + (keep := true ; + message "The %s alias %s already exists with the same value." Entity.name n) else if n = name && v <> value then error "another %s is already aliased as %s, use -force true to update" Entity.name n else if n <> name && v = value then @@ -130,8 +129,7 @@ module Alias = functor (Entity : Entity) -> struct return () else save list >>= fun () -> - message "New %s alias '%s' saved." Entity.name name ; - return () + message "New %s alias '%s' saved." Entity.name name let del name = load () >>= fun list -> @@ -140,55 +138,56 @@ module Alias = functor (Entity : Entity) -> struct let save list = save list >>= fun () -> - message "Successful update of the %s alias file." Entity.name ; - return () + message "Successful update of the %s alias file." Entity.name include Entity - let alias_param ?(n = "name") ?(desc = "existing " ^ name ^ " alias") next = - Param (n, desc, (fun s -> find s >>= fun v -> return (s, v)), next) + let alias_param ?(name = "name") ?(desc = "existing " ^ name ^ " alias") next = + param ~name ~desc + (fun s -> find s >>= fun v -> return (s, v)) + next - let fresh_alias_param ?(n = "new") ?(desc = "new " ^ name ^ " alias") next = - Param (n, - desc, - (fun s -> - load () >>= fun list -> - if not Client_config.force#get then - Lwt_list.iter_s (fun (n, _v) -> - if n = name then - error "the %s alias %s already exists, use -force true to update" Entity.name n - else return ()) - list >>= fun () -> - return s - else return s), - next) + let fresh_alias_param ?(name = "new") ?(desc = "new " ^ name ^ " alias") next = + param ~name ~desc + (fun s -> + load () >>= fun list -> + if not Client_config.force#get then + Lwt_list.iter_s (fun (n, _v) -> + if n = name then + error "the %s alias %s already exists, use -force true to update" Entity.name n + else return ()) + list >>= fun () -> + return s + else return s) + next - let source_param ?(n = "src") ?(desc = "source " ^ name) next = - Param (n, - desc ^ "\n" - ^ "can be an alias, file or litteral (autodetected in this order)\n\ - use 'file:path', 'text:litteral' or 'alias:name' to force", - (fun s -> - let read path = - catch - (fun () -> Lwt_io.(with_file ~mode:Input path read)) - (fun exn -> param_error "cannot read file (%s)" (Printexc.to_string exn)) - >>= of_source in - match Utils.split ~limit:1 ':' s with - | [ "alias" ; alias ]-> - find alias - | [ "text" ; text ] -> - of_source text - | [ "file" ; path ] -> - read path - | _ -> + let source_param ?(name = "src") ?(desc = "source " ^ name) next = + let desc = + desc ^ "\n" + ^ "can be an alias, file or litteral (autodetected in this order)\n\ + use 'file:path', 'text:litteral' or 'alias:name' to force" in + param ~name ~desc + (fun s -> + let read path = + catch + (fun () -> Lwt_io.(with_file ~mode:Input path read)) + (fun exn -> Lwt.fail_with @@ Format.asprintf "cannot read file (%s)" (Printexc.to_string exn)) + >>= of_source in + match Utils.split ~limit:1 ':' s with + | [ "alias" ; alias ]-> + find alias + | [ "text" ; text ] -> + of_source text + | [ "file" ; path ] -> + read path + | _ -> + catch + (fun () -> find s) + (fun _ -> catch - (fun () -> find s) - (fun _ -> - catch - (fun () -> read s) - (fun _ -> of_source s))), - next) + (fun () -> read s) + (fun _ -> of_source s))) + next let name d = rev_find d >>= function diff --git a/src/client/client_aliases.mli b/src/client/client_aliases.mli index 70296652c..a8f75e8af 100644 --- a/src/client/client_aliases.mli +++ b/src/client/client_aliases.mli @@ -29,16 +29,16 @@ module type Alias = sig val save : (Lwt_io.file_name * t) list -> unit Lwt.t val to_source : t -> string Lwt.t val alias_param : - ?n:string -> + ?name:string -> ?desc:string -> 'a Cli_entries.params -> (Lwt_io.file_name * t -> 'a) Cli_entries.params val fresh_alias_param : - ?n:string -> + ?name:string -> ?desc:string -> 'a Cli_entries.params -> (string -> 'a) Cli_entries.params val source_param : - ?n:string -> + ?name:string -> ?desc:string -> 'a Cli_entries.params -> (t -> 'a) Cli_entries.params end diff --git a/src/client/client_generic_rpcs.ml b/src/client/client_generic_rpcs.ml index 402b5ea94..22509b65a 100644 --- a/src/client/client_generic_rpcs.ml +++ b/src/client/client_generic_rpcs.ml @@ -332,9 +332,9 @@ let commands = Cli_entries.([ ~desc: "list all understood protocol versions" (fixed [ "list" ; "versions" ]) (fun () -> - List.iter + Lwt_list.iter_s (fun (ver, _) -> message "%a" Protocol_hash.pp_short ver) - (Client_version.get_versions ()) ; return ()) ; + (Client_version.get_versions ())) ; command ~tags: [ "low-level" ; "local" ] ~group: "rpc" diff --git a/src/client/client_node_rpcs.ml b/src/client/client_node_rpcs.ml index 247195539..def106a08 100644 --- a/src/client/client_node_rpcs.ml +++ b/src/client/client_node_rpcs.ml @@ -13,31 +13,13 @@ open Lwt open Cli_entries open Logging.RPC -let log_file = - let open CalendarLib in - Printer.Precise_Calendar.sprint - "%Y-%m-%dT%H:%M:%SZ.log" - (Calendar.Precise.now ()) - -let with_log_file f = - Utils.create_dir Client_config.(base_dir#get // "logs") >>= fun () -> - Lwt_io.with_file - ~flags: Unix.[ O_APPEND ; O_CREAT ; O_WRONLY ] - ~mode: Lwt_io.Output - Client_config.(base_dir#get // "logs" // log_file) - f - let log_request cpt url req = - with_log_file - (fun fp -> - Lwt_io.fprintf fp">>>>%d: %s\n%s\n" cpt url req >>= fun () -> - Lwt_io.flush fp) + Cli_entries.log "requests" + ">>>>%d: %s\n%s\n" cpt url req let log_response cpt code ans = - with_log_file - (fun fp -> - Lwt_io.fprintf fp"<<<<%d: %s\n%s\n" cpt (Cohttp.Code.string_of_status code) ans >>= fun () -> - Lwt_io.flush fp) + Cli_entries.log "requests" + "<<<<%d: %s\n%s\n" cpt (Cohttp.Code.string_of_status code) ans let cpt = ref 0 let make_request service json = @@ -67,9 +49,10 @@ let get_streamed_json service json = let ansbody = Cohttp_lwt_body.to_stream ansbody in match code, ansbody with | #Cohttp.Code.success_status, ansbody -> - if Client_config.print_timings#get then + (if Client_config.print_timings#get then message "Request to /%s succeeded in %gs" - (String.concat "/" service) time ; + (String.concat "/" service) time + else Lwt.return ()) >>= fun () -> Lwt.return ( Lwt_stream.filter_map_s (function @@ -80,11 +63,12 @@ let get_streamed_json service json = Lwt.return None) (Data_encoding.Json.from_stream ansbody)) | err, _ansbody -> - if Client_config.print_timings#get then + (if Client_config.print_timings#get then message "Request to /%s failed in %gs" - (String.concat "/" service) time ; + (String.concat "/" service) time + else Lwt.return ()) >>= fun () -> message "Request to /%s failed, server returned %s" - (String.concat "/" service) (Cohttp.Code.string_of_status err) ; + (String.concat "/" service) (Cohttp.Code.string_of_status err) >>= fun () -> error "the RPC server returned a non-success status (%s)" (Cohttp.Code.string_of_status err) @@ -93,9 +77,10 @@ let get_json service json = Cohttp_lwt_body.to_string ansbody >>= fun ansbody -> match code, ansbody with | #Cohttp.Code.success_status, ansbody -> begin - if Client_config.print_timings#get then - message "Request to /%s succeeded in %gs" - (String.concat "/" service) time ; + (if Client_config.print_timings#get then + message "Request to /%s succeeded in %gs" + (String.concat "/" service) time + else Lwt.return ()) >>= fun () -> log_response cpt code ansbody >>= fun () -> if ansbody = "" then Lwt.return `Null else match Data_encoding.Json.from_string ansbody with @@ -103,11 +88,12 @@ let get_json service json = | Ok res -> Lwt.return res end | err, _ansbody -> - if Client_config.print_timings#get then - message "Request to /%s failed in %gs" - (String.concat "/" service) time ; + (if Client_config.print_timings#get then + message "Request to /%s failed in %gs" + (String.concat "/" service) time + else Lwt.return ()) >>= fun () -> message "Request to /%s failed, server returned %s" - (String.concat "/" service) (Cohttp.Code.string_of_status err) ; + (String.concat "/" service) (Cohttp.Code.string_of_status err) >>= fun () -> error "the RPC server returned a non-success status (%s)" (Cohttp.Code.string_of_status err) diff --git a/src/client/client_protocols.ml b/src/client/client_protocols.ml index b8a1213ff..d6d3e0afc 100644 --- a/src/client/client_protocols.ml +++ b/src/client/client_protocols.ml @@ -11,8 +11,8 @@ let commands () = ~desc: "list known protocols" (prefixes [ "list" ; "protocols" ] stop) (fun () -> - Client_node_rpcs.Protocols.list ~contents:false () >|= fun protos -> - List.iter (fun (ph, _p) -> message "%a" Protocol_hash.pp ph) protos + Client_node_rpcs.Protocols.list ~contents:false () >>= fun protos -> + Lwt_list.iter_s (fun (ph, _p) -> message "%a" Protocol_hash.pp ph) protos ); command ~group: "protocols" @@ -26,8 +26,7 @@ let commands () = let proto = Tezos_compiler.Protocol.of_dir dirname in Client_node_rpcs.inject_protocol proto >>= function | Ok hash -> - message "Injected protocol %a successfully" Protocol_hash.pp_short hash; - Lwt.return (); + message "Injected protocol %a successfully" Protocol_hash.pp_short hash | Error err -> error "Error while injecting protocol from %s: %a" dirname Error_monad.pp_print_error err) @@ -44,7 +43,7 @@ let commands () = (fun ph () -> Client_node_rpcs.Protocols.bytes ph >>= fun { data } -> match data with | Ok proto -> - Updater.extract "" ph proto >|= fun () -> + Updater.extract "" ph proto >>= fun () -> message "Extracted protocol %a" Protocol_hash.pp_short ph | Error err -> error "Error while dumping protocol %a: %a" diff --git a/src/client/embedded/bootstrap/client_proto_args.ml b/src/client/embedded/bootstrap/client_proto_args.ml index 2e3b66991..ac2f66c36 100644 --- a/src/client/embedded/bootstrap/client_proto_args.ml +++ b/src/client/embedded/bootstrap/client_proto_args.ml @@ -81,14 +81,14 @@ let delegatable_args = Arg.Clear delegatable, "Set the created contract to be non delegatable (default)" ] -let tez_param ~n ~desc next = +let tez_param ~name ~desc next = Cli_entries.param - n + name (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 _ -> Cli_entries.param_error "invalid \xEA\x9C\xA9 notation") + with _ -> Lwt.fail_with "invalid \xEA\x9C\xA9 notation") next let max_priority = ref None diff --git a/src/client/embedded/bootstrap/client_proto_args.mli b/src/client/embedded/bootstrap/client_proto_args.mli index fbe0ec496..ab04ad0be 100644 --- a/src/client/embedded/bootstrap/client_proto_args.mli +++ b/src/client/embedded/bootstrap/client_proto_args.mli @@ -23,7 +23,7 @@ val force_arg: string * Arg.spec * string val endorsement_delay_arg: string * Arg.spec * string val tez_param : - n:string -> + name:string -> desc:string -> 'a Cli_entries.params -> (Tez.t -> 'a) Cli_entries.params diff --git a/src/client/embedded/bootstrap/client_proto_context.ml b/src/client/embedded/bootstrap/client_proto_context.ml index ecffdecfb..fc48aab3b 100644 --- a/src/client/embedded/bootstrap/client_proto_context.ml +++ b/src/client/embedded/bootstrap/client_proto_context.ml @@ -34,8 +34,7 @@ let get_delegate_pkh = function let get_timestamp block () = Client_node_rpcs.Blocks.timestamp block >>= fun v -> - Cli_entries.message "%s" (Time.to_notation v) ; - Lwt.return () + Cli_entries.message "%s" (Time.to_notation v) let list_contracts block () = Client_proto_rpcs.Context.Contract.list block >>=? fun contracts -> @@ -58,7 +57,7 @@ let list_contracts block () = let kind = match Contract.is_default h with | Some _ -> " (default)" | None -> "" in - Cli_entries.message "%s%s%s" (Contract.to_b48check h) kind nm; + Cli_entries.message "%s%s%s" (Contract.to_b48check h) kind nm >>= fun () -> return ()) contracts @@ -75,15 +74,15 @@ let transfer block ?force Client_proto_rpcs.Context.Contract.counter block source >>=? fun pcounter -> let counter = Int32.succ pcounter in message "Acquired the source's sequence counter (%ld -> %ld)." - pcounter counter ; + pcounter counter >>= fun () -> Client_proto_rpcs.Helpers.Forge.Manager.transaction block ~net ~source ~sourcePubKey:src_pk ~counter ~amount ~destination ?parameters ~fee () >>=? fun bytes -> - message "Forged the raw transaction frame." ; + message "Forged the raw transaction frame." >>= fun () -> let signed_bytes = Ed25519.append_signature src_sk bytes in Client_node_rpcs.inject_operation ?force ~wait:true signed_bytes >>=? fun oph -> - answer "Operation successfully injected in the node." ; - answer "Operation hash is '%a'." Operation_hash.pp oph ; + answer "Operation successfully injected in the node." >>= fun () -> + answer "Operation hash is '%a'." Operation_hash.pp oph >>= fun () -> return () let originate_account block ?force @@ -93,16 +92,16 @@ let originate_account block ?force Client_proto_rpcs.Context.Contract.counter block source >>=? fun pcounter -> let counter = Int32.succ pcounter in message "Acquired the source's sequence counter (%ld -> %ld)." - pcounter counter ; + pcounter counter >>= fun () -> Client_proto_rpcs.Helpers.Forge.Manager.origination block ~net ~source ~sourcePubKey:src_pk ~managerPubKey:manager_pkh ~counter ~balance ?spendable ?delegatable ?delegatePubKey:delegate ~fee () >>=? fun (contract, bytes) -> - message "Forged the raw origination frame." ; + message "Forged the raw origination frame." >>= fun () -> let signed_bytes = Ed25519.append_signature src_sk bytes in Client_node_rpcs.inject_operation ?force ~wait:true signed_bytes >>=? fun oph -> - message "Operation successfully injected in the node." ; - message "Operation hash is '%a'." Operation_hash.pp oph ; + message "Operation successfully injected in the node." >>= fun () -> + message "Operation hash is '%a'." Operation_hash.pp oph >>= fun () -> return contract let originate_contract @@ -115,18 +114,18 @@ let originate_contract Client_proto_rpcs.Context.Contract.counter block source >>=? fun pcounter -> let counter = Int32.succ pcounter in message "Acquired the source's sequence counter (%ld -> %ld)." - pcounter counter ; + pcounter counter >>= fun () -> Client_node_rpcs.Blocks.net block >>= fun net -> Client_proto_rpcs.Helpers.Forge.Manager.origination block ~net ~source ~sourcePubKey:src_pk ~managerPubKey:manager_pkh ~counter ~balance ~spendable:!spendable ?delegatable ?delegatePubKey ~script:(code, init) ~fee () >>=? fun (contract, bytes) -> - message "Forged the raw origination frame." ; + message "Forged the raw origination frame." >>= fun () -> let signed_bytes = Ed25519.append_signature src_sk bytes in Client_node_rpcs.inject_operation ?force ~wait:true signed_bytes >>=? fun oph -> - message "Operation successfully injected in the node." ; - message "Operation hash is '%a'." Operation_hash.pp oph ; + message "Operation successfully injected in the node." >>= fun () -> + message "Operation hash is '%a'." Operation_hash.pp oph >>= fun () -> return contract let commands () = @@ -157,26 +156,24 @@ let commands () = Public_key_hash.add name pkh >>= fun () -> Public_key.add name pk >>= fun () -> Secret_key.add name sk >>= fun () -> - message "Bootstrap keys added under the name '%s'." name; - Lwt.return_unit) + message "Bootstrap keys added under the name '%s'." name) accounts >>= fun () -> Lwt.return_unit) ; command ~group: "context" ~desc: "get the balance of a contract" (prefixes [ "get" ; "balance" ] - @@ ContractAlias.destination_param ~n:"src" ~desc:"source contract" + @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract" @@ stop) (fun (_, contract) () -> Client_proto_rpcs.Context.Contract.balance (block ()) contract >>= Client_proto_rpcs.handle_error >>= fun amount -> - answer "%a %s" Tez.pp amount tez_sym; - Lwt.return ()); + answer "%a %s" Tez.pp amount tez_sym); command ~group: "context" ~desc: "get the manager of a block" (prefixes [ "get" ; "manager" ] - @@ ContractAlias.destination_param ~n:"src" ~desc:"source contract" + @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract" @@ stop) (fun (_, contract) () -> Client_proto_rpcs.Context.Contract.manager (block ()) contract @@ -184,8 +181,7 @@ let commands () = Public_key_hash.rev_find manager >>= fun mn -> Public_key_hash.to_source manager >>= fun m -> message "%s (%s)" m - (match mn with None -> "unknown" | Some n -> "known as " ^ n) ; - Lwt.return ()); + (match mn with None -> "unknown" | Some n -> "known as " ^ n)); command ~group: "context" ~desc: "open a new account" @@ -193,16 +189,16 @@ let commands () = @ delegatable_args @ spendable_args) (prefixes [ "originate" ; "account" ] @@ RawContractAlias.fresh_alias_param - ~n: "new" ~desc: "name of the new contract" + ~name: "new" ~desc: "name of the new contract" @@ prefix "for" @@ Public_key_hash.alias_param - ~n: "mgr" ~desc: "manager of the new contract" + ~name: "mgr" ~desc: "manager of the new contract" @@ prefix "transfering" @@ tez_param - ~n: "qty" ~desc: "amount taken from source" + ~name: "qty" ~desc: "amount taken from source" @@ prefix "from" @@ ContractAlias.alias_param - ~n:"src" ~desc: "name of the source contract" + ~name:"src" ~desc: "name of the source contract" @@ stop) (fun neu (_, manager) balance (_, source) -> handle_error @@ fun () -> @@ -210,7 +206,7 @@ let commands () = get_delegate_pkh !delegate >>= fun delegate -> Client_proto_contracts.get_manager (block ()) source >>=? fun src_pkh -> Client_keys.get_key src_pkh >>=? fun (src_name, src_pk, src_sk) -> - message "Got the source's manager keys (%s)." src_name ; + message "Got the source's manager keys (%s)." src_name >>= fun () -> originate_account (block ()) ~force:!force ~source ~src_pk ~src_sk ~manager_pkh:manager ~balance ~fee:!fee ~delegatable:!delegatable ~spendable:!spendable ?delegate:delegate @@ -224,19 +220,19 @@ let commands () = delegatable_args @ spendable_args @ [ init_arg ]) (prefixes [ "originate" ; "contract" ] @@ RawContractAlias.fresh_alias_param - ~n: "new" ~desc: "name of the new contract" + ~name: "new" ~desc: "name of the new contract" @@ prefix "for" @@ Public_key_hash.alias_param - ~n: "mgr" ~desc: "manager of the new contract" + ~name: "mgr" ~desc: "manager of the new contract" @@ prefix "transfering" @@ tez_param - ~n: "qty" ~desc: "amount taken from source" + ~name: "qty" ~desc: "amount taken from source" @@ prefix "from" @@ ContractAlias.alias_param - ~n:"src" ~desc: "name of the source contract" + ~name:"src" ~desc: "name of the source contract" @@ prefix "running" @@ Program.source_param - ~n:"prg" ~desc: "script of the account\n\ + ~name:"prg" ~desc: "script of the account\n\ combine with -init if the storage type is non void" @@ stop) (fun neu (_, manager) balance (_, source) code -> @@ -245,7 +241,7 @@ let commands () = get_delegate_pkh !delegate >>= fun delegate -> Client_proto_contracts.get_manager (block ()) source >>=? fun src_pkh -> Client_keys.get_key src_pkh >>=? fun (src_name, src_pk, src_sk) -> - message "Got the source's manager keys (%s)." src_name ; + message "Got the source's manager keys (%s)." src_name >>= fun () -> originate_contract (block ()) ~force:!force ~source ~src_pk ~src_sk ~manager_pkh:manager ~balance ~fee:!fee ~delegatable:!delegatable ?delegatePubKey:delegate ~code ~init:!init () @@ -258,19 +254,19 @@ let commands () = ~args: [ fee_arg ; arg_arg ; force_arg ] (prefixes [ "transfer" ] @@ tez_param - ~n: "qty" ~desc: "amount taken from source" + ~name: "qty" ~desc: "amount taken from source" @@ prefix "from" @@ ContractAlias.alias_param - ~n: "src" ~desc: "name of the source contract" + ~name: "src" ~desc: "name of the source contract" @@ prefix "to" @@ ContractAlias.destination_param - ~n: "dst" ~desc: "name/literal of the destination contract" + ~name: "dst" ~desc: "name/literal of the destination contract" @@ stop) (fun amount (_, source) (_, destination) -> handle_error @@ fun () -> Client_proto_contracts.get_manager (block ()) source >>=? fun src_pkh -> Client_keys.get_key src_pkh >>=? fun (src_name, src_pk, src_sk) -> - message "Got the source's manager keys (%s)." src_name ; + message "Got the source's manager keys (%s)." src_name >>= fun () -> transfer (block ()) ~force:!force ~source ~src_pk ~src_sk ~destination ?arg:!arg ~amount ~fee:!fee ()) ] diff --git a/src/client/embedded/bootstrap/client_proto_contracts.ml b/src/client/embedded/bootstrap/client_proto_contracts.ml index 9a921f594..d48d540e9 100644 --- a/src/client/embedded/bootstrap/client_proto_contracts.ml +++ b/src/client/embedded/bootstrap/client_proto_contracts.ml @@ -51,33 +51,34 @@ module ContractAlias = struct find_key key | _ -> find s - let alias_param ?(n = "name") ?(desc = "existing contract alias") next = - Cli_entries.Param - (n, desc ^ "\n" - ^ "can be an contract alias or a key alias (autodetected in this order)\n\ - use 'key:name' to force the later", get_contract, next) + let alias_param ?(name = "name") ?(desc = "existing contract alias") next = + let desc = + desc ^ "\n" + ^ "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 get_contract next - let destination_param ?(n = "dst") ?(desc = "destination contract") next = - Cli_entries.Param - (n, - desc ^ "\n" - ^ "can be an alias, a key alias, or a litteral (autodetected in this order)\n\ - use 'text:litteral', 'alias:name', 'key:name' to force", - (fun s -> - match Utils.split ~limit:1 ':' s with - | [ "alias" ; alias ]-> - find alias - | [ "key" ; text ] -> - Client_keys.Public_key_hash.find text >>= fun v -> - Lwt.return (s, Contract.default_contract v) - | _ -> - Lwt.catch - (fun () -> find s) - (fun _ -> - match Contract.of_b48check s with - | Error _ -> Lwt.fail (Failure "bad contract notation") - | Ok v -> Lwt.return (s, v))), - next) + let destination_param ?(name = "dst") ?(desc = "destination contract") next = + let desc = + desc ^ "\n" + ^ "can be an alias, a key alias, or a litteral (autodetected in this order)\n\ + use 'text:litteral', 'alias:name', 'key:name' to force" in + Cli_entries.param ~name ~desc + (fun s -> + match Utils.split ~limit:1 ':' s with + | [ "alias" ; alias ]-> + find alias + | [ "key" ; text ] -> + Client_keys.Public_key_hash.find text >>= fun v -> + Lwt.return (s, Contract.default_contract v) + | _ -> + Lwt.catch + (fun () -> find s) + (fun _ -> + match Contract.of_b48check s with + | Error _ -> Lwt.fail (Failure "bad contract notation") + | Ok v -> Lwt.return (s, v))) + next let name contract = rev_find contract >|= function @@ -150,17 +151,16 @@ let commands () = (fixed [ "list" ; "known" ; "contracts" ]) (fun () -> RawContractAlias.load () >>= fun list -> - List.iter (fun (n, v) -> + Lwt_list.iter_s (fun (n, v) -> let v = Contract.to_b48check v in message "%s: %s" n v) - list ; + list >>= fun () -> Client_keys.Public_key_hash.load () >>= fun list -> Lwt_list.iter_s (fun (n, v) -> RawContractAlias.mem n >>= fun mem -> let p = if mem then "key:" else "" in let v = Contract.to_b48check (Contract.default_contract v) in - message "%s%s: %s" p n v ; - Lwt.return_unit) + message "%s%s: %s" p n v) list >>= fun () -> Lwt.return ()) ; command diff --git a/src/client/embedded/bootstrap/client_proto_contracts.mli b/src/client/embedded/bootstrap/client_proto_contracts.mli index 87e40ba04..54257e48f 100644 --- a/src/client/embedded/bootstrap/client_proto_contracts.mli +++ b/src/client/embedded/bootstrap/client_proto_contracts.mli @@ -13,12 +13,12 @@ module RawContractAlias : module ContractAlias : sig val get_contract: string -> (string * Contract.t) Lwt.t val alias_param: - ?n:string -> + ?name:string -> ?desc:string -> 'a Cli_entries.params -> (Lwt_io.file_name * Contract.t -> 'a) Cli_entries.params val destination_param: - ?n:string -> + ?name:string -> ?desc:string -> 'a Cli_entries.params -> (Lwt_io.file_name * Contract.t -> 'a) Cli_entries.params diff --git a/src/client/embedded/bootstrap/client_proto_programs.ml b/src/client/embedded/bootstrap/client_proto_programs.ml index 5620b123d..a7cabf824 100644 --- a/src/client/embedded/bootstrap/client_proto_programs.ml +++ b/src/client/embedded/bootstrap/client_proto_programs.ml @@ -183,7 +183,7 @@ let commands () = ~desc: "lists all known programs" (fixed [ "list" ; "known" ; "programs" ]) (fun () -> Program.load () >>= fun list -> - List.iter (fun (n, _) -> message "%s" n) list ; Lwt.return ()) ; + Lwt_list.iter_s (fun (n, _) -> message "%s" n) list) ; command ~group: "programs" ~desc: "remember a program under some name" @@ -262,7 +262,7 @@ let commands () = Client_proto_rpcs.Helpers.typecheck_code (block ()) program >>= function | Ok type_map -> let type_map, program = unexpand_macros type_map program in - message "Well typed" ; + message "Well typed" >>= fun () -> if !show_types then begin print_program (fun l -> List.mem_assoc l type_map) @@ -296,8 +296,7 @@ let commands () = Client_proto_rpcs.Helpers.typecheck_untagged_data (block ()) (data, exp_ty) >>= function | Ok () -> - message "Well typed" ; - Lwt.return () + message "Well typed" | Error errs -> pp_print_error Format.err_formatter errs ; error "ill-typed data") ; @@ -312,8 +311,7 @@ let commands () = let open Data_encoding in Client_proto_rpcs.Helpers.hash_data (block ()) data >>= function | Ok hash -> - message "%S" hash; - Lwt.return () + message "%S" hash | Error errs -> pp_print_error Format.err_formatter errs ; error "ill-formed data") ; @@ -337,8 +335,7 @@ let commands () = hash (signature |> Data_encoding.Binary.to_bytes Ed25519.signature_encoding |> - Hex_encode.hex_of_bytes) ; - Lwt.return () + Hex_encode.hex_of_bytes) | Error errs -> pp_print_error Format.err_formatter errs ; error "ill-formed data") ; diff --git a/src/client/embedded/bootstrap/mining/client_mining_main.ml b/src/client/embedded/bootstrap/mining/client_mining_main.ml index e87c68216..9e8c33156 100644 --- a/src/client/embedded/bootstrap/mining/client_mining_main.ml +++ b/src/client/embedded/bootstrap/mining/client_mining_main.ml @@ -101,7 +101,7 @@ let reveal_nonces ?force () = open Client_proto_args -let run_daemon delegates = +let run_daemon delegates () = Client_mining_daemon.run ?max_priority:!max_priority ~delay:!endorsement_delay @@ -126,7 +126,7 @@ let commands () = ~args: [ force_arg ] (prefixes [ "endorse"; "for" ] @@ Client_keys.Public_key_hash.alias_param - ~n:"miner" ~desc: "name of the delegate owning the endorsement right" + ~name:"miner" ~desc: "name of the delegate owning the endorsement right" @@ stop) (fun (_, delegate) () -> endorse_block @@ -138,7 +138,7 @@ let commands () = ~args: [ max_priority_arg ; force_arg ] (prefixes [ "mine"; "for" ] @@ Client_keys.Public_key_hash.alias_param - ~n:"miner" ~desc: "name of the delegate owning the mining right" + ~name:"miner" ~desc: "name of the delegate owning the mining right" @@ stop) (fun (_, delegate) () -> mine_block (block ()) @@ -150,7 +150,7 @@ let commands () = ~args: [ force_arg ] (prefixes [ "reveal"; "nonce"; "for" ] @@ Cli_entries.seq_of_param Block_hash.param) - (fun block_hashes -> + (fun block_hashes () -> reveal_block_nonces ~force:!force block_hashes >>= Client_proto_rpcs.handle_error) ; command ~group: "delegate" diff --git a/src/client_main.ml b/src/client_main.ml index e57cdd9cf..11d278621 100644 --- a/src/client_main.ml +++ b/src/client_main.ml @@ -11,6 +11,27 @@ open Lwt +let () = + let startup = + CalendarLib.Printer.Precise_Calendar.sprint + "%Y-%m-%dT%H:%M:%SZ" + (CalendarLib.Calendar.Precise.now ()) in + let log channel msg = match channel with + | "stdout" -> + print_endline msg ; + Lwt.return () + | "stderr" -> + prerr_endline msg ; + Lwt.return () + | log -> + Utils.create_dir Client_config.(base_dir#get // "logs" // log) >>= fun () -> + Lwt_io.with_file + ~flags: Unix.[ O_APPEND ; O_CREAT ; O_WRONLY ] + ~mode: Lwt_io.Output + Client_config.(base_dir#get // "logs" // log // startup) + (fun chan -> Lwt_io.write chan msg) in + Cli_entries.log_hook := Some log + (* Main (lwt) entry *) let main () = Random.self_init () ; @@ -24,7 +45,7 @@ let main () = (fun _ -> Cli_entries.message "\n\ The connection to the RPC server failed, \ - using the default protocol version.\n" ; + using the default protocol version.\n" >>= fun () -> Lwt.return Client_bootstrap.Client_proto_main.protocol) >>= fun version -> let commands = @@ -35,7 +56,7 @@ let main () = Client_version.commands_for_version version in Client_config.parse_args ~version (Cli_entries.usage commands) - (Cli_entries.inline_dispatcher commands)) + (Cli_entries.inline_dispatch commands)) (function | Arg.Help help -> Format.printf "%s%!" help ; diff --git a/src/utils/cli_entries.ml b/src/utils/cli_entries.ml index 3e262b0a6..c7071af56 100644 --- a/src/utils/cli_entries.ml +++ b/src/utils/cli_entries.ml @@ -16,21 +16,30 @@ exception Command_not_found exception Bad_argument of int * string * string exception Command_failed of string -(* A simple structure for command interpreters. *) -type 'a params = - | Prefix : string * 'a params -> 'a params - | Param : string * string * (string -> 'p Lwt.t) * 'a params -> ('p -> 'a) params - | Stop : (unit -> unit Lwt.t) params - | More : (string list -> unit Lwt.t) params - | Seq : string * string * (string -> 'p Lwt.t) -> ('p list -> unit Lwt.t) params +(* A simple structure for command interpreters. + This is more generic than the exported one, see end of file. *) +type ('a, 'arg, 'ret) tparams = + | Prefix : string * ('a, 'arg, 'ret) tparams -> + ('a, 'arg, 'ret) tparams + | Param : string * string * + (string -> 'p Lwt.t) * + ('a, 'arg, 'ret) tparams -> + ('p -> 'a, 'arg, 'ret) tparams + | Stop : + ('arg -> 'ret Lwt.t, 'arg, 'ret) tparams + | More : + (string list -> 'arg -> 'ret Lwt.t, 'arg, 'ret) tparams + | Seq : string * string * + (string -> 'p Lwt.t) -> + ('p list -> 'arg -> 'ret Lwt.t, 'arg, 'ret) tparams (* A command wraps a callback with its type and info *) -and command = +and ('arg, 'ret) tcommand = | Command - : 'a params * 'a * + : ('a, 'arg, 'ret) tparams * 'a * desc option * tag list * group option * (Arg.key * Arg.spec * Arg.doc) list - -> command + -> ('arg, 'ret) tcommand and desc = string and group = string @@ -77,25 +86,15 @@ let command ?desc ?(tags = []) ?group ?(args = []) params cb = (* Param combinators *) let string n desc next = param n desc (fun s -> return s) next -(* Error combinators for use in commands *) -let kasprintf cont fmt = - let buffer = Buffer.create 100 in - let ppf = Format.formatter_of_buffer buffer in - Format.kfprintf (fun ppf -> - Format.fprintf ppf "%!"; - cont (Buffer.contents buffer)) - ppf fmt -let error fmt = kasprintf (fun msg -> Lwt.fail (Command_failed msg)) fmt -let message fmt = kasprintf (Format.eprintf "%s\n%!") fmt -let answer fmt = kasprintf (Format.printf "%s\n%!") fmt -let param_error fmt = kasprintf (fun msg -> Lwt.fail (Failure msg)) fmt - (* Command execution *) -let exec (Command (params, cb, _, _, _, _)) args = +let exec + (type arg) (type ret) + (Command (params, cb, _, _, _, _)) (last : arg) args = let rec exec - : type a. int -> a params -> a -> string list -> unit Lwt.t = fun i params cb args -> + : type a. int -> (a, arg, ret) tparams -> a -> string list -> ret Lwt.t + = fun i params cb args -> match params, args with - | Stop, [] -> cb () + | Stop, [] -> cb last | Stop, _ -> Lwt.fail Command_not_found | Seq (_, _, f), seq -> let rec do_seq i acc = function @@ -108,8 +107,8 @@ let exec (Command (params, cb, _, _, _, _)) args = | exn -> Lwt.fail exn) >>= fun v -> do_seq (succ i) (v :: acc) rest in do_seq i [] seq >>= fun parsed -> - cb parsed - | More, rest -> cb rest + cb parsed last + | More, rest -> cb rest last | Prefix (n, next), p :: rest when n = p -> exec (succ i) next cb rest | Param (_, _, f, next), p :: rest -> @@ -122,116 +121,125 @@ let exec (Command (params, cb, _, _, _, _)) args = | _ -> Lwt.fail Command_not_found in exec 1 params cb args -module Command_tree = struct - type level = - { stop : command option ; - prefix : (string * tree) list } - and param_level = - { stop : command option ; - tree : tree } - and tree = - | TPrefix of level - | TParam of param_level - | TStop of command - | TMore of command - | TEmpty - let insert root (Command (params, _, _, _, _, _) as command) = - let rec insert_tree - : type a. tree -> a params -> tree - = fun t c -> match t, c with - | TEmpty, Stop -> TStop command - | TEmpty, More -> TMore command - | TEmpty, Seq _ -> TMore command - | TEmpty, Param (_, _, _, next) -> - TParam { tree = insert_tree TEmpty next ; stop = None } - | TEmpty, Prefix (n, next) -> - TPrefix { stop = None ; prefix = [ (n, insert_tree TEmpty next) ] } - | TStop command, Param (_, _, _, next) -> - TParam { tree = insert_tree TEmpty next ; stop = Some command } - | TStop command, Prefix (n, next) -> - TPrefix { stop = Some command ; - prefix = [ (n, insert_tree TEmpty next) ] } - | TParam t, Param (_, _, _, next) -> - TParam { t with tree = insert_tree t.tree next } - | TPrefix ({ prefix } as l), Prefix (n, next) -> - let rec insert_prefix = function - | [] -> [ (n, insert_tree TEmpty next) ] - | (n', t) :: rest when n = n' -> (n, insert_tree t next) :: rest - | item :: rest -> item :: insert_prefix rest in - TPrefix { l with prefix = insert_prefix prefix } - | TPrefix ({ stop = None } as l), Stop -> - TPrefix { l with stop = Some command } - | TParam ({ stop = None } as l), Stop -> - TParam { l with stop = Some command } - | _, _ -> - Pervasives.failwith - "Cli_entries.Command_tree.insert: conflicting commands" in - insert_tree root params - let make commands = - List.fold_left insert TEmpty commands - let dispatcher tree args = - let rec loop = function - | TStop c, [] -> exec c args - | TPrefix { stop = Some c }, [] -> exec c args - | TMore c, _ -> exec c args - | TPrefix { prefix }, n :: rest -> - begin try - let t = List.assoc n prefix in - loop (t, rest) - with Not_found -> Lwt.fail Command_not_found end - | TParam { tree }, _ :: rest -> - loop (tree, rest) - | _, _ -> Lwt.fail Command_not_found - in - loop (tree, args) - let inline_dispatcher tree () = - let state = ref (tree, []) in - fun arg -> match !state, arg with - | (( TStop c | - TMore c | - TPrefix { stop = Some c } | - TParam { stop = Some c}), acc), - `End -> - state := (TEmpty, []) ; - `Res (exec c (List.rev acc)) - | (TMore c, acc), `Arg n -> - state := (TMore c, n :: acc) ; - `Nop - | (TPrefix { prefix }, acc), `Arg n -> - begin try - let t = List.assoc n prefix in - state := (t, n :: acc) ; - begin match t with - | TStop (Command (_, _, _, _, _, args)) - | TMore (Command (_, _, _, _, _, args)) -> `Args args - | _ -> `Nop 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 -end +(* Command dispatch tree *) +type ('arg, 'ret) level = + { stop : ('arg, 'ret) tcommand option ; + prefix : (string * ('arg, 'ret) tree) list } +and ('arg, 'ret) param_level = + { stop : ('arg, 'ret) tcommand option ; + tree : ('arg, 'ret) tree } +and ('arg, 'ret) tree = + | TPrefix of ('arg, 'ret) level + | TParam of ('arg, 'ret) param_level + | TStop of ('arg, 'ret) tcommand + | TMore of ('arg, 'ret) tcommand + | TEmpty + +let insert_in_dispatch_tree + (type arg) (type ret) + root (Command (params, _, _, _, _, _) as command) = + let rec insert_tree + : type a. (arg, ret) tree -> (a, arg, ret) tparams -> (arg, ret) tree + = fun t c -> match t, c with + | TEmpty, Stop -> TStop command + | TEmpty, More -> TMore command + | TEmpty, Seq _ -> TMore command + | TEmpty, Param (_, _, _, next) -> + TParam { tree = insert_tree TEmpty next ; stop = None } + | TEmpty, Prefix (n, next) -> + TPrefix { stop = None ; prefix = [ (n, insert_tree TEmpty next) ] } + | TStop command, Param (_, _, _, next) -> + TParam { tree = insert_tree TEmpty next ; stop = Some command } + | TStop command, Prefix (n, next) -> + TPrefix { stop = Some command ; + prefix = [ (n, insert_tree TEmpty next) ] } + | TParam t, Param (_, _, _, next) -> + TParam { t with tree = insert_tree t.tree next } + | TPrefix ({ prefix } as l), Prefix (n, next) -> + let rec insert_prefix = function + | [] -> [ (n, insert_tree TEmpty next) ] + | (n', t) :: rest when n = n' -> (n, insert_tree t next) :: rest + | item :: rest -> item :: insert_prefix rest in + TPrefix { l with prefix = insert_prefix prefix } + | TPrefix ({ stop = None } as l), Stop -> + TPrefix { l with stop = Some command } + | TParam ({ stop = None } as l), Stop -> + TParam { l with stop = Some command } + | _, _ -> + Pervasives.failwith + "Cli_entries.Command_tree.insert: conflicting commands" in + insert_tree root params + +let make_dispatch_tree commands = + List.fold_left insert_in_dispatch_tree TEmpty commands + +let tree_dispatch tree last args = + let rec loop = function + | TStop c, [] -> exec c last args + | TPrefix { stop = Some c }, [] -> exec c last args + | TMore c, _ -> exec c last args + | TPrefix { prefix }, n :: rest -> + begin try + let t = List.assoc n prefix in + loop (t, rest) + with Not_found -> Lwt.fail Command_not_found end + | TParam { tree }, _ :: rest -> + loop (tree, rest) + | _, _ -> Lwt.fail Command_not_found + in + loop (tree, args) + +let inline_tree_dispatch tree last = + let state = ref (tree, []) in + fun arg -> match !state, arg with + | (( TStop c | + TMore c | + TPrefix { stop = Some c } | + TParam { stop = Some c}), acc), + `End -> + state := (TEmpty, []) ; + `Res (exec c last (List.rev acc)) + | (TMore c, acc), `Arg n -> + state := (TMore c, n :: acc) ; + `Nop + | (TPrefix { prefix }, acc), `Arg n -> + begin try + let t = List.assoc n prefix in + state := (t, n :: acc) ; + begin match t with + | TStop (Command (_, _, _, _, _, args)) + | TMore (Command (_, _, _, _, _, args)) -> `Args args + | _ -> `Nop 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 (* Try a list of commands on a list of arguments *) -let dispatcher commands = - let tree = Command_tree.make commands in - fun args -> Command_tree.dispatcher tree args +let dispatch commands = + let tree = make_dispatch_tree commands in + tree_dispatch tree (* Argument-by-argument dispatcher to be used during argument parsing *) -let inline_dispatcher commands = - let tree = Command_tree.make commands in - Command_tree.inline_dispatcher tree +let inline_dispatch commands = + let tree = make_dispatch_tree commands in + inline_tree_dispatch tree (* Command line help for a set of commands *) -let usage commands options = +let usage + (type arg) (type ret) + commands options = let trim s = (* config-file wokaround *) Utils.split '\n' s |> List.map String.trim |> String.concat "\n" in - let rec help : type a. Format.formatter -> a params -> unit = fun ppf -> function + let rec help + : type a. Format.formatter -> (a, arg, ret) tparams -> unit + = fun ppf -> function | Stop -> () | More -> Format.fprintf ppf "..." | Seq (n, "", _) -> Format.fprintf ppf "[ (%s) ...]" n @@ -242,7 +250,9 @@ let usage commands options = | Prefix (n, next) -> Format.fprintf ppf "%s %a" n help next | Param (n, "", _, next) -> Format.fprintf ppf "(%s) %a" n help next | Param (_, desc, _, next) -> Format.fprintf ppf "(%s) %a" desc help next in - let rec help_sum : type a. Format.formatter -> a params -> unit = fun ppf -> function + let rec help_sum + : type a. Format.formatter -> (a, arg, ret) tparams -> unit + = fun ppf -> function | Stop -> () | More -> Format.fprintf ppf "..." | Seq (n, _, _) -> Format.fprintf ppf "[ (%s) ... ]" n @@ -250,13 +260,21 @@ let usage commands options = | Param (n, _, _, Stop) -> Format.fprintf ppf "(%s)" n | Prefix (n, next) -> Format.fprintf ppf "%s %a" n help_sum next | Param (n, _, _, next) -> Format.fprintf ppf "(%s) %a" n help_sum next in - let rec help_args : type a. Format.formatter -> a params -> unit = fun ppf -> function - | Stop -> () - | More -> Format.fprintf ppf "..." - | Seq (n, desc, _) -> Format.fprintf ppf "(%s): @[%a@]" n Format.pp_print_text (trim desc) - | Prefix (_, next) -> help_args ppf next - | Param (n, desc, _, Stop) -> Format.fprintf ppf "(%s): @[%a@]" n Format.pp_print_text (trim desc) - | Param (n, desc, _, next) -> Format.fprintf ppf "(%s): @[%a@]@,%a" n Format.pp_print_text (trim desc) help_args next in + let rec help_args + : type a. Format.formatter -> (a, arg, ret) tparams -> unit + = fun ppf -> function + | Stop -> () + | More -> Format.fprintf ppf "..." + | Seq (n, desc, _) -> + Format.fprintf ppf "(%s): @[%a@]" + n Format.pp_print_text (trim desc) + | Prefix (_, next) -> help_args ppf next + | Param (n, desc, _, Stop) -> + Format.fprintf ppf "(%s): @[%a@]" + n Format.pp_print_text (trim desc) + | Param (n, desc, _, next) -> + Format.fprintf ppf "(%s): @[%a@]@,%a" + n Format.pp_print_text (trim desc) help_args next in let option_help ppf (n, opt, desc) = Format.fprintf ppf "%s%s" n Arg.(let rec example opt = match opt with @@ -277,27 +295,38 @@ let usage commands options = Format.fprintf ppf "@, @[%a@]" Format.pp_print_text (trim desc) in let command_help ppf (Command (p, _, desc, _, _, options)) = let small = Format.asprintf "@[%a@]" help p in + let desc = + match desc with + | None -> "undocumented command" + | Some desc -> trim desc in if String.length small < 50 then begin Format.fprintf ppf "@[%s@,@[%a@]" - small - Format.pp_print_text (match desc with None -> "undocumented command" | Some desc -> trim desc) + small Format.pp_print_text desc end else begin Format.fprintf ppf "@[%a@,@[%a@]@,%a" help_sum p - Format.pp_print_text (match desc with None -> "undocumented command" | Some desc -> trim desc) + Format.pp_print_text desc help_args p ; end ; if options = [] then Format.fprintf ppf "@]" else - Format.fprintf ppf "@,%a@]" (Format.pp_print_list option_help) options in + Format.fprintf ppf "@,%a@]" + (Format.pp_print_list option_help) + options in let rec group_help ppf (n, commands) = + let title = + match n with + | None -> "Miscellaneous commands" + | Some n -> group_title n in Format.fprintf ppf "@[%s:@,%a@]" - (match n with None -> "Miscellaneous commands" | Some n -> group_title n) + title (Format.pp_print_list command_help) !commands in let usage ppf (by_group, options) = Format.fprintf ppf - "@[@[Usage:@,%s [ options ] command [ command options ]@]@,@[Options:@,%a@]@,%a@]" + "@[@[Usage:@,%s [ options ] command [ command options ]@]@,\ + @[Options:@,%a@]@,\ + %a@]" Sys.argv.(0) (Format.pp_print_list option_help) options (Format.pp_print_list group_help) by_group in @@ -312,3 +341,34 @@ let usage commands options = (g, ref [ c ]) :: acc) [] commands |> List.sort compare in Format.asprintf "%a" usage (by_group, options) + +(* Pre-instanciated types *) +type 'a params = ('a, unit, unit) tparams +type command = (unit, unit) tcommand + +let log_hook + : (string -> string -> unit Lwt.t) option ref + = ref None + +let log channel msg = + match !log_hook with + | None -> Lwt.fail (Invalid_argument "Cli_entries.log: uninitialized hook") + | Some hook -> hook channel msg + +let error fmt= + Format.kasprintf + (fun msg -> + Lwt.fail (Failure msg)) + fmt + +let message fmt = + Format.kasprintf + (fun msg -> log "stdout" msg) + fmt + +let answer = message + +let log name fmt = + Format.kasprintf + (fun msg -> log name msg) + fmt diff --git a/src/utils/cli_entries.mli b/src/utils/cli_entries.mli index 7d6e63bde..209289a3b 100644 --- a/src/utils/cli_entries.mli +++ b/src/utils/cli_entries.mli @@ -14,29 +14,13 @@ exception Command_not_found exception Bad_argument of int * string * string exception Command_failed of string -type 'a params = - | Prefix: string * 'a params -> 'a params - | Param: string * string * (string -> 'p Lwt.t) * 'a params -> ('p -> 'a) params - | Stop: (unit -> unit Lwt.t) params - | More: (string list -> unit Lwt.t) params - | Seq : string * string * (string -> 'p Lwt.t) -> ('p list -> unit Lwt.t) params - -and command = - | Command - : 'a params * 'a * - desc option * tag list * group option * - (Arg.key * Arg.spec * Arg.doc) list - -> command +type 'a params +type command and desc = string and group = string and tag = string -val error: ('a, Format.formatter, unit, 'b Lwt.t) format4 -> 'a -val param_error: ('a, Format.formatter, unit, 'b Lwt.t) format4 -> 'a -val message: ('a, Format.formatter, unit, unit) format4 -> 'a -val answer: ('a, Format.formatter, unit, unit) format4 -> 'a - val param: name: string -> desc: string -> @@ -49,12 +33,13 @@ val stop: (unit -> unit Lwt.t) params val seq: name: string -> desc: string -> - (string -> 'p Lwt.t) -> ('p list -> unit Lwt.t) params + (string -> 'p Lwt.t) -> + ('p list -> unit -> unit Lwt.t) params -(* [seq_of_param (param ~name ~desc f) = seq ~name ~desc f] *) val seq_of_param: - ((unit -> unit Lwt.t) params -> ('a -> unit -> unit Lwt.t) params) -> - ('a list -> unit Lwt.t) params + ((unit -> unit Lwt.t) params -> + ('a -> unit -> unit Lwt.t) params) -> + ('a list -> unit -> unit Lwt.t) params val command: ?desc:desc -> @@ -68,7 +53,7 @@ val register_tag: tag -> string -> unit val usage: command list -> (string * Arg.spec * string) list -> string -val inline_dispatcher: +val inline_dispatch: command list -> unit -> [> `Arg of string | `End ] -> @@ -76,3 +61,13 @@ val inline_dispatcher: | `Fail of exn | `Nop | `Res of unit Lwt.t ] + +val dispatch: + command list -> unit -> string list -> unit Lwt.t + +val log_hook : (string -> string -> unit Lwt.t) option ref + +val error : ('a, Format.formatter, unit, 'b Lwt.t) format4 -> 'a +val message : ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a +val answer : ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a +val log : string -> ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a