From 83f2e0dcd32d9848b9f06eb3aa3ac9635f272592 Mon Sep 17 00:00:00 2001 From: Guillem Rieu Date: Wed, 15 Mar 2017 01:17:20 +0100 Subject: [PATCH] Client: switch to JSON config file and remove config-file dependency. --- src/.merlin | 1 - src/Makefile | 1 - src/client/client_aliases.ml | 19 +- src/client/client_commands.ml | 50 ++- src/client/client_commands.mli | 35 +- src/client/client_config.ml | 357 +++++++++--------- src/client/client_helpers.ml | 2 +- src/client/client_keys.ml | 5 +- src/client/client_node_rpcs.ml | 14 +- src/client/embedded/Makefile.shared | 4 +- .../alpha/baker/client_mining_endorsement.ml | 10 +- .../alpha/baker/client_mining_forge.ml | 22 +- .../alpha/baker/client_mining_main.ml | 13 +- .../embedded/alpha/client_proto_args.ml | 2 - .../embedded/alpha/client_proto_args.mli | 2 - .../embedded/alpha/client_proto_context.ml | 38 +- .../embedded/alpha/client_proto_contracts.ml | 3 +- .../embedded/alpha/client_proto_nonces.ml | 10 +- .../embedded/alpha/client_proto_programs.ml | 12 +- src/client/embedded/demo/client_proto_main.ml | 4 +- .../embedded/genesis/client_proto_main.ml | 8 +- src/client_main.ml | 20 +- src/node/shell/node_rpc_services.ml | 19 +- src/node/shell/node_rpc_services.mli | 2 + src/tezos-deps.opam | 2 - src/utils/cli_entries.ml | 10 +- src/webclient_main.ml | 27 +- test/Makefile | 1 - 28 files changed, 390 insertions(+), 303 deletions(-) diff --git a/src/.merlin b/src/.merlin index 52938da1d..f85696440 100644 --- a/src/.merlin +++ b/src/.merlin @@ -29,7 +29,6 @@ PKG cmdliner PKG cohttp PKG compiler-libs.optcomp PKG conduit -PKG config-file PKG cstruct PKG dynlink PKG ezjsonm diff --git a/src/Makefile b/src/Makefile index 73f68c1b7..71327c60c 100644 --- a/src/Makefile +++ b/src/Makefile @@ -290,7 +290,6 @@ COMPILER_IMPLS := \ COMPILER_PACKAGES := \ ${UTILS_PACKAGES} \ compiler-libs.optcomp \ - config-file \ lwt.unix \ ocplib-endian \ ocplib-ocamlres \ diff --git a/src/client/client_aliases.ml b/src/client/client_aliases.ml index b4899d5de..13a142439 100644 --- a/src/client/client_aliases.ml +++ b/src/client/client_aliases.ml @@ -75,17 +75,22 @@ end module Alias = functor (Entity : Entity) -> struct + open Client_commands + let encoding = let open Data_encoding in list (obj2 (req "name" string) (req "value" Entity.encoding)) - let filename () = - Client_config.(base_dir#get // Entity.name ^ "s") + let dirname cctxt = + cctxt.config.base_dir + + let filename cctxt = + Filename.concat (dirname cctxt) (Entity.name ^ "s") let load cctxt = - let filename = filename () in + let filename = filename cctxt in if not (Sys.file_exists filename) then return [] else Data_encoding_ezjsonm.read_file filename >>= function | Error _ -> @@ -126,10 +131,10 @@ module Alias = functor (Entity : Entity) -> struct let save cctxt list = catch (fun () -> - let dirname = Client_config.base_dir#get in + let dirname = dirname cctxt in (if not (Sys.file_exists dirname) then Lwt_utils.create_dir dirname else return ()) >>= fun () -> - let filename = filename () in + let filename = filename cctxt in let json = Data_encoding.Json.construct encoding list in Data_encoding_ezjsonm.write_file filename json >>= function | Error _ -> fail (Failure "Json.write_file") @@ -142,7 +147,7 @@ module Alias = functor (Entity : Entity) -> struct let add cctxt name value = let keep = ref false in load cctxt >>= fun list -> - (if not Client_config.force#get then + (if not cctxt.config.force then Lwt_list.iter_s (fun (n, v) -> if n = name && v = value then (keep := true ; @@ -186,7 +191,7 @@ module Alias = functor (Entity : Entity) -> struct param ~name ~desc (fun cctxt s -> load cctxt >>= fun list -> - if not Client_config.force#get then + if not cctxt.config.force then Lwt_list.iter_s (fun (n, _v) -> if n = s then cctxt.Client_commands.error diff --git a/src/client/client_commands.ml b/src/client/client_commands.ml index 169bc881e..6ff258e32 100644 --- a/src/client/client_commands.ml +++ b/src/client/client_commands.ml @@ -10,8 +10,26 @@ type ('a, 'b) lwt_format = ('a, Format.formatter, unit, 'b Lwt.t) format4 +type cfg = { + (* cli options *) + base_dir : string ; + config_file : string ; + print_timings : bool ; + force : bool ; + block : Node_rpc_services.Blocks.block ; + + (* network options (cli and config file) *) + incoming_addr : string ; + incoming_port : int ; + tls : bool ; + + (* webclient options *) + web_port : int ; +} + type context = - { error : 'a 'b. ('a, 'b) lwt_format -> 'a ; + { config : cfg ; + error : 'a 'b. ('a, 'b) lwt_format -> 'a ; warning : 'a. ('a, unit) lwt_format -> 'a ; message : 'a. ('a, unit) lwt_format -> 'a ; answer : 'a. ('a, unit) lwt_format -> 'a ; @@ -19,7 +37,33 @@ type context = type command = (context, unit) Cli_entries.command -let make_context log = +(* Default config *) + +let (//) = Filename.concat + +let home = + try Sys.getenv "HOME" + with Not_found -> "/root" + +let default_base_dir = home // ".tezos-client" + +let default_cfg_of_base_dir base_dir = { + base_dir ; + config_file = base_dir // "config"; + print_timings = false ; + force = false ; + block = `Prevalidation ; + + incoming_addr = "127.0.0.1" ; + incoming_port = 8732 ; + tls = false ; + + web_port = 8080 ; +} + +let default_cfg = default_cfg_of_base_dir default_base_dir + +let make_context ?(config = default_cfg) log = let error fmt = Format.kasprintf (fun msg -> @@ -39,7 +83,7 @@ let make_context log = Format.kasprintf (fun msg -> log name msg) fmt in - { error ; warning ; message ; answer ; log } + { config ; error ; warning ; message ; answer ; log } let ignore_context = make_context (fun _ _ -> Lwt.return ()) diff --git a/src/client/client_commands.mli b/src/client/client_commands.mli index 7b0d7d845..e19c19d55 100644 --- a/src/client/client_commands.mli +++ b/src/client/client_commands.mli @@ -10,8 +10,26 @@ type ('a, 'b) lwt_format = ('a, Format.formatter, unit, 'b Lwt.t) format4 +type cfg = { + (* cli options *) + base_dir : string ; + config_file : string ; + print_timings : bool ; + force : bool ; + block : Node_rpc_services.Blocks.block ; + + (* network options (cli and config file) *) + incoming_addr : string ; + incoming_port : int ; + tls : bool ; + + (* webclient options *) + web_port : int ; +} + type context = - { error : 'a 'b. ('a, 'b) lwt_format -> 'a ; + { config : cfg ; + error : 'a 'b. ('a, 'b) lwt_format -> 'a ; warning : 'a. ('a, unit) lwt_format -> 'a ; message : 'a. ('a, unit) lwt_format -> 'a ; answer : 'a. ('a, unit) lwt_format -> 'a ; @@ -23,10 +41,17 @@ type context = handler when running a command, and must be transmitted to all basic operations, also making client commands reantrant. *) -val make_context : (string -> string -> unit Lwt.t) -> context -(** [make_context log_fun] builds a context whose logging callbacks - call [log_fun section msg], and whose [error] function calls - [Lwt.fail_with]. *) +val default_base_dir : string +val default_cfg_of_base_dir : string -> cfg +val default_cfg : cfg + +val make_context : + ?config:cfg -> + (string -> string -> unit Lwt.t) -> context +(** [make_context ?config log_fun] builds a context whose logging + callbacks call [log_fun section msg], and whose [error] function + fails with [Failure] and the given message. If not passed, + [config] is {!default_cfg}. *) val ignore_context : context (** [ignore_context] is a context whose logging callbacks do nothing, diff --git a/src/client/client_config.ml b/src/client/client_config.ml index ead1acfa0..9fe141455 100644 --- a/src/client/client_config.ml +++ b/src/client/client_config.ml @@ -9,161 +9,41 @@ (* Tezos Command line interface - Configuration and Arguments Parsing *) -open Config_file +open Client_commands -let (//) = Filename.concat +module Cfg_file = struct + open Data_encoding -let home = - try Sys.getenv "HOME" - with Not_found -> "/root" + let encoding = + conv + (fun { incoming_addr ; incoming_port ; tls ; web_port } -> + (Some incoming_addr, Some incoming_port, Some tls, Some web_port)) + (fun (incoming_addr, incoming_port, tls, web_port) -> + let open Utils in + let incoming_addr = unopt ~default:default_cfg.incoming_addr incoming_addr in + let incoming_port = unopt ~default:default_cfg.incoming_port incoming_port in + let tls = unopt ~default:default_cfg.tls tls in + let web_port = unopt ~default:default_cfg.web_port web_port in + { default_cfg with + incoming_addr ; incoming_port ; tls ; web_port }) + (obj4 + (opt "incoming_addr" string) + (opt "incoming_port" int16) + (opt "tls" bool) + (opt "web_port" int16)) -class string_option_cp ?group name ?short_name default help = - object (self) - inherit [string] option_cp - string_wrappers ?group name ?short_name default help - method get_spec = - let set = function - | "" - | "none" -> self#set None | s -> self#set (Some s) in - Arg.String set - end + let from_json json = + Data_encoding.Json.destruct encoding json -let file_group = new group + let read fp = + Data_encoding_ezjsonm.read_file fp >>=? fun json -> + return (from_json json) -(* Command line options *) - -let cli_group = new group - -let base_dir = - new filename_cp ~group:cli_group ["base-dir"] (home // ".tezos-client") - "The directory where the Tezos client will store all its data." - -let config_file = - new filename_cp ~group:cli_group ["config-file"] (base_dir#get // "config") - "The main configuration file." - -let print_timings = - new bool_cp ~group:cli_group ["timings"] false - "Show RPC request times." - -let force = - new bool_cp ~group:cli_group ["force"] false - "Show less courtesy than the average user." - -let block = - new string_cp ~group:cli_group ["block"] "prevalidation" - "The block on which to apply contextual commands." - -let block () = - match Node_rpc_services.Blocks.parse_block block#get with - | Ok s -> s - | Error _ -> raise (Arg.Bad "Can't parse -block") - -let () = - let config_file_forced = ref false in - let update_config _old_file _new_file = config_file_forced := true in - let update_base_dir old_dir new_dir = - if new_dir <> old_dir then - if not !config_file_forced then begin - config_file#set (new_dir // "config"); - config_file_forced := false - end - in - config_file#add_hook update_config; - base_dir#add_hook update_base_dir - -(** Network options *) - -let in_both_groups cp = - file_group # add cp ; cli_group # add cp ; cp - -let incoming_addr = in_both_groups @@ - new string_cp [ "addr" ] ~short_name:"A" "127.0.0.1" - "The IP address at which the node's RPC server can be reached." - -let incoming_port = in_both_groups @@ - new int_cp [ "port" ] ~short_name:"P" 8732 - "The TCP port at which the node's RPC server can be reached." - -let tls = in_both_groups @@ - new bool_cp [ "tls" ] false - "Use TLS to connect to node." - -(* Version specific options *) - -let contextual_options : (unit -> unit) ref Protocol_hash.Table.t = - Protocol_hash.Table.create 7 - -let register_config_option version option = - let callback () = - file_group # add option ; - cli_group # add option in - try - let cont = Protocol_hash.Table.find contextual_options version in - cont := fun () -> callback () ; !cont () - with Not_found -> - Protocol_hash.Table.add contextual_options version (ref callback) - -(* Entry point *) - -let parse_args ?version usage dispatcher argv cctxt = - let open Lwt in - catch - (fun () -> - let args = ref (cli_group#command_line_args "-") in - begin match version with - | None -> () - | Some version -> - try - !(Protocol_hash.Table.find contextual_options version) () - with Not_found -> () end ; - let anon dispatch n = match dispatch (`Arg n) with - | `Nop -> () - | `Args nargs -> args := nargs @ !args - | `Fail exn -> raise exn - | `Res _ -> assert false in - Arg.parse_argv_dynamic - ~current:(ref 0) argv args (anon (dispatcher ())) "\000" ; - let dispatch = dispatcher () in - (if Sys.file_exists config_file#get then begin - try - file_group#read config_file#get ; - (* parse once again to overwrite file options by cli ones *) - Arg.parse_argv_dynamic - ~current:(ref 0) argv args (anon dispatch) "\000" ; - Lwt.return () - with Sys_error msg -> - cctxt.Client_commands.error - "Error: can't read the configuration file: %s\n%!" msg - end else begin - try - (* parse once again with contextual options *) - Arg.parse_argv_dynamic - ~current:(ref 0) argv args (anon dispatch) "\000" ; - Lwt_utils.create_dir (Filename.dirname config_file#get) >>= fun () -> - file_group#write config_file#get ; - Lwt.return () - with Sys_error msg -> - cctxt.Client_commands.warning - "Warning: can't create the default configuration file: %s\n%!" msg - end) >>= fun () -> - begin match dispatch `End with - | `Res res -> Lwt.return res - | `Fail exn -> fail exn - | `Nop | `Args _ -> assert false - end) - (function - | Arg.Bad msg -> - (* FIXME: this is an ugly hack to circumvent [Arg] - spuriously printing options at the end of the error - message. *) - let args = cli_group#command_line_args "-" in - let msg = List.hd (Utils.split '\000' msg) in - Lwt.fail (Arg.Help (msg ^ usage args ^ "\n")) - | Arg.Help _ -> - let args = cli_group#command_line_args "-" in - Lwt.fail (Arg.Help (usage args ^ "\n")) - | exn -> Lwt.fail exn) + let write out cfg = + Utils.write_file ~bin:false out + (Data_encoding.Json.construct encoding cfg |> + Data_encoding_ezjsonm.to_string) +end exception Found of string let preparse name argv = @@ -175,52 +55,173 @@ let preparse name argv = None with Found s -> Some s -let preparse_args argv cctxt : Node_rpc_services.Blocks.block Lwt.t = - begin +(* Entry point *) + +let parse_args ?(extra = (fun _cfg -> [])) usage dispatcher argv cctxt = + let open Lwt in + (* Init config reference which will be updated as args are parsed *) + let cfg = ref cctxt.Client_commands.config in + let set_block x = + match Node_rpc_services.Blocks.parse_block x with + | Error _ -> raise (Arg.Bad "Can't parse -block") + | Ok block -> cfg := { !cfg with block } + in + (* Command-line only args (not in config file) *) + let cli_args = [ + "-base-dir", Arg.String (fun x -> cfg := { !cfg with base_dir = x }), + "The directory where the Tezos client will store all its data.\n\ + default: " ^ Client_commands.(default_cfg.base_dir); + "-config-file", Arg.String (fun x -> cfg := { !cfg with config_file = x }), + "The main configuration file.\n\ + default: " ^ Client_commands.(default_cfg.config_file); + "-timings", Arg.Bool (fun x -> cfg := { !cfg with print_timings = x }), + "Show RPC request times.\n\ + default: " ^ string_of_bool Client_commands.(default_cfg.print_timings); + "-force", Arg.Bool (fun x -> cfg := { !cfg with force = x }), + "Show less courtesy than the average user.\n\ + default: " ^ string_of_bool Client_commands.(default_cfg.force); + "-block", Arg.String set_block, + "The block on which to apply contextual commands.\n\ + default: " ^ Node_rpc_services.Blocks.to_string Client_commands.(default_cfg.block); + ] in + (* Command-line args which can be set in config file as well *) + let file_args = [ + (* Network options *) + "-addr", Arg.String (fun x -> cfg := { !cfg with incoming_addr = x }), + "The IP address at which the node's RPC server can be reached.\n\ + default: " ^ Client_commands.(default_cfg.incoming_addr); + "-port", Arg.Int (fun x -> cfg := { !cfg with incoming_port = x }), + "The TCP port at which the node's RPC server can be reached.\n\ + default: " ^ string_of_int Client_commands.(default_cfg.incoming_port); + "-tls", Arg.Bool (fun x -> cfg := { !cfg with tls = x }), + "Use TLS to connect to node.\n\ + default: " ^ string_of_bool Client_commands.(default_cfg.tls); + ] in + let all_args = cli_args @ file_args @ (extra cfg) in + catch + (fun () -> + let args = ref all_args in + let anon dispatch n = match dispatch (`Arg n) with + | `Nop -> () + | `Args nargs -> args := nargs @ !args + | `Fail exn -> raise exn + | `Res _ -> assert false in + Arg.parse_argv_dynamic + ~current:(ref 0) argv args (anon (dispatcher ())) "\000" ; + let dispatch = dispatcher () in + (if Sys.file_exists !cfg.config_file then begin + try + (* Parse config file and init [cfg] with options defined in it *) + let config_file = !cfg.config_file in + Cfg_file.read config_file >>= begin function + | Error _err -> + cctxt.Client_commands.error + "Error: can't parse the configuration file: %s\n%!" + config_file + | Ok c -> + cfg := c ; + Lwt.return () + end >>= fun () -> + (* parse once again to overwrite file options by cli ones *) + Arg.parse_argv_dynamic + ~current:(ref 0) argv args (anon dispatch) "\000" ; + Lwt.return () + with Sys_error msg -> + cctxt.Client_commands.error + "Error: can't read the configuration file: %s\n%!" msg + end else begin + try + (* parse once again with contextual options *) + Arg.parse_argv_dynamic + ~current:(ref 0) argv args (anon dispatch) "\000" ; + Lwt_utils.create_dir (Filename.dirname !cfg.config_file) + >>= fun () -> + Cfg_file.write !cfg.config_file !cfg ; + Lwt.return () + with Sys_error msg -> + cctxt.Client_commands.warning + "Warning: can't create the default configuration file: %s\n%!" + msg + end) >>= fun () -> + begin match dispatch `End with + | `Res res -> Lwt.return (res, !cfg) + | `Fail exn -> fail exn + | `Nop | `Args _ -> assert false + end) + (function + | Arg.Bad msg -> + (* FIXME: this is an ugly hack to circumvent [Arg] + spuriously printing options at the end of the error + message. *) + let msg = List.hd (Utils.split '\000' msg) in + Lwt.fail (Arg.Help (msg ^ usage all_args ^ "\n")) + | Arg.Help _ -> + Lwt.fail (Arg.Help (usage all_args ^ "\n")) + | exn -> Lwt.fail exn) + +let preparse_args argv cctxt : cfg Lwt.t = + let cfg = match preparse "-base-dir" argv with - | None -> () - | Some dir -> base_dir#set dir - end ; - begin + | None -> default_cfg + | Some base_dir -> default_cfg_of_base_dir base_dir + in + let cfg = match preparse "-config-file" argv with - | None -> config_file#set @@ base_dir#get // "config" - | Some file -> config_file#set file - end ; + | None -> cfg + | Some config_file -> { cfg with config_file } + in + let no_config () = + cctxt.Client_commands.warning + "Warning: config file not found\n%!" in + let corrupted_config msg = + cctxt.Client_commands.error + "Error: can't parse the configuration file: %s\n%s\n%!" + cfg.config_file msg in begin - if Sys.file_exists config_file#get then try - (file_group#read config_file#get ; - Lwt.return ()) + if Sys.file_exists cfg.config_file then try + match + Utils.read_file ~bin:false cfg.config_file + |> Data_encoding_ezjsonm.from_string + with + | exception _ -> + no_config () >>= fun () -> + Lwt.return cfg + | Error msg -> corrupted_config msg + | Ok cfg_json -> + try Lwt.return (Cfg_file.from_json cfg_json) with + | Invalid_argument msg + | Failure msg -> corrupted_config msg with Sys_error msg -> cctxt.Client_commands.error "Error: can't read the configuration file: %s\n%!" msg - else Lwt.return () - end >>= fun () -> - begin + else Lwt.return cfg + end >>= fun cfg -> + let cfg = match preparse "-tls" argv with - | None -> () - | Some _ -> tls#set true - end ; - begin + | None -> cfg + | Some _ -> { cfg with tls = true } + in + let cfg = match preparse "-addr" argv with - | None -> () - | Some addr -> incoming_addr#set addr - end ; + | None -> cfg + | Some incoming_addr -> { cfg with incoming_addr } + in begin match preparse "-port" argv with - | None -> Lwt.return () + | None -> Lwt.return cfg | Some port -> try - incoming_port#set (int_of_string port) ; - Lwt.return () + let incoming_port = int_of_string port in + Lwt.return { cfg with incoming_port } with _ -> cctxt.Client_commands.error "Error: can't parse the -port option: %S.\n%!" port - end >>= fun () -> + end >>= fun cfg -> match preparse "-block" Sys.argv with - | None -> Lwt.return `Prevalidation + | None -> Lwt.return cfg | Some x -> match Node_rpc_services.Blocks.parse_block x with | Error _ -> cctxt.Client_commands.error "Error: can't parse the -block option: %S.\n%!" x - | Ok b -> Lwt.return b + | Ok block -> Lwt.return { cfg with block } diff --git a/src/client/client_helpers.ml b/src/client/client_helpers.ml index 444cae07e..923b56d54 100644 --- a/src/client/client_helpers.ml +++ b/src/client/client_helpers.ml @@ -28,7 +28,7 @@ let commands () = Cli_entries.[ ~desc: "the prefix of the Base58Check-encoded hash to be completed" @@ stop) (fun prefix cctxt -> - Client_node_rpcs.complete cctxt ~block:(block ()) prefix >>= fun completions -> + Client_node_rpcs.complete cctxt ~block:cctxt.config.block prefix >>= fun completions -> match completions with | [] -> Pervasives.exit 3 | _ :: _ :: _ when !unique -> Pervasives.exit 3 diff --git a/src/client/client_keys.ml b/src/client/client_keys.ml index 622a0fb64..9b34a514c 100644 --- a/src/client/client_keys.ml +++ b/src/client/client_keys.ml @@ -104,6 +104,7 @@ let group = let commands () = let open Cli_entries in + let open Client_commands in [ command ~group ~desc: "generate a pair of keys" (prefixes [ "gen" ; "keys" ] @@ Secret_key.fresh_alias_param @@ -117,7 +118,7 @@ let commands () = (fun name sk cctxt -> Lwt.catch (fun () -> Public_key.find cctxt name >>= fun pk -> - if check_keys_consistency pk sk || Client_config.force#get then + if check_keys_consistency pk sk || cctxt.config.force then Secret_key.add cctxt name sk else cctxt.error @@ -156,7 +157,7 @@ let commands () = command ~group ~desc: "forget all keys" (fixed [ "forget" ; "all" ; "keys" ]) (fun cctxt -> - if not Client_config.force#get then + if not cctxt.config.force then cctxt.Client_commands.error "this can only used with option -force true" else Public_key.save cctxt [] >>= fun () -> diff --git a/src/client/client_node_rpcs.ml b/src/client/client_node_rpcs.ml index 6a5e74556..c9a9bf36f 100644 --- a/src/client/client_node_rpcs.ml +++ b/src/client/client_node_rpcs.ml @@ -24,9 +24,9 @@ let cpt = ref 0 let make_request cctxt meth service json = incr cpt ; let cpt = !cpt in - let scheme = if Client_config.tls#get then "https" else "http" in - let host = Client_config.incoming_addr#get in - let port = Client_config.incoming_port#get in + let scheme = if cctxt.config.tls then "https" else "http" in + let host = cctxt.config.incoming_addr in + let port = cctxt.config.incoming_port in let path = String.concat "/" service in let uri = Uri.make ~scheme ~host ~port ~path () in let string_uri = Uri.to_string uri in @@ -50,7 +50,7 @@ let get_streamed_json cctxt meth 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 cctxt.config.print_timings then cctxt.message "Request to /%s succeeded in %gs" (String.concat "/" service) time else Lwt.return ()) >>= fun () -> @@ -64,7 +64,7 @@ let get_streamed_json cctxt meth service json = Lwt.return None) (Data_encoding_ezjsonm.from_stream ansbody)) | err, _ansbody -> - (if Client_config.print_timings#get then + (if cctxt.config.print_timings then cctxt.message "Request to /%s failed in %gs" (String.concat "/" service) time else Lwt.return ()) >>= fun () -> @@ -78,7 +78,7 @@ let get_json cctxt meth 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 cctxt.config.print_timings then cctxt.message "Request to /%s succeeded in %gs" (String.concat "/" service) time else Lwt.return ()) >>= fun () -> @@ -89,7 +89,7 @@ let get_json cctxt meth service json = | Ok res -> Lwt.return res end | err, _ansbody -> - (if Client_config.print_timings#get then + (if cctxt.config.print_timings then cctxt.message "Request to /%s failed in %gs" (String.concat "/" service) time else Lwt.return ()) >>= fun () -> diff --git a/src/client/embedded/Makefile.shared b/src/client/embedded/Makefile.shared index 5efe00ddb..e10d808f0 100644 --- a/src/client/embedded/Makefile.shared +++ b/src/client/embedded/Makefile.shared @@ -37,7 +37,7 @@ ${OBJS} ${OBJS_DEPS}: TARGET="(client_$(PROTO_VERSION).cmx)" ${OBJS}: EXTRA_OCAMLFLAGS = -for-pack Client_$(PROTO_VERSION) ../client_$(PROTO_VERSION).cmx: EXTRA_OCAMLFLAGS = ${OBJS} ${OBJS_DEPS} ../client_$(PROTO_VERSION).cmx: \ - PACKAGES=lwt ocplib-json-typed config-file sodium ocplib-ocamlres + PACKAGES=lwt ocplib-json-typed sodium ocplib-ocamlres ${OBJS} ${OBJS_DEPS} ../client_$(PROTO_VERSION).cmx: \ ../../../proto/client_embedded_proto_${PROTO_VERSION}.cmxa @@ -52,7 +52,7 @@ ${WEBOBJS} ${WEBOBJS_DEPS}: OPENED_MODULES += Client_${PROTO_VERSION} ${WEBOBJS}: EXTRA_OCAMLFLAGS = -for-pack Webclient_$(PROTO_VERSION) ../client_$(PROTO_VERSION).cmx: EXTRA_OCAMLFLAGS = ${WEBOBJS} ${WEBOBJS_DEPS} ../webclient_$(PROTO_VERSION).cmx: \ - PACKAGES=lwt ocplib-json-typed config-file sodium ocplib-ocamlres + PACKAGES=lwt ocplib-json-typed sodium ocplib-ocamlres ${WEBOBJS} ${WEBOBJS_DEPS} ../webclient_$(PROTO_VERSION).cmx: \ ../../../proto/client_embedded_proto_${PROTO_VERSION}.cmxa ${WEBOBJS} ../webclient_$(PROTO_VERSION).cmx: \ diff --git a/src/client/embedded/alpha/baker/client_mining_endorsement.ml b/src/client/embedded/alpha/baker/client_mining_endorsement.ml index 5814a5865..5f580858f 100644 --- a/src/client/embedded/alpha/baker/client_mining_endorsement.ml +++ b/src/client/embedded/alpha/baker/client_mining_endorsement.ml @@ -47,11 +47,11 @@ end = struct (req "block" Block_hash.encoding) (req "operation" Operation_hash.encoding)))))) - let filename () = - Client_config.(base_dir#get // "endorsements") + let filename cctxt = + Client_commands.(Filename.concat cctxt.config.base_dir "endorsements") let load cctxt = - let filename = filename () in + let filename = filename cctxt in if not (Sys.file_exists filename) then return LevelMap.empty else Data_encoding_ezjsonm.read_file filename >>= function | Error _ -> @@ -68,10 +68,10 @@ end = struct let save cctxt map = Lwt.catch (fun () -> - let dirname = Client_config.base_dir#get in + let dirname = Client_commands.(cctxt.config.base_dir) in (if not (Sys.file_exists dirname) then Lwt_utils.create_dir dirname else Lwt.return ()) >>= fun () -> - let filename = filename () in + let filename = filename cctxt in let json = Data_encoding.Json.construct encoding map in Data_encoding_ezjsonm.write_file filename json >>= function | Error _ -> failwith "Json.write_file" diff --git a/src/client/embedded/alpha/baker/client_mining_forge.ml b/src/client/embedded/alpha/baker/client_mining_forge.ml index ba34b4ed4..1ea1d87c6 100644 --- a/src/client/embedded/alpha/baker/client_mining_forge.ml +++ b/src/client/embedded/alpha/baker/client_mining_forge.ml @@ -172,11 +172,11 @@ end = struct (req "level" Raw_level.encoding) (req "blocks" (list Block_hash.encoding)))) - let filename () = - Client_config.(base_dir#get // "blocks") + let filename cctxt = + Client_commands.(Filename.concat cctxt.config.base_dir "blocks") - let load () = - let filename = filename () in + let load cctxt = + let filename = filename cctxt in if not (Sys.file_exists filename) then return LevelMap.empty else Data_encoding_ezjsonm.read_file filename >>= function | Error _ -> @@ -188,13 +188,13 @@ end = struct | map -> return map - let save map = + let save cctxt map = Lwt.catch (fun () -> - let dirname = Client_config.base_dir#get in + let dirname = Client_commands.(cctxt.config.base_dir) in (if not (Sys.file_exists dirname) then Lwt_utils.create_dir dirname else Lwt.return ()) >>= fun () -> - let filename = filename () in + let filename = filename cctxt in let json = Data_encoding.Json.construct encoding map in Data_encoding_ezjsonm.write_file filename json >>= function | Error _ -> failwith "Json.write_file" @@ -206,10 +206,10 @@ end = struct let lock = Lwt_mutex.create () - let get_block _cctxt level = + let get_block cctxt level = Lwt_mutex.with_lock lock (fun () -> - load () >>=? fun map -> + load cctxt >>=? fun map -> try let blocks = LevelMap.find level map in return blocks @@ -218,11 +218,11 @@ end = struct let record_block cctxt level hash nonce = Lwt_mutex.with_lock lock (fun () -> - load () >>=? fun map -> + load cctxt >>=? fun map -> let previous = try LevelMap.find level map with Not_found -> [] in - save + save cctxt (LevelMap.add level (hash :: previous) map)) >>=? fun () -> Client_proto_nonces.add cctxt hash nonce diff --git a/src/client/embedded/alpha/baker/client_mining_main.ml b/src/client/embedded/alpha/baker/client_mining_main.ml index 2d481765d..aebb9159a 100644 --- a/src/client/embedded/alpha/baker/client_mining_main.ml +++ b/src/client/embedded/alpha/baker/client_mining_main.ml @@ -32,10 +32,9 @@ let mine_block cctxt block ?force ?max_priority ?src_sk delegate = return () let endorse_block cctxt ?force ?max_priority delegate = - let block = Client_proto_args.block () in Client_keys.get_key cctxt delegate >>=? fun (_src_name, src_pk, src_sk) -> Client_mining_endorsement.forge_endorsement cctxt - block ?force ?max_priority ~src_sk src_pk >>=? fun oph -> + cctxt.config.block ?force ?max_priority ~src_sk src_pk >>=? fun oph -> cctxt.answer "Operation successfully injected in the node." >>= fun () -> cctxt.answer "Operation hash is '%a'." Operation_hash.pp oph >>= fun () -> return () @@ -59,7 +58,6 @@ let do_reveal cctxt ?force block blocks = return () let reveal_block_nonces cctxt ?force block_hashes = - let block = Client_proto_args.block () in Lwt_list.filter_map_p (fun hash -> Lwt.catch @@ -83,13 +81,12 @@ let reveal_block_nonces cctxt ?force block_hashes = | Some nonce -> return (Some (bi.hash, (bi.level.level, nonce)))) block_infos >>=? fun blocks -> - do_reveal cctxt ?force block blocks + do_reveal cctxt ?force cctxt.config.block blocks let reveal_nonces cctxt ?force () = - let block = Client_proto_args.block () in Client_mining_forge.get_unrevealed_nonces - cctxt ?force block >>=? fun nonces -> - do_reveal cctxt ?force block nonces + cctxt ?force cctxt.config.block >>=? fun nonces -> + do_reveal cctxt ?force cctxt.config.block nonces open Client_proto_args @@ -131,7 +128,7 @@ let commands () = ~name:"miner" ~desc: "name of the delegate owning the mining right" @@ stop) (fun (_, delegate) cctxt -> - mine_block cctxt (block ()) + mine_block cctxt cctxt.config.block ~force:!force ?max_priority:!max_priority delegate >>= Client_proto_rpcs.handle_error cctxt) ; command ~group ~desc: "Forge and inject a seed-nonce revelation operation" diff --git a/src/client/embedded/alpha/client_proto_args.ml b/src/client/embedded/alpha/client_proto_args.ml index 24f3cb36f..8a398a458 100644 --- a/src/client/embedded/alpha/client_proto_args.ml +++ b/src/client/embedded/alpha/client_proto_args.ml @@ -10,8 +10,6 @@ let tez_sym = "\xEA\x9C\xA9" -let block () = Client_config.block () - let tez_of_string s = match Tez.of_string s with | None -> invalid_arg "tez_of_string" diff --git a/src/client/embedded/alpha/client_proto_args.mli b/src/client/embedded/alpha/client_proto_args.mli index 22f8abf2d..0a42109e7 100644 --- a/src/client/embedded/alpha/client_proto_args.mli +++ b/src/client/embedded/alpha/client_proto_args.mli @@ -7,8 +7,6 @@ (* *) (**************************************************************************) -val block: unit -> Client_node_rpcs.Blocks.block - val tez_sym: string val init_arg: string * Arg.spec * string diff --git a/src/client/embedded/alpha/client_proto_context.ml b/src/client/embedded/alpha/client_proto_context.ml index bfe53f798..fd8070e26 100644 --- a/src/client/embedded/alpha/client_proto_context.ml +++ b/src/client/embedded/alpha/client_proto_context.ml @@ -167,20 +167,21 @@ let group = let commands () = let open Cli_entries in + let open Client_commands in [ command ~group ~desc: "access the timestamp of the block" (fixed [ "get" ; "timestamp" ]) - (fun cctxt -> get_timestamp cctxt (block ())) ; + (fun cctxt -> get_timestamp cctxt cctxt.config.block) ; command ~group ~desc: "lists all non empty contracts of the block" (fixed [ "list" ; "contracts" ]) (fun cctxt -> - list_contracts cctxt (block ()) >>= fun res -> + list_contracts cctxt cctxt.config.block >>= fun res -> Client_proto_rpcs.handle_error cctxt res) ; command ~group ~desc: "get the balance of a contract" (prefixes [ "get" ; "balance" ] @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract" @@ stop) (fun (_, contract) cctxt -> - Client_proto_rpcs.Context.Contract.balance cctxt (block ()) contract + Client_proto_rpcs.Context.Contract.balance cctxt cctxt.config.block contract >>= Client_proto_rpcs.handle_error cctxt >>= fun amount -> cctxt.answer "%a %s" Tez.pp amount tez_sym); command ~group ~desc: "get the manager of a block" @@ -188,7 +189,7 @@ let commands () = @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract" @@ stop) (fun (_, contract) cctxt -> - Client_proto_rpcs.Context.Contract.manager cctxt (block ()) contract + Client_proto_rpcs.Context.Contract.manager cctxt cctxt.config.block contract >>= Client_proto_rpcs.handle_error cctxt >>= fun manager -> Public_key_hash.rev_find cctxt manager >>= fun mn -> Public_key_hash.to_source cctxt manager >>= fun m -> @@ -213,10 +214,11 @@ let commands () = (fun neu (_, manager) balance (_, source) cctxt -> check_contract cctxt neu >>= fun () -> get_delegate_pkh cctxt !delegate >>= fun delegate -> - (Client_proto_contracts.get_manager cctxt (block ()) source >>=? fun src_pkh -> - Client_keys.get_key cctxt src_pkh >>=? fun (src_name, src_pk, src_sk) -> + (Client_proto_contracts.get_manager cctxt cctxt.config.block source >>=? fun src_pkh -> + Client_keys.get_key cctxt src_pkh + >>=? fun (src_name, src_pk, src_sk) -> cctxt.message "Got the source's manager keys (%s)." src_name >>= fun () -> - originate_account cctxt (block ()) ~force:!force + originate_account cctxt cctxt.config.block ~force:!force ~source ~src_pk ~src_sk ~manager_pkh:manager ~balance ~fee:!fee ~delegatable:!delegatable ~spendable:!spendable ?delegate:delegate ()) >>= Client_proto_rpcs.handle_error cctxt >>= fun contract -> @@ -244,10 +246,11 @@ let commands () = (fun neu (_, manager) balance (_, source) code cctxt -> check_contract cctxt neu >>= fun () -> get_delegate_pkh cctxt !delegate >>= fun delegate -> - (Client_proto_contracts.get_manager cctxt (block ()) source >>=? fun src_pkh -> - Client_keys.get_key cctxt src_pkh >>=? fun (src_name, src_pk, src_sk) -> + (Client_proto_contracts.get_manager cctxt cctxt.config.block source >>=? fun src_pkh -> + Client_keys.get_key cctxt src_pkh + >>=? fun (src_name, src_pk, src_sk) -> cctxt.message "Got the source's manager keys (%s)." src_name >>= fun () -> - originate_contract cctxt (block ()) ~force:!force + originate_contract cctxt cctxt.config.block ~force:!force ~source ~src_pk ~src_sk ~manager_pkh:manager ~balance ~fee:!fee ~delegatable:!delegatable ?delegatePubKey:delegate ~code ~init:!init ()) >>= Client_proto_rpcs.handle_error cctxt >>= fun contract -> @@ -264,7 +267,7 @@ let commands () = @@ stop) (fun neu (_, manager) cctxt -> check_contract cctxt neu >>= fun () -> - faucet cctxt (block ()) ~force:!force ~manager_pkh:manager () >>= Client_proto_rpcs.handle_error cctxt >>= fun contract -> + faucet cctxt cctxt.config.block ~force:!force ~manager_pkh:manager () >>= Client_proto_rpcs.handle_error cctxt >>= fun contract -> RawContractAlias.add cctxt neu contract) ; command ~group ~desc: "transfer tokens" ~args: [ fee_arg ; arg_arg ; force_arg ] @@ -279,10 +282,11 @@ let commands () = ~name: "dst" ~desc: "name/literal of the destination contract" @@ stop) (fun amount (_, source) (_, destination) cctxt -> - (Client_proto_contracts.get_manager cctxt (block ()) source >>=? fun src_pkh -> - Client_keys.get_key cctxt src_pkh >>=? fun (src_name, src_pk, src_sk) -> + (Client_proto_contracts.get_manager cctxt cctxt.config.block source >>=? fun src_pkh -> + Client_keys.get_key cctxt src_pkh + >>=? fun (src_name, src_pk, src_sk) -> cctxt.message "Got the source's manager keys (%s)." src_name >>= fun () -> - (transfer cctxt (block ()) ~force:!force + (transfer cctxt cctxt.config.block ~force:!force ~source ~src_pk ~src_sk ~destination ?arg:!arg ~amount ~fee:!fee ()) >>=? fun contracts -> Lwt_list.iter_s (fun c -> cctxt.message "New contract %a originated from a smart contract." @@ -300,8 +304,7 @@ let commands () = stop end (fun hash seckey cctxt -> - let block = Client_config.block () in - dictate cctxt block (Activate hash) seckey >>= + dictate cctxt cctxt.config.block (Activate hash) seckey >>= Client_proto_rpcs.handle_error cctxt) ; command ~desc: "Fork a test protocol" begin prefixes [ "fork" ; "test" ; "protocol" ] @@ @@ -314,7 +317,6 @@ let commands () = stop end (fun hash seckey cctxt -> - let block = Client_config.block () in - dictate cctxt block (Activate_testnet hash) seckey >>= + dictate cctxt cctxt.config.block (Activate_testnet hash) seckey >>= Client_proto_rpcs.handle_error cctxt) ; ] diff --git a/src/client/embedded/alpha/client_proto_contracts.ml b/src/client/embedded/alpha/client_proto_contracts.ml index 5bc0b6317..c275a311c 100644 --- a/src/client/embedded/alpha/client_proto_contracts.ml +++ b/src/client/embedded/alpha/client_proto_contracts.ml @@ -131,6 +131,7 @@ let group = let commands () = let open Cli_entries in + let open Client_commands in [ command ~group ~desc: "add a contract to the wallet" (prefixes [ "remember" ; "contract" ] @@ -162,7 +163,7 @@ let commands () = command ~group ~desc: "forget all known contracts" (fixed [ "forget" ; "all" ; "contracts" ]) (fun cctxt -> - if not Client_config.force#get then + if not cctxt.config.force then cctxt.Client_commands.error "this can only used with option -force true" else RawContractAlias.save cctxt []) ; diff --git a/src/client/embedded/alpha/client_proto_nonces.ml b/src/client/embedded/alpha/client_proto_nonces.ml index 26e8af42a..ac39bded1 100644 --- a/src/client/embedded/alpha/client_proto_nonces.ml +++ b/src/client/embedded/alpha/client_proto_nonces.ml @@ -20,11 +20,11 @@ let encoding : t Data_encoding.t = (req "block" Block_hash.encoding) (req "nonce" Nonce.encoding)) -let filename () = - Client_config.(base_dir#get // "nonces") +let filename cctxt = + Client_commands.(Filename.concat cctxt.config.base_dir "nonces") let load cctxt = - let filename = filename () in + let filename = filename cctxt in if not (Sys.file_exists filename) then Lwt.return [] else @@ -47,9 +47,9 @@ let check_dir dirname = let save cctxt list = Lwt.catch (fun () -> - let dirname = Client_config.base_dir#get in + let dirname = Client_commands.(cctxt.config.base_dir) in check_dir dirname >>= fun () -> - let filename = filename () in + let filename = filename cctxt in let json = Data_encoding.Json.construct encoding list in Data_encoding_ezjsonm.write_file filename json >>= function | Error _ -> failwith "Json.write_file" diff --git a/src/client/embedded/alpha/client_proto_programs.ml b/src/client/embedded/alpha/client_proto_programs.ml index b0fa25880..3f1e7c634 100644 --- a/src/client/embedded/alpha/client_proto_programs.ml +++ b/src/client/embedded/alpha/client_proto_programs.ml @@ -572,7 +572,7 @@ let commands () = let open Data_encoding in if !trace_stack then Client_proto_rpcs.Helpers.trace_code cctxt - (block ()) program (storage, input) >>= function + cctxt.config.block program (storage, input) >>= function | Ok (storage, output, trace) -> cctxt.message "@[@[storage@,%a@]@,@[output@,%a@]@,@[trace@,%a@]@]@." (print_expr no_locations) storage @@ -590,7 +590,7 @@ let commands () = cctxt.error "error running program" else Client_proto_rpcs.Helpers.run_code cctxt - (block ()) program (storage, input) >>= function + cctxt.config.block program (storage, input) >>= function | Ok (storage, output) -> cctxt.message "@[@[storage@,%a@]@,@[output@,%a@]@]@." (print_expr no_locations) storage @@ -605,7 +605,7 @@ let commands () = @@ stop) (fun program cctxt -> let open Data_encoding in - Client_proto_rpcs.Helpers.typecheck_code cctxt (block ()) program >>= function + Client_proto_rpcs.Helpers.typecheck_code cctxt cctxt.config.block program >>= function | Ok type_map -> let type_map, program = unexpand_macros type_map program in cctxt.message "Well typed" >>= fun () -> @@ -624,7 +624,7 @@ let commands () = (fun data exp_ty cctxt -> let open Data_encoding in Client_proto_rpcs.Helpers.typecheck_data cctxt - (block ()) (data, exp_ty) >>= function + cctxt.config.block (data, exp_ty) >>= function | Ok () -> cctxt.message "Well typed" | Error errs -> @@ -639,7 +639,7 @@ let commands () = (fun data cctxt -> let open Data_encoding in Client_proto_rpcs.Helpers.hash_data cctxt - (block ()) data >>= function + cctxt.config.block data >>= function | Ok hash -> cctxt.message "%S" hash | Error errs -> @@ -658,7 +658,7 @@ let commands () = (fun data (_, key) cctxt -> let open Data_encoding in Client_proto_rpcs.Helpers.hash_data cctxt - (block ()) data >>= function + cctxt.config.block data >>= function | Ok hash -> let signature = Ed25519.sign key (MBytes.of_string hash) in cctxt.message "Hash: %S@.Signature: %S" diff --git a/src/client/embedded/demo/client_proto_main.ml b/src/client/embedded/demo/client_proto_main.ml index a74b5e173..8e71da3b0 100644 --- a/src/client/embedded/demo/client_proto_main.ml +++ b/src/client/embedded/demo/client_proto_main.ml @@ -12,7 +12,7 @@ let protocol = "ProtoDemoDemoDemoDemoDemoDemoDemoDemoDemoDemoD3c8k9" let demo cctxt = - let block = Client_config.block () in + let block = Client_commands.(cctxt.config.block) in cctxt.Client_commands.message "Calling the 'echo' RPC." >>= fun () -> let msg = "test" in Client_proto_rpcs.echo cctxt block msg >>= fun reply -> @@ -35,7 +35,7 @@ let demo cctxt = let mine cctxt = let block = - match Client_config.block () with + match Client_commands.(cctxt.config.block) with | `Prevalidation -> `Head 0 | `Test_prevalidation -> `Test_head 0 | b -> b in diff --git a/src/client/embedded/genesis/client_proto_main.ml b/src/client/embedded/genesis/client_proto_main.ml index 7f9c17d1b..8ffda3707 100644 --- a/src/client/embedded/genesis/client_proto_main.ml +++ b/src/client/embedded/genesis/client_proto_main.ml @@ -63,10 +63,10 @@ let commands () = end (fun hash fitness seckey cctxt -> let timestamp = !timestamp in - let block = Client_config.block () in let fitness = Client_embedded_proto_alpha.Fitness_repr.from_int64 fitness in - mine cctxt ?timestamp block (Activate hash) fitness seckey >>= + mine cctxt ?timestamp cctxt.config.block + (Activate hash) fitness seckey >>= handle_error cctxt) ; command ~args ~desc: "Fork a test protocol" begin @@ -85,10 +85,10 @@ let commands () = end (fun hash fitness seckey cctxt -> let timestamp = !timestamp in - let block = Client_config.block () in let fitness = Client_embedded_proto_alpha.Fitness_repr.from_int64 fitness in - mine cctxt ?timestamp block (Activate_testnet hash) fitness seckey >>= + mine cctxt ?timestamp cctxt.config.block + (Activate_testnet hash) fitness seckey >>= handle_error cctxt) ; ] diff --git a/src/client_main.ml b/src/client_main.ml index fef55fb71..168d499df 100644 --- a/src/client_main.ml +++ b/src/client_main.ml @@ -12,6 +12,8 @@ open Lwt.Infix let cctxt = + (* TODO: set config as parameter? *) + let config = Client_commands.default_cfg in let startup = CalendarLib.Printer.Precise_Calendar.sprint "%Y-%m-%dT%H:%M:%SZ" @@ -24,11 +26,12 @@ let cctxt = prerr_endline msg ; Lwt.return () | log -> - Lwt_utils.create_dir Client_config.(base_dir#get // "logs" // log) >>= fun () -> + let (//) = Filename.concat in + Lwt_utils.create_dir (config.base_dir // "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) + Client_commands.(config.base_dir // "logs" // log // startup) (fun chan -> Lwt_io.write chan msg) in Client_commands.make_context log @@ -37,9 +40,10 @@ let main () = Random.self_init () ; Sodium.Random.stir () ; Lwt.catch begin fun () -> - Client_config.preparse_args Sys.argv cctxt >>= fun block -> + Client_config.preparse_args Sys.argv cctxt >>= fun config -> + let cctxt = { cctxt with config } in Lwt.catch begin fun () -> - Client_node_rpcs.Blocks.protocol cctxt block >>= fun version -> + Client_node_rpcs.Blocks.protocol cctxt cctxt.config.block >>= fun version -> Lwt.return (Some version, Client_commands.commands_for_version version) end begin fun exn -> cctxt.warning @@ -48,7 +52,7 @@ let main () = | Failure msg -> msg | exn -> Printexc.to_string exn) >>= fun () -> Lwt.return (None, []) - end >>= fun (version, commands_for_version) -> + end >>= fun (_version, commands_for_version) -> let commands = Client_generic_rpcs.commands @ Client_network.commands () @ @@ -56,11 +60,11 @@ let main () = Client_protocols.commands () @ Client_helpers.commands () @ commands_for_version in - Client_config.parse_args ?version + Client_config.parse_args (Cli_entries.usage ~commands) (Cli_entries.inline_dispatch commands) - Sys.argv cctxt >>= fun command -> - command cctxt >>= fun () -> + Sys.argv cctxt >>= fun (command, config) -> + command { cctxt with config } >>= fun () -> Lwt.return 0 end begin function | Arg.Help help -> diff --git a/src/node/shell/node_rpc_services.ml b/src/node/shell/node_rpc_services.ml index e9b1a0781..83c39291e 100644 --- a/src/node/shell/node_rpc_services.ml +++ b/src/node/shell/node_rpc_services.ml @@ -107,6 +107,15 @@ module Blocks = struct | _ -> raise Exit with _ -> Error "Cannot parse block identifier." + let to_string = function + | `Genesis -> "genesis" + | `Head 0 -> "head" + | `Head n -> Printf.sprintf "head~%d" n + | `Prevalidation -> "prevalidation" + | `Test_head 0 -> "test_head" + | `Test_head n -> Printf.sprintf "test_head~%d" n + | `Test_prevalidation -> "test_prevalidation" + | `Hash h -> Block_hash.to_b58check h let blocks_arg = let name = "block_id" in @@ -117,15 +126,7 @@ module Blocks = struct 'test_head' or 'test_prevalidation'. One might alse use 'head~N' to 'test_head~N', where N is an integer to denotes the Nth predecessors of 'head' or 'test_head'." in - let construct = function - | `Genesis -> "genesis" - | `Head 0 -> "head" - | `Head n -> Printf.sprintf "head~%d" n - | `Prevalidation -> "prevalidation" - | `Test_head 0 -> "test_head" - | `Test_head n -> Printf.sprintf "test_head~%d" n - | `Test_prevalidation -> "test_prevalidation" - | `Hash h -> Block_hash.to_b58check h in + let construct = to_string in let destruct = parse_block in RPC.Arg.make ~name ~descr ~construct ~destruct () diff --git a/src/node/shell/node_rpc_services.mli b/src/node/shell/node_rpc_services.mli index b3abd91f9..f8b62e512 100644 --- a/src/node/shell/node_rpc_services.mli +++ b/src/node/shell/node_rpc_services.mli @@ -24,6 +24,8 @@ module Blocks : sig val blocks_arg : block RPC.Arg.arg val parse_block: string -> (block, string) result + val to_string: block -> string + type net = State.Net_id.t = Id of Block_hash.t type block_info = { diff --git a/src/tezos-deps.opam b/src/tezos-deps.opam index 66240813f..cbde8c0f3 100644 --- a/src/tezos-deps.opam +++ b/src/tezos-deps.opam @@ -17,8 +17,6 @@ depends: [ "base-threads" "calendar" "cohttp" {>= "0.21" } - "cmdliner" {< "1.0.0"} - "config-file" "conduit" "git" "git-unix" diff --git a/src/utils/cli_entries.ml b/src/utils/cli_entries.ml index a83a6f3e1..385eba2b4 100644 --- a/src/utils/cli_entries.ml +++ b/src/utils/cli_entries.ml @@ -329,7 +329,11 @@ let usage with Not_found -> (group, ref [ command ]) :: acc) [] commands in - List.map (fun (g, c) -> (g, List.rev !c)) grouped @ - [ { name = "untitled" ; title = "Miscellaneous commands" }, - List.rev !ungrouped ] in + let misc = match !ungrouped with + | [] -> [] + | l -> + [ { name = "untitled" ; title = "Miscellaneous commands" }, + List.rev l ] + in + List.map (fun (g, c) -> (g, List.rev !c)) grouped @ misc in Format.asprintf "%a" usage (by_group, options) diff --git a/src/webclient_main.ml b/src/webclient_main.ml index 55f1bd4b2..554d54457 100644 --- a/src/webclient_main.ml +++ b/src/webclient_main.ml @@ -48,8 +48,10 @@ let eval_command argv = let cctxt, result = make_context () in Lwt.catch (fun () -> - Client_config.preparse_args argv cctxt >>= fun block -> - block_protocol cctxt block >>= fun version -> + Client_config.preparse_args argv cctxt >>= fun config -> + let cctxt = { cctxt with config } in + block_protocol cctxt Client_commands.(cctxt.config.block) + >>= fun version -> let commands = Client_generic_rpcs.commands @ Client_keys.commands () @ @@ -59,8 +61,8 @@ let eval_command argv = Client_config.parse_args ~version (Cli_entries.usage ~commands) (Cli_entries.inline_dispatch commands) - argv cctxt >>= fun command -> - command cctxt >>= fun () -> + argv cctxt >>= fun (command, config) -> + command Client_commands.({ cctxt with config }) >>= fun () -> Lwt.return (Ok (result ()))) (fun exn -> let msg = match exn with @@ -169,9 +171,13 @@ let http_proxy mode = Lwt.return (content_type, { RPC.Answer.code = 404 ; body }) in RPC_server.launch ~pre_hook ~post_hook mode root [] [] -let web_port = Client_config.in_both_groups @@ - new Config_file.int_cp [ "web" ; "port" ] 8080 - "The TCP port to point the web browser to." +let webclient_args cfg = + let open Client_commands in + [ + "-web-port", Arg.Int (fun x -> cfg := { !cfg with web_port = x }), + "The TCP port to point the web browser to.\n\ + default: " ^ string_of_int Client_commands.(default_cfg.web_port); + ] (* Where all the user friendliness starts *) let () = @@ -179,15 +185,18 @@ let () = (Lwt.catch (fun () -> Client_config.parse_args + ~extra:webclient_args (Cli_entries.usage ~commands: []) (fun () -> function | `Arg arg -> raise (Arg.Bad ("unexpected argument " ^ arg)) | `End -> `Res (fun () -> Lwt.return ())) - Sys.argv Client_commands.ignore_context>>= fun _no_command -> + Sys.argv Client_commands.ignore_context + >>= fun (_no_command, config) -> Random.self_init () ; Sodium.Random.stir () ; (* TODO: add TLS? *) - http_proxy (`TCP (`Port web_port#get)) >>= fun _server -> + http_proxy (`TCP (`Port Client_commands.(config.web_port))) + >>= fun _server -> fst (Lwt.wait ())) (function | Arg.Help help -> diff --git a/test/Makefile b/test/Makefile index 29655a43c..3fe7cb102 100644 --- a/test/Makefile +++ b/test/Makefile @@ -34,7 +34,6 @@ PACKAGES := \ calendar \ cohttp.lwt \ compiler-libs.optcomp \ - config-file \ cstruct \ dynlink \ ezjsonm \