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

45
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 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,17 +138,17 @@ 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,
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
@ -160,19 +158,20 @@ module Alias = functor (Entity : Entity) -> struct
else return ())
list >>= fun () ->
return s
else return s),
next)
else return s)
next
let source_param ?(n = "src") ?(desc = "source " ^ name) next =
Param (n,
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",
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 -> param_error "cannot read file (%s)" (Printexc.to_string exn))
(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 ]->
@ -187,8 +186,8 @@ module Alias = functor (Entity : Entity) -> struct
(fun _ ->
catch
(fun () -> read s)
(fun _ -> of_source s))),
next)
(fun _ -> of_source s)))
next
let name d =
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 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

4
src/client/client_generic_rpcs.ml
View File

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

50
src/client/client_node_rpcs.ml
View File

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

9
src/client/client_protocols.ml
View File

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

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

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

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 tez_param :
n:string ->
name:string ->
desc:string ->
'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 () =
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 ())
]

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

@ -51,18 +51,19 @@ module ContractAlias = struct
find_key key
| _ -> find s
let alias_param ?(n = "name") ?(desc = "existing contract alias") next =
Cli_entries.Param
(n, desc ^ "\n"
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", 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 =
Cli_entries.Param
(n,
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",
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 ]->
@ -76,8 +77,8 @@ module ContractAlias = struct
(fun _ ->
match Contract.of_b48check s with
| Error _ -> Lwt.fail (Failure "bad contract notation")
| Ok v -> Lwt.return (s, v))),
next)
| 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

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

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

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

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

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

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

25
src/client_main.ml
View File

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

200
src/utils/cli_entries.ml
View File

@ -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,22 +121,25 @@ 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
(* 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 root (Command (params, _, _, _, _, _) as command) =
let insert_in_dispatch_tree
(type arg) (type ret)
root (Command (params, _, _, _, _, _) as command) =
let rec insert_tree
: type a. tree -> a params -> 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
@ -167,13 +169,15 @@ module Command_tree = struct
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 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 args
| TPrefix { stop = Some c }, [] -> exec c args
| TMore c, _ -> exec c args
| 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
@ -184,7 +188,8 @@ module Command_tree = struct
| _, _ -> Lwt.fail Command_not_found
in
loop (tree, args)
let inline_dispatcher tree () =
let inline_tree_dispatch tree last =
let state = ref (tree, []) in
fun arg -> match !state, arg with
| (( TStop c |
@ -193,7 +198,7 @@ module Command_tree = struct
TParam { stop = Some c}), acc),
`End ->
state := (TEmpty, []) ;
`Res (exec c (List.rev acc))
`Res (exec c last (List.rev acc))
| (TMore c, acc), `Arg n ->
state := (TMore c, n :: acc) ;
`Nop
@ -213,25 +218,28 @@ module Command_tree = struct
| TMore (Command (_, _, _, _, _, args)) -> `Args args
| _ -> `Nop end
| _, _ -> `Fail Command_not_found
end
(* 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
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): @[<hov>%a@]" n Format.pp_print_text (trim desc)
| Seq (n, desc, _) ->
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
| 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) =
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 "@, @[<hov>%a@]" Format.pp_print_text (trim desc) in
let command_help ppf (Command (p, _, desc, _, _, options)) =
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
Format.fprintf ppf "@[<v 2>%s@,@[<hov>%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 "@[<v 2>%a@,@[<hov 0>%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 "@[<v 2>%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
"@[<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)
(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

41
src/utils/cli_entries.mli
View File

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