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 cohttp
PKG compiler-libs.optcomp PKG compiler-libs.optcomp
PKG conduit PKG conduit
PKG config-file
PKG cstruct PKG cstruct
PKG dynlink PKG dynlink
PKG ezjsonm PKG ezjsonm

1
src/Makefile
View File

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

19
src/client/client_aliases.ml
View File

@ -75,17 +75,22 @@ end
module Alias = functor (Entity : Entity) -> struct module Alias = functor (Entity : Entity) -> struct
open Client_commands
let encoding = let encoding =
let open Data_encoding in let open Data_encoding in
list (obj2 list (obj2
(req "name" string) (req "name" string)
(req "value" Entity.encoding)) (req "value" Entity.encoding))
let filename () = let dirname cctxt =
Client_config.(base_dir#get // Entity.name ^ "s") cctxt.config.base_dir
let filename cctxt =
Filename.concat (dirname cctxt) (Entity.name ^ "s")
let load cctxt = let load cctxt =
let filename = filename () in let filename = filename cctxt in
if not (Sys.file_exists filename) then return [] else if not (Sys.file_exists filename) then return [] else
Data_encoding_ezjsonm.read_file filename >>= function Data_encoding_ezjsonm.read_file filename >>= function
| Error _ -> | Error _ ->
@ -126,10 +131,10 @@ module Alias = functor (Entity : Entity) -> struct
let save cctxt list = let save cctxt list =
catch catch
(fun () -> (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 (if not (Sys.file_exists dirname) then Lwt_utils.create_dir dirname
else return ()) >>= fun () -> else return ()) >>= fun () ->
let filename = filename () in let filename = filename cctxt in
let json = Data_encoding.Json.construct encoding list in let json = Data_encoding.Json.construct encoding list in
Data_encoding_ezjsonm.write_file filename json >>= function Data_encoding_ezjsonm.write_file filename json >>= function
| Error _ -> fail (Failure "Json.write_file") | Error _ -> fail (Failure "Json.write_file")
@ -142,7 +147,7 @@ module Alias = functor (Entity : Entity) -> struct
let add cctxt name value = let add cctxt name value =
let keep = ref false in let keep = ref false in
load cctxt >>= fun list -> load cctxt >>= fun list ->
(if not Client_config.force#get then (if not cctxt.config.force then
Lwt_list.iter_s (fun (n, v) -> Lwt_list.iter_s (fun (n, v) ->
if n = name && v = value then if n = name && v = value then
(keep := true ; (keep := true ;
@ -186,7 +191,7 @@ module Alias = functor (Entity : Entity) -> struct
param ~name ~desc param ~name ~desc
(fun cctxt s -> (fun cctxt s ->
load cctxt >>= fun list -> load cctxt >>= fun list ->
if not Client_config.force#get then if not cctxt.config.force then
Lwt_list.iter_s (fun (n, _v) -> Lwt_list.iter_s (fun (n, _v) ->
if n = s then if n = s then
cctxt.Client_commands.error cctxt.Client_commands.error

50
src/client/client_commands.ml
View File

@ -10,8 +10,26 @@
type ('a, 'b) lwt_format = type ('a, 'b) lwt_format =
('a, Format.formatter, unit, 'b Lwt.t) format4 ('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 = 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 ; warning : 'a. ('a, unit) lwt_format -> 'a ;
message : 'a. ('a, unit) lwt_format -> 'a ; message : 'a. ('a, unit) lwt_format -> 'a ;
answer : '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 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 = let error fmt =
Format.kasprintf Format.kasprintf
(fun msg -> (fun msg ->
@ -39,7 +83,7 @@ let make_context log =
Format.kasprintf Format.kasprintf
(fun msg -> log name msg) (fun msg -> log name msg)
fmt in fmt in
{ error ; warning ; message ; answer ; log } { config ; error ; warning ; message ; answer ; log }
let ignore_context = let ignore_context =
make_context (fun _ _ -> Lwt.return ()) make_context (fun _ _ -> Lwt.return ())

35
src/client/client_commands.mli
View File

@ -10,8 +10,26 @@
type ('a, 'b) lwt_format = type ('a, 'b) lwt_format =
('a, Format.formatter, unit, 'b Lwt.t) format4 ('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 = 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 ; warning : 'a. ('a, unit) lwt_format -> 'a ;
message : 'a. ('a, unit) lwt_format -> 'a ; message : 'a. ('a, unit) lwt_format -> 'a ;
answer : '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 handler when running a command, and must be transmitted to all
basic operations, also making client commands reantrant. *) basic operations, also making client commands reantrant. *)
val make_context : (string -> string -> unit Lwt.t) -> context val default_base_dir : string
(** [make_context log_fun] builds a context whose logging callbacks val default_cfg_of_base_dir : string -> cfg
call [log_fun section msg], and whose [error] function calls val default_cfg : cfg
[Lwt.fail_with]. *)
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 val ignore_context : context
(** [ignore_context] is a context whose logging callbacks do nothing, (** [ignore_context] is a context whose logging callbacks do nothing,

357
src/client/client_config.ml
View File

@ -9,161 +9,41 @@
(* Tezos Command line interface - Configuration and Arguments Parsing *) (* 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 = let encoding =
try Sys.getenv "HOME" conv
with Not_found -> "/root" (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 = let from_json json =
object (self) Data_encoding.Json.destruct encoding json
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 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
let cli_group = new group (Data_encoding.Json.construct encoding cfg |>
Data_encoding_ezjsonm.to_string)
let base_dir = end
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)
exception Found of string exception Found of string
let preparse name argv = let preparse name argv =
@ -175,52 +55,173 @@ let preparse name argv =
None None
with Found s -> Some s with Found s -> Some s
let preparse_args argv cctxt : Node_rpc_services.Blocks.block Lwt.t = (* Entry point *)
begin
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 match preparse "-base-dir" argv with
| None -> () | None -> default_cfg
| Some dir -> base_dir#set dir | Some base_dir -> default_cfg_of_base_dir base_dir
end ; in
begin let cfg =
match preparse "-config-file" argv with match preparse "-config-file" argv with
| None -> config_file#set @@ base_dir#get // "config" | None -> cfg
| Some file -> config_file#set file | Some config_file -> { cfg with config_file }
end ; 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 begin
if Sys.file_exists config_file#get then try if Sys.file_exists cfg.config_file then try
(file_group#read config_file#get ; match
Lwt.return ()) 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 -> with Sys_error msg ->
cctxt.Client_commands.error cctxt.Client_commands.error
"Error: can't read the configuration file: %s\n%!" msg "Error: can't read the configuration file: %s\n%!" msg
else Lwt.return () else Lwt.return cfg
end >>= fun () -> end >>= fun cfg ->
begin let cfg =
match preparse "-tls" argv with match preparse "-tls" argv with
| None -> () | None -> cfg
| Some _ -> tls#set true | Some _ -> { cfg with tls = true }
end ; in
begin let cfg =
match preparse "-addr" argv with match preparse "-addr" argv with
| None -> () | None -> cfg
| Some addr -> incoming_addr#set addr | Some incoming_addr -> { cfg with incoming_addr }
end ; in
begin begin
match preparse "-port" argv with match preparse "-port" argv with
| None -> Lwt.return () | None -> Lwt.return cfg
| Some port -> | Some port ->
try try
incoming_port#set (int_of_string port) ; let incoming_port = int_of_string port in
Lwt.return () Lwt.return { cfg with incoming_port }
with _ -> with _ ->
cctxt.Client_commands.error cctxt.Client_commands.error
"Error: can't parse the -port option: %S.\n%!" port "Error: can't parse the -port option: %S.\n%!" port
end >>= fun () -> end >>= fun cfg ->
match preparse "-block" Sys.argv with match preparse "-block" Sys.argv with
| None -> Lwt.return `Prevalidation | None -> Lwt.return cfg
| Some x -> | Some x ->
match Node_rpc_services.Blocks.parse_block x with match Node_rpc_services.Blocks.parse_block x with
| Error _ -> | Error _ ->
cctxt.Client_commands.error cctxt.Client_commands.error
"Error: can't parse the -block option: %S.\n%!" x "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" @@ ~desc: "the prefix of the Base58Check-encoded hash to be completed" @@
stop) stop)
(fun prefix cctxt -> (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 match completions with
| [] -> Pervasives.exit 3 | [] -> Pervasives.exit 3
| _ :: _ :: _ when !unique -> 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 commands () =
let open Cli_entries in let open Cli_entries in
let open Client_commands in
[ command ~group ~desc: "generate a pair of keys" [ command ~group ~desc: "generate a pair of keys"
(prefixes [ "gen" ; "keys" ] (prefixes [ "gen" ; "keys" ]
@@ Secret_key.fresh_alias_param @@ Secret_key.fresh_alias_param
@ -117,7 +118,7 @@ let commands () =
(fun name sk cctxt -> (fun name sk cctxt ->
Lwt.catch (fun () -> Lwt.catch (fun () ->
Public_key.find cctxt name >>= fun pk -> 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 Secret_key.add cctxt name sk
else else
cctxt.error cctxt.error
@ -156,7 +157,7 @@ let commands () =
command ~group ~desc: "forget all keys" command ~group ~desc: "forget all keys"
(fixed [ "forget" ; "all" ; "keys" ]) (fixed [ "forget" ; "all" ; "keys" ])
(fun cctxt -> (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" cctxt.Client_commands.error "this can only used with option -force true"
else else
Public_key.save cctxt [] >>= fun () -> 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 = let make_request cctxt meth service json =
incr cpt ; incr cpt ;
let cpt = !cpt in let cpt = !cpt in
let scheme = if Client_config.tls#get then "https" else "http" in let scheme = if cctxt.config.tls then "https" else "http" in
let host = Client_config.incoming_addr#get in let host = cctxt.config.incoming_addr in
let port = Client_config.incoming_port#get in let port = cctxt.config.incoming_port in
let path = String.concat "/" service in let path = String.concat "/" service in
let uri = Uri.make ~scheme ~host ~port ~path () in let uri = Uri.make ~scheme ~host ~port ~path () in
let string_uri = Uri.to_string uri 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 let ansbody = Cohttp_lwt_body.to_stream ansbody in
match code, ansbody with match code, ansbody with
| #Cohttp.Code.success_status, ansbody -> | #Cohttp.Code.success_status, ansbody ->
(if Client_config.print_timings#get then (if cctxt.config.print_timings then
cctxt.message "Request to /%s succeeded in %gs" cctxt.message "Request to /%s succeeded in %gs"
(String.concat "/" service) time (String.concat "/" service) time
else Lwt.return ()) >>= fun () -> else Lwt.return ()) >>= fun () ->
@ -64,7 +64,7 @@ let get_streamed_json cctxt meth service json =
Lwt.return None) Lwt.return None)
(Data_encoding_ezjsonm.from_stream ansbody)) (Data_encoding_ezjsonm.from_stream ansbody))
| err, _ansbody -> | err, _ansbody ->
(if Client_config.print_timings#get then (if cctxt.config.print_timings then
cctxt.message "Request to /%s failed in %gs" cctxt.message "Request to /%s failed in %gs"
(String.concat "/" service) time (String.concat "/" service) time
else Lwt.return ()) >>= fun () -> else Lwt.return ()) >>= fun () ->
@ -78,7 +78,7 @@ let get_json cctxt meth service json =
Cohttp_lwt_body.to_string ansbody >>= fun ansbody -> Cohttp_lwt_body.to_string ansbody >>= fun ansbody ->
match code, ansbody with match code, ansbody with
| #Cohttp.Code.success_status, ansbody -> begin | #Cohttp.Code.success_status, ansbody -> begin
(if Client_config.print_timings#get then (if cctxt.config.print_timings then
cctxt.message "Request to /%s succeeded in %gs" cctxt.message "Request to /%s succeeded in %gs"
(String.concat "/" service) time (String.concat "/" service) time
else Lwt.return ()) >>= fun () -> else Lwt.return ()) >>= fun () ->
@ -89,7 +89,7 @@ let get_json cctxt meth service json =
| Ok res -> Lwt.return res | Ok res -> Lwt.return res
end end
| err, _ansbody -> | err, _ansbody ->
(if Client_config.print_timings#get then (if cctxt.config.print_timings then
cctxt.message "Request to /%s failed in %gs" cctxt.message "Request to /%s failed in %gs"
(String.concat "/" service) time (String.concat "/" service) time
else Lwt.return ()) >>= fun () -> 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) ${OBJS}: EXTRA_OCAMLFLAGS = -for-pack Client_$(PROTO_VERSION)
../client_$(PROTO_VERSION).cmx: EXTRA_OCAMLFLAGS = ../client_$(PROTO_VERSION).cmx: EXTRA_OCAMLFLAGS =
${OBJS} ${OBJS_DEPS} ../client_$(PROTO_VERSION).cmx: \ ${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: \ ${OBJS} ${OBJS_DEPS} ../client_$(PROTO_VERSION).cmx: \
../../../proto/client_embedded_proto_${PROTO_VERSION}.cmxa ../../../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) ${WEBOBJS}: EXTRA_OCAMLFLAGS = -for-pack Webclient_$(PROTO_VERSION)
../client_$(PROTO_VERSION).cmx: EXTRA_OCAMLFLAGS = ../client_$(PROTO_VERSION).cmx: EXTRA_OCAMLFLAGS =
${WEBOBJS} ${WEBOBJS_DEPS} ../webclient_$(PROTO_VERSION).cmx: \ ${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: \ ${WEBOBJS} ${WEBOBJS_DEPS} ../webclient_$(PROTO_VERSION).cmx: \
../../../proto/client_embedded_proto_${PROTO_VERSION}.cmxa ../../../proto/client_embedded_proto_${PROTO_VERSION}.cmxa
${WEBOBJS} ../webclient_$(PROTO_VERSION).cmx: \ ${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 "block" Block_hash.encoding)
(req "operation" Operation_hash.encoding)))))) (req "operation" Operation_hash.encoding))))))
let filename () = let filename cctxt =
Client_config.(base_dir#get // "endorsements") Client_commands.(Filename.concat cctxt.config.base_dir "endorsements")
let load cctxt = let load cctxt =
let filename = filename () in let filename = filename cctxt in
if not (Sys.file_exists filename) then return LevelMap.empty else if not (Sys.file_exists filename) then return LevelMap.empty else
Data_encoding_ezjsonm.read_file filename >>= function Data_encoding_ezjsonm.read_file filename >>= function
| Error _ -> | Error _ ->
@ -68,10 +68,10 @@ end = struct
let save cctxt map = let save cctxt map =
Lwt.catch Lwt.catch
(fun () -> (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 (if not (Sys.file_exists dirname) then Lwt_utils.create_dir dirname
else Lwt.return ()) >>= fun () -> else Lwt.return ()) >>= fun () ->
let filename = filename () in let filename = filename cctxt in
let json = Data_encoding.Json.construct encoding map in let json = Data_encoding.Json.construct encoding map in
Data_encoding_ezjsonm.write_file filename json >>= function Data_encoding_ezjsonm.write_file filename json >>= function
| Error _ -> failwith "Json.write_file" | 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 "level" Raw_level.encoding)
(req "blocks" (list Block_hash.encoding)))) (req "blocks" (list Block_hash.encoding))))
let filename () = let filename cctxt =
Client_config.(base_dir#get // "blocks") Client_commands.(Filename.concat cctxt.config.base_dir "blocks")
let load () = let load cctxt =
let filename = filename () in let filename = filename cctxt in
if not (Sys.file_exists filename) then return LevelMap.empty else if not (Sys.file_exists filename) then return LevelMap.empty else
Data_encoding_ezjsonm.read_file filename >>= function Data_encoding_ezjsonm.read_file filename >>= function
| Error _ -> | Error _ ->
@ -188,13 +188,13 @@ end = struct
| map -> | map ->
return map return map
let save map = let save cctxt map =
Lwt.catch Lwt.catch
(fun () -> (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 (if not (Sys.file_exists dirname) then Lwt_utils.create_dir dirname
else Lwt.return ()) >>= fun () -> else Lwt.return ()) >>= fun () ->
let filename = filename () in let filename = filename cctxt in
let json = Data_encoding.Json.construct encoding map in let json = Data_encoding.Json.construct encoding map in
Data_encoding_ezjsonm.write_file filename json >>= function Data_encoding_ezjsonm.write_file filename json >>= function
| Error _ -> failwith "Json.write_file" | Error _ -> failwith "Json.write_file"
@ -206,10 +206,10 @@ end = struct
let lock = Lwt_mutex.create () let lock = Lwt_mutex.create ()
let get_block _cctxt level = let get_block cctxt level =
Lwt_mutex.with_lock lock Lwt_mutex.with_lock lock
(fun () -> (fun () ->
load () >>=? fun map -> load cctxt >>=? fun map ->
try try
let blocks = LevelMap.find level map in let blocks = LevelMap.find level map in
return blocks return blocks
@ -218,11 +218,11 @@ end = struct
let record_block cctxt level hash nonce = let record_block cctxt level hash nonce =
Lwt_mutex.with_lock lock Lwt_mutex.with_lock lock
(fun () -> (fun () ->
load () >>=? fun map -> load cctxt >>=? fun map ->
let previous = let previous =
try LevelMap.find level map try LevelMap.find level map
with Not_found -> [] in with Not_found -> [] in
save save cctxt
(LevelMap.add level (hash :: previous) map)) >>=? fun () -> (LevelMap.add level (hash :: previous) map)) >>=? fun () ->
Client_proto_nonces.add cctxt hash nonce 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 () return ()
let endorse_block cctxt ?force ?max_priority delegate = 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_keys.get_key cctxt delegate >>=? fun (_src_name, src_pk, src_sk) ->
Client_mining_endorsement.forge_endorsement cctxt 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 successfully injected in the node." >>= fun () ->
cctxt.answer "Operation hash is '%a'." Operation_hash.pp oph >>= fun () -> cctxt.answer "Operation hash is '%a'." Operation_hash.pp oph >>= fun () ->
return () return ()
@ -59,7 +58,6 @@ let do_reveal cctxt ?force block blocks =
return () return ()
let reveal_block_nonces cctxt ?force block_hashes = let reveal_block_nonces cctxt ?force block_hashes =
let block = Client_proto_args.block () in
Lwt_list.filter_map_p Lwt_list.filter_map_p
(fun hash -> (fun hash ->
Lwt.catch Lwt.catch
@ -83,13 +81,12 @@ let reveal_block_nonces cctxt ?force block_hashes =
| Some nonce -> | Some nonce ->
return (Some (bi.hash, (bi.level.level, nonce)))) return (Some (bi.hash, (bi.level.level, nonce))))
block_infos >>=? fun blocks -> block_infos >>=? fun blocks ->
do_reveal cctxt ?force block blocks do_reveal cctxt ?force cctxt.config.block blocks
let reveal_nonces cctxt ?force () = let reveal_nonces cctxt ?force () =
let block = Client_proto_args.block () in
Client_mining_forge.get_unrevealed_nonces Client_mining_forge.get_unrevealed_nonces
cctxt ?force block >>=? fun nonces -> cctxt ?force cctxt.config.block >>=? fun nonces ->
do_reveal cctxt ?force block nonces do_reveal cctxt ?force cctxt.config.block nonces
open Client_proto_args open Client_proto_args
@ -131,7 +128,7 @@ let commands () =
~name:"miner" ~desc: "name of the delegate owning the mining right" ~name:"miner" ~desc: "name of the delegate owning the mining right"
@@ stop) @@ stop)
(fun (_, delegate) cctxt -> (fun (_, delegate) cctxt ->
mine_block cctxt (block ()) mine_block cctxt cctxt.config.block
~force:!force ?max_priority:!max_priority delegate >>= ~force:!force ?max_priority:!max_priority delegate >>=
Client_proto_rpcs.handle_error cctxt) ; Client_proto_rpcs.handle_error cctxt) ;
command ~group ~desc: "Forge and inject a seed-nonce revelation operation" 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 = let tez_sym =
"\xEA\x9C\xA9" "\xEA\x9C\xA9"
let block () = Client_config.block ()
let tez_of_string s = let tez_of_string s =
match Tez.of_string s with match Tez.of_string s with
| None -> invalid_arg "tez_of_string" | 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 tez_sym: string
val init_arg: string * Arg.spec * 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 commands () =
let open Cli_entries in let open Cli_entries in
let open Client_commands in
[ command ~group ~desc: "access the timestamp of the block" [ command ~group ~desc: "access the timestamp of the block"
(fixed [ "get" ; "timestamp" ]) (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" command ~group ~desc: "lists all non empty contracts of the block"
(fixed [ "list" ; "contracts" ]) (fixed [ "list" ; "contracts" ])
(fun cctxt -> (fun cctxt ->
list_contracts cctxt (block ()) >>= fun res -> list_contracts cctxt cctxt.config.block >>= fun res ->
Client_proto_rpcs.handle_error cctxt res) ; Client_proto_rpcs.handle_error cctxt res) ;
command ~group ~desc: "get the balance of a contract" command ~group ~desc: "get the balance of a contract"
(prefixes [ "get" ; "balance" ] (prefixes [ "get" ; "balance" ]
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract" @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@@ stop) @@ stop)
(fun (_, contract) cctxt -> (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 -> >>= Client_proto_rpcs.handle_error cctxt >>= fun amount ->
cctxt.answer "%a %s" Tez.pp amount tez_sym); cctxt.answer "%a %s" Tez.pp amount tez_sym);
command ~group ~desc: "get the manager of a block" command ~group ~desc: "get the manager of a block"
@ -188,7 +189,7 @@ let commands () =
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract" @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@@ stop) @@ stop)
(fun (_, contract) cctxt -> (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 -> >>= Client_proto_rpcs.handle_error cctxt >>= fun manager ->
Public_key_hash.rev_find cctxt manager >>= fun mn -> Public_key_hash.rev_find cctxt manager >>= fun mn ->
Public_key_hash.to_source cctxt manager >>= fun m -> Public_key_hash.to_source cctxt manager >>= fun m ->
@ -213,10 +214,11 @@ let commands () =
(fun neu (_, manager) balance (_, source) cctxt -> (fun neu (_, manager) balance (_, source) cctxt ->
check_contract cctxt neu >>= fun () -> check_contract cctxt neu >>= fun () ->
get_delegate_pkh cctxt !delegate >>= fun delegate -> get_delegate_pkh cctxt !delegate >>= fun delegate ->
(Client_proto_contracts.get_manager cctxt (block ()) source >>=? fun src_pkh -> (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) -> 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 () -> 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 ~source ~src_pk ~src_sk ~manager_pkh:manager ~balance ~fee:!fee
~delegatable:!delegatable ~spendable:!spendable ?delegate:delegate ~delegatable:!delegatable ~spendable:!spendable ?delegate:delegate
()) >>= Client_proto_rpcs.handle_error cctxt >>= fun contract -> ()) >>= Client_proto_rpcs.handle_error cctxt >>= fun contract ->
@ -244,10 +246,11 @@ let commands () =
(fun neu (_, manager) balance (_, source) code cctxt -> (fun neu (_, manager) balance (_, source) code cctxt ->
check_contract cctxt neu >>= fun () -> check_contract cctxt neu >>= fun () ->
get_delegate_pkh cctxt !delegate >>= fun delegate -> get_delegate_pkh cctxt !delegate >>= fun delegate ->
(Client_proto_contracts.get_manager cctxt (block ()) source >>=? fun src_pkh -> (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) -> 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 () -> 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 ~source ~src_pk ~src_sk ~manager_pkh:manager ~balance ~fee:!fee
~delegatable:!delegatable ?delegatePubKey:delegate ~code ~init:!init ~delegatable:!delegatable ?delegatePubKey:delegate ~code ~init:!init
()) >>= Client_proto_rpcs.handle_error cctxt >>= fun contract -> ()) >>= Client_proto_rpcs.handle_error cctxt >>= fun contract ->
@ -264,7 +267,7 @@ let commands () =
@@ stop) @@ stop)
(fun neu (_, manager) cctxt -> (fun neu (_, manager) cctxt ->
check_contract cctxt neu >>= fun () -> 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) ; RawContractAlias.add cctxt neu contract) ;
command ~group ~desc: "transfer tokens" command ~group ~desc: "transfer tokens"
~args: [ fee_arg ; arg_arg ; force_arg ] ~args: [ fee_arg ; arg_arg ; force_arg ]
@ -279,10 +282,11 @@ let commands () =
~name: "dst" ~desc: "name/literal of the destination contract" ~name: "dst" ~desc: "name/literal of the destination contract"
@@ stop) @@ stop)
(fun amount (_, source) (_, destination) cctxt -> (fun amount (_, source) (_, destination) cctxt ->
(Client_proto_contracts.get_manager cctxt (block ()) source >>=? fun src_pkh -> (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) -> 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 () -> 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 -> ~source ~src_pk ~src_sk ~destination ?arg:!arg ~amount ~fee:!fee ()) >>=? fun contracts ->
Lwt_list.iter_s Lwt_list.iter_s
(fun c -> cctxt.message "New contract %a originated from a smart contract." (fun c -> cctxt.message "New contract %a originated from a smart contract."
@ -300,8 +304,7 @@ let commands () =
stop stop
end end
(fun hash seckey cctxt -> (fun hash seckey cctxt ->
let block = Client_config.block () in dictate cctxt cctxt.config.block (Activate hash) seckey >>=
dictate cctxt block (Activate hash) seckey >>=
Client_proto_rpcs.handle_error cctxt) ; Client_proto_rpcs.handle_error cctxt) ;
command ~desc: "Fork a test protocol" begin command ~desc: "Fork a test protocol" begin
prefixes [ "fork" ; "test" ; "protocol" ] @@ prefixes [ "fork" ; "test" ; "protocol" ] @@
@ -314,7 +317,6 @@ let commands () =
stop stop
end end
(fun hash seckey cctxt -> (fun hash seckey cctxt ->
let block = Client_config.block () in dictate cctxt cctxt.config.block (Activate_testnet hash) seckey >>=
dictate cctxt block (Activate_testnet hash) seckey >>=
Client_proto_rpcs.handle_error cctxt) ; 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 commands () =
let open Cli_entries in let open Cli_entries in
let open Client_commands in
[ [
command ~group ~desc: "add a contract to the wallet" command ~group ~desc: "add a contract to the wallet"
(prefixes [ "remember" ; "contract" ] (prefixes [ "remember" ; "contract" ]
@ -162,7 +163,7 @@ let commands () =
command ~group ~desc: "forget all known contracts" command ~group ~desc: "forget all known contracts"
(fixed [ "forget" ; "all" ; "contracts" ]) (fixed [ "forget" ; "all" ; "contracts" ])
(fun cctxt -> (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" cctxt.Client_commands.error "this can only used with option -force true"
else else
RawContractAlias.save cctxt []) ; 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 "block" Block_hash.encoding)
(req "nonce" Nonce.encoding)) (req "nonce" Nonce.encoding))
let filename () = let filename cctxt =
Client_config.(base_dir#get // "nonces") Client_commands.(Filename.concat cctxt.config.base_dir "nonces")
let load cctxt = let load cctxt =
let filename = filename () in let filename = filename cctxt in
if not (Sys.file_exists filename) then if not (Sys.file_exists filename) then
Lwt.return [] Lwt.return []
else else
@ -47,9 +47,9 @@ let check_dir dirname =
let save cctxt list = let save cctxt list =
Lwt.catch Lwt.catch
(fun () -> (fun () ->
let dirname = Client_config.base_dir#get in let dirname = Client_commands.(cctxt.config.base_dir) in
check_dir dirname >>= fun () -> check_dir dirname >>= fun () ->
let filename = filename () in let filename = filename cctxt in
let json = Data_encoding.Json.construct encoding list in let json = Data_encoding.Json.construct encoding list in
Data_encoding_ezjsonm.write_file filename json >>= function Data_encoding_ezjsonm.write_file filename json >>= function
| Error _ -> failwith "Json.write_file" | 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 let open Data_encoding in
if !trace_stack then if !trace_stack then
Client_proto_rpcs.Helpers.trace_code cctxt Client_proto_rpcs.Helpers.trace_code cctxt
(block ()) program (storage, input) >>= function cctxt.config.block program (storage, input) >>= function
| Ok (storage, output, trace) -> | Ok (storage, output, trace) ->
cctxt.message "@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>output@,%a@]@,@[<v 2>trace@,%a@]@]@." cctxt.message "@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>output@,%a@]@,@[<v 2>trace@,%a@]@]@."
(print_expr no_locations) storage (print_expr no_locations) storage
@ -590,7 +590,7 @@ let commands () =
cctxt.error "error running program" cctxt.error "error running program"
else else
Client_proto_rpcs.Helpers.run_code cctxt Client_proto_rpcs.Helpers.run_code cctxt
(block ()) program (storage, input) >>= function cctxt.config.block program (storage, input) >>= function
| Ok (storage, output) -> | Ok (storage, output) ->
cctxt.message "@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>output@,%a@]@]@." cctxt.message "@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>output@,%a@]@]@."
(print_expr no_locations) storage (print_expr no_locations) storage
@ -605,7 +605,7 @@ let commands () =
@@ stop) @@ stop)
(fun program cctxt -> (fun program cctxt ->
let open Data_encoding in 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 -> | Ok type_map ->
let type_map, program = unexpand_macros type_map program in let type_map, program = unexpand_macros type_map program in
cctxt.message "Well typed" >>= fun () -> cctxt.message "Well typed" >>= fun () ->
@ -624,7 +624,7 @@ let commands () =
(fun data exp_ty cctxt -> (fun data exp_ty cctxt ->
let open Data_encoding in let open Data_encoding in
Client_proto_rpcs.Helpers.typecheck_data cctxt Client_proto_rpcs.Helpers.typecheck_data cctxt
(block ()) (data, exp_ty) >>= function cctxt.config.block (data, exp_ty) >>= function
| Ok () -> | Ok () ->
cctxt.message "Well typed" cctxt.message "Well typed"
| Error errs -> | Error errs ->
@ -639,7 +639,7 @@ let commands () =
(fun data cctxt -> (fun data cctxt ->
let open Data_encoding in let open Data_encoding in
Client_proto_rpcs.Helpers.hash_data cctxt Client_proto_rpcs.Helpers.hash_data cctxt
(block ()) data >>= function cctxt.config.block data >>= function
| Ok hash -> | Ok hash ->
cctxt.message "%S" hash cctxt.message "%S" hash
| Error errs -> | Error errs ->
@ -658,7 +658,7 @@ let commands () =
(fun data (_, key) cctxt -> (fun data (_, key) cctxt ->
let open Data_encoding in let open Data_encoding in
Client_proto_rpcs.Helpers.hash_data cctxt Client_proto_rpcs.Helpers.hash_data cctxt
(block ()) data >>= function cctxt.config.block data >>= function
| Ok hash -> | Ok hash ->
let signature = Ed25519.sign key (MBytes.of_string hash) in let signature = Ed25519.sign key (MBytes.of_string hash) in
cctxt.message "Hash: %S@.Signature: %S" cctxt.message "Hash: %S@.Signature: %S"

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

@ -12,7 +12,7 @@ let protocol =
"ProtoDemoDemoDemoDemoDemoDemoDemoDemoDemoDemoD3c8k9" "ProtoDemoDemoDemoDemoDemoDemoDemoDemoDemoDemoD3c8k9"
let demo cctxt = 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 () -> cctxt.Client_commands.message "Calling the 'echo' RPC." >>= fun () ->
let msg = "test" in let msg = "test" in
Client_proto_rpcs.echo cctxt block msg >>= fun reply -> Client_proto_rpcs.echo cctxt block msg >>= fun reply ->
@ -35,7 +35,7 @@ let demo cctxt =
let mine cctxt = let mine cctxt =
let block = let block =
match Client_config.block () with match Client_commands.(cctxt.config.block) with
| `Prevalidation -> `Head 0 | `Prevalidation -> `Head 0
| `Test_prevalidation -> `Test_head 0 | `Test_prevalidation -> `Test_head 0
| b -> b in | b -> b in

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

@ -63,10 +63,10 @@ let commands () =
end end
(fun hash fitness seckey cctxt -> (fun hash fitness seckey cctxt ->
let timestamp = !timestamp in let timestamp = !timestamp in
let block = Client_config.block () in
let fitness = let fitness =
Client_embedded_proto_alpha.Fitness_repr.from_int64 fitness in 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) handle_error cctxt)
; ;
command ~args ~desc: "Fork a test protocol" begin command ~args ~desc: "Fork a test protocol" begin
@ -85,10 +85,10 @@ let commands () =
end end
(fun hash fitness seckey cctxt -> (fun hash fitness seckey cctxt ->
let timestamp = !timestamp in let timestamp = !timestamp in
let block = Client_config.block () in
let fitness = let fitness =
Client_embedded_proto_alpha.Fitness_repr.from_int64 fitness in 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) ; handle_error cctxt) ;
] ]

20
src/client_main.ml
View File

@ -12,6 +12,8 @@
open Lwt.Infix open Lwt.Infix
let cctxt = let cctxt =
(* TODO: set config as parameter? *)
let config = Client_commands.default_cfg in
let startup = let startup =
CalendarLib.Printer.Precise_Calendar.sprint CalendarLib.Printer.Precise_Calendar.sprint
"%Y-%m-%dT%H:%M:%SZ" "%Y-%m-%dT%H:%M:%SZ"
@ -24,11 +26,12 @@ let cctxt =
prerr_endline msg ; prerr_endline msg ;
Lwt.return () Lwt.return ()
| log -> | 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 Lwt_io.with_file
~flags: Unix.[ O_APPEND ; O_CREAT ; O_WRONLY ] ~flags: Unix.[ O_APPEND ; O_CREAT ; O_WRONLY ]
~mode: Lwt_io.Output ~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 (fun chan -> Lwt_io.write chan msg) in
Client_commands.make_context log Client_commands.make_context log
@ -37,9 +40,10 @@ let main () =
Random.self_init () ; Random.self_init () ;
Sodium.Random.stir () ; Sodium.Random.stir () ;
Lwt.catch begin fun () -> 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 () -> 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) Lwt.return (Some version, Client_commands.commands_for_version version)
end begin fun exn -> end begin fun exn ->
cctxt.warning cctxt.warning
@ -48,7 +52,7 @@ let main () =
| Failure msg -> msg | Failure msg -> msg
| exn -> Printexc.to_string exn) >>= fun () -> | exn -> Printexc.to_string exn) >>= fun () ->
Lwt.return (None, []) Lwt.return (None, [])
end >>= fun (version, commands_for_version) -> end >>= fun (_version, commands_for_version) ->
let commands = let commands =
Client_generic_rpcs.commands @ Client_generic_rpcs.commands @
Client_network.commands () @ Client_network.commands () @
@ -56,11 +60,11 @@ let main () =
Client_protocols.commands () @ Client_protocols.commands () @
Client_helpers.commands () @ Client_helpers.commands () @
commands_for_version in commands_for_version in
Client_config.parse_args ?version Client_config.parse_args
(Cli_entries.usage ~commands) (Cli_entries.usage ~commands)
(Cli_entries.inline_dispatch commands) (Cli_entries.inline_dispatch commands)
Sys.argv cctxt >>= fun command -> Sys.argv cctxt >>= fun (command, config) ->
command cctxt >>= fun () -> command { cctxt with config } >>= fun () ->
Lwt.return 0 Lwt.return 0
end begin function end begin function
| Arg.Help help -> | Arg.Help help ->

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

@ -107,6 +107,15 @@ module Blocks = struct
| _ -> raise Exit | _ -> raise Exit
with _ -> Error "Cannot parse block identifier." 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 blocks_arg =
let name = "block_id" in let name = "block_id" in
@ -117,15 +126,7 @@ module Blocks = struct
'test_head' or 'test_prevalidation'. One might alse use 'head~N' '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 to 'test_head~N', where N is an integer to denotes the Nth predecessors
of 'head' or 'test_head'." in of 'head' or 'test_head'." in
let construct = function let construct = to_string in
| `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 destruct = parse_block in let destruct = parse_block in
RPC.Arg.make ~name ~descr ~construct ~destruct () 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 blocks_arg : block RPC.Arg.arg
val parse_block: string -> (block, string) result val parse_block: string -> (block, string) result
val to_string: block -> string
type net = State.Net_id.t = Id of Block_hash.t type net = State.Net_id.t = Id of Block_hash.t
type block_info = { type block_info = {

2
src/tezos-deps.opam
View File

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

10
src/utils/cli_entries.ml
View File

@ -329,7 +329,11 @@ let usage
with Not_found -> with Not_found ->
(group, ref [ command ]) :: acc) (group, ref [ command ]) :: acc)
[] commands in [] commands in
List.map (fun (g, c) -> (g, List.rev !c)) grouped @ let misc = match !ungrouped with
[ { name = "untitled" ; title = "Miscellaneous commands" }, | [] -> []
List.rev !ungrouped ] in | 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) 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 let cctxt, result = make_context () in
Lwt.catch Lwt.catch
(fun () -> (fun () ->
Client_config.preparse_args argv cctxt >>= fun block -> Client_config.preparse_args argv cctxt >>= fun config ->
block_protocol cctxt block >>= fun version -> let cctxt = { cctxt with config } in
block_protocol cctxt Client_commands.(cctxt.config.block)
>>= fun version ->
let commands = let commands =
Client_generic_rpcs.commands @ Client_generic_rpcs.commands @
Client_keys.commands () @ Client_keys.commands () @
@ -59,8 +61,8 @@ let eval_command argv =
Client_config.parse_args ~version Client_config.parse_args ~version
(Cli_entries.usage ~commands) (Cli_entries.usage ~commands)
(Cli_entries.inline_dispatch commands) (Cli_entries.inline_dispatch commands)
argv cctxt >>= fun command -> argv cctxt >>= fun (command, config) ->
command cctxt >>= fun () -> command Client_commands.({ cctxt with config }) >>= fun () ->
Lwt.return (Ok (result ()))) Lwt.return (Ok (result ())))
(fun exn -> (fun exn ->
let msg = match exn with let msg = match exn with
@ -169,9 +171,13 @@ let http_proxy mode =
Lwt.return (content_type, { RPC.Answer.code = 404 ; body }) in Lwt.return (content_type, { RPC.Answer.code = 404 ; body }) in
RPC_server.launch ~pre_hook ~post_hook mode root [] [] RPC_server.launch ~pre_hook ~post_hook mode root [] []
let web_port = Client_config.in_both_groups @@ let webclient_args cfg =
new Config_file.int_cp [ "web" ; "port" ] 8080 let open Client_commands in
"The TCP port to point the web browser to." [
"-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 *) (* Where all the user friendliness starts *)
let () = let () =
@ -179,15 +185,18 @@ let () =
(Lwt.catch (Lwt.catch
(fun () -> (fun () ->
Client_config.parse_args Client_config.parse_args
~extra:webclient_args
(Cli_entries.usage ~commands: []) (Cli_entries.usage ~commands: [])
(fun () -> function (fun () -> function
| `Arg arg -> raise (Arg.Bad ("unexpected argument " ^ arg)) | `Arg arg -> raise (Arg.Bad ("unexpected argument " ^ arg))
| `End -> `Res (fun () -> Lwt.return ())) | `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 () ; Random.self_init () ;
Sodium.Random.stir () ; Sodium.Random.stir () ;
(* TODO: add TLS? *) (* 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 ())) fst (Lwt.wait ()))
(function (function
| Arg.Help help -> | Arg.Help help ->

1
test/Makefile
View File

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