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

Client: switch to JSON config file and remove config-file dependency.

Browse Source
This commit is contained in:
Guillem Rieu 2017-03-15 01:17:20 +01:00 committed by Benjamin Canou
parent 04ef832ad3
commit 83f2e0dcd3
28 changed files with 390 additions and 303 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
src/.merlin
View File

@ -29,7 +29,6 @@ PKG cmdliner
PKG cohttp
PKG compiler-libs.optcomp
PKG conduit
PKG config-file
PKG cstruct
PKG dynlink
PKG ezjsonm

1
src/Makefile
View File

@ -290,7 +290,6 @@ COMPILER_IMPLS := \
COMPILER_PACKAGES := \
${UTILS_PACKAGES} \
compiler-libs.optcomp \
config-file \
lwt.unix \
ocplib-endian \
ocplib-ocamlres \

19
src/client/client_aliases.ml
View File

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

50
src/client/client_commands.ml
View File

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

35
src/client/client_commands.mli
View File

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

287
src/client/client_config.ml
View File

@ -9,114 +9,98 @@
(* 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 write out cfg =
Utils.write_file ~bin:false out
(Data_encoding.Json.construct encoding cfg |>
Data_encoding_ezjsonm.to_string)
end
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
exception Found of string
let preparse name argv =
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)
for i = 0 to Array.length argv - 1 do
if argv.(i) = name && i <> Array.length argv - 1 then
raise (Found argv.(i+1))
done ;
None
with Found s -> Some s
(* Entry point *)
let parse_args ?version usage dispatcher argv cctxt =
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 (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 args = ref all_args in
let anon dispatch n = match dispatch (`Arg n) with
| `Nop -> ()
| `Args nargs -> args := nargs @ !args
@ -125,9 +109,19 @@ let parse_args ?version usage dispatcher argv cctxt =
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
(if Sys.file_exists !cfg.config_file then begin
try
file_group#read config_file#get ;
(* 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" ;
@ -140,15 +134,17 @@ let parse_args ?version usage dispatcher argv cctxt =
(* 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_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
"Warning: can't create the default configuration file: %s\n%!"
msg
end) >>= fun () ->
begin match dispatch `End with
| `Res res -> Lwt.return res
| `Res res -> Lwt.return (res, !cfg)
| `Fail exn -> fail exn
| `Nop | `Args _ -> assert false
end)
@ -157,70 +153,75 @@ let parse_args ?version usage dispatcher argv cctxt =
(* 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"))
Lwt.fail (Arg.Help (msg ^ usage all_args ^ "\n"))
| Arg.Help _ ->
let args = cli_group#command_line_args "-" in
Lwt.fail (Arg.Help (usage args ^ "\n"))
Lwt.fail (Arg.Help (usage all_args ^ "\n"))
| exn -> Lwt.fail exn)
exception Found of string
let preparse name argv =
try
for i = 0 to Array.length argv - 1 do
if argv.(i) = name && i <> Array.length argv - 1 then
raise (Found argv.(i+1))
done ;
None
with Found s -> Some s
let preparse_args argv cctxt : Node_rpc_services.Blocks.block Lwt.t =
begin
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 }

2
src/client/client_helpers.ml
View File

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

5
src/client/client_keys.ml
View File

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

14
src/client/client_node_rpcs.ml
View File

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

4
src/client/embedded/Makefile.shared
View File

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

10
src/client/embedded/alpha/baker/client_mining_endorsement.ml
View File

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

22
src/client/embedded/alpha/baker/client_mining_forge.ml
View File

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

13
src/client/embedded/alpha/baker/client_mining_main.ml
View File

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

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

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

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

@ -7,8 +7,6 @@
(* *)
(**************************************************************************)
val block: unit -> Client_node_rpcs.Blocks.block
val tez_sym: string
val init_arg: string * Arg.spec * string

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

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

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

@ -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 []) ;

10
src/client/embedded/alpha/client_proto_nonces.ml
View File

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

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

@ -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 "@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>output@,%a@]@,@[<v 2>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 "@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>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"

4
src/client/embedded/demo/client_proto_main.ml
View File

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

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

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

20
src/client_main.ml
View File

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

19
src/node/shell/node_rpc_services.ml
View File

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

2
src/node/shell/node_rpc_services.mli
View File

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

2
src/tezos-deps.opam
View File

@ -17,8 +17,6 @@ depends: [
"base-threads"
"calendar"
"cohttp" {>= "0.21" }
"cmdliner" {< "1.0.0"}
"config-file"
"conduit"
"git"
"git-unix"

8
src/utils/cli_entries.ml
View File

@ -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 @
let misc = match !ungrouped with
| [] -> []
| l ->
[ { name = "untitled" ; title = "Miscellaneous commands" },
List.rev !ungrouped ] in
List.rev l ]
in
List.map (fun (g, c) -> (g, List.rev !c)) grouped @ misc in
Format.asprintf "%a" usage (by_group, options)

27
src/webclient_main.ml
View File

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

1
test/Makefile
View File

@ -34,7 +34,6 @@ PACKAGES := \
calendar \
cohttp.lwt \
compiler-libs.optcomp \
config-file \
cstruct \
dynlink \
ezjsonm \