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

Client: cli_entries module refactoring.

Browse Source
This commit is contained in:
Benjamin Canou 2016-11-22 14:23:40 +01:00
parent 1a1e17e1a0
commit 087a097cf7
15 changed files with 401 additions and 348 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

101
src/client/client_aliases.ml
View File

@ -33,16 +33,16 @@ module type Alias = sig
val save : (Lwt_io.file_name * t) list -> unit Lwt.t val save : (Lwt_io.file_name * t) list -> unit Lwt.t
val to_source : t -> string Lwt.t val to_source : t -> string Lwt.t
val alias_param : val alias_param :
?n:string -> ?name:string ->
?desc:string -> ?desc:string ->
'a Cli_entries.params -> 'a Cli_entries.params ->
(Lwt_io.file_name * t -> 'a) Cli_entries.params (Lwt_io.file_name * t -> 'a) Cli_entries.params
val fresh_alias_param : val fresh_alias_param :
?n:string -> ?name:string ->
?desc:string -> ?desc:string ->
'a Cli_entries.params -> (string -> 'a) Cli_entries.params 'a Cli_entries.params -> (string -> 'a) Cli_entries.params
val source_param : val source_param :
?n:string -> ?name:string ->
?desc:string -> ?desc:string ->
'a Cli_entries.params -> (t -> 'a) Cli_entries.params 'a Cli_entries.params -> (t -> 'a) Cli_entries.params
end end
@ -115,9 +115,8 @@ module Alias = functor (Entity : Entity) -> struct
(if not Client_config.force#get then (if not Client_config.force#get then
Lwt_list.iter_s (fun (n, v) -> Lwt_list.iter_s (fun (n, v) ->
if n = name && v = value then if n = name && v = value then
(message "The %s alias %s already exists with the same value." Entity.name n ; (keep := true ;
keep := true ; message "The %s alias %s already exists with the same value." Entity.name n)
return ())
else if n = name && v <> value then else if n = name && v <> value then
error "another %s is already aliased as %s, use -force true to update" Entity.name n error "another %s is already aliased as %s, use -force true to update" Entity.name n
else if n <> name && v = value then else if n <> name && v = value then
@ -130,8 +129,7 @@ module Alias = functor (Entity : Entity) -> struct
return () return ()
else else
save list >>= fun () -> save list >>= fun () ->
message "New %s alias '%s' saved." Entity.name name ; message "New %s alias '%s' saved." Entity.name name
return ()
let del name = let del name =
load () >>= fun list -> load () >>= fun list ->
@ -140,55 +138,56 @@ module Alias = functor (Entity : Entity) -> struct
let save list = let save list =
save list >>= fun () -> save list >>= fun () ->
message "Successful update of the %s alias file." Entity.name ; message "Successful update of the %s alias file." Entity.name
return ()
include Entity include Entity
let alias_param ?(n = "name") ?(desc = "existing " ^ name ^ " alias") next = let alias_param ?(name = "name") ?(desc = "existing " ^ name ^ " alias") next =
Param (n, desc, (fun s -> find s >>= fun v -> return (s, v)), 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 = let fresh_alias_param ?(name = "new") ?(desc = "new " ^ name ^ " alias") next =
Param (n, param ~name ~desc
desc, (fun s ->
(fun s -> load () >>= fun list ->
load () >>= fun list -> if not Client_config.force#get then
if not Client_config.force#get then Lwt_list.iter_s (fun (n, _v) ->
Lwt_list.iter_s (fun (n, _v) -> if n = name then
if n = name then error "the %s alias %s already exists, use -force true to update" Entity.name n
error "the %s alias %s already exists, use -force true to update" Entity.name n else return ())
else return ()) list >>= fun () ->
list >>= fun () -> return s
return s else return s)
else return s), next
next)
let source_param ?(n = "src") ?(desc = "source " ^ name) next = let source_param ?(name = "src") ?(desc = "source " ^ name) next =
Param (n, let desc =
desc ^ "\n" desc ^ "\n"
^ "can be an alias, file or litteral (autodetected in this order)\n\ ^ "can be an alias, file or litteral (autodetected in this order)\n\
use 'file:path', 'text:litteral' or 'alias:name' to force", use 'file:path', 'text:litteral' or 'alias:name' to force" in
(fun s -> param ~name ~desc
let read path = (fun s ->
catch let read path =
(fun () -> Lwt_io.(with_file ~mode:Input path read)) catch
(fun exn -> param_error "cannot read file (%s)" (Printexc.to_string exn)) (fun () -> Lwt_io.(with_file ~mode:Input path read))
>>= of_source in (fun exn -> Lwt.fail_with @@ Format.asprintf "cannot read file (%s)" (Printexc.to_string exn))
match Utils.split ~limit:1 ':' s with >>= of_source in
| [ "alias" ; alias ]-> match Utils.split ~limit:1 ':' s with
find alias | [ "alias" ; alias ]->
| [ "text" ; text ] -> find alias
of_source text | [ "text" ; text ] ->
| [ "file" ; path ] -> of_source text
read path | [ "file" ; path ] ->
| _ -> read path
| _ ->
catch
(fun () -> find s)
(fun _ ->
catch catch
(fun () -> find s) (fun () -> read s)
(fun _ -> (fun _ -> of_source s)))
catch next
(fun () -> read s)
(fun _ -> of_source s))),
next)
let name d = let name d =
rev_find d >>= function rev_find d >>= function

6
src/client/client_aliases.mli
View File

@ -29,16 +29,16 @@ module type Alias = sig
val save : (Lwt_io.file_name * t) list -> unit Lwt.t val save : (Lwt_io.file_name * t) list -> unit Lwt.t
val to_source : t -> string Lwt.t val to_source : t -> string Lwt.t
val alias_param : val alias_param :
?n:string -> ?name:string ->
?desc:string -> ?desc:string ->
'a Cli_entries.params -> 'a Cli_entries.params ->
(Lwt_io.file_name * t -> 'a) Cli_entries.params (Lwt_io.file_name * t -> 'a) Cli_entries.params
val fresh_alias_param : val fresh_alias_param :
?n:string -> ?name:string ->
?desc:string -> ?desc:string ->
'a Cli_entries.params -> (string -> 'a) Cli_entries.params 'a Cli_entries.params -> (string -> 'a) Cli_entries.params
val source_param : val source_param :
?n:string -> ?name:string ->
?desc:string -> ?desc:string ->
'a Cli_entries.params -> (t -> 'a) Cli_entries.params 'a Cli_entries.params -> (t -> 'a) Cli_entries.params
end end

4
src/client/client_generic_rpcs.ml
View File

@ -332,9 +332,9 @@ let commands = Cli_entries.([
~desc: "list all understood protocol versions" ~desc: "list all understood protocol versions"
(fixed [ "list" ; "versions" ]) (fixed [ "list" ; "versions" ])
(fun () -> (fun () ->
List.iter Lwt_list.iter_s
(fun (ver, _) -> message "%a" Protocol_hash.pp_short ver) (fun (ver, _) -> message "%a" Protocol_hash.pp_short ver)
(Client_version.get_versions ()) ; return ()) ; (Client_version.get_versions ())) ;
command command
~tags: [ "low-level" ; "local" ] ~tags: [ "low-level" ; "local" ]
~group: "rpc" ~group: "rpc"

54
src/client/client_node_rpcs.ml
View File

@ -13,31 +13,13 @@ open Lwt
open Cli_entries open Cli_entries
open Logging.RPC 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 = let log_request cpt url req =
with_log_file Cli_entries.log "requests"
(fun fp -> ">>>>%d: %s\n%s\n" cpt url req
Lwt_io.fprintf fp">>>>%d: %s\n%s\n" cpt url req >>= fun () ->
Lwt_io.flush fp)
let log_response cpt code ans = let log_response cpt code ans =
with_log_file Cli_entries.log "requests"
(fun fp -> "<<<<%d: %s\n%s\n" cpt (Cohttp.Code.string_of_status code) ans
Lwt_io.fprintf fp"<<<<%d: %s\n%s\n" cpt (Cohttp.Code.string_of_status code) ans >>= fun () ->
Lwt_io.flush fp)
let cpt = ref 0 let cpt = ref 0
let make_request service json = let make_request service json =
@ -67,9 +49,10 @@ let get_streamed_json service json =
let ansbody = Cohttp_lwt_body.to_stream ansbody in let ansbody = Cohttp_lwt_body.to_stream ansbody in
match code, ansbody with match code, ansbody with
| #Cohttp.Code.success_status, ansbody -> | #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" message "Request to /%s succeeded in %gs"
(String.concat "/" service) time ; (String.concat "/" service) time
else Lwt.return ()) >>= fun () ->
Lwt.return ( Lwt.return (
Lwt_stream.filter_map_s Lwt_stream.filter_map_s
(function (function
@ -80,11 +63,12 @@ let get_streamed_json service json =
Lwt.return None) Lwt.return None)
(Data_encoding.Json.from_stream ansbody)) (Data_encoding.Json.from_stream ansbody))
| err, _ansbody -> | err, _ansbody ->
if Client_config.print_timings#get then (if Client_config.print_timings#get then
message "Request to /%s failed in %gs" 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" 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)" error "the RPC server returned a non-success status (%s)"
(Cohttp.Code.string_of_status err) (Cohttp.Code.string_of_status err)
@ -93,9 +77,10 @@ let get_json service json =
Cohttp_lwt_body.to_string ansbody >>= fun ansbody -> Cohttp_lwt_body.to_string ansbody >>= fun ansbody ->
match code, ansbody with match code, ansbody with
| #Cohttp.Code.success_status, ansbody -> begin | #Cohttp.Code.success_status, ansbody -> begin
if Client_config.print_timings#get then (if Client_config.print_timings#get then
message "Request to /%s succeeded in %gs" message "Request to /%s succeeded in %gs"
(String.concat "/" service) time ; (String.concat "/" service) time
else Lwt.return ()) >>= fun () ->
log_response cpt code ansbody >>= fun () -> log_response cpt code ansbody >>= fun () ->
if ansbody = "" then Lwt.return `Null if ansbody = "" then Lwt.return `Null
else match Data_encoding.Json.from_string ansbody with else match Data_encoding.Json.from_string ansbody with
@ -103,11 +88,12 @@ let get_json service json =
| Ok res -> Lwt.return res | Ok res -> Lwt.return res
end end
| err, _ansbody -> | err, _ansbody ->
if Client_config.print_timings#get then (if Client_config.print_timings#get then
message "Request to /%s failed in %gs" 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" 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)" error "the RPC server returned a non-success status (%s)"
(Cohttp.Code.string_of_status err) (Cohttp.Code.string_of_status err)

9
src/client/client_protocols.ml
View File

@ -11,8 +11,8 @@ let commands () =
~desc: "list known protocols" ~desc: "list known protocols"
(prefixes [ "list" ; "protocols" ] stop) (prefixes [ "list" ; "protocols" ] stop)
(fun () -> (fun () ->
Client_node_rpcs.Protocols.list ~contents:false () >|= fun protos -> Client_node_rpcs.Protocols.list ~contents:false () >>= fun protos ->
List.iter (fun (ph, _p) -> message "%a" Protocol_hash.pp ph) protos Lwt_list.iter_s (fun (ph, _p) -> message "%a" Protocol_hash.pp ph) protos
); );
command command
~group: "protocols" ~group: "protocols"
@ -26,8 +26,7 @@ let commands () =
let proto = Tezos_compiler.Protocol.of_dir dirname in let proto = Tezos_compiler.Protocol.of_dir dirname in
Client_node_rpcs.inject_protocol proto >>= function Client_node_rpcs.inject_protocol proto >>= function
| Ok hash -> | Ok hash ->
message "Injected protocol %a successfully" Protocol_hash.pp_short hash; message "Injected protocol %a successfully" Protocol_hash.pp_short hash
Lwt.return ();
| Error err -> | Error err ->
error "Error while injecting protocol from %s: %a" error "Error while injecting protocol from %s: %a"
dirname Error_monad.pp_print_error err) dirname Error_monad.pp_print_error err)
@ -44,7 +43,7 @@ let commands () =
(fun ph () -> (fun ph () ->
Client_node_rpcs.Protocols.bytes ph >>= fun { data } -> match data with Client_node_rpcs.Protocols.bytes ph >>= fun { data } -> match data with
| Ok proto -> | Ok proto ->
Updater.extract "" ph proto >|= fun () -> Updater.extract "" ph proto >>= fun () ->
message "Extracted protocol %a" Protocol_hash.pp_short ph message "Extracted protocol %a" Protocol_hash.pp_short ph
| Error err -> | Error err ->
error "Error while dumping protocol %a: %a" error "Error while dumping protocol %a: %a"

6
src/client/embedded/bootstrap/client_proto_args.ml
View File

@ -81,14 +81,14 @@ let delegatable_args =
Arg.Clear delegatable, Arg.Clear delegatable,
"Set the created contract to be non delegatable (default)" ] "Set the created contract to be non delegatable (default)" ]
let tez_param ~n ~desc next = let tez_param ~name ~desc next =
Cli_entries.param Cli_entries.param
n name
(desc ^ " in \xEA\x9C\xA9\n\ (desc ^ " in \xEA\x9C\xA9\n\
text format: D,DDD,DDD.DD (centiles and comas are optional)") text format: D,DDD,DDD.DD (centiles and comas are optional)")
(fun s -> (fun s ->
try Lwt.return (tez_of_string 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 next
let max_priority = ref None let max_priority = ref None

2
src/client/embedded/bootstrap/client_proto_args.mli
View File

@ -23,7 +23,7 @@ val force_arg: string * Arg.spec * string
val endorsement_delay_arg: string * Arg.spec * string val endorsement_delay_arg: string * Arg.spec * string
val tez_param : val tez_param :
n:string -> name:string ->
desc:string -> desc:string ->
'a Cli_entries.params -> (Tez.t -> 'a) Cli_entries.params 'a Cli_entries.params -> (Tez.t -> 'a) Cli_entries.params

72
src/client/embedded/bootstrap/client_proto_context.ml
View File

@ -34,8 +34,7 @@ let get_delegate_pkh = function
let get_timestamp block () = let get_timestamp block () =
Client_node_rpcs.Blocks.timestamp block >>= fun v -> Client_node_rpcs.Blocks.timestamp block >>= fun v ->
Cli_entries.message "%s" (Time.to_notation v) ; Cli_entries.message "%s" (Time.to_notation v)
Lwt.return ()
let list_contracts block () = let list_contracts block () =
Client_proto_rpcs.Context.Contract.list block >>=? fun contracts -> 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 let kind = match Contract.is_default h with
| Some _ -> " (default)" | Some _ -> " (default)"
| None -> "" in | 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 ()) return ())
contracts contracts
@ -75,15 +74,15 @@ let transfer block ?force
Client_proto_rpcs.Context.Contract.counter block source >>=? fun pcounter -> Client_proto_rpcs.Context.Contract.counter block source >>=? fun pcounter ->
let counter = Int32.succ pcounter in let counter = Int32.succ pcounter in
message "Acquired the source's sequence counter (%ld -> %ld)." message "Acquired the source's sequence counter (%ld -> %ld)."
pcounter counter ; pcounter counter >>= fun () ->
Client_proto_rpcs.Helpers.Forge.Manager.transaction block Client_proto_rpcs.Helpers.Forge.Manager.transaction block
~net ~source ~sourcePubKey:src_pk ~counter ~amount ~net ~source ~sourcePubKey:src_pk ~counter ~amount
~destination ?parameters ~fee () >>=? fun bytes -> ~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 let signed_bytes = Ed25519.append_signature src_sk bytes in
Client_node_rpcs.inject_operation ?force ~wait:true signed_bytes >>=? fun oph -> Client_node_rpcs.inject_operation ?force ~wait:true signed_bytes >>=? fun oph ->
answer "Operation successfully injected in the node." ; answer "Operation successfully injected in the node." >>= fun () ->
answer "Operation hash is '%a'." Operation_hash.pp oph ; answer "Operation hash is '%a'." Operation_hash.pp oph >>= fun () ->
return () return ()
let originate_account block ?force let originate_account block ?force
@ -93,16 +92,16 @@ let originate_account block ?force
Client_proto_rpcs.Context.Contract.counter block source >>=? fun pcounter -> Client_proto_rpcs.Context.Contract.counter block source >>=? fun pcounter ->
let counter = Int32.succ pcounter in let counter = Int32.succ pcounter in
message "Acquired the source's sequence counter (%ld -> %ld)." message "Acquired the source's sequence counter (%ld -> %ld)."
pcounter counter ; pcounter counter >>= fun () ->
Client_proto_rpcs.Helpers.Forge.Manager.origination block Client_proto_rpcs.Helpers.Forge.Manager.origination block
~net ~source ~sourcePubKey:src_pk ~managerPubKey:manager_pkh ~net ~source ~sourcePubKey:src_pk ~managerPubKey:manager_pkh
~counter ~balance ?spendable ~counter ~balance ?spendable
?delegatable ?delegatePubKey:delegate ~fee () >>=? fun (contract, bytes) -> ?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 let signed_bytes = Ed25519.append_signature src_sk bytes in
Client_node_rpcs.inject_operation ?force ~wait:true signed_bytes >>=? fun oph -> Client_node_rpcs.inject_operation ?force ~wait:true signed_bytes >>=? fun oph ->
message "Operation successfully injected in the node." ; message "Operation successfully injected in the node." >>= fun () ->
message "Operation hash is '%a'." Operation_hash.pp oph ; message "Operation hash is '%a'." Operation_hash.pp oph >>= fun () ->
return contract return contract
let originate_contract let originate_contract
@ -115,18 +114,18 @@ let originate_contract
Client_proto_rpcs.Context.Contract.counter block source >>=? fun pcounter -> Client_proto_rpcs.Context.Contract.counter block source >>=? fun pcounter ->
let counter = Int32.succ pcounter in let counter = Int32.succ pcounter in
message "Acquired the source's sequence counter (%ld -> %ld)." message "Acquired the source's sequence counter (%ld -> %ld)."
pcounter counter ; pcounter counter >>= fun () ->
Client_node_rpcs.Blocks.net block >>= fun net -> Client_node_rpcs.Blocks.net block >>= fun net ->
Client_proto_rpcs.Helpers.Forge.Manager.origination block Client_proto_rpcs.Helpers.Forge.Manager.origination block
~net ~source ~sourcePubKey:src_pk ~managerPubKey:manager_pkh ~net ~source ~sourcePubKey:src_pk ~managerPubKey:manager_pkh
~counter ~balance ~spendable:!spendable ~counter ~balance ~spendable:!spendable
?delegatable ?delegatePubKey ?delegatable ?delegatePubKey
~script:(code, init) ~fee () >>=? fun (contract, bytes) -> ~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 let signed_bytes = Ed25519.append_signature src_sk bytes in
Client_node_rpcs.inject_operation ?force ~wait:true signed_bytes >>=? fun oph -> Client_node_rpcs.inject_operation ?force ~wait:true signed_bytes >>=? fun oph ->
message "Operation successfully injected in the node." ; message "Operation successfully injected in the node." >>= fun () ->
message "Operation hash is '%a'." Operation_hash.pp oph ; message "Operation hash is '%a'." Operation_hash.pp oph >>= fun () ->
return contract return contract
let commands () = let commands () =
@ -157,26 +156,24 @@ let commands () =
Public_key_hash.add name pkh >>= fun () -> Public_key_hash.add name pkh >>= fun () ->
Public_key.add name pk >>= fun () -> Public_key.add name pk >>= fun () ->
Secret_key.add name sk >>= fun () -> Secret_key.add name sk >>= fun () ->
message "Bootstrap keys added under the name '%s'." name; message "Bootstrap keys added under the name '%s'." name)
Lwt.return_unit)
accounts >>= fun () -> accounts >>= fun () ->
Lwt.return_unit) ; Lwt.return_unit) ;
command command
~group: "context" ~group: "context"
~desc: "get the balance of a contract" ~desc: "get the balance of a contract"
(prefixes [ "get" ; "balance" ] (prefixes [ "get" ; "balance" ]
@@ ContractAlias.destination_param ~n:"src" ~desc:"source contract" @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@@ stop) @@ stop)
(fun (_, contract) () -> (fun (_, contract) () ->
Client_proto_rpcs.Context.Contract.balance (block ()) contract Client_proto_rpcs.Context.Contract.balance (block ()) contract
>>= Client_proto_rpcs.handle_error >>= fun amount -> >>= Client_proto_rpcs.handle_error >>= fun amount ->
answer "%a %s" Tez.pp amount tez_sym; answer "%a %s" Tez.pp amount tez_sym);
Lwt.return ());
command command
~group: "context" ~group: "context"
~desc: "get the manager of a block" ~desc: "get the manager of a block"
(prefixes [ "get" ; "manager" ] (prefixes [ "get" ; "manager" ]
@@ ContractAlias.destination_param ~n:"src" ~desc:"source contract" @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@@ stop) @@ stop)
(fun (_, contract) () -> (fun (_, contract) () ->
Client_proto_rpcs.Context.Contract.manager (block ()) 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.rev_find manager >>= fun mn ->
Public_key_hash.to_source manager >>= fun m -> Public_key_hash.to_source manager >>= fun m ->
message "%s (%s)" m message "%s (%s)" m
(match mn with None -> "unknown" | Some n -> "known as " ^ n) ; (match mn with None -> "unknown" | Some n -> "known as " ^ n));
Lwt.return ());
command command
~group: "context" ~group: "context"
~desc: "open a new account" ~desc: "open a new account"
@ -193,16 +189,16 @@ let commands () =
@ delegatable_args @ spendable_args) @ delegatable_args @ spendable_args)
(prefixes [ "originate" ; "account" ] (prefixes [ "originate" ; "account" ]
@@ RawContractAlias.fresh_alias_param @@ RawContractAlias.fresh_alias_param
~n: "new" ~desc: "name of the new contract" ~name: "new" ~desc: "name of the new contract"
@@ prefix "for" @@ prefix "for"
@@ Public_key_hash.alias_param @@ Public_key_hash.alias_param
~n: "mgr" ~desc: "manager of the new contract" ~name: "mgr" ~desc: "manager of the new contract"
@@ prefix "transfering" @@ prefix "transfering"
@@ tez_param @@ tez_param
~n: "qty" ~desc: "amount taken from source" ~name: "qty" ~desc: "amount taken from source"
@@ prefix "from" @@ prefix "from"
@@ ContractAlias.alias_param @@ ContractAlias.alias_param
~n:"src" ~desc: "name of the source contract" ~name:"src" ~desc: "name of the source contract"
@@ stop) @@ stop)
(fun neu (_, manager) balance (_, source) -> (fun neu (_, manager) balance (_, source) ->
handle_error @@ fun () -> handle_error @@ fun () ->
@ -210,7 +206,7 @@ let commands () =
get_delegate_pkh !delegate >>= fun delegate -> get_delegate_pkh !delegate >>= fun delegate ->
Client_proto_contracts.get_manager (block ()) source >>=? fun src_pkh -> Client_proto_contracts.get_manager (block ()) source >>=? fun src_pkh ->
Client_keys.get_key src_pkh >>=? fun (src_name, src_pk, src_sk) -> 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 originate_account (block ()) ~force:!force
~source ~src_pk ~src_sk ~manager_pkh:manager ~balance ~fee:!fee ~source ~src_pk ~src_sk ~manager_pkh:manager ~balance ~fee:!fee
~delegatable:!delegatable ~spendable:!spendable ?delegate:delegate ~delegatable:!delegatable ~spendable:!spendable ?delegate:delegate
@ -224,19 +220,19 @@ let commands () =
delegatable_args @ spendable_args @ [ init_arg ]) delegatable_args @ spendable_args @ [ init_arg ])
(prefixes [ "originate" ; "contract" ] (prefixes [ "originate" ; "contract" ]
@@ RawContractAlias.fresh_alias_param @@ RawContractAlias.fresh_alias_param
~n: "new" ~desc: "name of the new contract" ~name: "new" ~desc: "name of the new contract"
@@ prefix "for" @@ prefix "for"
@@ Public_key_hash.alias_param @@ Public_key_hash.alias_param
~n: "mgr" ~desc: "manager of the new contract" ~name: "mgr" ~desc: "manager of the new contract"
@@ prefix "transfering" @@ prefix "transfering"
@@ tez_param @@ tez_param
~n: "qty" ~desc: "amount taken from source" ~name: "qty" ~desc: "amount taken from source"
@@ prefix "from" @@ prefix "from"
@@ ContractAlias.alias_param @@ ContractAlias.alias_param
~n:"src" ~desc: "name of the source contract" ~name:"src" ~desc: "name of the source contract"
@@ prefix "running" @@ prefix "running"
@@ Program.source_param @@ 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" combine with -init if the storage type is non void"
@@ stop) @@ stop)
(fun neu (_, manager) balance (_, source) code -> (fun neu (_, manager) balance (_, source) code ->
@ -245,7 +241,7 @@ let commands () =
get_delegate_pkh !delegate >>= fun delegate -> get_delegate_pkh !delegate >>= fun delegate ->
Client_proto_contracts.get_manager (block ()) source >>=? fun src_pkh -> Client_proto_contracts.get_manager (block ()) source >>=? fun src_pkh ->
Client_keys.get_key src_pkh >>=? fun (src_name, src_pk, src_sk) -> 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 originate_contract (block ()) ~force:!force
~source ~src_pk ~src_sk ~manager_pkh:manager ~balance ~fee:!fee ~source ~src_pk ~src_sk ~manager_pkh:manager ~balance ~fee:!fee
~delegatable:!delegatable ?delegatePubKey:delegate ~code ~init:!init () ~delegatable:!delegatable ?delegatePubKey:delegate ~code ~init:!init ()
@ -258,19 +254,19 @@ let commands () =
~args: [ fee_arg ; arg_arg ; force_arg ] ~args: [ fee_arg ; arg_arg ; force_arg ]
(prefixes [ "transfer" ] (prefixes [ "transfer" ]
@@ tez_param @@ tez_param
~n: "qty" ~desc: "amount taken from source" ~name: "qty" ~desc: "amount taken from source"
@@ prefix "from" @@ prefix "from"
@@ ContractAlias.alias_param @@ ContractAlias.alias_param
~n: "src" ~desc: "name of the source contract" ~name: "src" ~desc: "name of the source contract"
@@ prefix "to" @@ prefix "to"
@@ ContractAlias.destination_param @@ ContractAlias.destination_param
~n: "dst" ~desc: "name/literal of the destination contract" ~name: "dst" ~desc: "name/literal of the destination contract"
@@ stop) @@ stop)
(fun amount (_, source) (_, destination) -> (fun amount (_, source) (_, destination) ->
handle_error @@ fun () -> handle_error @@ fun () ->
Client_proto_contracts.get_manager (block ()) source >>=? fun src_pkh -> Client_proto_contracts.get_manager (block ()) source >>=? fun src_pkh ->
Client_keys.get_key src_pkh >>=? fun (src_name, src_pk, src_sk) -> 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 transfer (block ()) ~force:!force
~source ~src_pk ~src_sk ~destination ?arg:!arg ~amount ~fee:!fee ()) ~source ~src_pk ~src_sk ~destination ?arg:!arg ~amount ~fee:!fee ())
] ]

60
src/client/embedded/bootstrap/client_proto_contracts.ml
View File

@ -51,33 +51,34 @@ module ContractAlias = struct
find_key key find_key key
| _ -> find s | _ -> find s
let alias_param ?(n = "name") ?(desc = "existing contract alias") next = let alias_param ?(name = "name") ?(desc = "existing contract alias") next =
Cli_entries.Param let desc =
(n, desc ^ "\n" desc ^ "\n"
^ "can be an contract alias or a key alias (autodetected in this order)\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) 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 = let destination_param ?(name = "dst") ?(desc = "destination contract") next =
Cli_entries.Param let desc =
(n, desc ^ "\n"
desc ^ "\n" ^ "can be an alias, a key alias, or a litteral (autodetected in this order)\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
use 'text:litteral', 'alias:name', 'key:name' to force", Cli_entries.param ~name ~desc
(fun s -> (fun s ->
match Utils.split ~limit:1 ':' s with match Utils.split ~limit:1 ':' s with
| [ "alias" ; alias ]-> | [ "alias" ; alias ]->
find alias find alias
| [ "key" ; text ] -> | [ "key" ; text ] ->
Client_keys.Public_key_hash.find text >>= fun v -> Client_keys.Public_key_hash.find text >>= fun v ->
Lwt.return (s, Contract.default_contract v) Lwt.return (s, Contract.default_contract v)
| _ -> | _ ->
Lwt.catch Lwt.catch
(fun () -> find s) (fun () -> find s)
(fun _ -> (fun _ ->
match Contract.of_b48check s with match Contract.of_b48check s with
| Error _ -> Lwt.fail (Failure "bad contract notation") | Error _ -> Lwt.fail (Failure "bad contract notation")
| Ok v -> Lwt.return (s, v))), | Ok v -> Lwt.return (s, v)))
next) next
let name contract = let name contract =
rev_find contract >|= function rev_find contract >|= function
@ -150,17 +151,16 @@ let commands () =
(fixed [ "list" ; "known" ; "contracts" ]) (fixed [ "list" ; "known" ; "contracts" ])
(fun () -> (fun () ->
RawContractAlias.load () >>= fun list -> RawContractAlias.load () >>= fun list ->
List.iter (fun (n, v) -> Lwt_list.iter_s (fun (n, v) ->
let v = Contract.to_b48check v in let v = Contract.to_b48check v in
message "%s: %s" n v) message "%s: %s" n v)
list ; list >>= fun () ->
Client_keys.Public_key_hash.load () >>= fun list -> Client_keys.Public_key_hash.load () >>= fun list ->
Lwt_list.iter_s (fun (n, v) -> Lwt_list.iter_s (fun (n, v) ->
RawContractAlias.mem n >>= fun mem -> RawContractAlias.mem n >>= fun mem ->
let p = if mem then "key:" else "" in let p = if mem then "key:" else "" in
let v = Contract.to_b48check (Contract.default_contract v) in let v = Contract.to_b48check (Contract.default_contract v) in
message "%s%s: %s" p n v ; message "%s%s: %s" p n v)
Lwt.return_unit)
list >>= fun () -> list >>= fun () ->
Lwt.return ()) ; Lwt.return ()) ;
command command

4
src/client/embedded/bootstrap/client_proto_contracts.mli
View File

@ -13,12 +13,12 @@ module RawContractAlias :
module ContractAlias : sig module ContractAlias : sig
val get_contract: string -> (string * Contract.t) Lwt.t val get_contract: string -> (string * Contract.t) Lwt.t
val alias_param: val alias_param:
?n:string -> ?name:string ->
?desc:string -> ?desc:string ->
'a Cli_entries.params -> 'a Cli_entries.params ->
(Lwt_io.file_name * Contract.t -> 'a) Cli_entries.params (Lwt_io.file_name * Contract.t -> 'a) Cli_entries.params
val destination_param: val destination_param:
?n:string -> ?name:string ->
?desc:string -> ?desc:string ->
'a Cli_entries.params -> 'a Cli_entries.params ->
(Lwt_io.file_name * Contract.t -> 'a) Cli_entries.params (Lwt_io.file_name * Contract.t -> 'a) Cli_entries.params

13
src/client/embedded/bootstrap/client_proto_programs.ml
View File

@ -183,7 +183,7 @@ let commands () =
~desc: "lists all known programs" ~desc: "lists all known programs"
(fixed [ "list" ; "known" ; "programs" ]) (fixed [ "list" ; "known" ; "programs" ])
(fun () -> Program.load () >>= fun list -> (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 command
~group: "programs" ~group: "programs"
~desc: "remember a program under some name" ~desc: "remember a program under some name"
@ -262,7 +262,7 @@ let commands () =
Client_proto_rpcs.Helpers.typecheck_code (block ()) program >>= function Client_proto_rpcs.Helpers.typecheck_code (block ()) program >>= function
| Ok type_map -> | Ok type_map ->
let type_map, program = unexpand_macros type_map program in let type_map, program = unexpand_macros type_map program in
message "Well typed" ; message "Well typed" >>= fun () ->
if !show_types then begin if !show_types then begin
print_program print_program
(fun l -> List.mem_assoc l type_map) (fun l -> List.mem_assoc l type_map)
@ -296,8 +296,7 @@ let commands () =
Client_proto_rpcs.Helpers.typecheck_untagged_data Client_proto_rpcs.Helpers.typecheck_untagged_data
(block ()) (data, exp_ty) >>= function (block ()) (data, exp_ty) >>= function
| Ok () -> | Ok () ->
message "Well typed" ; message "Well typed"
Lwt.return ()
| Error errs -> | Error errs ->
pp_print_error Format.err_formatter errs ; pp_print_error Format.err_formatter errs ;
error "ill-typed data") ; error "ill-typed data") ;
@ -312,8 +311,7 @@ let commands () =
let open Data_encoding in let open Data_encoding in
Client_proto_rpcs.Helpers.hash_data (block ()) data >>= function Client_proto_rpcs.Helpers.hash_data (block ()) data >>= function
| Ok hash -> | Ok hash ->
message "%S" hash; message "%S" hash
Lwt.return ()
| Error errs -> | Error errs ->
pp_print_error Format.err_formatter errs ; pp_print_error Format.err_formatter errs ;
error "ill-formed data") ; error "ill-formed data") ;
@ -337,8 +335,7 @@ let commands () =
hash hash
(signature |> (signature |>
Data_encoding.Binary.to_bytes Ed25519.signature_encoding |> Data_encoding.Binary.to_bytes Ed25519.signature_encoding |>
Hex_encode.hex_of_bytes) ; Hex_encode.hex_of_bytes)
Lwt.return ()
| Error errs -> | Error errs ->
pp_print_error Format.err_formatter errs ; pp_print_error Format.err_formatter errs ;
error "ill-formed data") ; error "ill-formed data") ;

8
src/client/embedded/bootstrap/mining/client_mining_main.ml
View File

@ -101,7 +101,7 @@ let reveal_nonces ?force () =
open Client_proto_args open Client_proto_args
let run_daemon delegates = let run_daemon delegates () =
Client_mining_daemon.run Client_mining_daemon.run
?max_priority:!max_priority ?max_priority:!max_priority
~delay:!endorsement_delay ~delay:!endorsement_delay
@ -126,7 +126,7 @@ let commands () =
~args: [ force_arg ] ~args: [ force_arg ]
(prefixes [ "endorse"; "for" ] (prefixes [ "endorse"; "for" ]
@@ Client_keys.Public_key_hash.alias_param @@ 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) @@ stop)
(fun (_, delegate) () -> (fun (_, delegate) () ->
endorse_block endorse_block
@ -138,7 +138,7 @@ let commands () =
~args: [ max_priority_arg ; force_arg ] ~args: [ max_priority_arg ; force_arg ]
(prefixes [ "mine"; "for" ] (prefixes [ "mine"; "for" ]
@@ Client_keys.Public_key_hash.alias_param @@ 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) @@ stop)
(fun (_, delegate) () -> (fun (_, delegate) () ->
mine_block (block ()) mine_block (block ())
@ -150,7 +150,7 @@ let commands () =
~args: [ force_arg ] ~args: [ force_arg ]
(prefixes [ "reveal"; "nonce"; "for" ] (prefixes [ "reveal"; "nonce"; "for" ]
@@ Cli_entries.seq_of_param Block_hash.param) @@ 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) ; reveal_block_nonces ~force:!force block_hashes >>= Client_proto_rpcs.handle_error) ;
command command
~group: "delegate" ~group: "delegate"

25
src/client_main.ml
View File

@ -11,6 +11,27 @@
open Lwt 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 *) (* Main (lwt) entry *)
let main () = let main () =
Random.self_init () ; Random.self_init () ;
@ -24,7 +45,7 @@ let main () =
(fun _ -> (fun _ ->
Cli_entries.message "\n\ Cli_entries.message "\n\
The connection to the RPC server failed, \ 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) Lwt.return Client_bootstrap.Client_proto_main.protocol)
>>= fun version -> >>= fun version ->
let commands = let commands =
@ -35,7 +56,7 @@ let main () =
Client_version.commands_for_version version in Client_version.commands_for_version version in
Client_config.parse_args ~version Client_config.parse_args ~version
(Cli_entries.usage commands) (Cli_entries.usage commands)
(Cli_entries.inline_dispatcher commands)) (Cli_entries.inline_dispatch commands))
(function (function
| Arg.Help help -> | Arg.Help help ->
Format.printf "%s%!" help ; Format.printf "%s%!" help ;

344
src/utils/cli_entries.ml
View File

@ -16,21 +16,30 @@ exception Command_not_found
exception Bad_argument of int * string * string exception Bad_argument of int * string * string
exception Command_failed of string exception Command_failed of string
(* A simple structure for command interpreters. *) (* A simple structure for command interpreters.
type 'a params = This is more generic than the exported one, see end of file. *)
| Prefix : string * 'a params -> 'a params type ('a, 'arg, 'ret) tparams =
| Param : string * string * (string -> 'p Lwt.t) * 'a params -> ('p -> 'a) params | Prefix : string * ('a, 'arg, 'ret) tparams ->
| Stop : (unit -> unit Lwt.t) params ('a, 'arg, 'ret) tparams
| More : (string list -> unit Lwt.t) params | Param : string * string *
| Seq : string * string * (string -> 'p Lwt.t) -> ('p list -> unit Lwt.t) params (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 *) (* A command wraps a callback with its type and info *)
and command = and ('arg, 'ret) tcommand =
| Command | Command
: 'a params * 'a * : ('a, 'arg, 'ret) tparams * 'a *
desc option * tag list * group option * desc option * tag list * group option *
(Arg.key * Arg.spec * Arg.doc) list (Arg.key * Arg.spec * Arg.doc) list
-> command -> ('arg, 'ret) tcommand
and desc = string and desc = string
and group = string and group = string
@ -77,25 +86,15 @@ let command ?desc ?(tags = []) ?group ?(args = []) params cb =
(* Param combinators *) (* Param combinators *)
let string n desc next = param n desc (fun s -> return s) next 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 *) (* Command execution *)
let exec (Command (params, cb, _, _, _, _)) args = let exec
(type arg) (type ret)
(Command (params, cb, _, _, _, _)) (last : arg) args =
let rec exec 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 match params, args with
| Stop, [] -> cb () | Stop, [] -> cb last
| Stop, _ -> Lwt.fail Command_not_found | Stop, _ -> Lwt.fail Command_not_found
| Seq (_, _, f), seq -> | Seq (_, _, f), seq ->
let rec do_seq i acc = function let rec do_seq i acc = function
@ -108,8 +107,8 @@ let exec (Command (params, cb, _, _, _, _)) args =
| exn -> Lwt.fail exn) >>= fun v -> | exn -> Lwt.fail exn) >>= fun v ->
do_seq (succ i) (v :: acc) rest in do_seq (succ i) (v :: acc) rest in
do_seq i [] seq >>= fun parsed -> do_seq i [] seq >>= fun parsed ->
cb parsed cb parsed last
| More, rest -> cb rest | More, rest -> cb rest last
| Prefix (n, next), p :: rest when n = p -> | Prefix (n, next), p :: rest when n = p ->
exec (succ i) next cb rest exec (succ i) next cb rest
| Param (_, _, f, next), p :: rest -> | Param (_, _, f, next), p :: rest ->
@ -122,116 +121,125 @@ let exec (Command (params, cb, _, _, _, _)) args =
| _ -> Lwt.fail Command_not_found | _ -> Lwt.fail Command_not_found
in exec 1 params cb args in exec 1 params cb args
module Command_tree = struct (* Command dispatch tree *)
type level = type ('arg, 'ret) level =
{ stop : command option ; { stop : ('arg, 'ret) tcommand option ;
prefix : (string * tree) list } prefix : (string * ('arg, 'ret) tree) list }
and param_level = and ('arg, 'ret) param_level =
{ stop : command option ; { stop : ('arg, 'ret) tcommand option ;
tree : tree } tree : ('arg, 'ret) tree }
and tree = and ('arg, 'ret) tree =
| TPrefix of level | TPrefix of ('arg, 'ret) level
| TParam of param_level | TParam of ('arg, 'ret) param_level
| TStop of command | TStop of ('arg, 'ret) tcommand
| TMore of command | TMore of ('arg, 'ret) tcommand
| TEmpty | TEmpty
let insert root (Command (params, _, _, _, _, _) as command) =
let rec insert_tree let insert_in_dispatch_tree
: type a. tree -> a params -> tree (type arg) (type ret)
= fun t c -> match t, c with root (Command (params, _, _, _, _, _) as command) =
| TEmpty, Stop -> TStop command let rec insert_tree
| TEmpty, More -> TMore command : type a. (arg, ret) tree -> (a, arg, ret) tparams -> (arg, ret) tree
| TEmpty, Seq _ -> TMore command = fun t c -> match t, c with
| TEmpty, Param (_, _, _, next) -> | TEmpty, Stop -> TStop command
TParam { tree = insert_tree TEmpty next ; stop = None } | TEmpty, More -> TMore command
| TEmpty, Prefix (n, next) -> | TEmpty, Seq _ -> TMore command
TPrefix { stop = None ; prefix = [ (n, insert_tree TEmpty next) ] } | TEmpty, Param (_, _, _, next) ->
| TStop command, Param (_, _, _, next) -> TParam { tree = insert_tree TEmpty next ; stop = None }
TParam { tree = insert_tree TEmpty next ; stop = Some command } | TEmpty, Prefix (n, next) ->
| TStop command, Prefix (n, next) -> TPrefix { stop = None ; prefix = [ (n, insert_tree TEmpty next) ] }
TPrefix { stop = Some command ; | TStop command, Param (_, _, _, next) ->
prefix = [ (n, insert_tree TEmpty next) ] } TParam { tree = insert_tree TEmpty next ; stop = Some command }
| TParam t, Param (_, _, _, next) -> | TStop command, Prefix (n, next) ->
TParam { t with tree = insert_tree t.tree next } TPrefix { stop = Some command ;
| TPrefix ({ prefix } as l), Prefix (n, next) -> prefix = [ (n, insert_tree TEmpty next) ] }
let rec insert_prefix = function | TParam t, Param (_, _, _, next) ->
| [] -> [ (n, insert_tree TEmpty next) ] TParam { t with tree = insert_tree t.tree next }
| (n', t) :: rest when n = n' -> (n, insert_tree t next) :: rest | TPrefix ({ prefix } as l), Prefix (n, next) ->
| item :: rest -> item :: insert_prefix rest in let rec insert_prefix = function
TPrefix { l with prefix = insert_prefix prefix } | [] -> [ (n, insert_tree TEmpty next) ]
| TPrefix ({ stop = None } as l), Stop -> | (n', t) :: rest when n = n' -> (n, insert_tree t next) :: rest
TPrefix { l with stop = Some command } | item :: rest -> item :: insert_prefix rest in
| TParam ({ stop = None } as l), Stop -> TPrefix { l with prefix = insert_prefix prefix }
TParam { l with stop = Some command } | TPrefix ({ stop = None } as l), Stop ->
| _, _ -> TPrefix { l with stop = Some command }
Pervasives.failwith | TParam ({ stop = None } as l), Stop ->
"Cli_entries.Command_tree.insert: conflicting commands" in TParam { l with stop = Some command }
insert_tree root params | _, _ ->
let make commands = Pervasives.failwith
List.fold_left insert TEmpty commands "Cli_entries.Command_tree.insert: conflicting commands" in
let dispatcher tree args = insert_tree root params
let rec loop = function
| TStop c, [] -> exec c args let make_dispatch_tree commands =
| TPrefix { stop = Some c }, [] -> exec c args List.fold_left insert_in_dispatch_tree TEmpty commands
| TMore c, _ -> exec c args
| TPrefix { prefix }, n :: rest -> let tree_dispatch tree last args =
begin try let rec loop = function
let t = List.assoc n prefix in | TStop c, [] -> exec c last args
loop (t, rest) | TPrefix { stop = Some c }, [] -> exec c last args
with Not_found -> Lwt.fail Command_not_found end | TMore c, _ -> exec c last args
| TParam { tree }, _ :: rest -> | TPrefix { prefix }, n :: rest ->
loop (tree, rest) begin try
| _, _ -> Lwt.fail Command_not_found let t = List.assoc n prefix in
in loop (t, rest)
loop (tree, args) with Not_found -> Lwt.fail Command_not_found end
let inline_dispatcher tree () = | TParam { tree }, _ :: rest ->
let state = ref (tree, []) in loop (tree, rest)
fun arg -> match !state, arg with | _, _ -> Lwt.fail Command_not_found
| (( TStop c | in
TMore c | loop (tree, args)
TPrefix { stop = Some c } |
TParam { stop = Some c}), acc), let inline_tree_dispatch tree last =
`End -> let state = ref (tree, []) in
state := (TEmpty, []) ; fun arg -> match !state, arg with
`Res (exec c (List.rev acc)) | (( TStop c |
| (TMore c, acc), `Arg n -> TMore c |
state := (TMore c, n :: acc) ; TPrefix { stop = Some c } |
`Nop TParam { stop = Some c}), acc),
| (TPrefix { prefix }, acc), `Arg n -> `End ->
begin try state := (TEmpty, []) ;
let t = List.assoc n prefix in `Res (exec c last (List.rev acc))
state := (t, n :: acc) ; | (TMore c, acc), `Arg n ->
begin match t with state := (TMore c, n :: acc) ;
| TStop (Command (_, _, _, _, _, args)) `Nop
| TMore (Command (_, _, _, _, _, args)) -> `Args args | (TPrefix { prefix }, acc), `Arg n ->
| _ -> `Nop end begin try
with Not_found -> `Fail Command_not_found end let t = List.assoc n prefix in
| (TParam { tree }, acc), `Arg n -> state := (t, n :: acc) ;
state := (tree, n :: acc) ; begin match t with
begin match tree with | TStop (Command (_, _, _, _, _, args))
| TStop (Command (_, _, _, _, _, args)) | TMore (Command (_, _, _, _, _, args)) -> `Args args
| TMore (Command (_, _, _, _, _, args)) -> `Args args | _ -> `Nop end
| _ -> `Nop end with Not_found -> `Fail Command_not_found end
| _, _ -> `Fail Command_not_found | (TParam { tree }, acc), `Arg n ->
end 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 *) (* Try a list of commands on a list of arguments *)
let dispatcher commands = let dispatch commands =
let tree = Command_tree.make commands in let tree = make_dispatch_tree commands in
fun args -> Command_tree.dispatcher tree args tree_dispatch tree
(* Argument-by-argument dispatcher to be used during argument parsing *) (* Argument-by-argument dispatcher to be used during argument parsing *)
let inline_dispatcher commands = let inline_dispatch commands =
let tree = Command_tree.make commands in let tree = make_dispatch_tree commands in
Command_tree.inline_dispatcher tree inline_tree_dispatch tree
(* Command line help for a set of commands *) (* 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 *) let trim s = (* config-file wokaround *)
Utils.split '\n' s |> Utils.split '\n' s |>
List.map String.trim |> List.map String.trim |>
String.concat "\n" in 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 -> () | Stop -> ()
| More -> Format.fprintf ppf "..." | More -> Format.fprintf ppf "..."
| Seq (n, "", _) -> Format.fprintf ppf "[ (%s) ...]" n | 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 | Prefix (n, next) -> Format.fprintf ppf "%s %a" n help next
| Param (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 | 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 -> () | Stop -> ()
| More -> Format.fprintf ppf "..." | More -> Format.fprintf ppf "..."
| Seq (n, _, _) -> Format.fprintf ppf "[ (%s) ... ]" n | Seq (n, _, _) -> Format.fprintf ppf "[ (%s) ... ]" n
@ -250,13 +260,21 @@ let usage commands options =
| Param (n, _, _, Stop) -> Format.fprintf ppf "(%s)" n | Param (n, _, _, Stop) -> Format.fprintf ppf "(%s)" n
| Prefix (n, next) -> Format.fprintf ppf "%s %a" n help_sum next | 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 | 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 let rec help_args
| Stop -> () : type a. Format.formatter -> (a, arg, ret) tparams -> unit
| More -> Format.fprintf ppf "..." = fun ppf -> function
| Seq (n, desc, _) -> Format.fprintf ppf "(%s): @[<hov>%a@]" n Format.pp_print_text (trim desc) | Stop -> ()
| Prefix (_, next) -> help_args ppf next | More -> Format.fprintf ppf "..."
| Param (n, desc, _, Stop) -> Format.fprintf ppf "(%s): @[<hov>%a@]" n Format.pp_print_text (trim desc) | Seq (n, desc, _) ->
| Param (n, desc, _, next) -> Format.fprintf ppf "(%s): @[<hov>%a@]@,%a" n Format.pp_print_text (trim desc) help_args next in Format.fprintf ppf "(%s): @[<hov>%a@]"
n Format.pp_print_text (trim desc)
| Prefix (_, next) -> help_args ppf next
| Param (n, desc, _, Stop) ->
Format.fprintf ppf "(%s): @[<hov>%a@]"
n Format.pp_print_text (trim desc)
| Param (n, desc, _, next) ->
Format.fprintf ppf "(%s): @[<hov>%a@]@,%a"
n Format.pp_print_text (trim desc) help_args next in
let option_help ppf (n, opt, desc) = let option_help ppf (n, opt, desc) =
Format.fprintf ppf "%s%s" n Format.fprintf ppf "%s%s" n
Arg.(let rec example opt = match opt with Arg.(let rec example opt = match opt with
@ -277,27 +295,38 @@ let usage commands options =
Format.fprintf ppf "@, @[<hov>%a@]" Format.pp_print_text (trim desc) in Format.fprintf ppf "@, @[<hov>%a@]" Format.pp_print_text (trim desc) in
let command_help ppf (Command (p, _, desc, _, _, options)) = let command_help ppf (Command (p, _, desc, _, _, options)) =
let small = Format.asprintf "@[<h>%a@]" help p in let small = Format.asprintf "@[<h>%a@]" help p in
let desc =
match desc with
| None -> "undocumented command"
| Some desc -> trim desc in
if String.length small < 50 then begin if String.length small < 50 then begin
Format.fprintf ppf "@[<v 2>%s@,@[<hov>%a@]" Format.fprintf ppf "@[<v 2>%s@,@[<hov>%a@]"
small small Format.pp_print_text desc
Format.pp_print_text (match desc with None -> "undocumented command" | Some desc -> trim desc)
end else begin end else begin
Format.fprintf ppf "@[<v 2>%a@,@[<hov 0>%a@]@,%a" Format.fprintf ppf "@[<v 2>%a@,@[<hov 0>%a@]@,%a"
help_sum p 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 ; help_args p ;
end ; end ;
if options = [] then if options = [] then
Format.fprintf ppf "@]" Format.fprintf ppf "@]"
else 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 rec group_help ppf (n, commands) =
let title =
match n with
| None -> "Miscellaneous commands"
| Some n -> group_title n in
Format.fprintf ppf "@[<v 2>%s:@,%a@]" Format.fprintf ppf "@[<v 2>%s:@,%a@]"
(match n with None -> "Miscellaneous commands" | Some n -> group_title n) title
(Format.pp_print_list command_help) !commands in (Format.pp_print_list command_help) !commands in
let usage ppf (by_group, options) = let usage ppf (by_group, options) =
Format.fprintf ppf Format.fprintf ppf
"@[<v>@[<v 2>Usage:@,%s [ options ] command [ command options ]@]@,@[<v 2>Options:@,%a@]@,%a@]" "@[<v>@[<v 2>Usage:@,%s [ options ] command [ command options ]@]@,\
@[<v 2>Options:@,%a@]@,\
%a@]"
Sys.argv.(0) Sys.argv.(0)
(Format.pp_print_list option_help) options (Format.pp_print_list option_help) options
(Format.pp_print_list group_help) by_group in (Format.pp_print_list group_help) by_group in
@ -312,3 +341,34 @@ let usage commands options =
(g, ref [ c ]) :: acc) (g, ref [ c ]) :: acc)
[] commands |> List.sort compare in [] commands |> List.sort compare in
Format.asprintf "%a" usage (by_group, options) 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

41
src/utils/cli_entries.mli
View File

@ -14,29 +14,13 @@ exception Command_not_found
exception Bad_argument of int * string * string exception Bad_argument of int * string * string
exception Command_failed of string exception Command_failed of string
type 'a params = type 'a params
| Prefix: string * 'a params -> 'a params type command
| 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
and desc = string and desc = string
and group = string and group = string
and tag = 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: val param:
name: string -> name: string ->
desc: string -> desc: string ->
@ -49,12 +33,13 @@ val stop: (unit -> unit Lwt.t) params
val seq: val seq:
name: string -> name: string ->
desc: 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: val seq_of_param:
((unit -> unit Lwt.t) params -> ('a -> unit -> unit Lwt.t) params) -> ((unit -> unit Lwt.t) params ->
('a list -> unit Lwt.t) params ('a -> unit -> unit Lwt.t) params) ->
('a list -> unit -> unit Lwt.t) params
val command: val command:
?desc:desc -> ?desc:desc ->
@ -68,7 +53,7 @@ val register_tag: tag -> string -> unit
val usage: val usage:
command list -> (string * Arg.spec * string) list -> string command list -> (string * Arg.spec * string) list -> string
val inline_dispatcher: val inline_dispatch:
command list -> command list ->
unit -> unit ->
[> `Arg of string | `End ] -> [> `Arg of string | `End ] ->
@ -76,3 +61,13 @@ val inline_dispatcher:
| `Fail of exn | `Fail of exn
| `Nop | `Nop
| `Res of unit Lwt.t ] | `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