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

Client: more Error_monad in Cli_entries.

Browse Source
This commit is contained in:
Grégoire Henry 2017-04-05 10:22:41 +02:00 committed by Benjamin Canou
parent cfb7e35914
commit 166801fc77
20 changed files with 164 additions and 155 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/Makefile
View File

@ -225,9 +225,9 @@ UTILS_LIB_INTFS := \
UTILS_LIB_IMPLS := \
utils/base58.ml \
utils/cli_entries.ml \
utils/error_monad_sig.ml \
utils/error_monad.ml \
utils/cli_entries.ml \
utils/data_encoding_ezjsonm.ml \
utils/time.ml \
utils/hash.ml \

14
src/client/client_aliases.ml
View File

@ -208,9 +208,8 @@ module Alias = functor (Entity : Entity) -> struct
?(name = "name") ?(desc = "existing " ^ Entity.name ^ " alias") next =
param ~name ~desc
(fun cctxt s ->
find cctxt s >>= function
| Ok v -> Lwt.return (s, v)
| Error err -> cctxt.error "%a" pp_print_error err)
find cctxt s >>=? fun v ->
return (s, v))
next
let fresh_alias_param
@ -233,9 +232,8 @@ module Alias = functor (Entity : Entity) -> struct
return ())
list
end
end >>= function
| Ok () -> Lwt.return s
| Error err -> cctxt.error "%a" pp_print_error err)
end >>=? fun () ->
return s)
next
let source_param ?(name = "src") ?(desc = "source " ^ Entity.name) next =
@ -270,9 +268,7 @@ module Alias = functor (Entity : Entity) -> struct
read s >>= function
| Ok v -> return v
| Error _ -> of_source cctxt s
end >>= function
| Ok s -> Lwt.return s
| Error err -> cctxt.error "%a" pp_print_error err)
end)
next
let name cctxt d =

2
src/client/client_commands.ml
View File

@ -32,7 +32,7 @@ type context = {
log : 'a. string -> ('a, unit) lwt_format -> 'a ;
}
type command = (context, unit tzresult) Cli_entries.command
type command = (context, unit) Cli_entries.command
(* Default config *)

2
src/client/client_commands.mli
View File

@ -55,7 +55,7 @@ val ignore_context : context
(** [ignore_context] is a context whose logging callbacks do nothing,
and whose [error] function calls [Lwt.fail_with]. *)
type command = (context, unit tzresult) Cli_entries.command
type command = (context, unit) Cli_entries.command
exception Version_not_found

6
src/client/client_config.ml
View File

@ -215,14 +215,16 @@ let parse_args usage dispatcher argv =
let anon dispatch n = match dispatch (`Arg n) with
| `Nop -> ()
| `Args nargs -> args := nargs @ !args
| `Fail exn -> raise exn
| `Fail err ->
Format.kasprintf (fun s -> raise (Arg.Help s)) "%a" pp_print_error err
| `Res _ -> assert false in
let dispatch = dispatcher () in
Arg.parse_argv_dynamic
~current:(ref 0) argv args (anon dispatch) "\000" ;
match dispatch `End with
| `Res res -> (res, !parsed_args)
| `Fail exn -> raise exn
| `Fail err ->
Format.kasprintf (fun s -> raise (Arg.Help s)) "%a" pp_print_error err
| `Nop | `Args _ -> assert false
with
| Arg.Bad msg ->

7
src/client/client_generic_rpcs.ml
View File

@ -343,6 +343,7 @@ let group =
title = "Commands for the low level RPC layer" }
let commands = [
command ~desc: "list all understood protocol versions"
(fixed [ "list" ; "versions" ])
(fun cctxt ->
@ -350,20 +351,26 @@ let commands = [
(fun (ver, _) -> cctxt.Client_commands.message "%a" Protocol_hash.pp_short ver)
(Client_commands.get_versions ()) >>= fun () ->
return ()) ;
command ~group ~desc: "list available RPCs (low level command for advanced users)"
(prefixes [ "rpc" ; "list" ] @@ stop)
(list "/");
command ~group ~desc: "list available RPCs (low level command for advanced users)"
(prefixes [ "rpc" ; "list" ] @@ string ~name:"url" ~desc: "the RPC's prefix to be described" @@ stop)
list ;
command ~group ~desc: "get the schemas of an RPC"
(prefixes [ "rpc" ; "schema" ] @@ string ~name: "url" ~desc: "the RPC's URL" @@ stop)
schema ;
command ~group ~desc: "call an RPC (low level command for advanced users)"
(prefixes [ "rpc" ; "call" ] @@ string ~name: "url" ~desc: "the RPC's URL" @@ stop)
call ;
command ~group ~desc: "call an RPC (low level command for advanced users)"
(prefixes [ "rpc" ; "call" ] @@ string ~name: "url" ~desc: "the RPC's URL"
@@ prefix "with" @@ string ~name:"" ~desc:"" @@ stop)
call_with_json
]

11
src/client/client_protocols.ml
View File

@ -17,12 +17,11 @@ let commands () =
let open Cli_entries in
let check_dir _ dn =
if Sys.is_directory dn then
Lwt.return dn
return dn
else
Lwt.fail_with (dn ^ " is not a directory") in
let check_hash _ ph =
Lwt.wrap1 Protocol_hash.of_b58check_exn ph in
failwith "%s is not a directory" dn in
[
command ~group ~desc: "list known protocols"
(prefixes [ "list" ; "protocols" ] stop)
(fun cctxt ->
@ -30,6 +29,7 @@ let commands () =
Lwt_list.iter_s (fun (ph, _p) -> cctxt.message "%a" Protocol_hash.pp ph) protos >>= fun () ->
return ()
);
command ~group ~desc: "inject a new protocol to the shell database"
(prefixes [ "inject" ; "protocol" ]
@@ param ~name:"dir" ~desc:"directory containing a protocol" check_dir
@ -52,9 +52,10 @@ let commands () =
dirname Error_monad.pp_print_error [Error_monad.Exn exn] >>= fun () ->
return ())
);
command ~group ~desc: "dump a protocol from the shell database"
(prefixes [ "dump" ; "protocol" ]
@@ param ~name:"protocol hash" ~desc:"" check_hash
@@ Protocol_hash.param ~name:"protocol hash" ~desc:""
@@ stop)
(fun ph cctxt ->
Client_node_rpcs.Protocols.contents cctxt.rpc_config ph >>=? fun proto ->

4
src/client/client_tags.ml
View File

@ -65,9 +65,7 @@ module Tags (Entity : Entity) = struct
desc ^ "\n"
^ "can be one or multiple tags separated by commas" in
Cli_entries.param ~name ~desc
(fun cctxt s -> of_source cctxt s >>= function
| Ok r -> Lwt.return r
| Error err -> cctxt.error "%a" pp_print_error err)
(fun cctxt s -> of_source cctxt s)
next
let rev_find_by_tag cctxt tag =

4
src/client/embedded/alpha/client_proto_args.ml
View File

@ -85,8 +85,8 @@ let tez_param ~name ~desc next =
(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 _ -> Lwt.fail_with "invalid \xEA\x9C\xA9 notation")
try return (tez_of_string s)
with _ -> failwith "invalid \xEA\x9C\xA9 notation")
next
let max_priority = ref None

29
src/client/embedded/alpha/client_proto_context.ml
View File

@ -86,10 +86,10 @@ let transfer cctxt
Client_node_rpcs.Blocks.net cctxt.rpc_config block >>=? fun net ->
begin match arg with
| Some arg ->
Client_proto_programs.parse_data cctxt arg >>= fun arg ->
Lwt.return (Some arg)
| None -> Lwt.return None
end >>= fun parameters ->
Client_proto_programs.parse_data arg >>=? fun arg ->
return (Some arg)
| None -> return None
end >>=? fun parameters ->
Client_proto_rpcs.Context.Contract.counter cctxt.rpc_config block source >>=? fun pcounter ->
let counter = Int32.succ pcounter in
cctxt.message "Acquired the source's sequence counter (%ld -> %ld)."
@ -148,7 +148,7 @@ let originate_contract cctxt
block ?force
~source ~src_pk ~src_sk ~manager_pkh ~balance ?delegatable ?delegatePubKey
~(code:Script.code) ~init ~fee () =
Client_proto_programs.parse_data cctxt init >>= fun storage ->
Client_proto_programs.parse_data init >>=? fun storage ->
let storage = Script.{ storage ; storage_type = code.storage_type } in
Client_proto_rpcs.Context.Contract.counter cctxt.rpc_config block source >>=? fun pcounter ->
let counter = Int32.succ pcounter in
@ -358,12 +358,10 @@ let commands () =
command ~desc: "Activate a protocol" begin
prefixes [ "activate" ; "protocol" ] @@
param ~name:"version" ~desc:"Protocol version (b58check)"
(fun _ p -> Lwt.return @@ Protocol_hash.of_b58check_exn p) @@
Protocol_hash.param ~name:"version" ~desc:"Protocol version (b58check)" @@
prefixes [ "with" ; "key" ] @@
param ~name:"password" ~desc:"Dictator's key"
(fun _ key ->
Lwt.return (Environment.Ed25519.Secret_key.of_b58check_exn key))
Environment.Ed25519.Secret_key.param
~name:"password" ~desc:"Dictator's key" @@
stop
end
(fun hash seckey cctxt ->
@ -371,14 +369,13 @@ let commands () =
command ~desc: "Fork a test protocol" begin
prefixes [ "fork" ; "test" ; "protocol" ] @@
param ~name:"version" ~desc:"Protocol version (b58check)"
(fun _ p -> Lwt.return (Protocol_hash.of_b58check_exn p)) @@
Protocol_hash.param ~name:"version" ~desc:"Protocol version (b58check)" @@
prefixes [ "with" ; "key" ] @@
param ~name:"password" ~desc:"Dictator's key"
(fun _ key ->
Lwt.return (Environment.Ed25519.Secret_key.of_b58check_exn key))
stop
Environment.Ed25519.Secret_key.param
~name:"password" ~desc:"Dictator's key" @@
stop
end
(fun hash seckey cctxt ->
dictate cctxt cctxt.config.block (Activate_testnet hash) seckey) ;
]

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

@ -61,10 +61,7 @@ module ContractAlias = struct
^ "can be an contract alias or a key alias (autodetected in this order)\n\
use 'key:name' to force the later" in
Cli_entries.param ~name ~desc
(fun cctxt p ->
get_contract cctxt p >>= function
| Ok v -> Lwt.return v
| Error err -> cctxt.error "%a" pp_print_error err)
(fun cctxt p -> get_contract cctxt p)
next
let destination_param ?(name = "dst") ?(desc = "destination contract") next =
@ -87,9 +84,7 @@ module ContractAlias = struct
| Error _ ->
ContractEntity.of_source cctxt s >>=? fun v ->
return (s, v)
end >>= function
| Ok v -> Lwt.return v
| Error err -> cctxt.error "%a" pp_print_error err)
end)
next
let name cctxt contract =

71
src/client/embedded/alpha/client_proto_programs.ml
View File

@ -10,7 +10,7 @@
module Ed25519 = Environment.Ed25519
open Client_proto_args
let report_parse_error cctxt _prefix exn _lexbuf =
let report_parse_error _prefix exn _lexbuf =
let open Lexing in
let open Script_located_ir in
let print_loc ppf ((sl, sc), (el, ec)) =
@ -29,15 +29,15 @@ let report_parse_error cctxt _prefix exn _lexbuf =
sl sc el ec in
match exn with
| Missing_program_field n ->
cctxt.Client_commands.error "missing script %s" n
failwith "missing script %s" n
| Illegal_character (loc, c) ->
cctxt.Client_commands.error "%a, illegal character %C" print_loc loc c
failwith "%a, illegal character %C" print_loc loc c
| Illegal_escape (loc, c) ->
cctxt.Client_commands.error "%a, illegal escape sequence %S" print_loc loc c
failwith "%a, illegal escape sequence %S" print_loc loc c
| Failure s ->
cctxt.Client_commands.error "%s" s
failwith "%s" s
| exn ->
cctxt.Client_commands.error "%s" @@ Printexc.to_string exn
failwith "%s" @@ Printexc.to_string exn
let print_location_mark ppf = function
| None -> ()
@ -435,10 +435,10 @@ let report_typechecking_errors cctxt errs =
| err -> cctxt.warning "%a" pp_print_error [ err ])
errs
let parse_program cctxt s =
let parse_program s =
let lexbuf = Lexing.from_string s in
try
Lwt.return
return
(Concrete_parser.tree Concrete_lexer.(token (init_state ())) lexbuf |>
List.map Script_located_ir.strip_locations |> fun fields ->
let rec get_field n = function
@ -451,25 +451,25 @@ let parse_program cctxt s =
storage_type = get_field "storage" fields }
)
with
| exn -> report_parse_error cctxt "program: " exn lexbuf
| exn -> report_parse_error "program: " exn lexbuf
let parse_data cctxt s =
let parse_data s =
let lexbuf = Lexing.from_string s in
try
match Concrete_parser.tree Concrete_lexer.(token (init_state ())) lexbuf with
| [node] -> Lwt.return (Script_located_ir.strip_locations node)
| _ -> cctxt.Client_commands.error "single data expression expected"
| [node] -> return (Script_located_ir.strip_locations node)
| _ -> failwith "single data expression expected"
with
| exn -> report_parse_error cctxt "data: " exn lexbuf
| exn -> report_parse_error "data: " exn lexbuf
let parse_data_type cctxt s =
let parse_data_type s =
let lexbuf = Lexing.from_string s in
try
match Concrete_parser.tree Concrete_lexer.(token (init_state ())) lexbuf with
| [node] -> Lwt.return (Script_located_ir.strip_locations node)
| _ -> cctxt.Client_commands.error "single type expression expected"
| [node] -> return (Script_located_ir.strip_locations node)
| _ -> failwith "single type expression expected"
with
| exn -> report_parse_error cctxt "data_type: " exn lexbuf
| exn -> report_parse_error "data_type: " exn lexbuf
let unexpand_macros type_map (program : Script.code) =
let open Script in
@ -513,9 +513,7 @@ let unexpand_macros type_map (program : Script.code) =
module Program = Client_aliases.Alias (struct
type t = Script.code
let encoding = Script.code_encoding
let of_source cctxt s =
parse_program cctxt s >>= fun code ->
return code
let of_source _cctxt s = parse_program s
let to_source _ p =
return (Format.asprintf "%a" (print_program no_locations) (p, []))
let name = "program"
@ -573,9 +571,11 @@ let commands () =
(prefixes [ "run" ; "program" ]
@@ Program.source_param
@@ prefixes [ "on" ; "storage" ]
@@ Cli_entries.param ~name:"storage" ~desc:"the storage data" parse_data
@@ Cli_entries.param ~name:"storage" ~desc:"the storage data"
(fun _cctxt data -> parse_data data)
@@ prefixes [ "and" ; "input" ]
@@ Cli_entries.param ~name:"storage" ~desc:"the input data" parse_data
@@ Cli_entries.param ~name:"storage" ~desc:"the input data"
(fun _cctxt data -> parse_data data)
@@ stop)
(fun program storage input cctxt ->
let open Data_encoding in
@ -632,43 +632,44 @@ let commands () =
else return ()
| Error errs ->
report_typechecking_errors cctxt errs >>= fun () ->
cctxt.error "ill-typed program") ;
failwith "ill-typed program") ;
command ~group ~desc: "ask the node to typecheck a data expression"
(prefixes [ "typecheck" ; "data" ]
@@ Cli_entries.param ~name:"data" ~desc:"the data to typecheck" parse_data
@@ Cli_entries.param ~name:"data" ~desc:"the data to typecheck"
(fun _cctxt data -> parse_data data)
@@ prefixes [ "against" ; "type" ]
@@ Cli_entries.param ~name:"type" ~desc:"the expected type" parse_data
@@ Cli_entries.param ~name:"type" ~desc:"the expected type"
(fun _cctxt data -> parse_data data)
@@ stop)
(fun data exp_ty cctxt ->
let open Data_encoding in
Client_proto_rpcs.Helpers.typecheck_data cctxt.rpc_config
Client_proto_rpcs.Helpers.typecheck_data cctxt.Client_commands.rpc_config
cctxt.config.block (data, exp_ty) >>= function
| Ok () ->
cctxt.message "Well typed" >>= fun () ->
return ()
| Error errs ->
report_typechecking_errors cctxt errs >>= fun () ->
cctxt.error "ill-typed data" >>= fun () ->
return ()) ;
failwith "ill-typed data") ;
command ~group
~desc: "ask the node to compute the hash of a data expression \
using the same algorithm as script instruction H"
(prefixes [ "hash" ; "data" ]
@@ Cli_entries.param ~name:"data" ~desc:"the data to hash" parse_data
@@ Cli_entries.param ~name:"data" ~desc:"the data to hash"
(fun _cctxt data -> parse_data data)
@@ stop)
(fun data cctxt ->
let open Data_encoding in
Client_proto_rpcs.Helpers.hash_data cctxt.rpc_config
Client_proto_rpcs.Helpers.hash_data cctxt.Client_commands.rpc_config
cctxt.config.block data >>= function
| Ok hash ->
cctxt.message "%S" hash >>= fun () ->
return ()
| Error errs ->
cctxt.warning "%a" pp_print_error errs >>= fun () ->
cctxt.error "ill-formed data" >>= fun () ->
return ()) ;
failwith "ill-formed data") ;
command ~group
~desc: "ask the node to compute the hash of a data expression \
@ -676,7 +677,8 @@ let commands () =
a given secret key, and display it using the format expected by \
script instruction CHECK_SIGNATURE"
(prefixes [ "hash" ; "and" ; "sign" ; "data" ]
@@ Cli_entries.param ~name:"data" ~desc:"the data to hash" parse_data
@@ Cli_entries.param ~name:"data" ~desc:"the data to hash"
(fun _cctxt data -> parse_data data)
@@ prefixes [ "for" ]
@@ Client_keys.Secret_key.alias_param
@@ stop)
@ -694,7 +696,6 @@ let commands () =
return ()
| Error errs ->
cctxt.warning "%a" pp_print_error errs >>= fun () ->
cctxt.error "ill-formed data" >>= fun () ->
return ()) ;
failwith "ill-formed data") ;
]

12
src/client/embedded/alpha/client_proto_programs.mli
View File

@ -7,15 +7,9 @@
(* *)
(**************************************************************************)
val parse_program:
Client_commands.context ->
string -> Script.code Lwt.t
val parse_data:
Client_commands.context ->
string -> Script.expr Lwt.t
val parse_data_type:
Client_commands.context ->
string -> Script.expr Lwt.t
val parse_program: string -> Script.code tzresult Lwt.t
val parse_data: string -> Script.expr tzresult Lwt.t
val parse_data_type: string -> Script.expr tzresult Lwt.t
module Program : Client_aliases.Alias with type t = Script.code

19
src/client/embedded/genesis/client_proto_main.ml
View File

@ -56,12 +56,13 @@ let commands () =
command ~args ~desc: "Activate a protocol" begin
prefixes [ "activate" ; "protocol" ] @@
param ~name:"version" ~desc:"Protocol version (b58check)"
(fun _ p -> Lwt.return @@ Protocol_hash.of_b58check_exn p) @@
Protocol_hash.param ~name:"version" ~desc:"Protocol version (b58check)" @@
prefixes [ "with" ; "fitness" ] @@
param ~name:"fitness"
~desc:"Hardcoded fitness of the first block (integer)"
(fun _ p -> Lwt.return (Int64.of_string p)) @@
(fun _ p ->
try return (Int64.of_string p)
with _ -> failwith "Cannot read int64") @@
prefixes [ "and" ; "key" ] @@
Client_keys.Secret_key.source_param
~name:"password" ~desc:"Dictator's key" @@
@ -76,16 +77,16 @@ let commands () =
command ~args ~desc: "Fork a test protocol" begin
prefixes [ "fork" ; "test" ; "protocol" ] @@
param ~name:"version" ~desc:"Protocol version (b58check)"
(fun _ p -> Lwt.return (Protocol_hash.of_b58check_exn p)) @@
Protocol_hash.param ~name:"version" ~desc:"Protocol version (b58check)" @@
prefixes [ "with" ; "fitness" ] @@
param ~name:"fitness"
~desc:"Hardcoded fitness of the first block (integer)"
(fun _ p -> Lwt.return (Int64.of_string p)) @@
(fun _ p ->
try return (Int64.of_string p)
with _ -> failwith "Cannot read int64") @@
prefixes [ "and" ; "key" ] @@
param ~name:"password" ~desc:"Dictator's key"
(fun _ key ->
Lwt.return (Environment.Ed25519.Secret_key.of_b58check_exn key)) @@
Environment.Ed25519.Secret_key.param
~name:"password" ~desc:"Dictator's key" @@
stop
end begin fun hash fitness seckey cctxt ->
let timestamp = !timestamp in

20
src/client_main.ml
View File

@ -85,6 +85,15 @@ let main () =
command (cctxt config rpc_config) >>= function
| Ok () ->
Lwt.return 0
| Error [Cli_entries.Command_not_found] ->
Format.eprintf "Unknown command, try `-help`.@." ;
Lwt.return 1
| Error [Cli_entries.Bad_argument (idx, _n, v)] ->
Format.eprintf "There's a problem with argument %d, %s.@." idx v ;
Lwt.return 1
| Error [Cli_entries.Command_failed message] ->
Format.eprintf "Command failed, %s.@." message ;
Lwt.return 1
| Error err ->
Format.eprintf "Error: %a@." pp_print_error err ;
Lwt.return 1
@ -95,18 +104,9 @@ let main () =
| Arg.Bad help ->
Format.eprintf "%s%!" help ;
Lwt.return 1
| Cli_entries.Command_not_found ->
Format.eprintf "Unknown command, try `-help`.@." ;
Lwt.return 1
| Client_commands.Version_not_found ->
| Client_commands.Version_not_found ->
Format.eprintf "Unknown protocol version, try `list versions`.@." ;
Lwt.return 1
| Cli_entries.Bad_argument (idx, _n, v) ->
Format.eprintf "There's a problem with argument %d, %s.@." idx v ;
Lwt.return 1
| Cli_entries.Command_failed message ->
Format.eprintf "Command failed, %s.@." message ;
Lwt.return 1
| Failure message ->
Format.eprintf "Fatal error: %s@." message ;
Lwt.return 1

9
src/node/updater/environment.ml
View File

@ -58,6 +58,9 @@ module Ed25519 = struct
let of_bytes s = Sodium.Sign.Bytes.to_public_key s
let param ?(name="ed25519-public") ?(desc="Ed25519 public key (b58check-encoded)") t =
Cli_entries.param ~name ~desc (fun _ str -> Lwt.return (of_b58check str)) t
let () =
Base58.check_encoded_prefix b58check_encoding "edpk" 54
@ -117,6 +120,9 @@ module Ed25519 = struct
let of_bytes s = Sodium.Sign.Bytes.to_secret_key s
let param ?(name="ed25519-secret") ?(desc="Ed25519 secret key (b58check-encoded)") t =
Cli_entries.param ~name ~desc (fun _ str -> Lwt.return (of_b58check str)) t
let () =
Base58.check_encoded_prefix b58check_encoding "edsk" 98
@ -173,6 +179,9 @@ module Ed25519 = struct
let of_bytes s = MBytes.of_string (Bytes.to_string s)
let param ?(name="signature") ?(desc="Signature (b58check-encoded)") t =
Cli_entries.param ~name ~desc (fun _ str -> Lwt.return (of_b58check str)) t
let () =
Base58.check_encoded_prefix b58check_encoding "edsig" 99

46
src/utils/cli_entries.ml
View File

@ -9,12 +9,14 @@
(* Tezos Command line interface - Command Line Parsing *)
open Error_monad
open Lwt.Infix
(* User catchable exceptions *)
exception Command_not_found
exception Bad_argument of int * string * string
exception Command_failed of string
type error += Command_not_found
type error += Bad_argument of int * string * string
type error += Command_failed of string
(* A simple structure for command interpreters.
This is more generic than the exported one, see end of file. *)
@ -22,16 +24,16 @@ type ('a, 'arg, 'ret) params =
| Prefix : string * ('a, 'arg, 'ret) params ->
('a, 'arg, 'ret) params
| Param : string * string *
('arg -> string -> 'p Lwt.t) *
('arg -> string -> 'p tzresult Lwt.t) *
('a, 'arg, 'ret) params ->
('p -> 'a, 'arg, 'ret) params
| Stop :
('arg -> 'ret Lwt.t, 'arg, 'ret) params
('arg -> 'ret tzresult Lwt.t, 'arg, 'ret) params
| More :
(string list -> 'arg -> 'ret Lwt.t, 'arg, 'ret) params
(string list -> 'arg -> 'ret tzresult Lwt.t, 'arg, 'ret) params
| Seq : string * string *
('arg -> string -> 'p Lwt.t) ->
('p list -> 'arg -> 'ret Lwt.t, 'arg, 'ret) params
('arg -> string -> 'p tzresult Lwt.t) ->
('p list -> 'arg -> 'ret tzresult Lwt.t, 'arg, 'ret) params
(* A command group *)
type group =
@ -70,29 +72,29 @@ let command ?group ?(args = []) ~desc params handler =
(* Param combinators *)
let string ~name ~desc next =
param name desc (fun _ s -> Lwt.return s) next
param name desc (fun _ s -> return s) next
(* Command execution *)
let exec
(type arg) (type ret)
(Command { params ; handler }) (last : arg) args =
let rec exec
: type a. int -> (a, arg, ret) params -> a -> string list -> ret Lwt.t
: type a. int -> (a, arg, ret) params -> a -> string list -> ret tzresult Lwt.t
= fun i params cb args ->
match params, args with
| Stop, [] -> cb last
| Stop, _ -> Lwt.fail Command_not_found
| Stop, _ -> fail Command_not_found
| Seq (_, _, f), seq ->
let rec do_seq i acc = function
| [] -> Lwt.return (List.rev acc)
| [] -> return (List.rev acc)
| p :: rest ->
Lwt.catch
(fun () -> f last p)
(function
| Failure msg -> Lwt.fail (Bad_argument (i, p, msg))
| exn -> Lwt.fail exn) >>= fun v ->
| Failure msg -> fail (Bad_argument (i, p, msg))
| exn -> fail (Exn exn)) >>=? fun v ->
do_seq (succ i) (v :: acc) rest in
do_seq i [] seq >>= fun parsed ->
do_seq i [] seq >>=? fun parsed ->
cb parsed last
| More, rest -> cb rest last
| Prefix (n, next), p :: rest when n = p ->
@ -101,10 +103,10 @@ let exec
Lwt.catch
(fun () -> f last p)
(function
| Failure msg -> Lwt.fail (Bad_argument (i, p, msg))
| exn -> Lwt.fail exn) >>= fun v ->
| Failure msg -> fail (Bad_argument (i, p, msg))
| exn -> fail (Exn exn)) >>=? fun v ->
exec (succ i) next (cb v) rest
| _ -> Lwt.fail Command_not_found
| _ -> fail Command_not_found
in exec 1 params handler args
(* Command dispatch tree *)
@ -168,10 +170,10 @@ let tree_dispatch tree last args =
begin try
let t = List.assoc n prefix in
loop (t, rest)
with Not_found -> Lwt.fail Command_not_found end
with Not_found -> fail Command_not_found end
| TParam { tree }, _ :: rest ->
loop (tree, rest)
| _, _ -> Lwt.fail Command_not_found
| _, _ -> fail Command_not_found
in
loop (tree, args)
@ -196,14 +198,14 @@ let inline_tree_dispatch tree () =
| TStop (Command { args })
| TMore (Command { args }) -> `Args args
| _ -> `Nop end
with Not_found -> `Fail Command_not_found end
with Not_found -> `Fail [Command_not_found] end
| (TParam { tree }, acc), `Arg n ->
state := (tree, n :: acc) ;
begin match tree with
| TStop (Command { args })
| TMore (Command { args }) -> `Args args
| _ -> `Nop end
| _, _ -> `Fail Command_not_found
| _, _ -> `Fail [Command_not_found]
(* Try a list of commands on a list of arguments *)
let dispatch commands =

30
src/utils/cli_entries.mli
View File

@ -7,12 +7,14 @@
(* *)
(**************************************************************************)
open Error_monad
(* Tezos: a small Command Line Parsing library *)
(* Only used in the client. *)
exception Command_not_found
exception Bad_argument of int * string * string
exception Command_failed of string
type error += Command_not_found
type error += Bad_argument of int * string * string
type error += Command_failed of string
type ('a, 'arg, 'ret) params
type ('arg, 'ret) command
@ -20,7 +22,7 @@ type ('arg, 'ret) command
val param:
name: string ->
desc: string ->
('arg -> string -> 'a Lwt.t) ->
('arg -> string -> 'a tzresult Lwt.t) ->
('b, 'arg, 'ret) params ->
('a -> 'b, 'arg, 'ret) params
val prefix:
@ -33,14 +35,14 @@ val prefixes:
('a, 'arg, 'ret) params
val fixed:
string list ->
('arg -> 'ret Lwt.t, 'arg, 'ret) params
('arg -> 'ret tzresult Lwt.t, 'arg, 'ret) params
val stop:
('arg -> 'ret Lwt.t, 'arg, 'ret) params
('arg -> 'ret tzresult Lwt.t, 'arg, 'ret) params
val seq:
name: string ->
desc: string ->
('arg -> string -> 'p Lwt.t) ->
('p list -> 'arg -> 'ret Lwt.t, 'arg, 'ret) params
('arg -> string -> 'p tzresult Lwt.t) ->
('p list -> 'arg -> 'ret tzresult Lwt.t, 'arg, 'ret) params
val string:
name: string ->
@ -49,9 +51,9 @@ val string:
(string -> 'a, 'arg, 'ret) params
val seq_of_param:
(('arg -> 'ret Lwt.t, 'arg, 'ret) params ->
('a -> 'arg -> 'ret Lwt.t, 'arg, 'ret) params) ->
('a list -> 'arg -> 'ret Lwt.t, 'arg, 'ret) params
(('arg -> 'ret tzresult Lwt.t, 'arg, 'ret) params ->
('a -> 'arg -> 'ret tzresult Lwt.t, 'arg, 'ret) params) ->
('a list -> 'arg -> 'ret tzresult Lwt.t, 'arg, 'ret) params
type group =
{ name : string ;
@ -71,9 +73,9 @@ val inline_dispatch:
('arg, 'ret) command list -> unit ->
[ `Arg of string | `End ] ->
[ `Args of (Arg.key * Arg.spec * Arg.doc) list
| `Fail of exn
| `Fail of error list
| `Nop
| `Res of 'arg -> 'ret Lwt.t ]
| `Res of 'arg -> 'ret tzresult Lwt.t ]
val dispatch:
('arg, 'ret) command list -> 'arg -> string list -> 'ret Lwt.t
('arg, 'ret) command list -> 'arg -> string list -> 'ret tzresult Lwt.t

8
src/utils/hash.ml
View File

@ -13,6 +13,7 @@ let (//) = Filename.concat
let (>>=) = Lwt.bind
let (>|=) = Lwt.(>|=)
open Error_monad
open Utils
let () =
@ -99,6 +100,11 @@ end
module type INTERNAL_HASH = sig
include HASH
val of_b58check: string -> t tzresult
val param:
?name:string ->
?desc:string ->
('a, 'arg, 'ret) Cli_entries.params ->
(t -> 'a, 'arg, 'ret) Cli_entries.params
module Table : Hashtbl.S with type key = t
end
@ -307,7 +313,7 @@ module Make_Blake2B (R : sig
conv to_b58check (Data_encoding.Json.wrap_error of_b58check_exn) string)
let param ?(name=K.name) ?(desc=K.title) t =
Cli_entries.param ~name ~desc (fun _ str -> Lwt.return (of_b58check_exn str)) t
Cli_entries.param ~name ~desc (fun _ str -> Lwt.return (of_b58check str)) t
let pp ppf t =
Format.pp_print_string ppf (to_b58check t)

14
src/utils/hash.mli
View File

@ -91,6 +91,11 @@ end
module type INTERNAL_HASH = sig
include HASH
val of_b58check: string -> t tzresult
val param:
?name:string ->
?desc:string ->
('a, 'arg, 'ret) Cli_entries.params ->
(t -> 'a, 'arg, 'ret) Cli_entries.params
module Table : Hashtbl.S with type key = t
end
@ -156,14 +161,7 @@ module Make_Blake2B
(** {2 Predefined Hashes } ****************************************************)
(** Blocks hashes / IDs. *)
module Block_hash : sig
include INTERNAL_HASH
val param :
?name:string ->
?desc:string ->
('a, 'arg, 'ret) Cli_entries.params ->
(t -> 'a, 'arg, 'ret) Cli_entries.params
end
module Block_hash : INTERNAL_HASH
(** Operations hashes / IDs. *)
module Operation_hash : INTERNAL_HASH