Shell: Add missing CLI arguments.
- fix the semantics of `--base-dir` and `--sandbox`: - `--sandbox path` becomes : `--base-dir path --sandbox` - `--sandbox path --sandbox-param file.json` becomes `--base-dir path --sandbox=file.json` - added `--generate-identity` for generating the node cryptographic identity and the associated stamp of proof-of-work. The amount of required work can be adjusted with `--expected-pow f` where `f` is float value such as the 256-bit stamp should be below `2^(256-f)`. For instance `--expected-pow 16` requires 16 zero-bits. - added all the new p2p parameters: queue size, buffer size, ...
This commit is contained in:
commit
c194045f6e
37
README.md
37
README.md
@ -61,7 +61,7 @@ Running the node in a sandbox
|
|||||||
To run a single instance of a Tezos node in sandbox mode:
|
To run a single instance of a Tezos node in sandbox mode:
|
||||||
|
|
||||||
```
|
```
|
||||||
./tezos-node --sandbox /path/to/a/custom/data/dir --rpc-addr :::8732
|
./tezos-node --sandbox --rpc-addr :::8732
|
||||||
```
|
```
|
||||||
|
|
||||||
This "sandboxed" node will not participate in the P2P network, but will accept
|
This "sandboxed" node will not participate in the P2P network, but will accept
|
||||||
@ -77,20 +77,22 @@ test network. Use the following command to run a node that will accept incoming
|
|||||||
connections:
|
connections:
|
||||||
|
|
||||||
```
|
```
|
||||||
./tezos-node
|
./tezos-node --generate-identity --expected-pow 24.
|
||||||
```
|
```
|
||||||
|
|
||||||
The node will listen to connections coming in on `0.0.0.0:9732` (and
|
This will first generate a new node identity and compute the associated stamp
|
||||||
`[::]:9732`). All used data is stored at `$HOME/.tezos-node/`. For example,
|
of proof-of-work. Then, the node will listen to connections coming in on
|
||||||
the default configuration file is at `$HOME/.tezos-node/config`.
|
`0.0.0.0:9732` (and`[::]:9732`). All used data is stored at
|
||||||
|
`$HOME/.tezos-node/`. For example, the default configuration file is
|
||||||
|
at `$HOME/.tezos-node/config.json`.
|
||||||
|
|
||||||
To run multiple nodes on the same machine, you can duplicate and edit
|
To run multiple nodes on the same machine, you can duplicate and edit
|
||||||
`$HOME/.tezos-node/config` while making sure they don't share paths to the
|
`$HOME/.tezos-node/config.json` while making sure they don't share paths to the
|
||||||
database or any other data file (cf. options `db.store` ; `db.context` ;
|
database or any other data file (cf. options `db.store` ; `db.context` ;
|
||||||
`net.peers` and `protocol.dir`).
|
`db.protocol`, `net.peers-metadata` and `net.identity`).
|
||||||
|
|
||||||
You could also let Tezos generate a config file by specifying options on the
|
You could also let Tezos generate a config file by specifying options on the
|
||||||
command line. For instance, if `$dir/config` does not exist, the following
|
command line. For instance, if `$dir/config.json` does not exist, the following
|
||||||
command will generate it and replace the default values with the values from
|
command will generate it and replace the default values with the values from
|
||||||
the command line:
|
the command line:
|
||||||
|
|
||||||
@ -102,20 +104,23 @@ The Tezos server has a built-in mechanism to discover peers on the local
|
|||||||
network (using UDP packets broadcasted on port 7732).
|
network (using UDP packets broadcasted on port 7732).
|
||||||
|
|
||||||
If this mechanism is not sufficient, one can provide Tezos with a list of
|
If this mechanism is not sufficient, one can provide Tezos with a list of
|
||||||
initial peers, either by editing the option `net.bootstrap.peers` in the
|
initial peers, either by editing the option `net.bootstrap-peers` in the
|
||||||
`config` file, or by specifying a command line parameter:
|
`config.json` file, or by specifying a command line parameter:
|
||||||
|
|
||||||
```
|
```
|
||||||
./tezos-node --base-dir "$dir" --net-addr 127.0.0.1:2023 \
|
./tezos-node --base-dir "$dir" --net-addr 127.0.0.1:2023 \
|
||||||
--peer 127.0.0.1:2021 --peer 127.0.0.1:2022
|
--peer 127.0.0.1:2021 --peer 127.0.0.1:2022
|
||||||
```
|
```
|
||||||
|
|
||||||
If `"$dir"/config` exists, the command line options override those read in the
|
If `"$dir"/config.json` exists, the command line options override those
|
||||||
config file. Tezos won't modify the content of an existing `"$dir"/config`
|
read in the config file. By default, Tezos won't modify the content of an
|
||||||
file.
|
existing `"$dir"/config.json` file. But, you may explicit ask the node
|
||||||
|
to reset or to update the file according to the command line parameters
|
||||||
|
with the following commands line:
|
||||||
|
|
||||||
```
|
```
|
||||||
./tezos-node --config-file "$dir"/config
|
./tezos-node --reset-config --base-dir "$dir" --net-addr 127.0.0.1:9733
|
||||||
|
./tezos-node --update-config --base-dir "$dir" --net-addr 127.0.0.1:9734
|
||||||
```
|
```
|
||||||
|
|
||||||
|
|
||||||
@ -129,7 +134,7 @@ Typically, if you are not trying to run a local network and just want to
|
|||||||
explore the RPC, you would run:
|
explore the RPC, you would run:
|
||||||
|
|
||||||
```
|
```
|
||||||
./tezos-node --sandbox /path/to/a/custom/data/dir --rpc-addr :::8732
|
./tezos-node --sandbox --rpc-addr :::8732
|
||||||
```
|
```
|
||||||
|
|
||||||
The RPC interface is self-documented and the `tezos-client` executable is able
|
The RPC interface is self-documented and the `tezos-client` executable is able
|
||||||
@ -151,7 +156,7 @@ You might also want the JSON schema describing the expected input and output of
|
|||||||
a RPC. For instance:
|
a RPC. For instance:
|
||||||
|
|
||||||
```
|
```
|
||||||
./tezos-client rpc schema /block/genesis/hash
|
./tezos-client rpc schema /blocks/genesis/hash
|
||||||
```
|
```
|
||||||
|
|
||||||
Note: you can get the same information, but as a raw JSON object, with a simple
|
Note: you can get the same information, but as a raw JSON object, with a simple
|
||||||
|
@ -168,12 +168,12 @@ UTILS_LIB_INTFS := \
|
|||||||
UTILS_LIB_IMPLS := \
|
UTILS_LIB_IMPLS := \
|
||||||
utils/base48.ml \
|
utils/base48.ml \
|
||||||
utils/cli_entries.ml \
|
utils/cli_entries.ml \
|
||||||
|
utils/error_monad_sig.ml \
|
||||||
|
utils/error_monad.ml \
|
||||||
utils/data_encoding_ezjsonm.ml \
|
utils/data_encoding_ezjsonm.ml \
|
||||||
utils/time.ml \
|
utils/time.ml \
|
||||||
utils/hash.ml \
|
utils/hash.ml \
|
||||||
utils/crypto_box.ml \
|
utils/crypto_box.ml \
|
||||||
utils/error_monad_sig.ml \
|
|
||||||
utils/error_monad.ml \
|
|
||||||
utils/lwt_exit.ml \
|
utils/lwt_exit.ml \
|
||||||
utils/logging.ml \
|
utils/logging.ml \
|
||||||
utils/lwt_utils.ml \
|
utils/lwt_utils.ml \
|
||||||
|
@ -88,10 +88,10 @@ module Alias = functor (Entity : Entity) -> struct
|
|||||||
let filename = filename () in
|
let filename = filename () 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
|
||||||
| None ->
|
| Error _ ->
|
||||||
cctxt.Client_commands.error
|
cctxt.Client_commands.error
|
||||||
"couldn't to read the %s alias file" Entity.name
|
"couldn't to read the %s alias file" Entity.name
|
||||||
| Some json ->
|
| Ok json ->
|
||||||
match Data_encoding.Json.destruct encoding json with
|
match Data_encoding.Json.destruct encoding json with
|
||||||
| exception _ -> (* TODO print_error *)
|
| exception _ -> (* TODO print_error *)
|
||||||
cctxt.Client_commands.error
|
cctxt.Client_commands.error
|
||||||
@ -132,8 +132,8 @@ module Alias = functor (Entity : Entity) -> struct
|
|||||||
let filename = filename () in
|
let filename = filename () 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
|
||||||
| false -> fail (Failure "Json.write_file")
|
| Error _ -> fail (Failure "Json.write_file")
|
||||||
| true -> return ())
|
| Ok () -> return ())
|
||||||
(fun exn ->
|
(fun exn ->
|
||||||
cctxt.Client_commands.error
|
cctxt.Client_commands.error
|
||||||
"could not write the %s alias file: %s."
|
"could not write the %s alias file: %s."
|
||||||
|
@ -29,8 +29,9 @@ let load cctxt =
|
|||||||
Lwt.return []
|
Lwt.return []
|
||||||
else
|
else
|
||||||
Data_encoding_ezjsonm.read_file filename >>= function
|
Data_encoding_ezjsonm.read_file filename >>= function
|
||||||
| None -> cctxt.Client_commands.error "couldn't to read the nonces file"
|
| Error _ ->
|
||||||
| Some json ->
|
cctxt.Client_commands.error "couldn't to read the nonces file"
|
||||||
|
| Ok json ->
|
||||||
match Data_encoding.Json.destruct encoding json with
|
match Data_encoding.Json.destruct encoding json with
|
||||||
| exception _ -> (* TODO print_error *)
|
| exception _ -> (* TODO print_error *)
|
||||||
cctxt.Client_commands.error "didn't understand the nonces file"
|
cctxt.Client_commands.error "didn't understand the nonces file"
|
||||||
@ -51,8 +52,8 @@ let save cctxt list =
|
|||||||
let filename = filename () in
|
let filename = filename () 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
|
||||||
| false -> failwith "Json.write_file"
|
| Error _ -> failwith "Json.write_file"
|
||||||
| true -> return ())
|
| Ok () -> return ())
|
||||||
(fun exn ->
|
(fun exn ->
|
||||||
cctxt.Client_commands.error
|
cctxt.Client_commands.error
|
||||||
"could not write the nonces file: %s." (Printexc.to_string exn))
|
"could not write the nonces file: %s." (Printexc.to_string exn))
|
||||||
|
@ -51,9 +51,9 @@ end = struct
|
|||||||
let filename = filename () in
|
let filename = filename () 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
|
||||||
| None ->
|
| Error _ ->
|
||||||
cctxt.Client_commands.error "couldn't to read the endorsement file"
|
cctxt.Client_commands.error "couldn't to read the endorsement file"
|
||||||
| Some json ->
|
| Ok json ->
|
||||||
match Data_encoding.Json.destruct encoding json with
|
match Data_encoding.Json.destruct encoding json with
|
||||||
| exception _ -> (* TODO print_error *)
|
| exception _ -> (* TODO print_error *)
|
||||||
cctxt.Client_commands.error "didn't understand the endorsement file"
|
cctxt.Client_commands.error "didn't understand the endorsement file"
|
||||||
@ -69,8 +69,8 @@ end = struct
|
|||||||
let filename = filename () in
|
let filename = filename () 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
|
||||||
| false -> failwith "Json.write_file"
|
| Error _ -> failwith "Json.write_file"
|
||||||
| true -> return ())
|
| Ok () -> return ())
|
||||||
(fun exn ->
|
(fun exn ->
|
||||||
cctxt.Client_commands.error "could not write the endorsement file: %s."
|
cctxt.Client_commands.error "could not write the endorsement file: %s."
|
||||||
(Printexc.to_string exn))
|
(Printexc.to_string exn))
|
||||||
|
@ -171,9 +171,9 @@ end = struct
|
|||||||
let filename = filename () in
|
let filename = filename () 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
|
||||||
| None ->
|
| Error _ ->
|
||||||
failwith "couldn't to read the block file"
|
failwith "couldn't to read the block file"
|
||||||
| Some json ->
|
| Ok json ->
|
||||||
match Data_encoding.Json.destruct encoding json with
|
match Data_encoding.Json.destruct encoding json with
|
||||||
| exception _ -> (* TODO print_error *)
|
| exception _ -> (* TODO print_error *)
|
||||||
failwith "didn't understand the block file"
|
failwith "didn't understand the block file"
|
||||||
@ -189,8 +189,8 @@ end = struct
|
|||||||
let filename = filename () in
|
let filename = filename () 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
|
||||||
| false -> failwith "Json.write_file"
|
| Error _ -> failwith "Json.write_file"
|
||||||
| true -> return ())
|
| Ok () -> return ())
|
||||||
(fun exn ->
|
(fun exn ->
|
||||||
Error_monad.failwith
|
Error_monad.failwith
|
||||||
"could not write the block file: %s."
|
"could not write the block file: %s."
|
||||||
|
@ -9,13 +9,16 @@
|
|||||||
|
|
||||||
module StringMap = Map.Make (String)
|
module StringMap = Map.Make (String)
|
||||||
|
|
||||||
let split delim ?(limit = max_int) path =
|
let split delim ?(dup = true) ?(limit = max_int) path =
|
||||||
let l = String.length path in
|
let l = String.length path in
|
||||||
let rec do_slashes acc limit i =
|
let rec do_slashes acc limit i =
|
||||||
if i >= l then
|
if i >= l then
|
||||||
List.rev acc
|
List.rev acc
|
||||||
else if String.get path i = delim then
|
else if String.get path i = delim then
|
||||||
|
if dup then
|
||||||
do_slashes acc limit (i + 1)
|
do_slashes acc limit (i + 1)
|
||||||
|
else
|
||||||
|
do_split acc limit (i + 1)
|
||||||
else
|
else
|
||||||
do_split acc limit i
|
do_split acc limit i
|
||||||
and do_split acc limit i =
|
and do_split acc limit i =
|
||||||
@ -55,8 +58,8 @@ let iter_option ~f = function
|
|||||||
| None -> ()
|
| None -> ()
|
||||||
| Some x -> f x
|
| Some x -> f x
|
||||||
|
|
||||||
let unopt x = function
|
let unopt ~default = function
|
||||||
| None -> x
|
| None -> default
|
||||||
| Some x -> x
|
| Some x -> x
|
||||||
|
|
||||||
let unopt_map ~f ~default = function
|
let unopt_map ~f ~default = function
|
||||||
@ -85,8 +88,16 @@ let list_sub l n = list_rev_sub l n |> List.rev
|
|||||||
|
|
||||||
let display_paragraph ppf description =
|
let display_paragraph ppf description =
|
||||||
Format.fprintf ppf "@[%a@]"
|
Format.fprintf ppf "@[%a@]"
|
||||||
(fun ppf words -> List.iter (Format.fprintf ppf "%s@ ") words)
|
(Format.pp_print_list ~pp_sep:Format.pp_print_newline
|
||||||
(split ' ' description)
|
(fun ppf line ->
|
||||||
|
Format.pp_print_list ~pp_sep:Format.pp_print_space
|
||||||
|
(fun ppf w ->
|
||||||
|
(* replace by real spaces... *)
|
||||||
|
Format.fprintf ppf "%s@ "
|
||||||
|
(Stringext.replace_all ~pattern:"\xC2\xA0" ~with_:" " w))
|
||||||
|
ppf
|
||||||
|
(split ' ' line)))
|
||||||
|
(split ~dup:false '\n' description)
|
||||||
|
|
||||||
let rec remove_elem_from_list nb = function
|
let rec remove_elem_from_list nb = function
|
||||||
| [] -> []
|
| [] -> []
|
||||||
@ -128,6 +139,8 @@ let rec (--) i j =
|
|||||||
if j < i then acc else loop (j :: acc) (pred j) in
|
if j < i then acc else loop (j :: acc) (pred j) in
|
||||||
loop [] j
|
loop [] j
|
||||||
|
|
||||||
|
let rec repeat n x = if n <= 0 then [] else x :: repeat (pred n) x
|
||||||
|
|
||||||
let take_n_unsorted n l =
|
let take_n_unsorted n l =
|
||||||
let rec loop acc n = function
|
let rec loop acc n = function
|
||||||
| [] -> l
|
| [] -> l
|
||||||
|
@ -16,12 +16,12 @@ val split_path: string -> string list
|
|||||||
(** Splits a string on a delimier character, grouping multiple
|
(** Splits a string on a delimier character, grouping multiple
|
||||||
delimiters, and ignoring delimiters at the beginning and end of
|
delimiters, and ignoring delimiters at the beginning and end of
|
||||||
string, if [limit] is passed, stops after [limit] split(s). *)
|
string, if [limit] is passed, stops after [limit] split(s). *)
|
||||||
val split: char -> ?limit: int -> string -> string list
|
val split: char -> ?dup:bool -> ?limit: int -> string -> string list
|
||||||
|
|
||||||
val map_option: f:('a -> 'b) -> 'a option -> 'b option
|
val map_option: f:('a -> 'b) -> 'a option -> 'b option
|
||||||
val apply_option: f:('a -> 'b option) -> 'a option -> 'b option
|
val apply_option: f:('a -> 'b option) -> 'a option -> 'b option
|
||||||
val iter_option: f:('a -> unit) -> 'a option -> unit
|
val iter_option: f:('a -> unit) -> 'a option -> unit
|
||||||
val unopt: 'a -> 'a option -> 'a
|
val unopt: default:'a -> 'a option -> 'a
|
||||||
val unopt_map: f:('a -> 'b) -> default:'b -> 'a option -> 'b
|
val unopt_map: f:('a -> 'b) -> default:'b -> 'a option -> 'b
|
||||||
val unopt_list: 'a option list -> 'a list
|
val unopt_list: 'a option list -> 'a list
|
||||||
val first_some: 'a option -> 'a option -> 'a option
|
val first_some: 'a option -> 'a option -> 'a option
|
||||||
@ -51,6 +51,8 @@ val (<<) : ('b -> 'c) -> ('a -> 'b) -> 'a -> 'c
|
|||||||
(** Sequence: [i--j] is the sequence [i;i+1;...;j-1;j] *)
|
(** Sequence: [i--j] is the sequence [i;i+1;...;j-1;j] *)
|
||||||
val (--) : int -> int -> int list
|
val (--) : int -> int -> int list
|
||||||
|
|
||||||
|
val repeat: int -> 'a -> 'a list
|
||||||
|
|
||||||
(** [take_n n l] returns the [n] first elements of [n]. When [compare]
|
(** [take_n n l] returns the [n] first elements of [n]. When [compare]
|
||||||
is provided, it returns the [n] greatest element of [l]. *)
|
is provided, it returns the [n] greatest element of [l]. *)
|
||||||
val take_n: ?compare:('a -> 'a -> int) -> int -> 'a list -> 'a list
|
val take_n: ?compare:('a -> 'a -> int) -> int -> 'a list -> 'a list
|
||||||
|
@ -224,7 +224,7 @@ end
|
|||||||
|
|
||||||
module Fake = struct
|
module Fake = struct
|
||||||
|
|
||||||
let id = Identity.generate Crypto_box.default_target
|
let id = Identity.generate (Crypto_box.make_target 0.)
|
||||||
let empty_stat = {
|
let empty_stat = {
|
||||||
Stat.total_sent = 0 ;
|
Stat.total_sent = 0 ;
|
||||||
total_recv = 0 ;
|
total_recv = 0 ;
|
||||||
@ -261,9 +261,8 @@ type ('msg, 'meta) t = {
|
|||||||
}
|
}
|
||||||
type ('msg, 'meta) net = ('msg, 'meta) t
|
type ('msg, 'meta) net = ('msg, 'meta) t
|
||||||
|
|
||||||
let bootstrap ~config ~limits meta_cfg msg_cfg =
|
let create ~config ~limits meta_cfg msg_cfg =
|
||||||
Real.create ~config ~limits meta_cfg msg_cfg >>= fun net ->
|
Real.create ~config ~limits meta_cfg msg_cfg >>= fun net ->
|
||||||
Real.maintain net () >>= fun () ->
|
|
||||||
Lwt.return {
|
Lwt.return {
|
||||||
gid = Real.gid net ;
|
gid = Real.gid net ;
|
||||||
maintain = Real.maintain net ;
|
maintain = Real.maintain net ;
|
||||||
|
@ -124,7 +124,7 @@ type ('msg, 'meta) net = ('msg, 'meta) t
|
|||||||
val faked_network : ('msg, 'meta) net
|
val faked_network : ('msg, 'meta) net
|
||||||
|
|
||||||
(** Main network initialisation function *)
|
(** Main network initialisation function *)
|
||||||
val bootstrap :
|
val create :
|
||||||
config:config -> limits:limits ->
|
config:config -> limits:limits ->
|
||||||
'meta meta_config -> 'msg message_config -> ('msg, 'meta) net Lwt.t
|
'meta meta_config -> 'msg message_config -> ('msg, 'meta) net Lwt.t
|
||||||
|
|
||||||
|
@ -634,16 +634,16 @@ let create config meta_config message_config io_sched =
|
|||||||
events ;
|
events ;
|
||||||
} in
|
} in
|
||||||
List.iter (Points.set_trusted pool) config.trusted_points ;
|
List.iter (Points.set_trusted pool) config.trusted_points ;
|
||||||
Lwt.catch
|
Gid_info.File.load config.peers_file meta_config.encoding >>= function
|
||||||
(fun () ->
|
| Ok gids ->
|
||||||
Gid_info.File.load config.peers_file meta_config.encoding)
|
|
||||||
(fun _ ->
|
|
||||||
(* TODO log error *)
|
|
||||||
Lwt.return_nil) >>= fun gids ->
|
|
||||||
List.iter
|
List.iter
|
||||||
(fun gi -> Gid.Table.add pool.known_gids (Gid_info.gid gi) gi)
|
(fun gi -> Gid.Table.add pool.known_gids (Gid_info.gid gi) gi)
|
||||||
gids ;
|
gids ;
|
||||||
Lwt.return pool
|
Lwt.return pool
|
||||||
|
| Error err ->
|
||||||
|
log_error "@[Failed to parsed peers file:@ %a@]"
|
||||||
|
pp_print_error err ;
|
||||||
|
Lwt.return pool
|
||||||
|
|
||||||
let destroy pool =
|
let destroy pool =
|
||||||
Point.Table.fold (fun _point pi acc ->
|
Point.Table.fold (fun _point pi acc ->
|
||||||
|
@ -449,9 +449,11 @@ module Gid_info = struct
|
|||||||
|
|
||||||
let load path metadata_encoding =
|
let load path metadata_encoding =
|
||||||
let enc = Data_encoding.list (encoding metadata_encoding) in
|
let enc = Data_encoding.list (encoding metadata_encoding) in
|
||||||
Data_encoding_ezjsonm.read_file path >|=
|
if path <> "/dev/null" && Sys.file_exists path then
|
||||||
map_option ~f:(Data_encoding.Json.destruct enc) >|=
|
Data_encoding_ezjsonm.read_file path >>=? fun json ->
|
||||||
unopt []
|
return (Data_encoding.Json.destruct enc json)
|
||||||
|
else
|
||||||
|
return []
|
||||||
|
|
||||||
let save path metadata_encoding peers =
|
let save path metadata_encoding peers =
|
||||||
let open Data_encoding in
|
let open Data_encoding in
|
||||||
|
@ -256,10 +256,10 @@ module Gid_info : sig
|
|||||||
module File : sig
|
module File : sig
|
||||||
val load :
|
val load :
|
||||||
string -> 'meta Data_encoding.t ->
|
string -> 'meta Data_encoding.t ->
|
||||||
('conn, 'meta) gid_info list Lwt.t
|
('conn, 'meta) gid_info list tzresult Lwt.t
|
||||||
val save :
|
val save :
|
||||||
string -> 'meta Data_encoding.t ->
|
string -> 'meta Data_encoding.t ->
|
||||||
('conn, 'meta) gid_info list -> bool Lwt.t
|
('conn, 'meta) gid_info list -> unit tzresult Lwt.t
|
||||||
end
|
end
|
||||||
|
|
||||||
end
|
end
|
||||||
|
@ -147,7 +147,7 @@ module Scheduler(IO : IO) = struct
|
|||||||
canceler = Canceler.create () ;
|
canceler = Canceler.create () ;
|
||||||
worker = Lwt.return_unit ;
|
worker = Lwt.return_unit ;
|
||||||
counter = Moving_average.create ~init:0 ~alpha ;
|
counter = Moving_average.create ~init:0 ~alpha ;
|
||||||
max_speed ; quota = unopt 0 max_speed ;
|
max_speed ; quota = unopt ~default:0 max_speed ;
|
||||||
quota_updated = Lwt_condition.create () ;
|
quota_updated = Lwt_condition.create () ;
|
||||||
readys = Lwt_condition.create () ;
|
readys = Lwt_condition.create () ;
|
||||||
readys_high = Queue.create () ;
|
readys_high = Queue.create () ;
|
||||||
@ -358,9 +358,9 @@ let write_now { write_queue } msg = Lwt_pipe.push_now write_queue msg
|
|||||||
|
|
||||||
let read_from conn ?pos ?len buf msg =
|
let read_from conn ?pos ?len buf msg =
|
||||||
let maxlen = MBytes.length buf in
|
let maxlen = MBytes.length buf in
|
||||||
let pos = unopt 0 pos in
|
let pos = unopt ~default:0 pos in
|
||||||
assert (0 <= pos && pos < maxlen) ;
|
assert (0 <= pos && pos < maxlen) ;
|
||||||
let len = unopt (maxlen - pos) len in
|
let len = unopt ~default:(maxlen - pos) len in
|
||||||
assert (len <= maxlen - pos) ;
|
assert (len <= maxlen - pos) ;
|
||||||
match msg with
|
match msg with
|
||||||
| Ok msg ->
|
| Ok msg ->
|
||||||
@ -400,8 +400,8 @@ let read conn ?pos ?len buf =
|
|||||||
|
|
||||||
let read_full conn ?pos ?len buf =
|
let read_full conn ?pos ?len buf =
|
||||||
let maxlen = MBytes.length buf in
|
let maxlen = MBytes.length buf in
|
||||||
let pos = unopt 0 pos in
|
let pos = unopt ~default:0 pos in
|
||||||
let len = unopt (maxlen - pos) len in
|
let len = unopt ~default:(maxlen - pos) len in
|
||||||
assert (0 <= pos && pos < maxlen) ;
|
assert (0 <= pos && pos < maxlen) ;
|
||||||
assert (len <= maxlen - pos) ;
|
assert (len <= maxlen - pos) ;
|
||||||
let rec loop pos len =
|
let rec loop pos len =
|
||||||
|
@ -79,6 +79,7 @@ let rec try_to_contact
|
|||||||
let contactable =
|
let contactable =
|
||||||
connectable st start_time max_to_contact in
|
connectable st start_time max_to_contact in
|
||||||
if contactable = [] then
|
if contactable = [] then
|
||||||
|
Lwt_unix.yield () >>= fun () ->
|
||||||
Lwt.return_false
|
Lwt.return_false
|
||||||
else
|
else
|
||||||
List.fold_left
|
List.fold_left
|
||||||
@ -111,11 +112,11 @@ let rec maintain st =
|
|||||||
and too_few_connections st n_connected =
|
and too_few_connections st n_connected =
|
||||||
let Pool pool = st.pool in
|
let Pool pool = st.pool in
|
||||||
(* too few connections, try and contact many peers *)
|
(* too few connections, try and contact many peers *)
|
||||||
lwt_debug "Too few connections (%d)" n_connected >>= fun () ->
|
lwt_log_notice "Too few connections (%d)" n_connected >>= fun () ->
|
||||||
let min_to_contact = st.bounds.min_target - n_connected in
|
let min_to_contact = st.bounds.min_target - n_connected in
|
||||||
let max_to_contact = st.bounds.max_target - n_connected in
|
let max_to_contact = st.bounds.max_target - n_connected in
|
||||||
try_to_contact st min_to_contact max_to_contact >>= fun continue ->
|
try_to_contact st min_to_contact max_to_contact >>= fun success ->
|
||||||
if not continue then begin
|
if success then begin
|
||||||
maintain st
|
maintain st
|
||||||
end else begin
|
end else begin
|
||||||
(* not enough contacts, ask the pals of our pals,
|
(* not enough contacts, ask the pals of our pals,
|
||||||
|
@ -193,12 +193,55 @@ module Identity = struct
|
|||||||
(req "secret_key" Crypto_box.secret_key_encoding)
|
(req "secret_key" Crypto_box.secret_key_encoding)
|
||||||
(req "proof_of_work_stamp" Crypto_box.nonce_encoding))
|
(req "proof_of_work_stamp" Crypto_box.nonce_encoding))
|
||||||
|
|
||||||
let generate target =
|
let generate ?max target =
|
||||||
let secret_key, public_key, gid = Crypto_box.random_keypair () in
|
let secret_key, public_key, gid = Crypto_box.random_keypair () in
|
||||||
let proof_of_work_stamp =
|
let proof_of_work_stamp =
|
||||||
Crypto_box.generate_proof_of_work public_key target in
|
Crypto_box.generate_proof_of_work ?max public_key target in
|
||||||
{ gid ; public_key ; secret_key ; proof_of_work_stamp }
|
{ gid ; public_key ; secret_key ; proof_of_work_stamp }
|
||||||
|
|
||||||
|
let animation = [|
|
||||||
|
"|.....|" ;
|
||||||
|
"|o....|" ;
|
||||||
|
"|oo...|" ;
|
||||||
|
"|ooo..|" ;
|
||||||
|
"|.ooo.|" ;
|
||||||
|
"|..ooo|" ;
|
||||||
|
"|...oo|" ;
|
||||||
|
"|....o|" ;
|
||||||
|
"|.....|" ;
|
||||||
|
"|.....|" ;
|
||||||
|
"|.....|" ;
|
||||||
|
"|.....|" ;
|
||||||
|
|]
|
||||||
|
|
||||||
|
let init = String.make (String.length animation.(0)) '\ '
|
||||||
|
let clean = String.make (String.length animation.(0)) '\b'
|
||||||
|
let animation = Array.map (fun x -> clean ^ x) animation
|
||||||
|
let animation_size = Array.length animation
|
||||||
|
let duration = 1200 / animation_size
|
||||||
|
|
||||||
|
let generate_with_animation ppf target =
|
||||||
|
Format.fprintf ppf "%s%!" init ;
|
||||||
|
let count = ref 10000 in
|
||||||
|
let rec loop n =
|
||||||
|
let start = Mtime.counter () in
|
||||||
|
Format.fprintf ppf "%s%!" animation.(n mod animation_size);
|
||||||
|
try generate ~max:!count target
|
||||||
|
with Not_found ->
|
||||||
|
let time = Mtime.to_ms (Mtime.count start) in
|
||||||
|
count :=
|
||||||
|
if time <= 0. then
|
||||||
|
!count * 10
|
||||||
|
else
|
||||||
|
!count * duration / int_of_float time ;
|
||||||
|
loop (n+1)
|
||||||
|
in
|
||||||
|
let id = loop 0 in
|
||||||
|
Format.fprintf ppf "%s%s\n%!" clean init ;
|
||||||
|
id
|
||||||
|
|
||||||
|
let generate target = generate target
|
||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
module Connection_info = struct
|
module Connection_info = struct
|
||||||
|
@ -94,6 +94,12 @@ module Identity : sig
|
|||||||
val generate : Crypto_box.target -> t
|
val generate : Crypto_box.target -> t
|
||||||
(** [generate target] is a freshly minted identity whose proof of
|
(** [generate target] is a freshly minted identity whose proof of
|
||||||
work stamp difficulty is at least equal to [target]. *)
|
work stamp difficulty is at least equal to [target]. *)
|
||||||
|
|
||||||
|
val generate_with_animation :
|
||||||
|
Format.formatter -> Crypto_box.target -> t
|
||||||
|
(** [generate_with_animation ppf target] is a freshly minted identity
|
||||||
|
whose proof of work stamp difficulty is at least equal to [target]. *)
|
||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
|
|
||||||
|
@ -211,10 +211,21 @@ let init_p2p net_params =
|
|||||||
Lwt.return Tezos_p2p.faked_network
|
Lwt.return Tezos_p2p.faked_network
|
||||||
| Some (config, limits) ->
|
| Some (config, limits) ->
|
||||||
lwt_log_notice "bootstraping network..." >>= fun () ->
|
lwt_log_notice "bootstraping network..." >>= fun () ->
|
||||||
Tezos_p2p.bootstrap config limits
|
Tezos_p2p.create config limits >>= fun p2p ->
|
||||||
|
Lwt.async (fun () -> Tezos_p2p.maintain p2p) ;
|
||||||
|
Lwt.return p2p
|
||||||
|
|
||||||
let create
|
type config = {
|
||||||
~genesis ~store_root ~context_root ?test_protocol ?patch_context net_params =
|
genesis: Store.genesis ;
|
||||||
|
store_root: string ;
|
||||||
|
context_root: string ;
|
||||||
|
test_protocol: Protocol_hash.t option ;
|
||||||
|
patch_context: (Context.t -> Context.t Lwt.t) option ;
|
||||||
|
p2p: (P2p.config * P2p.limits) option ;
|
||||||
|
}
|
||||||
|
|
||||||
|
let create { genesis ; store_root ; context_root ;
|
||||||
|
test_protocol ; patch_context ; p2p = net_params } =
|
||||||
lwt_debug "-> Node.create" >>= fun () ->
|
lwt_debug "-> Node.create" >>= fun () ->
|
||||||
init_p2p net_params >>= fun p2p ->
|
init_p2p net_params >>= fun p2p ->
|
||||||
lwt_log_info "reading state..." >>= fun () ->
|
lwt_log_info "reading state..." >>= fun () ->
|
||||||
@ -234,11 +245,12 @@ let create
|
|||||||
end >>=? fun global_net ->
|
end >>=? fun global_net ->
|
||||||
Validator.activate validator global_net >>= fun global_validator ->
|
Validator.activate validator global_net >>= fun global_validator ->
|
||||||
let cleanup () =
|
let cleanup () =
|
||||||
|
Tezos_p2p.shutdown p2p >>= fun () ->
|
||||||
Lwt.join [ Validator.shutdown validator ;
|
Lwt.join [ Validator.shutdown validator ;
|
||||||
Discoverer.shutdown discoverer ] >>= fun () ->
|
Discoverer.shutdown discoverer ] >>= fun () ->
|
||||||
State.store state
|
State.store state
|
||||||
in
|
in
|
||||||
|
let canceler = Lwt_utils.Canceler.create () in
|
||||||
lwt_log_info "starting worker..." >>= fun () ->
|
lwt_log_info "starting worker..." >>= fun () ->
|
||||||
let worker =
|
let worker =
|
||||||
let handle_msg peer msg =
|
let handle_msg peer msg =
|
||||||
@ -249,22 +261,23 @@ let create
|
|||||||
Lwt.return_unit
|
Lwt.return_unit
|
||||||
in
|
in
|
||||||
let rec worker_loop () =
|
let rec worker_loop () =
|
||||||
Tezos_p2p.recv p2p >>= fun (peer, msg) ->
|
Lwt_utils.protect ~canceler begin fun () ->
|
||||||
|
Tezos_p2p.recv p2p >>= return
|
||||||
|
end >>=? fun (peer, msg) ->
|
||||||
handle_msg peer msg >>= fun () ->
|
handle_msg peer msg >>= fun () ->
|
||||||
worker_loop () in
|
worker_loop () in
|
||||||
Lwt.catch
|
worker_loop () >>= function
|
||||||
worker_loop
|
| Error [Lwt_utils.Canceled] | Ok () ->
|
||||||
(function
|
cleanup ()
|
||||||
| Queue.Empty -> cleanup ()
|
| Error err ->
|
||||||
| exn ->
|
lwt_log_error
|
||||||
lwt_log_error "unexpected exception in worker\n%s"
|
"@[Unexpected error in worker@ %a@]"
|
||||||
(Printexc.to_string exn) >>= fun () ->
|
pp_print_error err >>= fun () ->
|
||||||
Tezos_p2p.shutdown p2p >>= fun () ->
|
cleanup ()
|
||||||
cleanup ())
|
|
||||||
in
|
in
|
||||||
let shutdown () =
|
let shutdown () =
|
||||||
lwt_log_info "stopping worker..." >>= fun () ->
|
lwt_log_info "stopping worker..." >>= fun () ->
|
||||||
Tezos_p2p.shutdown p2p >>= fun () ->
|
Lwt_utils.Canceler.cancel canceler >>= fun () ->
|
||||||
worker >>= fun () ->
|
worker >>= fun () ->
|
||||||
lwt_log_info "stopped"
|
lwt_log_info "stopped"
|
||||||
in
|
in
|
||||||
|
@ -9,14 +9,16 @@
|
|||||||
|
|
||||||
type t
|
type t
|
||||||
|
|
||||||
val create:
|
type config = {
|
||||||
genesis:Store.genesis ->
|
genesis: Store.genesis ;
|
||||||
store_root:string ->
|
store_root: string ;
|
||||||
context_root:string ->
|
context_root: string ;
|
||||||
?test_protocol:Protocol_hash.t ->
|
test_protocol: Protocol_hash.t option ;
|
||||||
?patch_context:(Context.t -> Context.t Lwt.t) ->
|
patch_context: (Context.t -> Context.t Lwt.t) option ;
|
||||||
(P2p.config * P2p.limits) option ->
|
p2p: (P2p.config * P2p.limits) option ;
|
||||||
t tzresult Lwt.t
|
}
|
||||||
|
|
||||||
|
val create: config -> t tzresult Lwt.t
|
||||||
|
|
||||||
module RPC : sig
|
module RPC : sig
|
||||||
|
|
||||||
|
@ -394,9 +394,9 @@ let build_rpc_directory node =
|
|||||||
let dir =
|
let dir =
|
||||||
let implementation (net_id, pred, time, fitness, operations, header) =
|
let implementation (net_id, pred, time, fitness, operations, header) =
|
||||||
Node.RPC.block_info node (`Head 0) >>= fun bi ->
|
Node.RPC.block_info node (`Head 0) >>= fun bi ->
|
||||||
let timestamp = Utils.unopt (Time.now ()) time in
|
let timestamp = Utils.unopt ~default:(Time.now ()) time in
|
||||||
let net_id = Utils.unopt bi.net net_id in
|
let net_id = Utils.unopt ~default:bi.net net_id in
|
||||||
let predecessor = Utils.unopt bi.hash pred in
|
let predecessor = Utils.unopt ~default:bi.hash pred in
|
||||||
let res =
|
let res =
|
||||||
Store.Block.to_bytes {
|
Store.Block.to_bytes {
|
||||||
shell = { net_id ; predecessor ; timestamp ; fitness ; operations } ;
|
shell = { net_id ; predecessor ; timestamp ; fitness ; operations } ;
|
||||||
|
@ -524,7 +524,7 @@ let inject_block =
|
|||||||
(fun (block, blocking, force) ->
|
(fun (block, blocking, force) ->
|
||||||
(block, Some blocking, force))
|
(block, Some blocking, force))
|
||||||
(fun (block, blocking, force) ->
|
(fun (block, blocking, force) ->
|
||||||
(block, Utils.unopt true blocking, force))
|
(block, Utils.unopt ~default:true blocking, force))
|
||||||
(obj3
|
(obj3
|
||||||
(req "data" bytes)
|
(req "data" bytes)
|
||||||
(opt "blocking"
|
(opt "blocking"
|
||||||
@ -555,25 +555,23 @@ let inject_operation =
|
|||||||
RPCs ubder /blocks/prevalidation for more details on the \
|
RPCs ubder /blocks/prevalidation for more details on the \
|
||||||
prevalidation context."
|
prevalidation context."
|
||||||
~input:
|
~input:
|
||||||
(conv
|
|
||||||
(fun (block, blocking, force) -> (block, Some blocking, force))
|
|
||||||
(fun (block, blocking, force) -> (block, unopt true blocking, force))
|
|
||||||
(obj3
|
(obj3
|
||||||
(req "signedOperationContents"
|
(req "signedOperationContents"
|
||||||
(describe ~title: "Tezos signed operation (hex encoded)"
|
(describe ~title: "Tezos signed operation (hex encoded)"
|
||||||
bytes))
|
bytes))
|
||||||
(opt "blocking"
|
(dft "blocking"
|
||||||
(describe
|
(describe
|
||||||
~description:
|
~description:
|
||||||
"Should the RPC wait for the operation to be \
|
"Should the RPC wait for the operation to be \
|
||||||
(pre-)validated before to answer. (default: true)"
|
(pre-)validated before to answer. (default: true)"
|
||||||
bool))
|
bool)
|
||||||
|
true)
|
||||||
(opt "force"
|
(opt "force"
|
||||||
(describe
|
(describe
|
||||||
~description:
|
~description:
|
||||||
"Should we inject operation that are \"branch_refused\" \
|
"Should we inject operation that are \"branch_refused\" \
|
||||||
or \"branch_delayed\". (default: false)"
|
or \"branch_delayed\". (default: false)"
|
||||||
bool))))
|
bool)))
|
||||||
~output:
|
~output:
|
||||||
(Error.wrap @@
|
(Error.wrap @@
|
||||||
describe
|
describe
|
||||||
@ -582,7 +580,18 @@ let inject_operation =
|
|||||||
RPC.Path.(root / "inject_operation")
|
RPC.Path.(root / "inject_operation")
|
||||||
|
|
||||||
let inject_protocol =
|
let inject_protocol =
|
||||||
|
let proto_of_rpc =
|
||||||
|
List.map (fun (name, interface, implementation) ->
|
||||||
|
{ Tezos_compiler.Protocol.name; interface; implementation })
|
||||||
|
in
|
||||||
|
let rpc_of_proto =
|
||||||
|
List.map (fun { Tezos_compiler.Protocol.name; interface; implementation } ->
|
||||||
|
(name, interface, implementation))
|
||||||
|
in
|
||||||
let proto =
|
let proto =
|
||||||
|
conv
|
||||||
|
rpc_of_proto
|
||||||
|
proto_of_rpc
|
||||||
(list
|
(list
|
||||||
(obj3
|
(obj3
|
||||||
(req "name"
|
(req "name"
|
||||||
@ -597,36 +606,26 @@ let inject_protocol =
|
|||||||
~description:"Content of the .ml file"
|
~description:"Content of the .ml file"
|
||||||
string))))
|
string))))
|
||||||
in
|
in
|
||||||
let proto_of_rpc =
|
|
||||||
List.map (fun (name, interface, implementation) ->
|
|
||||||
{ Tezos_compiler.Protocol.name; interface; implementation })
|
|
||||||
in
|
|
||||||
let rpc_of_proto =
|
|
||||||
List.map (fun { Tezos_compiler.Protocol.name; interface; implementation } ->
|
|
||||||
(name, interface, implementation))
|
|
||||||
in
|
|
||||||
RPC.service
|
RPC.service
|
||||||
~description:
|
~description:
|
||||||
"Inject a protocol in node. Returns the ID of the protocol."
|
"Inject a protocol in node. Returns the ID of the protocol."
|
||||||
~input:
|
~input:
|
||||||
(conv
|
|
||||||
(fun (proto, blocking, force) -> (rpc_of_proto proto, Some blocking, force))
|
|
||||||
(fun (proto, blocking, force) -> (proto_of_rpc proto, unopt true blocking, force))
|
|
||||||
(obj3
|
(obj3
|
||||||
(req "protocol"
|
(req "protocol"
|
||||||
(describe ~title: "Tezos protocol"
|
(describe ~title: "Tezos protocol"
|
||||||
proto))
|
proto))
|
||||||
(opt "blocking"
|
(dft "blocking"
|
||||||
(describe
|
(describe
|
||||||
~description:
|
~description:
|
||||||
"Should the RPC wait for the protocol to be \
|
"Should the RPC wait for the protocol to be \
|
||||||
validated before to answer. (default: true)"
|
validated before to answer. (default: true)"
|
||||||
bool))
|
bool)
|
||||||
|
true)
|
||||||
(opt "force"
|
(opt "force"
|
||||||
(describe
|
(describe
|
||||||
~description:
|
~description:
|
||||||
"Should we inject protocol that is invalid. (default: false)"
|
"Should we inject protocol that is invalid. (default: false)"
|
||||||
bool))))
|
bool)))
|
||||||
~output:
|
~output:
|
||||||
(Error.wrap @@
|
(Error.wrap @@
|
||||||
describe
|
describe
|
||||||
|
@ -699,7 +699,8 @@ module Valid_block = struct
|
|||||||
(* TODO check coherency: test_protocol. *)
|
(* TODO check coherency: test_protocol. *)
|
||||||
Lwt.return res
|
Lwt.return res
|
||||||
| None ->
|
| None ->
|
||||||
let test_protocol = Utils.unopt genesis.protocol test_protocol in
|
let test_protocol =
|
||||||
|
Utils.unopt ~default:genesis.protocol test_protocol in
|
||||||
Context.create_genesis_context
|
Context.create_genesis_context
|
||||||
vstate.index genesis test_protocol >>= fun _context ->
|
vstate.index genesis test_protocol >>= fun _context ->
|
||||||
Block.db_store vstate.block_db genesis.block {
|
Block.db_store vstate.block_db genesis.block {
|
||||||
|
@ -106,8 +106,8 @@ and msg_cfg : _ P2p.message_config = {
|
|||||||
|
|
||||||
type net = (Message.t, Metadata.t) P2p.net
|
type net = (Message.t, Metadata.t) P2p.net
|
||||||
|
|
||||||
let bootstrap ~config ~limits =
|
let create ~config ~limits =
|
||||||
P2p.bootstrap ~config ~limits meta_cfg msg_cfg
|
P2p.create ~config ~limits meta_cfg msg_cfg
|
||||||
|
|
||||||
let broadcast = P2p.broadcast
|
let broadcast = P2p.broadcast
|
||||||
let try_send = P2p.try_send
|
let try_send = P2p.try_send
|
||||||
|
@ -8,7 +8,7 @@ type net
|
|||||||
val faked_network : net
|
val faked_network : net
|
||||||
|
|
||||||
(** Main network initialisation function *)
|
(** Main network initialisation function *)
|
||||||
val bootstrap : config:config -> limits:limits -> net Lwt.t
|
val create : config:config -> limits:limits -> net Lwt.t
|
||||||
|
|
||||||
(** A maintenance operation : try and reach the ideal number of peers *)
|
(** A maintenance operation : try and reach the ideal number of peers *)
|
||||||
val maintain : net -> unit Lwt.t
|
val maintain : net -> unit Lwt.t
|
||||||
|
1075
src/node_main.ml
1075
src/node_main.ml
File diff suppressed because it is too large
Load Diff
@ -15,7 +15,7 @@ type secret_key = Sodium.Box.secret_key
|
|||||||
type public_key = Sodium.Box.public_key
|
type public_key = Sodium.Box.public_key
|
||||||
type channel_key = Sodium.Box.channel_key
|
type channel_key = Sodium.Box.channel_key
|
||||||
type nonce = Sodium.Box.nonce
|
type nonce = Sodium.Box.nonce
|
||||||
type target = int64 list (* used as unsigned intergers... *)
|
type target = Z.t
|
||||||
exception TargetNot256Bit
|
exception TargetNot256Bit
|
||||||
|
|
||||||
module Public_key_hash = Hash.Make_Blake2B (Base48) (struct
|
module Public_key_hash = Hash.Make_Blake2B (Base48) (struct
|
||||||
@ -44,24 +44,29 @@ let fast_box_open ck msg nonce =
|
|||||||
try Some (Sodium.Box.Bigbytes.fast_box_open ck msg nonce) with
|
try Some (Sodium.Box.Bigbytes.fast_box_open ck msg nonce) with
|
||||||
| Sodium.Verification_failure -> None
|
| Sodium.Verification_failure -> None
|
||||||
|
|
||||||
let make_target target =
|
|
||||||
if List.length target > 8 then raise TargetNot256Bit ;
|
|
||||||
target
|
|
||||||
|
|
||||||
(* Compare a SHA256 hash to a 256bits-target prefix.
|
|
||||||
The prefix is a list of "unsigned" int64. *)
|
|
||||||
let compare_target hash target =
|
let compare_target hash target =
|
||||||
let hash = Hash.Generic_hash.to_string hash in
|
let hash = Z.of_bits (Hash.Generic_hash.to_string hash) in
|
||||||
let rec check offset = function
|
Z.compare hash target <= 0
|
||||||
| [] -> true
|
|
||||||
| x :: xs ->
|
|
||||||
Compare.Uint64.(EndianString.BigEndian.get_int64 hash offset <= x)
|
|
||||||
&& check (offset + 8) xs in
|
|
||||||
check 0 target
|
|
||||||
|
|
||||||
let default_target =
|
let make_target f =
|
||||||
(* FIXME we use an easy target until we allow custom configuration. *)
|
if f < 0. || 256. < f then invalid_arg "Cryptobox.target_of_float" ;
|
||||||
[ Int64.shift_left 1L 48 ]
|
let frac, shift = modf f in
|
||||||
|
let shift = int_of_float shift in
|
||||||
|
let m =
|
||||||
|
Z.of_int64 @@
|
||||||
|
if frac = 0. then
|
||||||
|
Int64.(pred (shift_left 1L 54))
|
||||||
|
else
|
||||||
|
Int64.of_float (2. ** (54. -. frac))
|
||||||
|
in
|
||||||
|
if shift < 202 then
|
||||||
|
Z.logor
|
||||||
|
(Z.shift_left m (202 - shift))
|
||||||
|
(Z.pred @@ Z.shift_left Z.one (202 - shift))
|
||||||
|
else
|
||||||
|
Z.shift_right m (shift - 202)
|
||||||
|
|
||||||
|
let default_target = make_target 24.
|
||||||
|
|
||||||
let check_proof_of_work pk nonce target =
|
let check_proof_of_work pk nonce target =
|
||||||
let hash =
|
let hash =
|
||||||
@ -71,11 +76,18 @@ let check_proof_of_work pk nonce target =
|
|||||||
] in
|
] in
|
||||||
compare_target hash target
|
compare_target hash target
|
||||||
|
|
||||||
let generate_proof_of_work pk target =
|
let generate_proof_of_work ?max pk target =
|
||||||
let rec loop nonce =
|
let may_interupt =
|
||||||
if check_proof_of_work pk nonce target then nonce
|
match max with
|
||||||
else loop (increment_nonce nonce) in
|
| None -> (fun _ -> ())
|
||||||
loop (random_nonce ())
|
| Some max -> (fun cpt -> if max < cpt then raise Not_found) in
|
||||||
|
let rec loop nonce cpt =
|
||||||
|
may_interupt cpt ;
|
||||||
|
if check_proof_of_work pk nonce target then
|
||||||
|
nonce
|
||||||
|
else
|
||||||
|
loop (increment_nonce nonce) (cpt + 1) in
|
||||||
|
loop (random_nonce ()) 0
|
||||||
|
|
||||||
let public_key_encoding =
|
let public_key_encoding =
|
||||||
let open Data_encoding in
|
let open Data_encoding in
|
||||||
|
@ -16,8 +16,8 @@ val increment_nonce : ?step:int -> nonce -> nonce
|
|||||||
val nonce_encoding : nonce Data_encoding.t
|
val nonce_encoding : nonce Data_encoding.t
|
||||||
|
|
||||||
type target
|
type target
|
||||||
val make_target : (* unsigned *) Int64.t list -> target
|
|
||||||
val default_target : target
|
val default_target : target
|
||||||
|
val make_target : float -> target
|
||||||
|
|
||||||
type secret_key
|
type secret_key
|
||||||
type public_key
|
type public_key
|
||||||
@ -38,5 +38,5 @@ val fast_box : channel_key -> MBytes.t -> nonce -> MBytes.t
|
|||||||
val fast_box_open : channel_key -> MBytes.t -> nonce -> MBytes.t option
|
val fast_box_open : channel_key -> MBytes.t -> nonce -> MBytes.t option
|
||||||
|
|
||||||
val check_proof_of_work : public_key -> nonce -> target -> bool
|
val check_proof_of_work : public_key -> nonce -> target -> bool
|
||||||
val generate_proof_of_work : public_key -> target -> nonce
|
val generate_proof_of_work : ?max:int -> public_key -> target -> nonce
|
||||||
|
|
||||||
|
@ -7,6 +7,8 @@
|
|||||||
(* *)
|
(* *)
|
||||||
(**************************************************************************)
|
(**************************************************************************)
|
||||||
|
|
||||||
|
open Error_monad
|
||||||
|
|
||||||
let to_root = function
|
let to_root = function
|
||||||
| `O ctns -> `O ctns
|
| `O ctns -> `O ctns
|
||||||
| `A ctns -> `A ctns
|
| `A ctns -> `A ctns
|
||||||
@ -35,22 +37,21 @@ let from_stream (stream: string Lwt_stream.t) =
|
|||||||
|
|
||||||
let write_file file json =
|
let write_file file json =
|
||||||
let json = to_root json in
|
let json = to_root json in
|
||||||
let open Lwt in
|
protect begin fun () ->
|
||||||
catch
|
Lwt_io.with_file ~mode:Output file begin fun chan ->
|
||||||
(fun () ->
|
|
||||||
Lwt_io.(with_file ~mode:Output file (fun chan ->
|
|
||||||
let str = to_string json in
|
let str = to_string json in
|
||||||
write chan str >>= fun _ ->
|
Lwt_io.write chan str >>= fun _ ->
|
||||||
return true)))
|
return ()
|
||||||
(fun _ -> return false)
|
end
|
||||||
|
end
|
||||||
|
|
||||||
let read_file file =
|
let read_file file =
|
||||||
let open Lwt in
|
protect begin fun () ->
|
||||||
catch
|
Lwt_io.with_file ~mode:Input file begin fun chan ->
|
||||||
(fun () ->
|
Lwt_io.read chan >>= fun str ->
|
||||||
Lwt_io.(with_file ~mode:Input file (fun chan ->
|
return (Ezjsonm.from_string str :> Data_encoding.json)
|
||||||
read chan >>= fun str ->
|
end
|
||||||
return (Some (Ezjsonm.from_string str :> Data_encoding.json)))))
|
end
|
||||||
(fun _ ->
|
|
||||||
(* TODO log error or use Error_monad. *)
|
let () =
|
||||||
return None)
|
Error_monad.json_to_string := to_string
|
||||||
|
@ -7,6 +7,8 @@
|
|||||||
(* *)
|
(* *)
|
||||||
(**************************************************************************)
|
(**************************************************************************)
|
||||||
|
|
||||||
|
open Error_monad
|
||||||
|
|
||||||
(** Read a JSON document from a string. *)
|
(** Read a JSON document from a string. *)
|
||||||
val from_string : string -> (Data_encoding.json, string) result
|
val from_string : string -> (Data_encoding.json, string) result
|
||||||
|
|
||||||
@ -20,7 +22,7 @@ val from_stream : string Lwt_stream.t -> (Data_encoding.json, string) result Lwt
|
|||||||
val to_string : Data_encoding.json -> string
|
val to_string : Data_encoding.json -> string
|
||||||
|
|
||||||
(** Loads a JSON file in memory *)
|
(** Loads a JSON file in memory *)
|
||||||
val read_file : string -> Data_encoding.json option Lwt.t
|
val read_file : string -> Data_encoding.json tzresult Lwt.t
|
||||||
|
|
||||||
(** (Over)write a JSON file from in memory data *)
|
(** (Over)write a JSON file from in memory data *)
|
||||||
val write_file : string -> Data_encoding.json -> bool Lwt.t
|
val write_file : string -> Data_encoding.json -> unit tzresult Lwt.t
|
||||||
|
@ -16,10 +16,13 @@ type error_category = [ `Branch | `Temporary | `Permanent ]
|
|||||||
type 'err full_error_category =
|
type 'err full_error_category =
|
||||||
[ error_category | `Wrapped of 'err -> error_category ]
|
[ error_category | `Wrapped of 'err -> error_category ]
|
||||||
|
|
||||||
|
(* HACK: forward reference from [Data_encoding_ezjsonm] *)
|
||||||
|
let json_to_string = ref (fun _ -> "")
|
||||||
|
|
||||||
let json_pp encoding ppf x =
|
let json_pp encoding ppf x =
|
||||||
Format.pp_print_string ppf @@
|
Format.pp_print_string ppf @@
|
||||||
Data_encoding_ezjsonm.to_string @@
|
!json_to_string @@
|
||||||
Data_encoding.Json.(construct encoding x)
|
Data_encoding.Json.construct encoding x
|
||||||
|
|
||||||
module Make() = struct
|
module Make() = struct
|
||||||
|
|
||||||
@ -74,7 +77,7 @@ module Make() = struct
|
|||||||
category ;
|
category ;
|
||||||
from_error ;
|
from_error ;
|
||||||
encoding_case ;
|
encoding_case ;
|
||||||
pp = Utils.unopt (json_pp encoding) pp } :: !error_kinds
|
pp = Utils.unopt ~default:(json_pp encoding) pp } :: !error_kinds
|
||||||
|
|
||||||
let register_wrapped_error_kind
|
let register_wrapped_error_kind
|
||||||
category ~id ~title ~description ?pp
|
category ~id ~title ~description ?pp
|
||||||
@ -174,11 +177,6 @@ module Make() = struct
|
|||||||
|
|
||||||
let fail s = Lwt.return (Error [ s ])
|
let fail s = Lwt.return (Error [ s ])
|
||||||
|
|
||||||
let protect ~on_error t =
|
|
||||||
t >>= function
|
|
||||||
| Ok res -> return res
|
|
||||||
| Error err -> on_error err
|
|
||||||
|
|
||||||
let (>>?) v f =
|
let (>>?) v f =
|
||||||
match v with
|
match v with
|
||||||
| Error _ as err -> err
|
| Error _ as err -> err
|
||||||
@ -325,6 +323,11 @@ let () =
|
|||||||
error_kinds :=
|
error_kinds :=
|
||||||
Error_kind { id; from_error ; category; encoding_case ; pp } :: !error_kinds
|
Error_kind { id; from_error ; category; encoding_case ; pp } :: !error_kinds
|
||||||
|
|
||||||
|
let protect ~on_error t =
|
||||||
|
t >>= function
|
||||||
|
| Ok res -> return res
|
||||||
|
| Error err -> on_error err
|
||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
include Make()
|
include Make()
|
||||||
@ -340,6 +343,14 @@ let error_exn s = Error [ Exn s ]
|
|||||||
let trace_exn exn f = trace (Exn exn) f
|
let trace_exn exn f = trace (Exn exn) f
|
||||||
let record_trace_exn exn f = record_trace (Exn exn) f
|
let record_trace_exn exn f = record_trace (Exn exn) f
|
||||||
|
|
||||||
|
let protect ?on_error t =
|
||||||
|
Lwt.catch t (fun exn -> fail (Exn exn)) >>= function
|
||||||
|
| Ok res -> return res
|
||||||
|
| Error err ->
|
||||||
|
match on_error with
|
||||||
|
| Some f -> f err
|
||||||
|
| None -> Lwt.return (Error err)
|
||||||
|
|
||||||
let pp_exn ppf exn = pp ppf (Exn exn)
|
let pp_exn ppf exn = pp ppf (Exn exn)
|
||||||
|
|
||||||
let () =
|
let () =
|
||||||
|
@ -26,6 +26,10 @@ val failwith :
|
|||||||
('a, Format.formatter, unit, 'b tzresult Lwt.t) format4 ->
|
('a, Format.formatter, unit, 'b tzresult Lwt.t) format4 ->
|
||||||
'a
|
'a
|
||||||
|
|
||||||
|
val protect :
|
||||||
|
?on_error: (error list -> 'a tzresult Lwt.t) ->
|
||||||
|
(unit -> 'a tzresult Lwt.t) -> 'a tzresult Lwt.t
|
||||||
|
|
||||||
val error_exn : exn -> 'a tzresult
|
val error_exn : exn -> 'a tzresult
|
||||||
val record_trace_exn : exn -> 'a tzresult -> 'a tzresult
|
val record_trace_exn : exn -> 'a tzresult -> 'a tzresult
|
||||||
val trace_exn : exn -> 'b tzresult Lwt.t -> 'b tzresult Lwt.t
|
val trace_exn : exn -> 'b tzresult Lwt.t -> 'b tzresult Lwt.t
|
||||||
@ -35,3 +39,6 @@ type error += Exn of exn
|
|||||||
type error += Unclassified of string
|
type error += Unclassified of string
|
||||||
|
|
||||||
module Make() : Error_monad_sig.S
|
module Make() : Error_monad_sig.S
|
||||||
|
|
||||||
|
(**/**)
|
||||||
|
val json_to_string : (Data_encoding.json -> string) ref
|
||||||
|
@ -7,6 +7,8 @@
|
|||||||
(* *)
|
(* *)
|
||||||
(**************************************************************************)
|
(**************************************************************************)
|
||||||
|
|
||||||
|
open Lwt.Infix
|
||||||
|
|
||||||
module type LOG = sig
|
module type LOG = sig
|
||||||
|
|
||||||
val debug: ('a, Format.formatter, unit, unit) format4 -> 'a
|
val debug: ('a, Format.formatter, unit, unit) format4 -> 'a
|
||||||
@ -86,32 +88,134 @@ module Client = struct
|
|||||||
end
|
end
|
||||||
module Webclient = Make(struct let name = "webclient" end)
|
module Webclient = Make(struct let name = "webclient" end)
|
||||||
|
|
||||||
let template = "$(date) $(name)[$(pid)]: $(message)"
|
type template = Lwt_log.template
|
||||||
|
let default_template = "$(date) - $(section): $(message)"
|
||||||
let default_logger () =
|
|
||||||
Lwt_log.channel ~template ~close_mode:`Keep ~channel:Lwt_io.stderr ()
|
|
||||||
|
|
||||||
type kind =
|
type kind =
|
||||||
| Null
|
| Null
|
||||||
| Stdout
|
| Stdout
|
||||||
| Stderr
|
| Stderr
|
||||||
| File of string
|
| File of string
|
||||||
| Syslog
|
| Syslog of Lwt_log.syslog_facility
|
||||||
| Manual of Lwt_log.logger
|
|
||||||
|
|
||||||
let init kind =
|
let kind_encoding =
|
||||||
let logger =
|
let open Data_encoding in
|
||||||
|
conv
|
||||||
|
(function
|
||||||
|
| Null -> "/dev/null"
|
||||||
|
| Stdout -> "stdout"
|
||||||
|
| Stderr -> "stderr"
|
||||||
|
| File fp -> fp
|
||||||
|
| Syslog `Auth -> "syslog:auth"
|
||||||
|
| Syslog `Authpriv -> "syslog:authpriv"
|
||||||
|
| Syslog `Cron -> "syslog:cron"
|
||||||
|
| Syslog `Daemon -> "syslog:daemon"
|
||||||
|
| Syslog `FTP -> "syslog:ftp"
|
||||||
|
| Syslog `Kernel -> "syslog:kernel"
|
||||||
|
| Syslog `Local0 -> "syslog:local0"
|
||||||
|
| Syslog `Local1 -> "syslog:local1"
|
||||||
|
| Syslog `Local2 -> "syslog:local2"
|
||||||
|
| Syslog `Local3 -> "syslog:local3"
|
||||||
|
| Syslog `Local4 -> "syslog:local4"
|
||||||
|
| Syslog `Local5 -> "syslog:local5"
|
||||||
|
| Syslog `Local6 -> "syslog:local6"
|
||||||
|
| Syslog `Local7 -> "syslog:local7"
|
||||||
|
| Syslog `LPR -> "syslog:lpr"
|
||||||
|
| Syslog `Mail -> "syslog:mail"
|
||||||
|
| Syslog `News -> "syslog:news"
|
||||||
|
| Syslog `Syslog -> "syslog:syslog"
|
||||||
|
| Syslog `User -> "syslog:user"
|
||||||
|
| Syslog `UUCP -> "syslog:uucp"
|
||||||
|
| Syslog `NTP -> "syslog:ntp"
|
||||||
|
| Syslog `Security -> "syslog:security"
|
||||||
|
| Syslog `Console -> "syslog:console")
|
||||||
|
(function
|
||||||
|
| "/dev/null" | "null" -> Null
|
||||||
|
| "stdout" -> Stdout
|
||||||
|
| "stderr" -> Stderr
|
||||||
|
| "syslog:auth" -> Syslog `Auth
|
||||||
|
| "syslog:authpriv" -> Syslog `Authpriv
|
||||||
|
| "syslog:cron" -> Syslog `Cron
|
||||||
|
| "syslog:daemon" -> Syslog `Daemon
|
||||||
|
| "syslog:ftp" -> Syslog `FTP
|
||||||
|
| "syslog:kernel" -> Syslog `Kernel
|
||||||
|
| "syslog:local0" -> Syslog `Local0
|
||||||
|
| "syslog:local1" -> Syslog `Local1
|
||||||
|
| "syslog:local2" -> Syslog `Local2
|
||||||
|
| "syslog:local3" -> Syslog `Local3
|
||||||
|
| "syslog:local4" -> Syslog `Local4
|
||||||
|
| "syslog:local5" -> Syslog `Local5
|
||||||
|
| "syslog:local6" -> Syslog `Local6
|
||||||
|
| "syslog:local7" -> Syslog `Local7
|
||||||
|
| "syslog:lpr" -> Syslog `LPR
|
||||||
|
| "syslog:mail" -> Syslog `Mail
|
||||||
|
| "syslog:news" -> Syslog `News
|
||||||
|
| "syslog:syslog" -> Syslog `Syslog
|
||||||
|
| "syslog:user" -> Syslog `User
|
||||||
|
| "syslog:uucp" -> Syslog `UUCP
|
||||||
|
| "syslog:ntp" -> Syslog `NTP
|
||||||
|
| "syslog:security" -> Syslog `Security
|
||||||
|
| "syslog:console" -> Syslog `Console
|
||||||
|
(* | s when start_with "syslog:" FIXME error or warning. *)
|
||||||
|
| fp ->
|
||||||
|
(* TODO check absolute path *)
|
||||||
|
File fp)
|
||||||
|
string
|
||||||
|
|
||||||
|
|
||||||
|
let init ?(template = default_template) kind =
|
||||||
|
begin
|
||||||
match kind with
|
match kind with
|
||||||
| Stderr ->
|
| Stderr ->
|
||||||
default_logger ()
|
Lwt.return @@
|
||||||
|
Lwt_log.channel ~template ~close_mode:`Keep ~channel:Lwt_io.stderr ()
|
||||||
| Stdout ->
|
| Stdout ->
|
||||||
|
Lwt.return @@
|
||||||
Lwt_log.channel ~template ~close_mode:`Keep ~channel:Lwt_io.stdout ()
|
Lwt_log.channel ~template ~close_mode:`Keep ~channel:Lwt_io.stdout ()
|
||||||
| File file_name ->
|
| File file_name ->
|
||||||
Lwt_main.run (Lwt_log.file ~file_name ~template ())
|
Lwt_log.file ~file_name ~template ()
|
||||||
| Null ->
|
| Null ->
|
||||||
|
Lwt.return @@
|
||||||
Lwt_log.null
|
Lwt_log.null
|
||||||
| Syslog ->
|
| Syslog facility ->
|
||||||
Printf.eprintf "Warning: log_kind \"syslog\" not yet implemented.\n%!";
|
Lwt.return @@
|
||||||
default_logger ()
|
Lwt_log.syslog ~template ~facility ()
|
||||||
| Manual logger -> logger in
|
end >>= fun logger ->
|
||||||
Lwt_log.default := logger
|
Lwt_log.default := logger ;
|
||||||
|
Lwt.return_unit
|
||||||
|
|
||||||
|
type level = Lwt_log_core.level =
|
||||||
|
| Debug
|
||||||
|
(** Debugging message. They can be automatically removed by the
|
||||||
|
syntax extension. *)
|
||||||
|
| Info
|
||||||
|
(** Informational message. Suitable to be displayed when the
|
||||||
|
program is in verbose mode. *)
|
||||||
|
| Notice
|
||||||
|
(** Same as {!Info}, but is displayed by default. *)
|
||||||
|
| Warning
|
||||||
|
(** Something strange happend *)
|
||||||
|
| Error
|
||||||
|
(** An error message, which should not means the end of the
|
||||||
|
program. *)
|
||||||
|
| Fatal
|
||||||
|
|
||||||
|
let level_encoding =
|
||||||
|
let open Data_encoding in
|
||||||
|
conv
|
||||||
|
(function
|
||||||
|
| Fatal -> "fatal"
|
||||||
|
| Error -> "error"
|
||||||
|
| Warning -> "warning"
|
||||||
|
| Notice -> "notice"
|
||||||
|
| Info -> "info"
|
||||||
|
| Debug -> "debug")
|
||||||
|
(function
|
||||||
|
| "error" -> Error
|
||||||
|
| "warn" -> Warning
|
||||||
|
| "notice" -> Notice
|
||||||
|
| "info" -> Info
|
||||||
|
| "debug" -> Debug
|
||||||
|
| "fatal" -> Fatal
|
||||||
|
| _ -> invalid_arg "Logging.level")
|
||||||
|
string
|
||||||
|
@ -48,12 +48,34 @@ module Webclient : LOG
|
|||||||
|
|
||||||
module Make(S: sig val name: string end) : LOG
|
module Make(S: sig val name: string end) : LOG
|
||||||
|
|
||||||
|
type level = Lwt_log_core.level =
|
||||||
|
| Debug
|
||||||
|
(** Debugging message. They can be automatically removed by the
|
||||||
|
syntax extension. *)
|
||||||
|
| Info
|
||||||
|
(** Informational message. Suitable to be displayed when the
|
||||||
|
program is in verbose mode. *)
|
||||||
|
| Notice
|
||||||
|
(** Same as {!Info}, but is displayed by default. *)
|
||||||
|
| Warning
|
||||||
|
(** Something strange happend *)
|
||||||
|
| Error
|
||||||
|
(** An error message, which should not means the end of the
|
||||||
|
program. *)
|
||||||
|
| Fatal
|
||||||
|
|
||||||
|
type template = Lwt_log.template
|
||||||
|
val default_template : template
|
||||||
|
|
||||||
|
val level_encoding : level Data_encoding.t
|
||||||
|
|
||||||
type kind =
|
type kind =
|
||||||
| Null
|
| Null
|
||||||
| Stdout
|
| Stdout
|
||||||
| Stderr
|
| Stderr
|
||||||
| File of string
|
| File of string
|
||||||
| Syslog
|
| Syslog of Lwt_log.syslog_facility
|
||||||
| Manual of Lwt_log.logger
|
|
||||||
|
|
||||||
val init: kind -> unit
|
val kind_encoding : kind Data_encoding.t
|
||||||
|
|
||||||
|
val init: ?template:template -> kind -> unit Lwt.t
|
||||||
|
@ -346,12 +346,14 @@ let remove_dir dir =
|
|||||||
Lwt.return ()
|
Lwt.return ()
|
||||||
|
|
||||||
let rec create_dir ?(perm = 0o755) dir =
|
let rec create_dir ?(perm = 0o755) dir =
|
||||||
if Sys.file_exists dir then
|
Lwt_unix.file_exists dir >>= function
|
||||||
Lwt.return ()
|
| false ->
|
||||||
else begin
|
|
||||||
create_dir (Filename.dirname dir) >>= fun () ->
|
create_dir (Filename.dirname dir) >>= fun () ->
|
||||||
Lwt_unix.mkdir dir perm
|
Lwt_unix.mkdir dir perm
|
||||||
end
|
| true ->
|
||||||
|
Lwt_unix.stat dir >>= function
|
||||||
|
| {st_kind = S_DIR} -> Lwt.return_unit
|
||||||
|
| _ -> failwith "Not a directory"
|
||||||
|
|
||||||
let create_file ?(perm = 0o644) name content =
|
let create_file ?(perm = 0o644) name content =
|
||||||
Lwt_unix.openfile name Unix.([O_TRUNC; O_CREAT; O_WRONLY]) perm >>= fun fd ->
|
Lwt_unix.openfile name Unix.([O_TRUNC; O_CREAT; O_WRONLY]) perm >>= fun fd ->
|
||||||
@ -402,4 +404,6 @@ let with_timeout ?(canceler = Canceler.create ()) timeout f =
|
|||||||
Canceler.cancel canceler >>= fun () ->
|
Canceler.cancel canceler >>= fun () ->
|
||||||
fail Timeout
|
fail Timeout
|
||||||
|
|
||||||
|
let unless cond f =
|
||||||
|
if cond then Lwt.return () else f ()
|
||||||
|
|
||||||
|
@ -67,3 +67,5 @@ val with_timeout:
|
|||||||
?canceler:Canceler.t ->
|
?canceler:Canceler.t ->
|
||||||
float -> (Canceler.t -> 'a tzresult Lwt.t) -> 'a tzresult Lwt.t
|
float -> (Canceler.t -> 'a tzresult Lwt.t) -> 'a tzresult Lwt.t
|
||||||
|
|
||||||
|
val unless: bool -> (unit -> unit Lwt.t) -> unit Lwt.t
|
||||||
|
|
||||||
|
@ -14,6 +14,16 @@ include Kaputt.Assertion
|
|||||||
|
|
||||||
let format_msg = function None -> None | Some msg -> Some (msg ^ "\n")
|
let format_msg = function None -> None | Some msg -> Some (msg ^ "\n")
|
||||||
|
|
||||||
|
let is_error ?(msg="") x =
|
||||||
|
match x with
|
||||||
|
| Error _ -> ()
|
||||||
|
| Ok _ -> fail "Error _" "Ok _" msg
|
||||||
|
|
||||||
|
let is_ok ?(msg="") x =
|
||||||
|
match x with
|
||||||
|
| Ok _ -> ()
|
||||||
|
| Error _ -> fail "Ok _" "Error _" msg
|
||||||
|
|
||||||
let equal_persist_list ?msg l1 l2 =
|
let equal_persist_list ?msg l1 l2 =
|
||||||
let msg = format_msg msg in
|
let msg = format_msg msg in
|
||||||
let pr_persist l =
|
let pr_persist l =
|
||||||
|
@ -8,8 +8,12 @@
|
|||||||
(**************************************************************************)
|
(**************************************************************************)
|
||||||
|
|
||||||
open Hash
|
open Hash
|
||||||
|
open Error_monad
|
||||||
include (module type of struct include Kaputt.Assertion end)
|
include (module type of struct include Kaputt.Assertion end)
|
||||||
|
|
||||||
|
val is_ok : ?msg:string -> 'a tzresult -> unit
|
||||||
|
val is_error : ?msg:string -> 'a tzresult -> unit
|
||||||
|
|
||||||
val fail_msg : ('a, Format.formatter, unit, 'b) format4 -> 'a
|
val fail_msg : ('a, Format.formatter, unit, 'b) format4 -> 'a
|
||||||
|
|
||||||
val fail : string -> string -> ('a, Format.formatter, unit, 'b) format4 -> 'a
|
val fail : string -> string -> ('a, Format.formatter, unit, 'b) format4 -> 'a
|
||||||
|
@ -19,11 +19,8 @@ let detach ?(prefix = "") f =
|
|||||||
| 0 ->
|
| 0 ->
|
||||||
Random.self_init () ;
|
Random.self_init () ;
|
||||||
let template = Format.asprintf "%s$(section): $(message)" prefix in
|
let template = Format.asprintf "%s$(section): $(message)" prefix in
|
||||||
let logger =
|
|
||||||
Lwt_log.channel
|
|
||||||
~template ~close_mode:`Keep ~channel:Lwt_io.stderr () in
|
|
||||||
Logging.init (Manual logger) ;
|
|
||||||
Lwt_main.run begin
|
Lwt_main.run begin
|
||||||
|
Logging.init ~template Stderr >>= fun () ->
|
||||||
lwt_log_notice "PID: %d" (Unix.getpid ()) >>= fun () ->
|
lwt_log_notice "PID: %d" (Unix.getpid ()) >>= fun () ->
|
||||||
f ()
|
f ()
|
||||||
end ;
|
end ;
|
||||||
|
@ -5,8 +5,8 @@ set -e
|
|||||||
DIR=$(dirname "$0")
|
DIR=$(dirname "$0")
|
||||||
cd "${DIR}"
|
cd "${DIR}"
|
||||||
|
|
||||||
DATA_DIR=$(mktemp -d /tmp/tezos_node.XXXXXXXXXX)
|
DATA_DIR="$(mktemp -td tezos_node.XXXXXXXXXX)"
|
||||||
CLIENT_DIR=$(mktemp -d /tmp/tezos_client.XXXXXXXXXX)
|
CLIENT_DIR="$(mktemp -td tezos_client.XXXXXXXXXX)"
|
||||||
|
|
||||||
cleanup() {
|
cleanup() {
|
||||||
rm -fr ${DATA_DIR} ${CLIENT_DIR}
|
rm -fr ${DATA_DIR} ${CLIENT_DIR}
|
||||||
@ -17,8 +17,8 @@ trap cleanup EXIT QUIT INT
|
|||||||
NODE=../tezos-node
|
NODE=../tezos-node
|
||||||
CLIENT="../tezos-client -base-dir ${CLIENT_DIR}"
|
CLIENT="../tezos-client -base-dir ${CLIENT_DIR}"
|
||||||
|
|
||||||
CUSTOM_PARAM="--sandbox-param ./sandbox.json"
|
CUSTOM_PARAM="--sandbox ./sandbox.json"
|
||||||
${NODE} --sandbox "${DATA_DIR}" ${CUSTOM_PARAM} --rpc-addr :::8732 > LOG 2>&1 &
|
${NODE} --base-dir "${DATA_DIR}" ${CUSTOM_PARAM} --rpc-addr :::8732 > LOG 2>&1 &
|
||||||
NODE_PID="$!"
|
NODE_PID="$!"
|
||||||
|
|
||||||
sleep 3
|
sleep 3
|
||||||
|
@ -50,8 +50,8 @@ let fork_node () =
|
|||||||
Unix.create_process
|
Unix.create_process
|
||||||
Filename.(concat (dirname (Sys.getcwd ())) "tezos-node")
|
Filename.(concat (dirname (Sys.getcwd ())) "tezos-node")
|
||||||
[| "tezos-node" ;
|
[| "tezos-node" ;
|
||||||
"--sandbox"; data_dir ;
|
"--base-dir"; data_dir ;
|
||||||
"--sandbox-param"; "./sandbox.json";
|
"--sandbox"; "./sandbox.json";
|
||||||
"--rpc-addr"; ":::8732" |]
|
"--rpc-addr"; ":::8732" |]
|
||||||
null_fd log_fd log_fd in
|
null_fd log_fd log_fd in
|
||||||
Printf.printf "Created node, pid: %d, log: %s\n%!" pid log_file_name ;
|
Printf.printf "Created node, pid: %d, log: %s\n%!" pid log_file_name ;
|
||||||
|
@ -110,11 +110,11 @@ let test_json testdir =
|
|||||||
let f_str = to_string v in
|
let f_str = to_string v in
|
||||||
Assert.equal_string ~msg:__LOC__ f_str "[\n 42\n]";
|
Assert.equal_string ~msg:__LOC__ f_str "[\n 42\n]";
|
||||||
read_file (testdir // "NONEXISTINGFILE") >>= fun rf ->
|
read_file (testdir // "NONEXISTINGFILE") >>= fun rf ->
|
||||||
Assert.is_none ~msg:__LOC__ rf;
|
Assert.is_error ~msg:__LOC__ rf ;
|
||||||
write_file file v >>= fun success ->
|
write_file file v >>= fun success ->
|
||||||
Assert.is_true ~msg:__LOC__ success;
|
Assert.is_ok ~msg:__LOC__ success ;
|
||||||
read_file file >>= fun opt ->
|
read_file file >>= fun opt ->
|
||||||
Assert.is_some ~msg:__LOC__ opt;
|
Assert.is_ok ~msg:__LOC__ opt ;
|
||||||
Lwt.return ()
|
Lwt.return ()
|
||||||
|
|
||||||
type t = A of int | B of string | C of int | D of string | E
|
type t = A of int | B of string | C of int | D of string | E
|
||||||
@ -269,8 +269,8 @@ let test_json_input testdir =
|
|||||||
|}
|
|}
|
||||||
in
|
in
|
||||||
Data_encoding_ezjsonm.read_file file >>= function
|
Data_encoding_ezjsonm.read_file file >>= function
|
||||||
None -> Assert.fail_msg "Cannot parse \"good.json\"."
|
| Error _ -> Assert.fail_msg "Cannot parse \"good.json\"."
|
||||||
| Some json ->
|
| Ok json ->
|
||||||
let (id, value, popup) = Json.destruct enc json in
|
let (id, value, popup) = Json.destruct enc json in
|
||||||
Assert.equal_string ~msg:__LOC__ "file" id;
|
Assert.equal_string ~msg:__LOC__ "file" id;
|
||||||
Assert.equal_string ~msg:__LOC__ "File" value;
|
Assert.equal_string ~msg:__LOC__ "File" value;
|
||||||
@ -295,8 +295,8 @@ let test_json_input testdir =
|
|||||||
|}
|
|}
|
||||||
in
|
in
|
||||||
Data_encoding_ezjsonm.read_file file >>= function
|
Data_encoding_ezjsonm.read_file file >>= function
|
||||||
None -> Assert.fail_msg "Cannot parse \"unknown.json\"."
|
| Error _ -> Assert.fail_msg "Cannot parse \"unknown.json\"."
|
||||||
| Some json ->
|
| Ok json ->
|
||||||
Assert.test_fail ~msg:__LOC__
|
Assert.test_fail ~msg:__LOC__
|
||||||
(fun () -> ignore (Json.destruct enc json))
|
(fun () -> ignore (Json.destruct enc json))
|
||||||
(function
|
(function
|
||||||
|
@ -14,14 +14,13 @@ open Error_monad
|
|||||||
open P2p_types
|
open P2p_types
|
||||||
include Logging.Make (struct let name = "test-p2p-connection" end)
|
include Logging.Make (struct let name = "test-p2p-connection" end)
|
||||||
|
|
||||||
let proof_of_work_target =
|
let proof_of_work_target = Crypto_box.make_target 16.
|
||||||
Crypto_box.make_target [Int64.shift_left 1L 48]
|
|
||||||
let id1 = Identity.generate proof_of_work_target
|
let id1 = Identity.generate proof_of_work_target
|
||||||
let id2 = Identity.generate proof_of_work_target
|
let id2 = Identity.generate proof_of_work_target
|
||||||
|
|
||||||
let id0 =
|
let id0 =
|
||||||
(* Luckilly, this will be an insuficient proof of work! *)
|
(* Luckilly, this will be an insuficient proof of work! *)
|
||||||
Identity.generate (Crypto_box.make_target [])
|
Identity.generate (Crypto_box.make_target 0.)
|
||||||
|
|
||||||
let versions = Version.[{ name = "TEST" ; minor = 0 ; major = 0 }]
|
let versions = Version.[{ name = "TEST" ; minor = 0 ; major = 0 }]
|
||||||
|
|
||||||
|
@ -126,7 +126,7 @@ let run_net config repeat points addr port =
|
|||||||
|
|
||||||
let make_net points repeat n =
|
let make_net points repeat n =
|
||||||
let point, points = Utils.select n points in
|
let point, points = Utils.select n points in
|
||||||
let proof_of_work_target = Crypto_box.make_target [] in
|
let proof_of_work_target = Crypto_box.make_target 0. in
|
||||||
let identity = Identity.generate proof_of_work_target in
|
let identity = Identity.generate proof_of_work_target in
|
||||||
let config = P2p_connection_pool.{
|
let config = P2p_connection_pool.{
|
||||||
identity ;
|
identity ;
|
||||||
@ -158,7 +158,7 @@ let make_net points repeat n =
|
|||||||
let addr = ref Ipaddr.V6.localhost
|
let addr = ref Ipaddr.V6.localhost
|
||||||
let port = ref (1024 + Random.int 8192)
|
let port = ref (1024 + Random.int 8192)
|
||||||
let clients = ref 10
|
let clients = ref 10
|
||||||
let repeat = ref 5
|
let repeat_connections = ref 5
|
||||||
|
|
||||||
let spec = Arg.[
|
let spec = Arg.[
|
||||||
|
|
||||||
@ -169,7 +169,8 @@ let spec = Arg.[
|
|||||||
|
|
||||||
"--clients", Set_int clients, " Number of concurrent clients." ;
|
"--clients", Set_int clients, " Number of concurrent clients." ;
|
||||||
|
|
||||||
"--repeat", Set_int repeat, " Number of connections/disconnections." ;
|
"--repeat", Set_int repeat_connections,
|
||||||
|
" Number of connections/disconnections." ;
|
||||||
|
|
||||||
"-v", Unit (fun () -> Lwt_log_core.(add_rule "p2p.connection-pool" Info)),
|
"-v", Unit (fun () -> Lwt_log_core.(add_rule "p2p.connection-pool" Info)),
|
||||||
" Log up to info msgs" ;
|
" Log up to info msgs" ;
|
||||||
@ -181,16 +182,15 @@ let spec = Arg.[
|
|||||||
|
|
||||||
let main () =
|
let main () =
|
||||||
let open Utils in
|
let open Utils in
|
||||||
|
Logging.init Stderr >>= fun () ->
|
||||||
let anon_fun num_peers = raise (Arg.Bad "No anonymous argument.") in
|
let anon_fun num_peers = raise (Arg.Bad "No anonymous argument.") in
|
||||||
let usage_msg = "Usage: %s <num_peers>.\nArguments are:" in
|
let usage_msg = "Usage: %s <num_peers>.\nArguments are:" in
|
||||||
Arg.parse spec anon_fun usage_msg ;
|
Arg.parse spec anon_fun usage_msg ;
|
||||||
let ports = !port -- (!port + !clients - 1) in
|
let ports = !port -- (!port + !clients - 1) in
|
||||||
let points = List.map (fun port -> !addr, port) ports in
|
let points = List.map (fun port -> !addr, port) ports in
|
||||||
Lwt_list.iter_p (make_net points !repeat) (0 -- (!clients - 1))
|
Lwt_list.iter_p (make_net points !repeat_connections) (0 -- (!clients - 1))
|
||||||
|
|
||||||
let () =
|
let () =
|
||||||
Sys.catch_break true ;
|
Sys.catch_break true ;
|
||||||
try
|
try Lwt_main.run @@ main ()
|
||||||
Logging.init Stderr ;
|
|
||||||
Lwt_main.run @@ main ()
|
|
||||||
with _ -> ()
|
with _ -> ()
|
||||||
|
@ -140,7 +140,7 @@ let run
|
|||||||
?max_download_speed ?max_upload_speed
|
?max_download_speed ?max_upload_speed
|
||||||
~read_buffer_size ?read_queue_size ?write_queue_size
|
~read_buffer_size ?read_queue_size ?write_queue_size
|
||||||
addr port time n =
|
addr port time n =
|
||||||
Logging.init Stderr ;
|
Logging.init Stderr >>= fun () ->
|
||||||
listen ?port addr >>= fun (main_socket, port) ->
|
listen ?port addr >>= fun (main_socket, port) ->
|
||||||
let server =
|
let server =
|
||||||
Process.detach ~prefix:"server " begin fun () ->
|
Process.detach ~prefix:"server " begin fun () ->
|
||||||
|
@ -39,7 +39,7 @@ let incr_fitness fitness =
|
|||||||
| [ _ ; fitness ] ->
|
| [ _ ; fitness ] ->
|
||||||
Pervasives.(
|
Pervasives.(
|
||||||
Data_encoding.Binary.of_bytes Data_encoding.int64 fitness
|
Data_encoding.Binary.of_bytes Data_encoding.int64 fitness
|
||||||
|> Utils.unopt 0L
|
|> Utils.unopt ~default:0L
|
||||||
|> Int64.succ
|
|> Int64.succ
|
||||||
|> Data_encoding.Binary.to_bytes Data_encoding.int64
|
|> Data_encoding.Binary.to_bytes Data_encoding.int64
|
||||||
)
|
)
|
||||||
|
Loading…
Reference in New Issue
Block a user