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

Merge branch 'p2p' into 'master'

Browse Source 
Split the p2p layer in multiple files

See merge request !132
This commit is contained in:
Grégoire Henry 2017-01-19 10:31:50 +01:00
commit 77ccf7ad34
66 changed files with 6069 additions and 2081 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.gitignore vendored
View File

@ -39,7 +39,9 @@
/test/test-context
/test/test-basic
/test/test-data-encoding
/test/test-p2p
/test/test-p2p-io-scheduler
/test/test-p2p-connection
/test/test-p2p-connection-pool
/test/LOG
*~

30
.gitlab-ci.yml
View File

@ -107,6 +107,36 @@ test:data-encoding:
- build
- build:test
test:p2p-io-scheduler:
stage: test
tags:
- tezos_builder
script:
- make -C test run-test-p2p-io-scheduler
dependencies:
- build
- build:test
test:p2p-connection:
stage: test
tags:
- tezos_builder
script:
- make -C test run-test-p2p-connection
dependencies:
- build
- build:test
test:p2p-connection-pool:
stage: test
tags:
- tezos_builder
script:
- make -C test run-test-p2p-connection-pool
dependencies:
- build
- build:test
expurge:
stage: expurge
tags:

2
scripts/create_docker_builder.sh
View File

@ -9,6 +9,8 @@ image_name=${1:=tezos_build}
ocaml_version=${2:=alpine_ocaml-4.03.0}
image_version=$3
docker pull ocaml/opam:${ocaml_version}
cp ${cur_dir}/install_build_deps.sh ${dir}
cp ${cur_dir}/../src/tezos-deps.opam ${dir}
cat > ${dir}/Dockerfile <<EOF

2
scripts/install_build_deps.sh
View File

@ -49,6 +49,8 @@ if ! [ -z "$pin" ]; then
opam pin --yes add --no-action --dev-repo ocp-ocamlres
opam pin --yes add --no-action --dev-repo ocplib-json-typed
opam pin --yes add --no-action --dev-repo ocplib-resto
## Ouch, that's an awfull (temporary) hack...
EDITOR='sed -i "s|\"ocamlfind\"|\"ocamlfind\"\ndepopts: \"camlp4\"|"' opam pin add typerex-build 1.99.17-beta --edit --no-action
## Force opam to take account of the new `tezos-deps.opam`
opam pin --yes remove tezos-deps
opam pin --yes add --no-action tezos-deps src

5
src/.merlin
View File

@ -23,6 +23,7 @@ FLG -w -30
FLG -w -40
PKG base64
PKG calendar
PKG cmdliner
PKG cohttp
PKG compiler-libs.optcomp
PKG conduit
@ -31,14 +32,16 @@ PKG cstruct
PKG dynlink
PKG ezjsonm
PKG git
PKG ipv6-multicast
PKG irmin
PKG lwt
PKG mtime.os
PKG ocplib-endian
PKG ocplib-json-typed
PKG ocplib-ocamlres
PKG ocplib-resto.directory
PKG result
PKG sodium
PKG ssl
PKG unix
PKG zarith
PKG cmdliner

25
src/Makefile
View File

@ -163,6 +163,7 @@ UTILS_LIB_INTFS := \
utils/lwt_pipe.mli \
utils/IO.mli \
utils/moving_average.mli \
utils/ring.mli \
UTILS_LIB_IMPLS := \
utils/base48.ml \
@ -179,12 +180,14 @@ UTILS_LIB_IMPLS := \
utils/lwt_pipe.ml \
utils/IO.ml \
utils/moving_average.ml \
utils/ring.ml \
UTILS_PACKAGES := \
${MINUTILS_PACKAGES} \
base64 \
calendar \
ezjsonm \
mtime.os \
sodium \
zarith \
$(COVERAGEPKG) \
@ -254,6 +257,14 @@ clean::
NODE_LIB_INTFS := \
\
node/net/p2p_types.mli \
node/net/p2p_io_scheduler.mli \
node/net/p2p_connection.mli \
node/net/p2p_connection_pool_types.mli \
node/net/p2p_connection_pool.mli \
node/net/p2p_welcome.mli \
node/net/p2p_discovery.mli \
node/net/p2p_maintenance.mli \
node/net/p2p.mli \
node/net/RPC_server.mli \
\
@ -284,7 +295,16 @@ NODE_LIB_IMPLS := \
\
compiler/node_compiler_main.ml \
\
node/net/p2p_types.ml \
node/net/p2p_io_scheduler.ml \
node/net/p2p_connection.ml \
node/net/p2p_connection_pool_types.ml \
node/net/p2p_connection_pool.ml \
node/net/p2p_welcome.ml \
node/net/p2p_discovery.ml \
node/net/p2p_maintenance.ml \
node/net/p2p.ml \
\
node/net/RPC_server.ml \
\
node/updater/fitness.ml \
@ -316,12 +336,13 @@ NODE_IMPLS := \
NODE_PACKAGES := \
$(COMPILER_PACKAGES) \
calendar \
cmdliner \
cohttp.lwt \
dynlink \
git \
ipv6-multicast \
irmin.unix \
ocplib-resto.directory \
cmdliner \
EMBEDDED_NODE_PROTOCOLS := \
@ -592,10 +613,8 @@ NO_DEPS := \
compiler/embedded_cmis.cmx compiler/embedded_cmis.cmi: OPENED_MODULES=
ifneq ($(MAKECMDGOALS),clean)
ifneq ($(MAKECMDGOALS),build-deps)
include .depend
endif
endif
DEPENDS := $(filter-out $(NO_DEPS), \
$(MINUTILS_LIB_INTFS) $(MINUTILS_LIB_IMPLS) \
$(UTILS_LIB_INTFS) $(UTILS_LIB_IMPLS) \

211
src/attacker/attacker_minimal.ml
View File

@ -8,8 +8,7 @@
(**************************************************************************)
open Format
open Lwt
open Tezos_p2p
include Logging.Make(struct let name = "attacker" end)
module Proto = Client_embedded_proto_bootstrap
module Ed25519 = Proto.Local_environment.Environment.Ed25519
@ -104,141 +103,170 @@ let ballot_forged period prop vote =
operations = [ballot] }) in
forge { net_id = network } op
let identity = P2p_types.Identity.generate Crypto_box.default_target
(* connect to the network, run an action and then disconnect *)
let try_action addr port action =
let limits : P2p.limits = {
max_message_size = 1 lsl 16 ;
peer_answer_timeout = 10. ;
expected_connections = 1;
min_connections = 1 ;
max_connections = 1 ;
blacklist_time = 0. ;
} in
let config : P2p.config = {
incoming_port = None ;
discovery_port = None ;
known_peers = [(addr, port)] ;
peers_file = Filename.temp_file "peers_file" ".txt";
closed_network = true ;
} in
bootstrap ~config ~limits >>= fun net ->
let peer =
match peers net with
| [peer] -> peer
| _ -> Pervasives.failwith "" in
action net peer >>= fun () -> shutdown net
let socket = Lwt_unix.socket PF_INET6 SOCK_STREAM 0 in
let uaddr = Ipaddr_unix.V6.to_inet_addr addr in
Lwt_unix.connect socket (Lwt_unix.ADDR_INET (uaddr, port)) >>= fun () ->
let io_sched = P2p_io_scheduler.create ~read_buffer_size:(1 lsl 14) () in
let conn = P2p_io_scheduler.register io_sched socket in
P2p_connection.authenticate
~proof_of_work_target:Crypto_box.default_target
~incoming:false
conn
(addr, port)
identity Tezos_p2p.Raw.supported_versions >>=? fun (_, auth_fd) ->
P2p_connection.accept auth_fd Tezos_p2p.Raw.encoding >>= function
| Error _ -> failwith "Connection rejected by peer."
| Ok conn ->
action conn >>=? fun () ->
P2p_connection.close conn >>= fun () ->
return ()
let replicate n x =
let rec replicate_acc acc n x =
if n <= 0 then acc else replicate_acc (x :: acc) (n-1) x in
replicate_acc [] n x
let request_block_times block_hash n net peer =
let open Block_hash in
let () = printf "requesting %a block %a times\n"
pp_short block_hash pp_print_int n in
let block_hashes = replicate n block_hash in
send net peer (Get_blocks block_hashes)
let send conn (msg : Tezos_p2p.msg) =
P2p_connection.write conn (Tezos_p2p.Raw.Message msg)
let request_op_times op_signed n net peer =
let request_block_times block_hash n conn =
let open Block_hash in
lwt_log_notice
"requesting %a block %d times"
pp_short block_hash n >>= fun () ->
let block_hashes = replicate n block_hash in
send conn (Get_blocks block_hashes)
let request_op_times op_signed n conn =
let open Operation_hash in
let op_hash = hash_bytes [op_signed] in
let () = printf "sending %a transaction\n" pp_short op_hash in
send net peer (Operation op_signed) >>= fun () ->
let () = printf "requesting %a transaction %a times\n"
pp_short op_hash pp_print_int n in
lwt_log_notice "sending %a transaction" pp_short op_hash >>= fun () ->
send conn (Operation op_signed) >>=? fun () ->
lwt_log_notice
"requesting %a transaction %d times"
pp_short op_hash n >>= fun () ->
let op_hashes = replicate n op_hash in
send net peer (Get_operations op_hashes)
send conn (Get_operations op_hashes)
let send_block_size n net peer =
let send_block_size n conn =
let bytes = MBytes.create n in
let open Block_hash in
let () = printf "propagating fake %a byte block %a\n"
pp_print_int n pp_short (hash_bytes [bytes]) in
send net peer (Block bytes)
lwt_log_notice
"propagating fake %d byte block %a" n pp_short (hash_bytes [bytes]) >>= fun () ->
send conn (Block bytes)
let send_protocol_size n net peer =
let send_protocol_size n conn =
let bytes = MBytes.create n in
let open Protocol_hash in
let () = printf "propagating fake %a byte protocol %a\n"
pp_print_int n pp_short (hash_bytes [bytes]) in
send net peer (Protocol bytes)
lwt_log_notice
"propagating fake %d byte protocol %a"
n pp_short (hash_bytes [bytes]) >>= fun () ->
send conn (Protocol bytes)
let send_operation_size n net peer =
let send_operation_size n conn =
let op_faked = MBytes.create n in
let op_hashed = Operation_hash.hash_bytes [op_faked] in
let () = printf "propagating fake %a byte operation %a\n"
pp_print_int n Operation_hash.pp_short op_hashed in
send net peer (Operation op_faked) >>= fun () ->
lwt_log_notice
"propagating fake %d byte operation %a"
n Operation_hash.pp_short op_hashed >>= fun () ->
send conn (Operation op_faked) >>=? fun () ->
let block = signed (block_forged [op_hashed]) in
let block_hashed = Block_hash.hash_bytes [block] in
let () = printf "propagating block %a with operation\n"
Block_hash.pp_short block_hashed in
send net peer (Block block)
lwt_log_notice
"propagating block %a with operation"
Block_hash.pp_short block_hashed >>= fun () ->
send conn (Block block)
let send_operation_bad_signature () net peer =
let send_operation_bad_signature () conn =
let open Operation_hash in
let signed_wrong_op = signed_wrong (tx_forged 5L 1L) in
let hashed_wrong_op = hash_bytes [signed_wrong_op] in
let () = printf "propagating operation %a with wrong signature\n"
pp_short hashed_wrong_op in
send net peer (Operation signed_wrong_op) >>= fun () ->
lwt_log_notice
"propagating operation %a with wrong signature"
pp_short hashed_wrong_op >>= fun () ->
send conn (Operation signed_wrong_op) >>=? fun () ->
let block = signed (block_forged [hashed_wrong_op]) in
let block_hashed = Block_hash.hash_bytes [block] in
let () = printf "propagating block %a with operation\n"
Block_hash.pp_short block_hashed in
send net peer (Block block)
lwt_log_notice
"propagating block %a with operation"
Block_hash.pp_short block_hashed >>= fun () ->
send conn (Block block)
let send_block_bad_signature () net peer =
let send_block_bad_signature () conn =
let open Block_hash in
let signed_wrong_block = signed_wrong (block_forged []) in
let () = printf "propagating block %a with wrong signature\n"
pp_short (hash_bytes [signed_wrong_block]) in
send net peer (Block signed_wrong_block)
lwt_log_notice
"propagating block %a with wrong signature"
pp_short (hash_bytes [signed_wrong_block]) >>= fun () ->
send conn (Block signed_wrong_block)
let double_spend () net peer =
let double_spend () conn =
let spend account =
let op_signed = signed (tx_forged ~dest:account 199999999L 1L) in
let op_hashed = Operation_hash.hash_bytes [op_signed] in
let block_signed = signed (block_forged [op_hashed]) in
let block_hashed = Block_hash.hash_bytes [block_signed] in
let () = printf "propagating operation %a\n"
Operation_hash.pp_short op_hashed in
send net peer (Operation op_signed) >>= fun () ->
let () = printf "propagating block %a\n"
Block_hash.pp_short block_hashed in
send net peer (Block block_signed) in
spend destination_account <&> spend another_account
lwt_log_notice
"propagating operation %a"
Operation_hash.pp_short op_hashed >>= fun () ->
send conn (Operation op_signed) >>=? fun () ->
lwt_log_notice
"propagating block %a"
Block_hash.pp_short block_hashed >>= fun () ->
send conn (Block block_signed) in
spend destination_account >>=? fun () ->
spend another_account
let long_chain n net peer =
let () = printf "propogating %a blocks\n"
pp_print_int n in
let long_chain n conn =
lwt_log_notice "propogating %d blocks" n >>= fun () ->
let prev_ref = ref genesis_block_hashed in
let rec loop k = if k < 1 then return_unit else
let rec loop k =
if k < 1 then
return ()
else
let block = signed (block_forged ~prev:!prev_ref []) in
let () = prev_ref := Block_hash.hash_bytes [block] in
send net peer (Block block) >>= fun () -> loop (k-1) in
prev_ref := Block_hash.hash_bytes [block] ;
send conn (Block block) >>=? fun () ->
loop (k-1) in
loop n
let lots_transactions amount fee n net peer =
let lots_transactions amount fee n conn =
let signed_op = signed (tx_forged amount fee) in
let rec loop k = if k < 1 then return_unit else
send net peer (Operation signed_op) >>= fun () -> loop (k-1) in
let rec loop k =
if k < 1 then
return ()
else
send conn (Operation signed_op) >>=? fun () ->
loop (k-1) in
let ops = replicate n (Operation_hash.hash_bytes [signed_op]) in
let signed_block = signed (block_forged ops) in
let () = printf "propogating %a transactions\n"
pp_print_int n in
loop n >>= fun () ->
let () = printf "propagating block %a with wrong signature\n"
Block_hash.pp_short (Block_hash.hash_bytes [signed_block]) in
send net peer (Block signed_block)
lwt_log_notice "propogating %d transactions" n >>= fun () ->
loop n >>=? fun () ->
lwt_log_notice
"propagating block %a with wrong signature"
Block_hash.pp_short (Block_hash.hash_bytes [signed_block]) >>= fun () ->
send conn (Block signed_block)
let main () =
let addr = Ipaddr.V4 Ipaddr.V4.localhost in
let addr = Ipaddr.V6.localhost in
let port = 9732 in
let run_action action = try_action addr port action in
let run_cmd_unit lwt = Arg.Unit (fun () -> Lwt_main.run (lwt ())) in
let run_cmd_int_suffix lwt = Arg.String (fun str ->
let run_cmd_unit lwt =
Arg.Unit begin fun () ->
Lwt_main.run begin
lwt () >>= function
| Ok () -> Lwt.return_unit
| Error err ->
lwt_log_error "Error: %a" pp_print_error err >>= fun () ->
Lwt.return_unit
end
end in
let run_cmd_int_suffix lwt =
Arg.String begin fun str ->
let last = str.[String.length str - 1] in
let init = String.sub str 0 (String.length str - 1) in
let n =
@ -249,7 +277,14 @@ let main () =
else if last == 'g' || last == 'G'
then int_of_string init * 1 lsl 30
else int_of_string str in
Lwt_main.run (lwt n)) in
Lwt_main.run begin
lwt n >>= function
| Ok () -> Lwt.return_unit
| Error err ->
lwt_log_error "Error: %a" pp_print_error err >>= fun () ->
Lwt.return_unit
end
end in
let cmds =
[( "-1",
run_cmd_int_suffix (run_action << request_block_times genesis_block_hashed),

2
src/client/embedded/bootstrap/mining/client_mining_forge.ml
View File

@ -198,7 +198,7 @@ end = struct
let lock = Lwt_mutex.create ()
let get_block cctxt level =
let get_block _cctxt level =
Lwt_mutex.with_lock lock
(fun () ->
load () >>=? fun map ->

9
src/client/embedded/bootstrap/mining/client_mining_operations.ml
View File

@ -93,12 +93,15 @@ let filter_valid_endorsement cctxt { hash; content } =
let monitor_endorsement cctxt =
monitor cctxt ~contents:true ~check:true () >>= fun ops_stream ->
let endorsement_stream, push = Lwt_stream.create () in
Lwt_stream.on_termination ops_stream (fun () -> push None) ;
Lwt.async (fun () ->
Lwt.async begin fun () ->
Lwt_stream.closed ops_stream >|= fun () -> push None
end;
Lwt.async begin fun () ->
Lwt_stream.iter_p
(Lwt_list.iter_p (fun e ->
filter_valid_endorsement cctxt e >>= function
| None -> Lwt.return_unit
| Some e -> push (Some e) ; Lwt.return_unit))
ops_stream) ;
ops_stream
end ;
Lwt.return endorsement_stream

2
src/client/embedded/bootstrap/webclient/webclient_proto_service_directory.ml
View File

@ -15,7 +15,7 @@ let cctxt = Client_commands.ignore_context
let root =
let root =
RPC.register RPC.empty Services.contracts @@ fun block () ->
RPC.register RPC.empty Services.contracts @@ fun _block () ->
Client_proto_contracts.RawContractAlias.load cctxt >>= fun list ->
let (names, _) = List.split list in
RPC.Answer.return names in

10
src/minutils/data_encoding.ml
View File

@ -1178,4 +1178,14 @@ let rec length : type x. x t -> x -> int = fun e ->
let to_bytes = to_bytes
let length = length
let fixed_length e =
match classify e with
| `Fixed n -> Some n
| `Dynamic | `Variable -> None
let fixed_length_exn e =
match fixed_length e with
| Some n -> n
| None -> invalid_arg "Data_encoding.Binary.fixed_length_exn"
end

3
src/minutils/data_encoding.mli
View File

@ -236,4 +236,7 @@ module Binary : sig
val to_bytes : 'a encoding -> 'a -> MBytes.t
val of_bytes : 'a encoding -> MBytes.t -> 'a option
val fixed_length : 'a encoding -> int option
val fixed_length_exn : 'a encoding -> int
end

76
src/minutils/utils.ml
View File

@ -59,6 +59,10 @@ let unopt x = function
| None -> x
| Some x -> x
let unopt_map ~f ~default = function
| None -> default
| Some x -> f x
let unopt_list l =
let may_cons xs x = match x with None -> xs | Some x -> x :: xs in
List.rev @@ List.fold_left may_cons [] l
@ -72,6 +76,13 @@ let filter_map f l =
let may_cons xs x = match f x with None -> xs | Some x -> x :: xs in
List.rev @@ List.fold_left may_cons [] l
let list_rev_sub l n =
ListLabels.fold_left l ~init:(n, []) ~f:begin fun (n, l) elt ->
if n <= 0 then (n, l) else (n - 1, elt :: l)
end |> snd
let list_sub l n = list_rev_sub l n |> List.rev
let display_paragraph ppf description =
Format.fprintf ppf "@[%a@]"
(fun ppf words -> List.iter (Format.fprintf ppf "%s@ ") words)
@ -111,3 +122,68 @@ let write_file ?(bin=false) fn contents =
(fun () -> close_out oc)
let (<<) g f = fun a -> g (f a)
let rec (--) i j =
let rec loop acc j =
if j < i then acc else loop (j :: acc) (pred j) in
loop [] j
let take_n_unsorted n l =
let rec loop acc n = function
| [] -> l
| _ when n <= 0 -> List.rev acc
| x :: xs -> loop (x :: acc) (pred n) xs in
loop [] n l
module Bounded(E: Set.OrderedType) = struct
(* TODO one day replace list by an heap array *)
type t = {
bound : int ;
mutable size : int ;
mutable data : E.t list ;
}
let create bound = { bound ; size = 0 ; data = [] }
let rec push x = function
| [] -> [x]
| (y :: xs) as ys ->
let c = compare x y in
if c < 0 then x :: ys else if c = 0 then ys else y :: push x xs
let replace x xs =
match xs with
| y :: xs when compare x y > 0 ->
push x xs
| xs -> xs
let insert x t =
if t.size < t.bound then begin
t.size <- t.size + 1 ;
t.data <- push x t.data
end else if E.compare (List.hd t.data) x < 0 then
t.data <- replace x t.data
let get { data } = data
end
let take_n_sorted (type a) compare n l =
let module B = Bounded(struct type t = a let compare = compare end) in
let t = B.create n in
List.iter (fun x -> B.insert x t) l ;
B.get t
let take_n ?compare n l =
match compare with
| None -> take_n_unsorted n l
| Some compare -> take_n_sorted compare n l
let select n l =
let rec loop n acc = function
| [] -> invalid_arg "Utils.select"
| x :: xs when n <= 0 -> x, List.rev_append acc xs
| x :: xs -> loop (pred n) (x :: acc) xs
in
loop n [] l

23
src/minutils/utils.mli
View File

@ -22,6 +22,7 @@ val map_option: f:('a -> 'b) -> '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 unopt: 'a -> 'a option -> 'a
val unopt_map: f:('a -> 'b) -> default:'b -> 'a option -> 'b
val unopt_list: 'a option list -> 'a list
val first_some: 'a option -> 'a option -> 'a option
@ -34,6 +35,11 @@ val remove_prefix: prefix:string -> string -> string option
val filter_map: ('a -> 'b option) -> 'a list -> 'b list
(** [list_rev_sub l n] is (List.rev l) capped to max n elements *)
val list_rev_sub : 'a list -> int -> 'a list
(** [list_sub l n] is l capped to max n elements *)
val list_sub: 'a list -> int -> 'a list
val finalize: (unit -> 'a) -> (unit -> unit) -> 'a
val read_file: ?bin:bool -> string -> string
@ -41,3 +47,20 @@ val write_file: ?bin:bool -> string -> string -> unit
(** Compose functions from right to left. *)
val (<<) : ('b -> 'c) -> ('a -> 'b) -> 'a -> 'c
(** Sequence: [i--j] is the sequence [i;i+1;...;j-1;j] *)
val (--) : int -> int -> int list
(** [take_n n l] returns the [n] first elements of [n]. When [compare]
is provided, it returns the [n] greatest element of [l]. *)
val take_n: ?compare:('a -> 'a -> int) -> int -> 'a list -> 'a list
(** Bounded sequence: keep only the [n] greatest elements. *)
module Bounded(E: Set.OrderedType) : sig
type t
val create: int -> t
val insert: E.t -> t -> unit
val get: t -> E.t list
end
val select: int -> 'a list -> 'a * 'a list

1687
src/node/net/p2p.ml
View File

File diff suppressed because it is too large Load Diff

248
src/node/net/p2p.mli
View File

@ -8,154 +8,186 @@
(**************************************************************************)
(** A peer connection address *)
type addr = Ipaddr.t
type addr = Ipaddr.V6.t
(** A peer connection port *)
type port = int
(** A p2p protocol version *)
type version = {
name : string ;
major : int ;
minor : int ;
}
(** Network configuration *)
type config = {
(** Tells if incoming connections accepted, precising the TCP port
on which the peer can be reached *)
incoming_port : port option ;
(** Tells if peers should be discovered automatically on the local
network, precising the UDP port to use *)
discovery_port : port option ;
(** List of hard-coded known peers to bootstrap the network from *)
known_peers : (addr * port) list ;
(** The path to the JSON file where the peer cache is loaded / stored *)
peers_file : string ;
(** If [true], the only accepted connections are from peers whose
addresses are in [known_peers] *)
closed_network : bool ;
}
(** Network capacities *)
type limits = {
(** Maximum length in bytes of network messages *)
max_message_size : int ;
(** Delay after which a non responding peer is considered dead *)
peer_answer_timeout : float ;
(** Minimum number of connections to reach when staring / maitening *)
expected_connections : int ;
(** Strict minimum number of connections (triggers an urgent maintenance) *)
min_connections : int ;
(** Maximum number of connections (exceeding peers are disconnected) *)
max_connections : int ;
(** How long peers can be blacklisted for maintenance *)
blacklist_time : float ;
}
module Version = P2p_types.Version
(** A global identifier for a peer, a.k.a. an identity *)
type gid
val pp_gid : Format.formatter -> gid -> unit
module Gid = P2p_types.Gid
type 'msg encoding = Encoding : {
module Identity = P2p_types.Identity
module Point = P2p_types.Point
module Id_point = P2p_types.Id_point
module Connection_info = P2p_types.Connection_info
module Stat = P2p_types.Stat
type 'meta meta_config = {
encoding : 'meta Data_encoding.t;
initial : 'meta;
}
type 'msg app_message_encoding = Encoding : {
tag: int ;
encoding: 'a Data_encoding.t ;
wrap: 'a -> 'msg ;
unwrap: 'msg -> 'a option ;
max_length: int option ;
} -> 'msg encoding
} -> 'msg app_message_encoding
module type PARAMS = sig
type 'msg message_config = {
encoding : 'msg app_message_encoding list ;
versions : Version.t list;
}
(** Type of message used by higher layers *)
type msg
(** Network configuration *)
type config = {
val encodings : msg encoding list
listening_port : port option;
(** Tells if incoming connections accepted, precising the TCP port
on which the peer can be reached *)
(** Type of metadata associated to an identity *)
type metadata
listening_addr : addr option;
(** When incoming connections are accepted, precising on which
IP adddress the node listen (default: [[::]]). *)
val initial_metadata : metadata
val metadata_encoding : metadata Data_encoding.t
val score : metadata -> float
trusted_points : Point.t list ;
(** List of hard-coded known peers to bootstrap the network from. *)
(** High level protocol(s) talked by the peer. When two peers
initiate a connection, they exchange their list of supported
versions. The chosen one, if any, is the maximum common one (in
lexicographic order) *)
val supported_versions : version list
peers_file : string ;
(** The path to the JSON file where the metadata associated to
gids are loaded / stored. *)
end
closed_network : bool ;
(** If [true], the only accepted connections are from peers whose
addresses are in [trusted_peers]. *)
module Make (P : PARAMS) : sig
identity : Identity.t ;
(** Cryptographic identity of the peer. *)
type net
proof_of_work_target : Crypto_box.target ;
(** Expected level of proof of work of peers' identity. *)
(** A faked p2p layer, which do not initiate any connection
}
(** Network capacities *)
type limits = {
authentification_timeout : float ;
(** Delay granted to a peer to perform authentication, in seconds. *)
min_connections : int ;
(** Strict minimum number of connections (triggers an urgent maintenance) *)
expected_connections : int ;
(** Targeted number of connections to reach when bootstraping / maitening *)
max_connections : int ;
(** Maximum number of connections (exceeding peers are disconnected) *)
backlog : int ;
(** Argument of [Lwt_unix.accept].*)
max_incoming_connections : int ;
(** Maximum not-yet-authentified incoming connections. *)
max_download_speed : int option ;
(** Hard-limit in the number of bytes received per second. *)
max_upload_speed : int option ;
(** Hard-limit in the number of bytes sent per second. *)
read_buffer_size : int ;
(** Size in bytes of the buffer passed to [Lwt_unix.read]. *)
read_queue_size : int option ;
write_queue_size : int option ;
incoming_app_message_queue_size : int option ;
incoming_message_queue_size : int option ;
outgoing_message_queue_size : int option ;
(** Various bounds for internal queues. *)
}
type ('msg, 'meta) t
type ('msg, 'meta) net = ('msg, 'meta) t
(** A faked p2p layer, which do not initiate any connection
nor open any listening socket *)
val faked_network : net
val faked_network : ('msg, 'meta) net
(** Main network initialisation function *)
val bootstrap : config:config -> limits:limits -> net Lwt.t
(** Main network initialisation function *)
val bootstrap :
config:config -> limits:limits ->
'meta meta_config -> 'msg message_config -> ('msg, 'meta) net Lwt.t
(** Return one's gid *)
val gid : net -> gid
(** Return one's gid *)
val gid : ('msg, 'meta) net -> Gid.t
(** A maintenance operation : try and reach the ideal number of peers *)
val maintain : net -> unit Lwt.t
(** A maintenance operation : try and reach the ideal number of peers *)
val maintain : ('msg, 'meta) net -> unit Lwt.t
(** Voluntarily drop some peers and replace them by new buddies *)
val roll : net -> unit Lwt.t
(** Voluntarily drop some peers and replace them by new buddies *)
val roll : ('msg, 'meta) net -> unit Lwt.t
(** Close all connections properly *)
val shutdown : net -> unit Lwt.t
(** Close all connections properly *)
val shutdown : ('msg, 'meta) net -> unit Lwt.t
(** A connection to a peer *)
type peer
(** A connection to a peer *)
type ('msg, 'meta) connection
(** Access the domain of active peers *)
val peers : net -> peer list
(** Access the domain of active peers *)
val connections : ('msg, 'meta) net -> ('msg, 'meta) connection list
(** Return the active peer with identity [gid] *)
val find_peer : net -> gid -> peer option
(** Return the active peer with identity [gid] *)
val find_connection : ('msg, 'meta) net -> Gid.t -> ('msg, 'meta) connection option
type peer_info = {
gid : gid ;
addr : addr ;
port : port ;
version : version ;
total_sent : int ;
total_recv : int ;
current_inflow : float ;
current_outflow : float ;
}
(** Access the info of an active peer, if available *)
val connection_info :
('msg, 'meta) net -> ('msg, 'meta) connection -> Connection_info.t
val connection_stat :
('msg, 'meta) net -> ('msg, 'meta) connection -> Stat.t
val global_stat : ('msg, 'meta) net -> Stat.t
(** Access the info of an active peer, if available *)
val peer_info : net -> peer -> peer_info
(** Accessors for meta information about a global identifier *)
val get_metadata : ('msg, 'meta) net -> Gid.t -> 'meta option
val set_metadata : ('msg, 'meta) net -> Gid.t -> 'meta -> unit
(** Accessors for meta information about a global identifier *)
val get_metadata : net -> gid -> P.metadata option
val set_metadata : net -> gid -> P.metadata -> unit
(** Wait for a message from a given connection. *)
val recv :
('msg, 'meta) net -> ('msg, 'meta) connection -> 'msg tzresult Lwt.t
(** Wait for a message from any peer in the network *)
val recv : net -> (peer * P.msg) Lwt.t
(** Wait for a message from any active connections. *)
val recv_any :
('msg, 'meta) net -> (('msg, 'meta) connection * 'msg) Lwt.t
(** [send net peer msg] is a thread that returns when [msg] has been
(** [send net peer msg] is a thread that returns when [msg] has been
successfully enqueued in the send queue. *)
val send : net -> peer -> P.msg -> unit Lwt.t
val send :
('msg, 'meta) net -> ('msg, 'meta) connection -> 'msg -> unit Lwt.t
(** [try_send net peer msg] is [true] if [msg] has been added to the
(** [try_send net peer msg] is [true] if [msg] has been added to the
send queue for [peer], [false] otherwise *)
val try_send : net -> peer -> P.msg -> bool
val try_send :
('msg, 'meta) net -> ('msg, 'meta) connection -> 'msg -> bool
(** Send a message to all peers *)
val broadcast : net -> P.msg -> unit
(** Shutdown the connection to all peers at this address and stop the
communications with this machine for [duration] seconds *)
val blacklist : net -> gid -> unit
(** Keep a connection to this pair as often as possible *)
val whitelist : net -> gid -> unit
(** Send a message to all peers *)
val broadcast : ('msg, 'meta) net -> 'msg -> unit
(**/**)
module Raw : sig
type 'a t =
| Bootstrap
| Advertise of P2p_types.Point.t list
| Message of 'a
| Disconnect
val encoding: 'msg app_message_encoding list -> 'msg t Data_encoding.t
end

410
src/node/net/p2p_connection.ml Normal file
View File

@ -0,0 +1,410 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
(* TODO encode/encrypt before to push into the writer pipe. *)
(* TODO patch Sodium.Box to avoid allocation of the encrypted buffer.*)
(* TODO patch Data_encoding for continuation-based binary writer/reader. *)
(* TODO use queue bound by memory size of its elements, not by the
number of elements. *)
(* TODO test `close ~wait:true`. *)
(* TODO nothing in welcoming message proves that the incoming peer is
the owner of the public key... only the first message will
really proves it. Should this to be changed? Not really
important, but... an attacker might forge a random public key
with enough proof of work (hard task), open a connection, wait
infinitly. This would avoid the real peer to talk with us. And
this might also have an influence on its "score". *)
open P2p_types
include Logging.Make(struct let name = "p2p.connection" end)
type error += Decipher_error
type error += Invalid_message_size
type error += Encoding_error
type error += Rejected
type error += Decoding_error
type error += Myself of Id_point.t
type error += Not_enough_proof_of_work of Gid.t
type cryptobox_data = {
channel_key : Crypto_box.channel_key ;
mutable local_nonce : Crypto_box.nonce ;
mutable remote_nonce : Crypto_box.nonce ;
}
let header_length = 2
let crypto_overhead = 18 (* FIXME import from Sodium.Box. *)
let max_content_length =
1 lsl (header_length * 8) - crypto_overhead
module Connection_message = struct
type t = {
port : int option ;
versions : Version.t list ;
public_key : Crypto_box.public_key ;
proof_of_work_stamp : Crypto_box.nonce ;
message_nonce : Crypto_box.nonce ;
}
let encoding =
let open Data_encoding in
conv
(fun { port ; public_key ; proof_of_work_stamp ;
message_nonce ; versions } ->
let port = match port with None -> 0 | Some port -> port in
(port, public_key, proof_of_work_stamp,
message_nonce, versions))
(fun (port, public_key, proof_of_work_stamp,
message_nonce, versions) ->
let port = if port = 0 then None else Some port in
{ port ; public_key ; proof_of_work_stamp ;
message_nonce ; versions })
(obj5
(req "port" uint16)
(req "pubkey" Crypto_box.public_key_encoding)
(req "proof_of_work_stamp" Crypto_box.nonce_encoding)
(req "message_nonce" Crypto_box.nonce_encoding)
(req "versions" (Variable.list Version.encoding)))
let write fd message =
let encoded_message_len =
Data_encoding.Binary.length encoding message in
fail_unless
(encoded_message_len < max_content_length)
Encoding_error >>=? fun () ->
let len = header_length + encoded_message_len in
let buf = MBytes.create len in
match Data_encoding.Binary.write encoding message buf header_length with
| None ->
fail Encoding_error
| Some last ->
fail_unless (last = len) Encoding_error >>=? fun () ->
MBytes.set_int16 buf 0 encoded_message_len ;
P2p_io_scheduler.write fd buf
let read fd =
let header_buf = MBytes.create header_length in
P2p_io_scheduler.read_full ~len:header_length fd header_buf >>=? fun () ->
let len = MBytes.get_uint16 header_buf 0 in
let buf = MBytes.create len in
P2p_io_scheduler.read_full ~len fd buf >>=? fun () ->
match Data_encoding.Binary.read encoding buf 0 len with
| None ->
fail Decoding_error
| Some (read_len, message) ->
if read_len <> len then
fail Decoding_error
else
return message
end
module Ack = struct
type t = bool
let ack = MBytes.of_string "\255"
let nack = MBytes.of_string "\000"
let write fd b =
match b with
| true ->
P2p_io_scheduler.write fd ack
| false ->
P2p_io_scheduler.write fd nack
let read fd =
let buf = MBytes.create 1 in
P2p_io_scheduler.read_full fd buf >>=? fun () ->
return (buf <> nack)
end
type authenticated_fd =
P2p_io_scheduler.connection * Connection_info.t * cryptobox_data
let kick (fd, _ , _) =
Ack.write fd false >>= fun _ ->
P2p_io_scheduler.close fd >>= fun _ ->
Lwt.return_unit
(* First step: write and read credentials, makes no difference
whether we're trying to connect to a peer or checking an incoming
connection, both parties must first introduce themselves. *)
let authenticate
~proof_of_work_target
~incoming fd (remote_addr, remote_socket_port as point)
?listening_port identity supported_versions =
let local_nonce = Crypto_box.random_nonce () in
lwt_debug "Sending authenfication to %a" Point.pp point >>= fun () ->
Connection_message.write fd
{ public_key = identity.Identity.public_key ;
proof_of_work_stamp = identity.proof_of_work_stamp ;
message_nonce = local_nonce ;
port = listening_port ;
versions = supported_versions } >>=? fun () ->
Connection_message.read fd >>=? fun msg ->
let remote_listening_port =
if incoming then msg.port else Some remote_socket_port in
let id_point = remote_addr, remote_listening_port in
let remote_gid = Crypto_box.hash msg.public_key in
fail_unless
(remote_gid <> identity.Identity.gid)
(Myself id_point) >>=? fun () ->
fail_unless
(Crypto_box.check_proof_of_work
msg.public_key msg.proof_of_work_stamp proof_of_work_target)
(Not_enough_proof_of_work remote_gid) >>=? fun () ->
let channel_key =
Crypto_box.precompute identity.Identity.secret_key msg.public_key in
let info =
{ Connection_info.gid = remote_gid ; versions = msg.versions ; incoming ;
id_point ; remote_socket_port ;} in
let cryptobox_data =
{ channel_key ; local_nonce ;
remote_nonce = msg.message_nonce } in
return (info, (fd, info, cryptobox_data))
type connection = {
info : Connection_info.t ;
fd : P2p_io_scheduler.connection ;
cryptobox_data : cryptobox_data ;
}
module Reader = struct
type 'msg t = {
canceler: Canceler.t ;
conn: connection ;
encoding: 'msg Data_encoding.t ;
messages: 'msg tzresult Lwt_pipe.t ;
mutable worker: unit Lwt.t ;
}
let read_chunk { fd ; cryptobox_data } =
let header_buf = MBytes.create header_length in
P2p_io_scheduler.read_full ~len:header_length fd header_buf >>=? fun () ->
let len = MBytes.get_uint16 header_buf 0 in
let buf = MBytes.create len in
P2p_io_scheduler.read_full ~len fd buf >>=? fun () ->
let remote_nonce = cryptobox_data.remote_nonce in
cryptobox_data.remote_nonce <- Crypto_box.increment_nonce remote_nonce ;
match
Crypto_box.fast_box_open cryptobox_data.channel_key buf remote_nonce
with
| None ->
fail Decipher_error
| Some buf ->
return buf
let rec read_message st buf =
return (Data_encoding.Binary.of_bytes st.encoding buf)
let rec worker_loop st =
Lwt_unix.yield () >>= fun () ->
Lwt_utils.protect ~canceler:st.canceler begin fun () ->
read_chunk st.conn >>=? fun buf ->
read_message st buf
end >>= function
| Ok None ->
Lwt_pipe.push st.messages (Error [Decoding_error]) >>= fun () ->
worker_loop st
| Ok (Some msg) ->
Lwt_pipe.push st.messages (Ok msg) >>= fun () ->
worker_loop st
| Error [Lwt_utils.Canceled | Exn Lwt_pipe.Closed] ->
Lwt.return_unit
| Error _ as err ->
Lwt_pipe.push st.messages err >>= fun () ->
Canceler.cancel st.canceler >>= fun () ->
Lwt.return_unit
let run ?size conn encoding canceler =
let st =
{ canceler ; conn ; encoding ;
messages = Lwt_pipe.create ?size () ;
worker = Lwt.return_unit ;
} in
Canceler.on_cancel st.canceler begin fun () ->
Lwt_pipe.close st.messages ;
Lwt.return_unit
end ;
st.worker <-
Lwt_utils.worker "reader"
(fun () -> worker_loop st)
(fun () -> Canceler.cancel st.canceler) ;
st
let shutdown st =
Canceler.cancel st.canceler >>= fun () ->
st.worker
end
module Writer = struct
type 'msg t = {
canceler: Canceler.t ;
conn: connection ;
encoding: 'msg Data_encoding.t ;
messages: ('msg * unit tzresult Lwt.u option) Lwt_pipe.t ;
mutable worker: unit Lwt.t ;
}
let write_chunk { cryptobox_data ; fd } buf =
let header_buf = MBytes.create header_length in
let local_nonce = cryptobox_data.local_nonce in
cryptobox_data.local_nonce <- Crypto_box.increment_nonce local_nonce ;
let encrypted_message =
Crypto_box.fast_box cryptobox_data.channel_key buf local_nonce in
let encrypted_len = MBytes.length encrypted_message in
fail_unless
(encrypted_len < max_content_length)
Invalid_message_size >>=? fun () ->
MBytes.set_int16 header_buf 0 encrypted_len ;
P2p_io_scheduler.write fd header_buf >>=? fun () ->
P2p_io_scheduler.write fd encrypted_message >>=? fun () ->
return ()
let encode_message st msg =
try return (Data_encoding.Binary.to_bytes st.encoding msg)
with _ -> fail Encoding_error
let rec worker_loop st =
Lwt_unix.yield () >>= fun () ->
Lwt_utils.protect ~canceler:st.canceler begin fun () ->
Lwt_pipe.pop st.messages >>= fun (msg, wakener) ->
encode_message st msg >>=? fun buf ->
write_chunk st.conn buf >>= fun res ->
iter_option wakener ~f:(fun u -> Lwt.wakeup_later u res) ;
Lwt.return res
end >>= function
| Ok () ->
worker_loop st
| Error [Lwt_utils.Canceled | Exn Lwt_pipe.Closed] ->
Lwt.return_unit
| Error err ->
lwt_log_error
"@[<v 2>Error while writing to %a@ %a@]"
Connection_info.pp st.conn.info pp_print_error err >>= fun () ->
Canceler.cancel st.canceler >>= fun () ->
Lwt.return_unit
let run ?size conn encoding canceler =
let st =
{ canceler ; conn ; encoding ;
messages = Lwt_pipe.create ?size () ;
worker = Lwt.return_unit ;
} in
Canceler.on_cancel st.canceler begin fun () ->
Lwt_pipe.close st.messages ;
Lwt.return_unit
end ;
st.worker <-
Lwt_utils.worker "writer"
(fun () -> worker_loop st)
(fun () -> Canceler.cancel st.canceler) ;
st
let shutdown st =
Canceler.cancel st.canceler >>= fun () ->
st.worker
end
type 'msg t = {
conn : connection ;
reader : 'msg Reader.t ;
writer : 'msg Writer.t ;
}
let pp ppf { conn } = Connection_info.pp ppf conn.info
let info { conn } = conn.info
let accept
?incoming_message_queue_size ?outgoing_message_queue_size
(fd, info, cryptobox_data) encoding =
Lwt_utils.protect begin fun () ->
Ack.write fd true >>=? fun () ->
Ack.read fd
end ~on_error:begin fun err ->
P2p_io_scheduler.close fd >>= fun _ ->
Lwt.return (Error err)
end >>=? fun accepted ->
fail_unless accepted Rejected >>=? fun () ->
let canceler = Canceler.create () in
let conn = { fd ; info ; cryptobox_data } in
let reader =
Reader.run ?size:incoming_message_queue_size conn encoding canceler
and writer =
Writer.run ?size:outgoing_message_queue_size conn encoding canceler in
let conn = { conn ; reader ; writer } in
Canceler.on_cancel canceler begin fun () ->
P2p_io_scheduler.close fd >>= fun _ ->
Lwt.return_unit
end ;
return conn
exception Not_available
exception Connection_closed
let catch_closed_pipe f =
Lwt.catch f begin function
| Lwt_pipe.Closed -> fail P2p_io_scheduler.Connection_closed
| exn -> fail (Exn exn)
end
let is_writable { writer } =
not (Lwt_pipe.is_full writer.messages)
let wait_writable { writer } =
Lwt_pipe.not_full writer.messages
let write { writer } msg =
catch_closed_pipe begin fun () ->
Lwt_pipe.push writer.messages (msg, None) >>= return
end
let write_sync { writer } msg =
catch_closed_pipe begin fun () ->
let waiter, wakener = Lwt.wait () in
Lwt_pipe.push writer.messages (msg, Some wakener) >>= fun () ->
waiter
end
let write_now { writer } msg =
try Ok (Lwt_pipe.push_now writer.messages (msg, None))
with Lwt_pipe.Closed -> Error [P2p_io_scheduler.Connection_closed]
let is_readable { reader } =
not (Lwt_pipe.is_empty reader.messages)
let wait_readable { reader } =
catch_closed_pipe begin fun () ->
Lwt_pipe.values_available reader.messages >>= return
end
let read { reader } =
catch_closed_pipe begin fun () ->
Lwt_pipe.pop reader.messages
end
let read_now { reader } =
try Lwt_pipe.pop_now reader.messages
with Lwt_pipe.Closed -> Some (Error [P2p_io_scheduler.Connection_closed])
let stat { conn = { fd } } = P2p_io_scheduler.stat fd
let close ?(wait = false) st =
begin
if not wait then Lwt.return_unit
else begin
Lwt_pipe.close st.reader.messages ;
Lwt_pipe.close st.writer.messages ;
st.writer.worker
end
end >>= fun () ->
Reader.shutdown st.reader >>= fun () ->
Writer.shutdown st.writer >>= fun () ->
P2p_io_scheduler.close st.conn.fd >>= fun _ ->
Lwt.return_unit

119
src/node/net/p2p_connection.mli Normal file
View File

@ -0,0 +1,119 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
(** This modules adds message encoding and encryption to
[P2p_io_scheduler]'s generic throttled connections.
Each connection have an associated internal read (resp. write)
queue containing messages (of type ['msg]), whose size can be
limited by providing corresponding arguments to [accept].
*)
open P2p_types
(** {1 Types} *)
type error += Decipher_error
type error += Invalid_message_size
type error += Encoding_error
type error += Decoding_error
type error += Rejected
type error += Myself of Id_point.t
type error += Not_enough_proof_of_work of Gid.t
type authenticated_fd
(** Type of a connection that successfully passed the authentication
phase, but has not been accepted yet. *)
type 'msg t
(** Type of an accepted connection, parametrized by the type of
messages exchanged between peers. *)
val pp : Format.formatter -> 'msg t -> unit
val info: 'msg t -> Connection_info.t
(** {1 Low-level functions (do not use directly)} *)
val authenticate:
proof_of_work_target:Crypto_box.target ->
incoming:bool ->
P2p_io_scheduler.connection -> Point.t ->
?listening_port: int ->
Identity.t -> Version.t list ->
(Connection_info.t * authenticated_fd) tzresult Lwt.t
(** (Low-level) (Cancelable) Authentication function of a remote
peer. Used in [P2p_connection_pool], to promote a
[P2P_io_scheduler.connection] into an [authenticated_fd] (auth
correct, acceptation undecided). *)
val kick: authenticated_fd -> unit Lwt.t
(** (Low-level) (Cancelable) [kick afd] notifies the remote peer that
we refuse this connection and then closes [afd]. Used in
[P2p_connection_pool] to reject an [aunthenticated_fd] which we do
not want to connect to for some reason. *)
val accept:
?incoming_message_queue_size:int ->
?outgoing_message_queue_size:int ->
authenticated_fd -> 'msg Data_encoding.t -> 'msg t tzresult Lwt.t
(** (Low-level) (Cancelable) Accepts a remote peer given an
authenticated_fd. Used in [P2p_connection_pool], to promote an
[authenticated_fd] to the status of an active peer. *)
(** {1 IO functions on connections} *)
(** {2 Output functions} *)
val is_writable: 'msg t -> bool
(** [is_writable conn] is [true] iff [conn] internal write queue is
not full. *)
val wait_writable: 'msg t -> unit Lwt.t
(** (Cancelable) [wait_writable conn] returns when [conn]'s internal
write queue becomes writable (i.e. not full). *)
val write: 'msg t -> 'msg -> unit tzresult Lwt.t
(** [write conn msg] returns when [msg] has successfully been added to
[conn]'s internal write queue or fails with a corresponding
error. *)
val write_now: 'msg t -> 'msg -> bool tzresult
(** [write_now conn msg] is [Ok true] if [msg] has been added to
[conn]'s internal write queue, [Ok false] if [msg] has been
dropped, or fails with a correponding error otherwise. *)
val write_sync: 'msg t -> 'msg -> unit tzresult Lwt.t
(** [write_sync conn msg] returns when [msg] has been successfully
sent to the remote end of [conn], or fails accordingly. *)
(** {2 Input functions} *)
val is_readable: 'msg t -> bool
(** [is_readable conn] is [true] iff [conn] internal read queue is not
empty. *)
val wait_readable: 'msg t -> unit tzresult Lwt.t
(** (Cancelable) [wait_readable conn] returns when [conn]'s internal
read queue becomes readable (i.e. not empty). *)
val read: 'msg t -> 'msg tzresult Lwt.t
(** [read conn msg] returns when [msg] has successfully been popped
from [conn]'s internal read queue or fails with a corresponding
error. *)
val read_now: 'msg t -> 'msg tzresult option
(** [read_now conn msg] is [Some msg] if [conn]'s internal read queue
is not empty, [None] if it is empty, or fails with a correponding
error otherwise. *)
val stat: 'msg t -> Stat.t
(** [stat conn] is a snapshot of current bandwidth usage for
[conn]. *)
val close: ?wait:bool -> 'msg t -> unit Lwt.t

667
src/node/net/p2p_connection_pool.ml Normal file
View File

@ -0,0 +1,667 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
(* TODO check version negotiation *)
(* TODO Test cancelation of a (pending) connection *)
(* TODO do not recompute list_known_points at each requests... but
only once in a while, e.g. every minutes or when a point
or the associated gid is blacklisted. *)
(* TODO allow to track "requested gids" when we reconnect to a point. *)
open P2p_types
open P2p_connection_pool_types
include Logging.Make (struct let name = "p2p.connection-pool" end)
type 'msg encoding = Encoding : {
tag: int ;
encoding: 'a Data_encoding.t ;
wrap: 'a -> 'msg ;
unwrap: 'msg -> 'a option ;
max_length: int option ;
} -> 'msg encoding
module Message = struct
type 'msg t =
| Bootstrap
| Advertise of Point.t list
| Message of 'msg
| Disconnect
let encoding msg_encoding =
let open Data_encoding in
union ~tag_size:`Uint16
([ case ~tag:0x01 null
(function Disconnect -> Some () | _ -> None)
(fun () -> Disconnect);
case ~tag:0x02 null
(function Bootstrap -> Some () | _ -> None)
(fun () -> Bootstrap);
case ~tag:0x03 (Variable.list Point.encoding)
(function Advertise points -> Some points | _ -> None)
(fun points -> Advertise points);
] @
ListLabels.map msg_encoding
~f:(function Encoding { tag ; encoding ; wrap ; unwrap } ->
case ~tag encoding
(function Message msg -> unwrap msg | _ -> None)
(fun msg -> Message (wrap msg))))
end
module Answerer = struct
type 'msg callback = {
bootstrap: unit -> Point.t list Lwt.t ;
advertise: Point.t list -> unit Lwt.t ;
message: 'msg -> unit Lwt.t ;
}
type 'msg t = {
canceler: Canceler.t ;
conn: 'msg Message.t P2p_connection.t ;
callback: 'msg callback ;
mutable worker: unit Lwt.t ;
}
let rec worker_loop st =
Lwt_unix.yield () >>= fun () ->
Lwt_utils.protect ~canceler:st.canceler begin fun () ->
P2p_connection.read st.conn
end >>= function
| Ok Bootstrap -> begin
st.callback.bootstrap () >>= function
| [] ->
worker_loop st
| points ->
match P2p_connection.write_now st.conn (Advertise points) with
| Ok _sent ->
(* if not sent then ?? TODO count dropped message ?? *)
worker_loop st
| Error _ ->
Canceler.cancel st.canceler >>= fun () ->
Lwt.return_unit
end
| Ok (Advertise points) ->
st.callback.advertise points >>= fun () ->
worker_loop st
| Ok (Message msg) ->
st.callback.message msg >>= fun () ->
worker_loop st
| Ok Disconnect | Error [P2p_io_scheduler.Connection_closed] ->
Canceler.cancel st.canceler >>= fun () ->
Lwt.return_unit
| Error [Lwt_utils.Canceled] ->
Lwt.return_unit
| Error err ->
lwt_log_error "@[Answerer unexpected error:@ %a@]"
Error_monad.pp_print_error err >>= fun () ->
Canceler.cancel st.canceler >>= fun () ->
Lwt.return_unit
let run conn canceler callback =
let st = {
canceler ; conn ; callback ;
worker = Lwt.return_unit ;
} in
st.worker <-
Lwt_utils.worker "answerer"
(fun () -> worker_loop st)
(fun () -> Canceler.cancel canceler) ;
st
let shutdown st =
Canceler.cancel st.canceler >>= fun () ->
st.worker
end
type config = {
identity : Identity.t ;
proof_of_work_target : Crypto_box.target ;
trusted_points : Point.t list ;
peers_file : string ;
closed_network : bool ;
listening_port : port option ;
min_connections : int ;
max_connections : int ;
max_incoming_connections : int ;
authentification_timeout : float ;
incoming_app_message_queue_size : int option ;
incoming_message_queue_size : int option ;
outgoing_message_queue_size : int option ;
}
type 'meta meta_config = {
encoding : 'meta Data_encoding.t;
initial : 'meta;
}
type 'msg message_config = {
encoding : 'msg encoding list ;
versions : P2p_types.Version.t list;
}
type ('msg, 'meta) t = {
config : config ;
meta_config : 'meta meta_config ;
message_config : 'msg message_config ;
my_id_points : unit Point.Table.t ;
known_gids : (('msg, 'meta) connection, 'meta) Gid_info.t Gid.Table.t ;
connected_gids : (('msg, 'meta) connection, 'meta) Gid_info.t Gid.Table.t ;
known_points : ('msg, 'meta) connection Point_info.t Point.Table.t ;
connected_points : ('msg, 'meta) connection Point_info.t Point.Table.t ;
incoming : Canceler.t Point.Table.t ;
io_sched : P2p_io_scheduler.t ;
encoding : 'msg Message.t Data_encoding.t ;
events : events ;
}
and events = {
too_few_connections : unit Lwt_condition.t ;
too_many_connections : unit Lwt_condition.t ;
new_point : unit Lwt_condition.t ;
}
and ('msg, 'meta) connection = {
canceler : Canceler.t ;
messages : 'msg Lwt_pipe.t ;
conn : 'msg Message.t P2p_connection.t ;
gid_info : (('msg, 'meta) connection, 'meta) Gid_info.t ;
point_info : ('msg, 'meta) connection Point_info.t option ;
answerer : 'msg Answerer.t ;
mutable wait_close : bool ;
}
type ('msg, 'meta) pool = ('msg, 'meta) t
let register_point pool ?trusted (addr, port as point) =
match Point.Table.find pool.known_points point with
| exception Not_found ->
let pi = Point_info.create ?trusted addr port in
Point.Table.add pool.known_points point pi ;
pi
| pi -> pi
let register_peer pool gid =
match Gid.Table.find pool.known_gids gid with
| exception Not_found ->
Lwt_condition.broadcast pool.events.new_point () ;
let peer = Gid_info.create gid ~metadata:pool.meta_config.initial in
Gid.Table.add pool.known_gids gid peer ;
peer
| peer -> peer
let register_new_point pool _gid point =
if not (Point.Table.mem pool.my_id_points point) then
ignore (register_point pool point)
let register_new_points pool gid points =
List.iter (register_new_point pool gid) points ;
Lwt.return_unit
let compare_known_point_info p1 p2 =
(* The most-recently disconnected peers are greater. *)
(* Then come long-standing connected peers. *)
let disconnected1 = Point_info.State.is_disconnected p1
and disconnected2 = Point_info.State.is_disconnected p2 in
let compare_last_seen p1 p2 =
match Point_info.last_seen p1, Point_info.last_seen p2 with
| None, None -> Random.int 2 * 2 - 1 (* HACK... *)
| Some _, None -> 1
| None, Some _ -> -1
| Some (_, time1), Some (_, time2) ->
match compare time1 time2 with
| 0 -> Random.int 2 * 2 - 1 (* HACK... *)
| x -> x in
match disconnected1, disconnected2 with
| false, false -> compare_last_seen p1 p2
| false, true -> -1
| true, false -> 1
| true, true -> compare_last_seen p2 p1
let list_known_points pool _gid () =
let knowns =
Point.Table.fold (fun _ pi acc -> pi :: acc) pool.known_points [] in
let best_knowns =
Utils.take_n ~compare:compare_known_point_info 50 knowns in
Lwt.return (List.map Point_info.point best_knowns)
let active_connections pool = Gid.Table.length pool.connected_gids
let create_connection pool conn id_point pi gi =
let gid = Gid_info.gid gi in
let canceler = Canceler.create () in
let messages =
Lwt_pipe.create ?size:pool.config.incoming_app_message_queue_size () in
let callback =
{ Answerer.message = Lwt_pipe.push messages ;
advertise = register_new_points pool gid ;
bootstrap = list_known_points pool gid ;
} in
let answerer = Answerer.run conn canceler callback in
let conn =
{ conn ; point_info = pi ; gid_info = gi ;
messages ; canceler ; answerer ; wait_close = false } in
iter_option pi ~f:begin fun pi ->
Point_info.State.set_running pi gid conn ;
Point.Table.add pool.connected_points (Point_info.point pi) pi ;
end ;
Gid_info.State.set_running gi id_point conn ;
Gid.Table.add pool.connected_gids gid gi ;
Canceler.on_cancel canceler begin fun () ->
lwt_debug "Disconnect: %a (%a)"
Gid.pp gid Id_point.pp id_point >>= fun () ->
iter_option ~f:Point_info.State.set_disconnected pi;
Gid_info.State.set_disconnected gi ;
iter_option pi ~f:begin fun pi ->
Point.Table.remove pool.connected_points (Point_info.point pi) ;
end ;
Gid.Table.remove pool.connected_gids gid ;
if pool.config.max_connections <= active_connections pool then
Lwt_condition.broadcast pool.events.too_many_connections () ;
P2p_connection.close ~wait:conn.wait_close conn.conn
end ;
if active_connections pool < pool.config.min_connections then
Lwt_condition.broadcast pool.events.too_few_connections () ;
conn
let disconnect ?(wait = false) conn =
conn.wait_close <- wait ;
Canceler.cancel conn.canceler >>= fun () ->
conn.answerer.worker
type error += Rejected of Gid.t
type error += Unexpected_point_state
type error += Unexpected_gid_state
let may_register_my_id_point pool = function
| [P2p_connection.Myself (addr, Some port)] ->
Point.Table.add pool.my_id_points (addr, port) () ;
Point.Table.remove pool.known_points (addr, port)
| _ -> ()
let authenticate pool ?pi canceler fd point =
let incoming = pi = None in
lwt_debug "authenticate: %a%s"
Point.pp point
(if incoming then " incoming" else "") >>= fun () ->
Lwt_utils.protect ~canceler begin fun () ->
P2p_connection.authenticate
~proof_of_work_target:pool.config.proof_of_work_target
~incoming (P2p_io_scheduler.register pool.io_sched fd) point
?listening_port:pool.config.listening_port
pool.config.identity pool.message_config.versions
end ~on_error: begin fun err ->
(* TODO do something when the error is Not_enough_proof_of_work ?? *)
lwt_debug "authenticate: %a%s -> failed %a"
Point.pp point
(if incoming then " incoming" else "")
pp_print_error err >>= fun () ->
may_register_my_id_point pool err ;
if incoming then
Point.Table.remove pool.incoming point
else
iter_option Point_info.State.set_disconnected pi ;
Lwt.return (Error err)
end >>=? fun (info, auth_fd) ->
lwt_debug "authenticate: %a -> auth %a"
Point.pp point
Connection_info.pp info >>= fun () ->
let remote_pi =
match info.id_point with
| addr, Some port
when not (Point.Table.mem pool.my_id_points (addr, port)) ->
Some (register_point pool (addr, port))
| _ -> None in
let connection_pi =
match pi, remote_pi with
| None, None -> None
| Some _ as pi, _ | _, (Some _ as pi) -> pi in
let gi = register_peer pool info.gid in
let acceptable_point =
unopt_map connection_pi
~default:(not pool.config.closed_network)
~f:begin fun connection_pi ->
match Point_info.State.get connection_pi with
| Requested _ -> not incoming
| Disconnected ->
not pool.config.closed_network
|| Point_info.trusted connection_pi
| Accepted _ | Running _ -> false
end
in
let acceptable_gid =
match Gid_info.State.get gi with
| Accepted _ ->
(* TODO: in some circumstances cancel and accept... *)
false
| Running _ -> false
| Disconnected -> true
in
if incoming then Point.Table.remove pool.incoming point ;
if not acceptable_gid || not acceptable_point then begin
lwt_debug "authenticate: %a -> kick %a point: %B gid: %B"
Point.pp point
Connection_info.pp info
acceptable_point acceptable_gid >>= fun () ->
P2p_connection.kick auth_fd >>= fun () ->
if not incoming then begin
iter_option ~f:Point_info.State.set_disconnected pi ;
(* FIXME Gid_info.State.set_disconnected ~requested:true gi ; *)
end ;
fail (Rejected info.gid)
end else begin
iter_option connection_pi
~f:(fun pi -> Point_info.State.set_accepted pi info.gid canceler) ;
Gid_info.State.set_accepted gi info.id_point canceler ;
lwt_debug "authenticate: %a -> accept %a"
Point.pp point
Connection_info.pp info >>= fun () ->
Lwt_utils.protect ~canceler begin fun () ->
P2p_connection.accept
?incoming_message_queue_size:pool.config.incoming_message_queue_size
?outgoing_message_queue_size:pool.config.outgoing_message_queue_size
auth_fd pool.encoding >>= fun conn ->
lwt_debug "authenticate: %a -> Connected %a"
Point.pp point
Connection_info.pp info >>= fun () ->
Lwt.return conn
end ~on_error: begin fun err ->
lwt_debug "authenticate: %a -> rejected %a"
Point.pp point
Connection_info.pp info >>= fun () ->
iter_option connection_pi ~f:Point_info.State.set_disconnected;
Gid_info.State.set_disconnected gi ;
Lwt.return (Error err)
end >>=? fun conn ->
let id_point =
match info.id_point, map_option Point_info.point pi with
| (addr, _), Some (_, port) -> addr, Some port
| id_point, None -> id_point in
return (create_connection pool conn id_point connection_pi gi)
end
type error += Pending_connection
type error += Connected
type error += Connection_closed = P2p_io_scheduler.Connection_closed
type error += Connection_refused
type error += Closed_network
let fail_unless_disconnected_point pi =
match Point_info.State.get pi with
| Disconnected -> return ()
| Requested _ | Accepted _ -> fail Pending_connection
| Running _ -> fail Connected
let fail_unless_disconnected_gid gi =
match Gid_info.State.get gi with
| Disconnected -> return ()
| Accepted _ -> fail Pending_connection
| Running _ -> fail Connected
let raw_connect canceler pool point =
let pi = register_point pool point in
let addr, port as point = Point_info.point pi in
fail_unless
(not pool.config.closed_network || Point_info.trusted pi)
Closed_network >>=? fun () ->
fail_unless_disconnected_point pi >>=? fun () ->
Point_info.State.set_requested pi canceler ;
let fd = Lwt_unix.socket PF_INET6 SOCK_STREAM 0 in
let uaddr =
Lwt_unix.ADDR_INET (Ipaddr_unix.V6.to_inet_addr addr, port) in
lwt_debug "connect: %a" Point.pp point >>= fun () ->
Lwt_utils.protect ~canceler begin fun () ->
Lwt_unix.connect fd uaddr >>= fun () ->
return ()
end ~on_error: begin fun err ->
lwt_debug "connect: %a -> disconnect" Point.pp point >>= fun () ->
Point_info.State.set_disconnected pi ;
match err with
| [Exn (Unix.Unix_error (Unix.ECONNREFUSED, _, _))] ->
fail Connection_refused
| err -> Lwt.return (Error err)
end >>=? fun () ->
lwt_debug "connect: %a -> authenticate" Point.pp point >>= fun () ->
authenticate pool ~pi canceler fd point
type error += Too_many_connections
let connect ~timeout pool point =
fail_unless
(active_connections pool <= pool.config.max_connections)
Too_many_connections >>=? fun () ->
let canceler = Canceler.create () in
Lwt_utils.with_timeout ~canceler timeout begin fun canceler ->
raw_connect canceler pool point
end
let accept pool fd point =
if pool.config.max_incoming_connections <= Point.Table.length pool.incoming
|| pool.config.max_connections <= active_connections pool then
Lwt.async (fun () -> Lwt_utils.safe_close fd)
else
let canceler = Canceler.create () in
Point.Table.add pool.incoming point canceler ;
Lwt.async begin fun () ->
Lwt_utils.with_timeout
~canceler pool.config.authentification_timeout
(fun canceler -> authenticate pool canceler fd point)
end
(***************************************************************************)
let read { messages } =
Lwt.catch
(fun () -> Lwt_pipe.pop messages >>= return)
(fun _ (* Closed *) -> fail P2p_io_scheduler.Connection_closed)
let is_readable { messages } =
Lwt.catch
(fun () -> Lwt_pipe.values_available messages >>= return)
(fun _ (* Closed *) -> fail P2p_io_scheduler.Connection_closed)
let write { conn } msg =
P2p_connection.write conn (Message msg)
let write_sync { conn } msg =
P2p_connection.write_sync conn (Message msg)
let write_now { conn } msg =
P2p_connection.write_now conn (Message msg)
let write_all pool msg =
Gid.Table.iter
(fun _gid gi ->
match Gid_info.State.get gi with
| Running { data = conn } ->
ignore (write_now conn msg : bool tzresult )
| _ -> ())
pool.connected_gids
let broadcast_bootstrap_msg pool =
Gid.Table.iter
(fun _gid gi ->
match Gid_info.State.get gi with
| Running { data = { conn } } ->
ignore (P2p_connection.write_now conn Bootstrap : bool tzresult )
| _ -> ())
pool.connected_gids
(***************************************************************************)
module Gids = struct
type ('msg, 'meta) info = (('msg, 'meta) connection, 'meta) Gid_info.t
let info { known_gids } point =
try Some (Gid.Table.find known_gids point)
with Not_found -> None
let get_metadata pool gid =
try Some (Gid_info.metadata (Gid.Table.find pool.known_gids gid))
with Not_found -> None
let set_metadata pool gid data =
Gid_info.set_metadata (register_peer pool gid) data
let get_trusted pool gid =
try Gid_info.trusted (Gid.Table.find pool.known_gids gid)
with Not_found -> false
let set_trusted pool gid =
try Gid_info.set_trusted (register_peer pool gid)
with Not_found -> ()
let unset_trusted pool gid =
try Gid_info.unset_trusted (Gid.Table.find pool.known_gids gid)
with Not_found -> ()
let find_connection pool gid =
apply_option
(info pool gid)
~f:(fun p ->
match Gid_info.State.get p with
| Running { data } -> Some data
| _ -> None)
let fold_known pool ~init ~f =
Gid.Table.fold f pool.known_gids init
let fold_connected pool ~init ~f =
Gid.Table.fold f pool.connected_gids init
end
let fold_connections pool ~init ~f =
Gids.fold_connected pool ~init ~f:begin fun gid gi acc ->
match Gid_info.State.get gi with
| Running { data } -> f gid data acc
| _ -> acc
end
module Points = struct
type ('msg, 'meta) info = ('msg, 'meta) connection Point_info.t
let info { known_points } point =
try Some (Point.Table.find known_points point)
with Not_found -> None
let get_trusted pool gid =
try Point_info.trusted (Point.Table.find pool.known_points gid)
with Not_found -> false
let set_trusted pool gid =
try Point_info.set_trusted (register_point pool gid)
with Not_found -> ()
let unset_trusted pool gid =
try Point_info.unset_trusted (Point.Table.find pool.known_points gid)
with Not_found -> ()
let find_connection pool point =
apply_option
(info pool point)
~f:(fun p ->
match Point_info.State.get p with
| Running { data } -> Some data
| _ -> None)
let fold_known pool ~init ~f =
Point.Table.fold f pool.known_points init
let fold_connected pool ~init ~f =
Point.Table.fold f pool.connected_points init
end
module Events = struct
let too_few_connections pool =
Lwt_condition.wait pool.events.too_few_connections
let too_many_connections pool =
Lwt_condition.wait pool.events.too_many_connections
let new_point pool =
Lwt_condition.wait pool.events.new_point
end
let connection_stat { conn } =
P2p_connection.stat conn
let pool_stat { io_sched } =
P2p_io_scheduler.global_stat io_sched
let connection_info { conn } =
P2p_connection.info conn
(***************************************************************************)
let create config meta_config message_config io_sched =
let events = {
too_few_connections = Lwt_condition.create () ;
too_many_connections = Lwt_condition.create () ;
new_point = Lwt_condition.create () ;
} in
let pool = {
config ; meta_config ; message_config ;
my_id_points = Point.Table.create 7 ;
known_gids = Gid.Table.create 53 ;
connected_gids = Gid.Table.create 53 ;
known_points = Point.Table.create 53 ;
connected_points = Point.Table.create 53 ;
incoming = Point.Table.create 53 ;
io_sched ;
encoding = Message.encoding message_config.encoding ;
events ;
} in
List.iter (Points.set_trusted pool) config.trusted_points ;
Lwt.catch
(fun () ->
Gid_info.File.load config.peers_file meta_config.encoding)
(fun _ ->
(* TODO log error *)
Lwt.return_nil) >>= fun gids ->
List.iter
(fun gi -> Gid.Table.add pool.known_gids (Gid_info.gid gi) gi)
gids ;
Lwt.return pool
let destroy pool =
Point.Table.fold (fun _point pi acc ->
match Point_info.State.get pi with
| Requested { cancel } | Accepted { cancel } ->
Canceler.cancel cancel >>= fun () -> acc
| Running { data = conn } ->
disconnect conn >>= fun () -> acc
| Disconnected -> acc)
pool.known_points @@
Gid.Table.fold (fun _gid gi acc ->
match Gid_info.State.get gi with
| Accepted { cancel } ->
Canceler.cancel cancel >>= fun () -> acc
| Running { data = conn } ->
disconnect conn >>= fun () -> acc
| Disconnected -> acc)
pool.known_gids @@
Point.Table.fold (fun _point canceler acc ->
Canceler.cancel canceler >>= fun () -> acc)
pool.incoming Lwt.return_unit

290
src/node/net/p2p_connection_pool.mli Normal file
View File

@ -0,0 +1,290 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
(** Pool of connections. This module manages the connection pool that
the shell needs to maintain in order to function correctly.
A pool and its connections are parametrized by the type of
messages exchanged over the connection and the type of
meta-information associated with a peer. The type [('msg, 'meta)
connection] is a wrapper on top of [P2p_connection.t] that adds
meta-information, a data-structure describing a fine-grained state
of the connection, as well as a new message queue (referred to
"app message queue") that will only contain the messages from the
internal [P2p_connection.t] that needs to be examined by the
higher layers. Some messages are directly processed by an internal
worker and thus never propagated above.
*)
open P2p_types
open P2p_connection_pool_types
type 'msg encoding = Encoding : {
tag: int ;
encoding: 'a Data_encoding.t ;
wrap: 'a -> 'msg ;
unwrap: 'msg -> 'a option ;
max_length: int option ;
} -> 'msg encoding
(** {1 Pool management} *)
type ('msg, 'meta) t
type ('msg, 'meta) pool = ('msg, 'meta) t
(** The type of a pool of connections, parametrized by resp. the type
of messages and the meta-information associated to an identity. *)
type config = {
identity : Identity.t ;
(** Our identity. *)
proof_of_work_target : Crypto_box.target ;
(** The proof of work target we require from peers. *)
trusted_points : Point.t list ;
(** List of hard-coded known peers to bootstrap the network from. *)
peers_file : string ;
(** The path to the JSON file where the metadata associated to
gids are loaded / stored. *)
closed_network : bool ;
(** If [true], the only accepted connections are from peers whose
addresses are in [trusted_peers]. *)
listening_port : port option ;
(** If provided, it will be passed to [P2p_connection.authenticate]
when we authenticate against a new peer. *)
min_connections : int ;
(** Strict minimum number of connections
(triggers [Event.too_few_connections]). *)
max_connections : int ;
(** Max number of connections. If it's reached, [connect] and
[accept] will fail, i.e. not add more connections
(also triggers [Event.too_many_connections]). *)
max_incoming_connections : int ;
(** Max not-yet-authentified incoming connections.
Above this number, [accept] will start dropping incoming
connections. *)
authentification_timeout : float ;
(** Delay granted to a peer to perform authentication, in seconds. *)
incoming_app_message_queue_size : int option ;
(** Size of the message queue for user messages (messages returned
by this module's [read] function. *)
incoming_message_queue_size : int option ;
(** Size of the incoming message queue internal of a peer's Reader
(See [P2p_connection.accept]). *)
outgoing_message_queue_size : int option ;
(** Size of the outgoing message queue internal to a peer's Writer
(See [P2p_connection.accept]). *)
}
type 'meta meta_config = {
encoding : 'meta Data_encoding.t;
initial : 'meta;
}
type 'msg message_config = {
encoding : 'msg encoding list ;
versions : P2p_types.Version.t list;
}
val create:
config ->
'meta meta_config ->
'msg message_config ->
P2p_io_scheduler.t ->
('msg, 'meta) pool Lwt.t
(** [create config meta_cfg msg_cfg io_sched] is a freshly minted
pool. *)
val destroy: ('msg, 'meta) pool -> unit Lwt.t
(** [destroy pool] returns when member connections are either
disconnected or canceled. *)
val active_connections: ('msg, 'meta) pool -> int
(** [active_connections pool] is the number of connections inside
[pool]. *)
val pool_stat: ('msg, 'meta) pool -> Stat.t
(** [pool_stat pool] is a snapshot of current bandwidth usage for the
entire [pool]. *)
(** {2 Pool events} *)
module Events : sig
val too_few_connections: ('msg, 'meta) pool -> unit Lwt.t
val too_many_connections: ('msg, 'meta) pool -> unit Lwt.t
val new_point: ('msg, 'meta) pool -> unit Lwt.t
end
(** {1 Connections management} *)
type ('msg, 'meta) connection
(** Type of a connection to a peer, parametrized by the type of
messages exchanged as well as meta-information associated to a
peer. It mostly wraps [P2p_connection.connection], adding
meta-information and data-structures describing a more
fine-grained logical state of the connection. *)
type error += Pending_connection
type error += Connected
type error += Connection_refused
type error += Rejected of Gid.t
type error += Too_many_connections
type error += Closed_network
val connect:
timeout:float ->
('msg, 'meta) pool -> Point.t ->
('msg, 'meta) connection tzresult Lwt.t
(** [connect ~timeout pool point] tries to add a
connection to [point] in [pool] in less than [timeout] seconds. *)
val accept:
('msg, 'meta) pool -> Lwt_unix.file_descr -> Point.t -> unit
(** [accept pool fd point] instructs [pool] to start the process of
accepting a connection from [fd]. Used by [P2p]. *)
val disconnect:
?wait:bool -> ('msg, 'meta) connection -> unit Lwt.t
(** [disconnect conn] cleanly closes [conn] and returns after [conn]'s
internal worker has returned. *)
val connection_info: ('msg, 'meta) connection -> Connection_info.t
val connection_stat: ('msg, 'meta) connection -> Stat.t
(** [stat conn] is a snapshot of current bandwidth usage for
[conn]. *)
val fold_connections:
('msg, 'meta) pool ->
init:'a ->
f:(Gid.t -> ('msg, 'meta) connection -> 'a -> 'a) ->
'a
(** {1 I/O on connections} *)
type error += Connection_closed
val read: ('msg, 'meta) connection -> 'msg tzresult Lwt.t
(** [read conn] returns a message popped from [conn]'s app message
queue, or fails with [Connection_closed]. *)
val is_readable: ('msg, 'meta) connection -> unit tzresult Lwt.t
(** [is_readable conn] returns when there is at least one message
ready to be read. *)
val write: ('msg, 'meta) connection -> 'msg -> unit tzresult Lwt.t
(** [write conn msg] is [P2p_connection.write conn' msg] where [conn']
is the internal [P2p_connection.t] inside [conn]. *)
val write_sync: ('msg, 'meta) connection -> 'msg -> unit tzresult Lwt.t
(** [write_sync conn msg] is [P2p_connection.write_sync conn' msg]
where [conn'] is the internal [P2p_connection.t] inside [conn]. *)
val write_now: ('msg, 'meta) connection -> 'msg -> bool tzresult
(** [write_now conn msg] is [P2p_connection.write_now conn' msg] where
[conn'] is the internal [P2p_connection.t] inside [conn]. *)
(** {2 Broadcast functions} *)
val write_all: ('msg, 'meta) pool -> 'msg -> unit
(** [write_all pool msg] is [write_now conn msg] for all member
connections to [pool] in [Running] state. *)
val broadcast_bootstrap_msg: ('msg, 'meta) pool -> unit
(** [write_all pool msg] is [P2P_connection.write_now conn Bootstrap]
for all member connections to [pool] in [Running] state. *)
(** {1 Functions on [Gid]} *)
module Gids : sig
type ('msg, 'meta) info = (('msg, 'meta) connection, 'meta) Gid_info.t
val info:
('msg, 'meta) pool -> Gid.t -> ('msg, 'meta) info option
val get_metadata: ('msg, 'meta) pool -> Gid.t -> 'meta option
val set_metadata: ('msg, 'meta) pool -> Gid.t -> 'meta -> unit
val get_trusted: ('msg, 'meta) pool -> Gid.t -> bool
val set_trusted: ('msg, 'meta) pool -> Gid.t -> unit
val unset_trusted: ('msg, 'meta) pool -> Gid.t -> unit
val find_connection:
('msg, 'meta) pool -> Gid.t -> ('msg, 'meta) connection option
val fold_known:
('msg, 'meta) pool ->
init:'a ->
f:(Gid.t -> ('msg, 'meta) info -> 'a -> 'a) ->
'a
val fold_connected:
('msg, 'meta) pool ->
init:'a ->
f:(Gid.t -> ('msg, 'meta) info -> 'a -> 'a) ->
'a
end
(** {1 Functions on [Points]} *)
module Points : sig
type ('msg, 'meta) info = ('msg, 'meta) connection Point_info.t
val info:
('msg, 'meta) pool -> Point.t -> ('msg, 'meta) info option
val get_trusted: ('msg, 'meta) pool -> Point.t -> bool
val set_trusted: ('msg, 'meta) pool -> Point.t -> unit
val unset_trusted: ('msg, 'meta) pool -> Point.t -> unit
val find_connection:
('msg, 'meta) pool -> Point.t -> ('msg, 'meta) connection option
val fold_known:
('msg, 'meta) pool ->
init:'a ->
f:(Point.t -> ('msg, 'meta) info -> 'a -> 'a) ->
'a
val fold_connected:
('msg, 'meta) pool ->
init:'a ->
f:(Point.t -> ('msg, 'meta) info -> 'a -> 'a) ->
'a
end
(**/**)
module Message : sig
type 'msg t =
| Bootstrap
| Advertise of Point.t list
| Message of 'msg
| Disconnect
val encoding: 'msg encoding list -> 'msg t Data_encoding.t
end

463
src/node/net/p2p_connection_pool_types.ml Normal file
View File

@ -0,0 +1,463 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
open P2p_types
module Point_info = struct
type 'data state =
| Requested of { cancel: Canceler.t }
| Accepted of { current_gid: Gid.t ;
cancel: Canceler.t }
| Running of { data: 'data ;
current_gid: Gid.t }
| Disconnected
module Event = struct
type kind =
| Outgoing_request
| Accepting_request of Gid.t
| Rejecting_request of Gid.t
| Request_rejected of Gid.t option
| Connection_established of Gid.t
| Disconnection of Gid.t
| External_disconnection of Gid.t
type t = {
kind : kind ;
timestamp : Time.t ;
}
end
type greylisting_config = {
factor: float ;
initial_delay: int ;
disconnection_delay: int ;
}
type 'data t = {
point : Point.t ;
mutable trusted : bool ;
mutable state : 'data state ;
mutable last_failed_connection : Time.t option ;
mutable last_rejected_connection : (Gid.t * Time.t) option ;
mutable last_established_connection : (Gid.t * Time.t) option ;
mutable last_disconnection : (Gid.t * Time.t) option ;
greylisting : greylisting_config ;
mutable greylisting_delay : float ;
mutable greylisting_end : Time.t ;
events : Event.t Ring.t ;
}
type 'data point_info = 'data t
let compare pi1 pi2 = Point.compare pi1.point pi2.point
let log_size = 100
let default_greylisting_config = {
factor = 1.2 ;
initial_delay = 1 ;
disconnection_delay = 60 ;
}
let create
?(trusted = false)
?(greylisting_config = default_greylisting_config) addr port = {
point = (addr, port) ;
trusted ;
state = Disconnected ;
last_failed_connection = None ;
last_rejected_connection = None ;
last_established_connection = None ;
last_disconnection = None ;
events = Ring.create log_size ;
greylisting = greylisting_config ;
greylisting_delay = 1. ;
greylisting_end = Time.now () ;
}
let point s = s.point
let trusted s = s.trusted
let set_trusted gi = gi.trusted <- true
let unset_trusted gi = gi.trusted <- false
let last_established_connection s = s.last_established_connection
let last_disconnection s = s.last_disconnection
let last_failed_connection s = s.last_failed_connection
let last_rejected_connection s = s.last_rejected_connection
let greylisted ?(now = Time.now ()) s =
Time.compare now s.greylisting_end <= 0
let recent a1 a2 =
match a1, a2 with
| (None, None) -> None
| (None, (Some _ as a))
| (Some _ as a, None) -> a
| (Some (_, t1), Some (_, t2)) ->
if Time.compare t1 t2 < 0 then a2 else a1
let last_seen s =
recent s.last_rejected_connection
(recent s.last_established_connection s.last_disconnection)
let last_miss s =
match
s.last_failed_connection,
(map_option ~f:(fun (_, time) -> time) @@
recent s.last_rejected_connection s.last_disconnection) with
| (None, None) -> None
| (None, (Some _ as a))
| (Some _ as a, None) -> a
| (Some t1 as a1 , (Some t2 as a2)) ->
if Time.compare t1 t2 < 0 then a2 else a1
let fold_events { events } ~init ~f = Ring.fold events ~init ~f
let log { events } ?(timestamp = Time.now ()) kind =
Ring.add events { kind ; timestamp }
let log_incoming_rejection ?timestamp point_info gid =
log point_info ?timestamp (Rejecting_request gid)
module State = struct
type 'data t = 'data state =
| Requested of { cancel: Canceler.t }
| Accepted of { current_gid: Gid.t ;
cancel: Canceler.t }
| Running of { data: 'data ;
current_gid: Gid.t }
| Disconnected
type 'data state = 'data t
let pp ppf = function
| Requested _ ->
Format.fprintf ppf "requested"
| Accepted { current_gid } ->
Format.fprintf ppf "accepted %a" Gid.pp current_gid
| Running { current_gid } ->
Format.fprintf ppf "running %a" Gid.pp current_gid
| Disconnected ->
Format.fprintf ppf "disconnected"
let get { state } = state
let is_disconnected { state } =
match state with
| Disconnected -> true
| Requested _ | Accepted _ | Running _ -> false
let set_requested ?timestamp point_info cancel =
assert begin
match point_info.state with
| Requested _ -> true
| Accepted _ | Running _ -> false
| Disconnected -> true
end ;
point_info.state <- Requested { cancel } ;
log point_info ?timestamp Outgoing_request
let set_accepted
?(timestamp = Time.now ())
point_info current_gid cancel =
(* log_notice "SET_ACCEPTED %a@." Point.pp point_info.point ; *)
assert begin
match point_info.state with
| Accepted _ | Running _ -> false
| Requested _ | Disconnected -> true
end ;
point_info.state <- Accepted { current_gid ; cancel } ;
log point_info ~timestamp (Accepting_request current_gid)
let set_running
?(timestamp = Time.now ())
point_info gid data =
assert begin
match point_info.state with
| Disconnected -> true (* request to unknown gid. *)
| Running _ -> false
| Accepted { current_gid } -> Gid.equal gid current_gid
| Requested _ -> true
end ;
point_info.state <- Running { data ; current_gid = gid } ;
point_info.last_established_connection <- Some (gid, timestamp) ;
log point_info ~timestamp (Connection_established gid)
let set_greylisted timestamp point_info =
point_info.greylisting_end <-
Time.add
timestamp
(Int64.of_float point_info.greylisting_delay) ;
point_info.greylisting_delay <-
point_info.greylisting_delay *. point_info.greylisting.factor
let set_disconnected
?(timestamp = Time.now ()) ?(requested = false) point_info =
let event : Event.kind =
match point_info.state with
| Requested _ ->
set_greylisted timestamp point_info ;
point_info.last_failed_connection <- Some timestamp ;
Request_rejected None
| Accepted { current_gid } ->
set_greylisted timestamp point_info ;
point_info.last_rejected_connection <-
Some (current_gid, timestamp) ;
Request_rejected (Some current_gid)
| Running { current_gid } ->
point_info.greylisting_delay <-
float_of_int point_info.greylisting.initial_delay ;
point_info.greylisting_end <-
Time.add timestamp
(Int64.of_int point_info.greylisting.disconnection_delay) ;
point_info.last_disconnection <- Some (current_gid, timestamp) ;
if requested
then Disconnection current_gid
else External_disconnection current_gid
| Disconnected ->
assert false
in
point_info.state <- Disconnected ;
log point_info ~timestamp event
end
end
module Gid_info = struct
type 'data state =
| Accepted of { current_point: Id_point.t ;
cancel: Canceler.t }
| Running of { data: 'data ;
current_point: Id_point.t }
| Disconnected
module Event = struct
type kind =
| Accepting_request
| Rejecting_request
| Request_rejected
| Connection_established
| Disconnection
| External_disconnection
let kind_encoding =
let open Data_encoding in
Data_encoding.string_enum [
"incoming_request", Accepting_request ;
"rejecting_request", Rejecting_request ;
"request_rejected", Request_rejected ;
"connection_established", Connection_established ;
"disconnection", Disconnection ;
"external_disconnection", External_disconnection ;
]
type t = {
kind : kind ;
timestamp : Time.t ;
point : Id_point.t ;
}
let encoding =
let open Data_encoding in
conv
(fun { kind ; timestamp ; point = (addr, port) } ->
(kind, timestamp, Ipaddr.V6.to_string addr, port))
(fun (kind, timestamp, addr, port) ->
let addr = Ipaddr.V6.of_string_exn addr in
{ kind ; timestamp ; point = (addr, port) })
(obj4
(req "kind" kind_encoding)
(req "timestamp" Time.encoding)
(req "addr" string)
(opt "port" int16))
end
type ('conn, 'meta) t = {
gid : Gid.t ;
mutable state : 'conn state ;
mutable metadata : 'meta ;
mutable trusted : bool ;
mutable last_failed_connection : (Id_point.t * Time.t) option ;
mutable last_rejected_connection : (Id_point.t * Time.t) option ;
mutable last_established_connection : (Id_point.t * Time.t) option ;
mutable last_disconnection : (Id_point.t * Time.t) option ;
events : Event.t Ring.t ;
}
type ('conn, 'meta) gid_info = ('conn, 'meta) t
let compare gi1 gi2 = Gid.compare gi1.gid gi2.gid
let log_size = 100
let create ?(trusted = false) ~metadata gid =
{ gid ;
state = Disconnected ;
metadata ;
trusted ;
events = Ring.create log_size ;
last_failed_connection = None ;
last_rejected_connection = None ;
last_established_connection = None ;
last_disconnection = None ;
}
let encoding metadata_encoding =
let open Data_encoding in
conv
(fun { gid ; trusted ; metadata ; events ;
last_failed_connection ; last_rejected_connection ;
last_established_connection ; last_disconnection } ->
(gid, trusted, metadata, Ring.elements events,
last_failed_connection, last_rejected_connection,
last_established_connection, last_disconnection))
(fun (gid, trusted, metadata, event_list,
last_failed_connection, last_rejected_connection,
last_established_connection, last_disconnection) ->
let info = create ~trusted ~metadata gid in
let events = Ring.create log_size in
Ring.add_list info.events event_list ;
{ state = Disconnected ;
trusted ; gid ; metadata ; events ;
last_failed_connection ;
last_rejected_connection ;
last_established_connection ;
last_disconnection ;
})
(obj8
(req "gid" Gid.encoding)
(dft "trusted" bool false)
(req "metadata" metadata_encoding)
(dft "events" (list Event.encoding) [])
(opt "last_failed_connection"
(tup2 Id_point.encoding Time.encoding))
(opt "last_rejected_connection"
(tup2 Id_point.encoding Time.encoding))
(opt "last_established_connection"
(tup2 Id_point.encoding Time.encoding))
(opt "last_disconnection"
(tup2 Id_point.encoding Time.encoding)))
let gid { gid } = gid
let metadata { metadata } = metadata
let set_metadata gi metadata = gi.metadata <- metadata
let trusted { trusted } = trusted
let set_trusted gi = gi.trusted <- true
let unset_trusted gi = gi.trusted <- false
let fold_events { events } ~init ~f = Ring.fold events ~init ~f
let last_established_connection s = s.last_established_connection
let last_disconnection s = s.last_disconnection
let last_failed_connection s = s.last_failed_connection
let last_rejected_connection s = s.last_rejected_connection
let recent = Point_info.recent
let last_seen s =
recent
s.last_established_connection
(recent s.last_rejected_connection s.last_disconnection)
let last_miss s =
recent
s.last_failed_connection
(recent s.last_rejected_connection s.last_disconnection)
let log { events } ?(timestamp = Time.now ()) point kind =
Ring.add events { kind ; timestamp ; point }
let log_incoming_rejection ?timestamp gid_info point =
log gid_info ?timestamp point Rejecting_request
module State = struct
type 'data t = 'data state =
| Accepted of { current_point: Id_point.t ;
cancel: Canceler.t }
| Running of { data: 'data ;
current_point: Id_point.t }
| Disconnected
type 'data state = 'data t
let pp ppf = function
| Accepted { current_point } ->
Format.fprintf ppf "accepted %a" Id_point.pp current_point
| Running { current_point } ->
Format.fprintf ppf "running %a" Id_point.pp current_point
| Disconnected ->
Format.fprintf ppf "disconnected"
let get { state } = state
let is_disconnected { state } =
match state with
| Disconnected -> true
| Accepted _ | Running _ -> false
let set_accepted
?(timestamp = Time.now ())
gid_info current_point cancel =
assert begin
match gid_info.state with
| Accepted _ | Running _ -> false
| Disconnected -> true
end ;
gid_info.state <- Accepted { current_point ; cancel } ;
log gid_info ~timestamp current_point Accepting_request
let set_running
?(timestamp = Time.now ())
gid_info point data =
assert begin
match gid_info.state with
| Disconnected -> true (* request to unknown gid. *)
| Running _ -> false
| Accepted { current_point } ->
Id_point.equal point current_point
end ;
gid_info.state <- Running { data ; current_point = point } ;
gid_info.last_established_connection <- Some (point, timestamp) ;
log gid_info ~timestamp point Connection_established
let set_disconnected
?(timestamp = Time.now ()) ?(requested = false) gid_info =
let current_point, (event : Event.kind) =
match gid_info.state with
| Accepted { current_point } ->
gid_info.last_rejected_connection <-
Some (current_point, timestamp) ;
current_point, Request_rejected
| Running { current_point } ->
gid_info.last_disconnection <-
Some (current_point, timestamp) ;
current_point,
if requested then Disconnection else External_disconnection
| Disconnected -> assert false
in
gid_info.state <- Disconnected ;
log gid_info ~timestamp current_point event
end
module File = struct
let load path metadata_encoding =
let enc = Data_encoding.list (encoding metadata_encoding) in
Data_encoding_ezjsonm.read_file path >|=
map_option ~f:(Data_encoding.Json.destruct enc) >|=
unopt []
let save path metadata_encoding peers =
let open Data_encoding in
Data_encoding_ezjsonm.write_file path @@
Json.construct (list (encoding metadata_encoding)) peers
end
end

265
src/node/net/p2p_connection_pool_types.mli Normal file
View File

@ -0,0 +1,265 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
open P2p_types
module Point_info : sig
type 'conn t
type 'conn point_info = 'conn t
(** Type of info associated to a point. *)
val compare : 'conn point_info -> 'conn point_info -> int
type greylisting_config = {
factor: float ;
initial_delay: int ;
disconnection_delay: int ;
}
val create :
?trusted:bool ->
?greylisting_config:greylisting_config ->
addr -> port -> 'conn point_info
(** [create ~trusted addr port] is a freshly minted point_info. If
[trusted] is true, this point is considered trusted and will
be treated as such. *)
val trusted : 'conn point_info -> bool
(** [trusted pi] is [true] iff [pi] has is trusted,
i.e. "whitelisted". *)
val set_trusted : 'conn point_info -> unit
val unset_trusted : 'conn point_info -> unit
val last_failed_connection :
'conn point_info -> Time.t option
val last_rejected_connection :
'conn point_info -> (Gid.t * Time.t) option
val last_established_connection :
'conn point_info -> (Gid.t * Time.t) option
val last_disconnection :
'conn point_info -> (Gid.t * Time.t) option
val last_seen :
'conn point_info -> (Gid.t * Time.t) option
(** [last_seen pi] is the most recent of:
* last established connection
* last rejected connection
* last disconnection
*)
val last_miss :
'conn point_info -> Time.t option
val greylisted :
?now:Time.t -> 'conn point_info -> bool
val point : 'conn point_info -> Point.t
module State : sig
type 'conn t =
| Requested of { cancel: Canceler.t }
(** We initiated a connection. *)
| Accepted of { current_gid: Gid.t ;
cancel: Canceler.t }
(** We accepted a incoming connection. *)
| Running of { data: 'conn ;
current_gid: Gid.t }
(** Successfully authentificated connection, normal business. *)
| Disconnected
(** No connection established currently. *)
type 'conn state = 'conn t
val pp : Format.formatter -> 'conn t -> unit
val get : 'conn point_info -> 'conn state
val is_disconnected : 'conn point_info -> bool
val set_requested :
?timestamp:Time.t ->
'conn point_info -> Canceler.t -> unit
val set_accepted :
?timestamp:Time.t ->
'conn point_info -> Gid.t -> Canceler.t -> unit
val set_running :
?timestamp:Time.t -> 'conn point_info -> Gid.t -> 'conn -> unit
val set_disconnected :
?timestamp:Time.t -> ?requested:bool -> 'conn point_info -> unit
end
module Event : sig
type kind =
| Outgoing_request
(** We initiated a connection. *)
| Accepting_request of Gid.t
(** We accepted a connection after authentifying the remote peer. *)
| Rejecting_request of Gid.t
(** We rejected a connection after authentifying the remote peer. *)
| Request_rejected of Gid.t option
(** The remote peer rejected our connection. *)
| Connection_established of Gid.t
(** We succesfully established a authentified connection. *)
| Disconnection of Gid.t
(** We decided to close the connection. *)
| External_disconnection of Gid.t
(** The connection was closed for external reason. *)
type t = {
kind : kind ;
timestamp : Time.t ;
}
end
val fold_events :
'conn point_info -> init:'a -> f:('a -> Event.t -> 'a) -> 'a
val log_incoming_rejection :
?timestamp:Time.t -> 'conn point_info -> Gid.t -> unit
end
(** Gid info: current and historical information about a gid *)
module Gid_info : sig
type ('conn, 'meta) t
type ('conn, 'meta) gid_info = ('conn, 'meta) t
val compare : ('conn, 'meta) t -> ('conn, 'meta) t -> int
val create :
?trusted:bool ->
metadata:'meta ->
Gid.t -> ('conn, 'meta) gid_info
(** [create ~trusted ~meta gid] is a freshly minted gid info for
[gid]. *)
val gid : ('conn, 'meta) gid_info -> Gid.t
val metadata : ('conn, 'meta) gid_info -> 'meta
val set_metadata : ('conn, 'meta) gid_info -> 'meta -> unit
val trusted : ('conn, 'meta) gid_info -> bool
val set_trusted : ('conn, 'meta) gid_info -> unit
val unset_trusted : ('conn, 'meta) gid_info -> unit
val last_failed_connection :
('conn, 'meta) gid_info -> (Id_point.t * Time.t) option
val last_rejected_connection :
('conn, 'meta) gid_info -> (Id_point.t * Time.t) option
val last_established_connection :
('conn, 'meta) gid_info -> (Id_point.t * Time.t) option
val last_disconnection :
('conn, 'meta) gid_info -> (Id_point.t * Time.t) option
val last_seen :
('conn, 'meta) gid_info -> (Id_point.t * Time.t) option
(** [last_seen gi] is the most recent of:
* last established connection
* last rejected connection
* last disconnection
*)
val last_miss :
('conn, 'meta) gid_info -> (Id_point.t * Time.t) option
(** [last_miss gi] is the most recent of:
* last failed connection
* last rejected connection
* last disconnection
*)
module State : sig
type 'conn t =
| Accepted of { current_point: Id_point.t ;
cancel: Canceler.t }
(** We accepted a incoming connection, we greeted back and
we are waiting for an acknowledgement. *)
| Running of { data: 'conn ;
current_point: Id_point.t }
(** Successfully authentificated connection, normal business. *)
| Disconnected
(** No connection established currently. *)
type 'conn state = 'conn t
val pp : Format.formatter -> 'conn t -> unit
val get : ('conn, 'meta) gid_info -> 'conn state
val is_disconnected : ('conn, 'meta) gid_info -> bool
val set_accepted :
?timestamp:Time.t ->
('conn, 'meta) gid_info -> Id_point.t -> Canceler.t -> unit
val set_running :
?timestamp:Time.t ->
('conn, 'meta) gid_info -> Id_point.t -> 'conn -> unit
val set_disconnected :
?timestamp:Time.t ->
?requested:bool ->
('conn, 'meta) gid_info -> unit
end
module Event : sig
type kind =
| Accepting_request
(** We accepted a connection after authentifying the remote peer. *)
| Rejecting_request
(** We rejected a connection after authentifying the remote peer. *)
| Request_rejected
(** The remote peer rejected our connection. *)
| Connection_established
(** We succesfully established a authentified connection. *)
| Disconnection
(** We decided to close the connection. *)
| External_disconnection
(** The connection was closed for external reason. *)
type t = {
kind : kind ;
timestamp : Time.t ;
point : Id_point.t ;
}
end
val fold_events :
('conn, 'meta) gid_info -> init:'a -> f:('a -> Event.t -> 'a) -> 'a
val log_incoming_rejection :
?timestamp:Time.t ->
('conn, 'meta) gid_info -> Id_point.t -> unit
module File : sig
val load :
string -> 'meta Data_encoding.t ->
('conn, 'meta) gid_info list Lwt.t
val save :
string -> 'meta Data_encoding.t ->
('conn, 'meta) gid_info list -> bool Lwt.t
end
end

138
src/node/net/p2p_discovery.ml Normal file
View File

@ -0,0 +1,138 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
open P2p_types
include Logging.Make (struct let name = "p2p.discovery" end)
type t = ()
let create _pool = ()
let restart () = (() : unit)
let shutdown () = Lwt.return_unit
let inet_addr = Unix.inet_addr_of_string "ff0e::54:455a:3053"
module Message = struct
let encoding =
Data_encoding.(tup3 (Fixed.string 10) Gid.encoding int16)
let length = Data_encoding.Binary.fixed_length_exn encoding
let make gid port =
Data_encoding.Binary.to_bytes encoding ("DISCOMAGIC", gid, port)
end
(* Sends discover messages into space in an exponentially delayed loop,
restartable using a condition *)
let sender sock saddr my_gid inco_port cancelation restart =
let buf = Message.make my_gid inco_port in
let rec loop delay n =
Lwt.catch
(fun () ->
Lwt_bytes.sendto sock buf 0 Message.length [] saddr >>= fun _nb_sent ->
Lwt.return_unit)
(fun exn ->
lwt_debug "(%a) error broadcasting a discovery request: %a"
Gid.pp my_gid Error_monad.pp (Exn exn)) >>= fun () ->
Lwt.pick
[ (Lwt_unix.sleep delay >>= fun () -> Lwt.return (Some (delay, n + 1))) ;
(cancelation () >>= fun () -> Lwt.return_none) ;
(Lwt_condition.wait restart >>= fun () -> Lwt.return (Some (0.1, 0))) ]
>>= function
| Some (delay, n) when n = 10 -> loop delay 9
| Some (delay, n) -> loop (delay *. 2.) n
| None -> Lwt.return_unit
in
loop 0.2 1
let create_socket (iface, disco_addr, disco_port) =
let usock = Unix.socket PF_INET6 SOCK_DGRAM 0 in
let sock = Lwt_unix.of_unix_file_descr ~blocking:false usock in
let saddr = Unix.ADDR_INET (disco_addr, disco_port) in
Unix.setsockopt usock SO_REUSEADDR true ;
Ipv6_multicast.Unix.bind ?iface usock saddr ;
Ipv6_multicast.Unix.membership ?iface usock disco_addr `Join ;
iface, sock, saddr
(*
module Answerer = struct
(* Launch an answer machine for the discovery mechanism, takes a
callback to fill the answers and returns a canceler function *)
let answerer sock my_gid cancelation callback =
(* the answering function *)
let buf = MBytes.create Message.length in
let rec step () =
Lwt.pick
[ (cancelation () >>= fun () -> Lwt.return_none) ;
(Lwt_bytes.recvfrom sock buf 0 Message.length [] >>= fun r ->
Lwt.return (Some r)) ] >>= function
| None -> Lwt.return_unit
| Some (len', Lwt_unix.ADDR_INET (remote_addr, _mcast_port))
when len' = Message.length -> begin
match (Data_encoding.Binary.of_bytes Message.encoding buf) with
| Some ("DISCOMAGIC", remote_gid, remote_inco_port)
when remote_gid <> my_gid ->
Lwt.catch
(fun () -> callback ~remote_addr ~remote_inco_port)
(fun exn ->
lwt_debug "Error processing a discovery request: %a"
pp_exn exn) >>=
step
| _ ->
step ()
end
| Some _ -> step ()
in
step ()
let worker_loop st =
let callback ~remote_addr ~remote_inco_port =
let remote_uaddr = Ipaddr_unix.V6.of_inet_addr_exn remote_addr in
P2p_connection_loop.notify_new_peer
in
Lwt.catch
(fun () ->
Lwt_utils.worker
(Format.asprintf "(%a) discovery answerer" Gid.pp my_gid)
(fun () -> answerer fd my_gid cancelation callback)
cancel)
(fun exn ->
lwt_log_error "Discovery answerer not started: %a"
Error_monad.pp (Exn exn))
end
let discovery_sender =
match config.pending_authentification_port with
| None -> Lwt.return_unit
| Some inco_port ->
Lwt.catch
(fun () ->
let sender () =
Discovery.sender fd
saddr my_gid inco_port cancelation restart_discovery in
Lwt_utils.worker
(Format.asprintf "(%a) discovery sender" Gid.pp my_gid)
sender cancel)
(fun exn ->
lwt_log_error "Discovery sender not started: %a"
Error_monad.pp (Exn exn))
let discovery_answerer, discovery_sender =
match map_option ~f:create_socket st.config.local_discovery with
| exception exn ->
log_error "Error creating discovery socket: %a" Error_monad.pp (Exn exn) ;
(Lwt.return_unit, Lwt.return_unit)
| None -> Lwt.return_unit, Lwt.return_unit
| Some (iface, fd, saddr) ->
discovery_answerer, discovery_sender
*)

13
src/node/net/p2p_discovery.mli Normal file
View File

@ -0,0 +1,13 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
type t
val create : ('msg, 'meta) P2p_connection_pool.pool -> t
val restart : t -> unit
val shutdown : t -> unit Lwt.t

449
src/node/net/p2p_io_scheduler.ml Normal file
View File

@ -0,0 +1,449 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
(* TODO decide whether we need to preallocate buffers or not. *)
open P2p_types
include Logging.Make (struct let name = "p2p.io-scheduler" end)
module Inttbl = Hashtbl.Make(struct
type t = int
let equal (x: int) (y: int) = x = y
let hash = Hashtbl.hash
end)
let alpha = 0.2
module type IO = sig
val name: string
type in_param
val pop: in_param -> MBytes.t tzresult Lwt.t
type out_param
val push: out_param -> MBytes.t -> unit tzresult Lwt.t
val close: out_param -> error list -> unit Lwt.t
end
module Scheduler(IO : IO) = struct
type t = {
canceler: Canceler.t ;
mutable worker: unit Lwt.t ;
counter: Moving_average.t ;
max_speed: int option ;
mutable quota: int ;
quota_updated: unit Lwt_condition.t ;
readys: unit Lwt_condition.t ;
readys_high: (connection * MBytes.t tzresult) Queue.t ;
readys_low: (connection * MBytes.t tzresult) Queue.t ;
}
and connection = {
id: int ;
mutable closed: bool ;
canceler: Canceler.t ;
in_param: IO.in_param ;
out_param: IO.out_param ;
mutable current_pop: MBytes.t tzresult Lwt.t ;
mutable current_push: unit tzresult Lwt.t ;
counter: Moving_average.t ;
mutable quota: int ;
mutable last_quota: int ;
}
let cancel (conn : connection) err =
if not conn.closed then begin
conn.closed <- true ;
Lwt.catch
(fun () -> IO.close conn.out_param err)
(fun _ -> Lwt.return_unit) >>= fun () ->
Canceler.cancel conn.canceler
end else
Lwt.return_unit
let waiter st conn =
assert (Lwt.state conn.current_pop <> Sleep) ;
conn.current_pop <- IO.pop conn.in_param ;
Lwt.async begin fun () ->
conn.current_pop >>= fun res ->
conn.current_push >>= fun _ ->
let was_empty =
Queue.is_empty st.readys_high && Queue.is_empty st.readys_low in
if conn.quota > 0 then
Queue.push (conn, res) st.readys_high
else
Queue.push (conn, res) st.readys_low ;
if was_empty then Lwt_condition.broadcast st.readys () ;
Lwt.return_unit
end
let wait_data st =
let is_empty =
Queue.is_empty st.readys_high && Queue.is_empty st.readys_low in
if is_empty then Lwt_condition.wait st.readys else Lwt.return_unit
let check_quota st =
if st.max_speed <> None && st.quota < 0 then
Lwt_condition.wait st.quota_updated
else
Lwt_unix.yield ()
let rec worker_loop st =
check_quota st >>= fun () ->
Lwt.pick [
Canceler.cancelation st.canceler ;
wait_data st
] >>= fun () ->
if Canceler.canceled st.canceler then
Lwt.return_unit
else
let prio, (conn, msg) =
if not (Queue.is_empty st.readys_high) then
true, (Queue.pop st.readys_high)
else
false, (Queue.pop st.readys_low)
in
match msg with
| Error [Lwt_utils.Canceled] ->
worker_loop st
| Error ([Exn (Lwt_pipe.Closed |
Unix.Unix_error (EBADF, _, _))] as err) ->
cancel conn err >>= fun () ->
worker_loop st
| Error err ->
lwt_debug "Error %a" pp_print_error err >>= fun () ->
cancel conn err >>= fun () ->
worker_loop st
| Ok msg ->
conn.current_push <- begin
IO.push conn.out_param msg >>= function
| Ok ()
| Error [Lwt_utils.Canceled] ->
return ()
| Error ([Exn (Unix.Unix_error (EBADF, _, _) |
Lwt_pipe.Closed)] as err) ->
cancel conn err >>= fun () ->
return ()
| Error err ->
lwt_debug "Error %a" pp_print_error err >>= fun () ->
cancel conn err >>= fun () ->
Lwt.return (Error err)
end ;
let len = MBytes.length msg in
Moving_average.add st.counter len ;
st.quota <- st.quota - len ;
Moving_average.add conn.counter len ;
if prio then conn.quota <- conn.quota - len ;
waiter st conn ;
worker_loop st
let create max_speed =
let st = {
canceler = Canceler.create () ;
worker = Lwt.return_unit ;
counter = Moving_average.create ~init:0 ~alpha ;
max_speed ; quota = unopt 0 max_speed ;
quota_updated = Lwt_condition.create () ;
readys = Lwt_condition.create () ;
readys_high = Queue.create () ;
readys_low = Queue.create () ;
} in
st.worker <-
Lwt_utils.worker IO.name
(fun () -> worker_loop st)
(fun () -> Canceler.cancel st.canceler) ;
st
let create_connection st in_param out_param canceler id =
let conn =
{ id ; closed = false ;
canceler ;
in_param ; out_param ;
current_pop = Lwt.fail Not_found (* dummy *) ;
current_push = return () ;
counter = Moving_average.create ~init:0 ~alpha ;
quota = 0 ; last_quota = 0 ;
} in
waiter st conn ;
conn
let update_quota st =
iter_option st.max_speed ~f:begin fun quota ->
st.quota <- (min st.quota 0) + quota ;
Lwt_condition.broadcast st.quota_updated ()
end ;
if not (Queue.is_empty st.readys_low) then begin
let tmp = Queue.create () in
Queue.iter
(fun ((conn : connection), _ as msg) ->
if conn.quota > 0 then
Queue.push msg st.readys_high
else
Queue.push msg tmp)
st.readys_low ;
Queue.clear st.readys_low ;
Queue.transfer tmp st.readys_low ;
end
let shutdown st =
Canceler.cancel st.canceler >>= fun () ->
st.worker
end
type error += Connection_closed
module ReadScheduler = Scheduler(struct
let name = "io_scheduler(read)"
type in_param = Lwt_unix.file_descr * int
let pop (fd, maxlen) =
Lwt.catch
(fun () ->
let buf = MBytes.create maxlen in
Lwt_bytes.read fd buf 0 maxlen >>= fun len ->
if len = 0 then
fail Connection_closed
else
return (MBytes.sub buf 0 len) )
(function
| Unix.Unix_error(Unix.ECONNRESET, _, _) ->
fail Connection_closed
| exn ->
Lwt.return (error_exn exn))
type out_param = MBytes.t tzresult Lwt_pipe.t
let push p msg =
Lwt.catch
(fun () -> Lwt_pipe.push p (Ok msg) >>= return)
(fun exn -> fail (Exn exn))
let close p err =
Lwt.catch
(fun () -> Lwt_pipe.push p (Error err))
(fun _ -> Lwt.return_unit)
end)
module WriteScheduler = Scheduler(struct
let name = "io_scheduler(write)"
type in_param = MBytes.t Lwt_pipe.t
let pop p =
Lwt.catch
(fun () -> Lwt_pipe.pop p >>= return)
(fun _ -> fail (Exn Lwt_pipe.Closed))
type out_param = Lwt_unix.file_descr
let push fd buf =
Lwt.catch
(fun () ->
Lwt_utils.write_mbytes fd buf >>= return)
(function
| Unix.Unix_error(Unix.EPIPE, _, _)
| Lwt.Canceled
| End_of_file ->
fail Connection_closed
| exn ->
Lwt.return (error_exn exn))
let close _p _err = Lwt.return_unit
end)
type connection = {
id: int ;
sched: t ;
conn: Lwt_unix.file_descr ;
canceler: Canceler.t ;
read_conn: ReadScheduler.connection ;
read_queue: MBytes.t tzresult Lwt_pipe.t ;
write_conn: WriteScheduler.connection ;
write_queue: MBytes.t Lwt_pipe.t ;
mutable partial_read: MBytes.t option ;
}
and t = {
mutable closed: bool ;
connected: connection Inttbl.t ;
read_scheduler: ReadScheduler.t ;
write_scheduler: WriteScheduler.t ;
max_upload_speed: int option ; (* bytes per second. *)
max_download_speed: int option ;
read_buffer_size: int ;
read_queue_size: int option ;
write_queue_size: int option ;
}
let reset_quota st =
let { Moving_average.average = current_inflow } =
Moving_average.stat st.read_scheduler.counter
and { Moving_average.average = current_outflow } =
Moving_average.stat st.write_scheduler.counter in
let nb_conn = Inttbl.length st.connected in
if nb_conn > 0 then begin
let fair_read_quota = current_inflow / nb_conn
and fair_write_quota = current_outflow / nb_conn in
Inttbl.iter
(fun _id conn ->
conn.read_conn.last_quota <- fair_read_quota ;
conn.read_conn.quota <-
(min conn.read_conn.quota 0) + fair_read_quota ;
conn.write_conn.last_quota <- fair_write_quota ;
conn.write_conn.quota <-
(min conn.write_conn.quota 0) + fair_write_quota ; )
st.connected
end ;
ReadScheduler.update_quota st.read_scheduler ;
WriteScheduler.update_quota st.write_scheduler
let create
?max_upload_speed ?max_download_speed
?read_queue_size ?write_queue_size
~read_buffer_size
() =
let st = {
closed = false ;
connected = Inttbl.create 53 ;
read_scheduler = ReadScheduler.create max_download_speed ;
write_scheduler = WriteScheduler.create max_upload_speed ;
max_upload_speed ;
max_download_speed ;
read_buffer_size ;
read_queue_size ;
write_queue_size ;
} in
Moving_average.on_update (fun () -> reset_quota st) ;
st
exception Closed
let register =
let cpt = ref 0 in
fun st conn ->
if st.closed then begin
Lwt.async (fun () -> Lwt_utils.safe_close conn) ;
raise Closed
end else begin
let id = incr cpt; !cpt in
let canceler = Canceler.create () in
let read_queue = Lwt_pipe.create ?size:st.read_queue_size ()
and write_queue = Lwt_pipe.create ?size:st.write_queue_size () in
let read_conn =
ReadScheduler.create_connection
st.read_scheduler (conn, st.read_buffer_size) read_queue canceler id
and write_conn =
WriteScheduler.create_connection
st.write_scheduler write_queue conn canceler id in
Canceler.on_cancel canceler begin fun () ->
Inttbl.remove st.connected id ;
Moving_average.destroy read_conn.counter ;
Moving_average.destroy write_conn.counter ;
Lwt_pipe.close write_queue ;
Lwt_pipe.close read_queue ;
Lwt_utils.safe_close conn
end ;
let conn = {
sched = st ; id ; conn ; canceler ;
read_queue ; read_conn ;
write_queue ; write_conn ;
partial_read = None ;
} in
Inttbl.add st.connected id conn ;
conn
end
let write { write_queue } msg =
Lwt.catch
(fun () -> Lwt_pipe.push write_queue msg >>= return)
(fun _ -> fail Connection_closed)
let write_now { write_queue } msg = Lwt_pipe.push_now write_queue msg
let read_from conn ?pos ?len buf msg =
let maxlen = MBytes.length buf in
let pos = unopt 0 pos in
assert (0 <= pos && pos < maxlen) ;
let len = unopt (maxlen - pos) len in
assert (len <= maxlen - pos) ;
match msg with
| Ok msg ->
let msg_len = MBytes.length msg in
let read_len = min len msg_len in
MBytes.blit msg 0 buf pos read_len ;
if read_len < msg_len then
conn.partial_read <-
Some (MBytes.sub msg read_len (msg_len - read_len)) ;
Ok read_len
| Error _ ->
Error [Connection_closed]
let read_now conn ?pos ?len buf =
match conn.partial_read with
| Some msg ->
conn.partial_read <- None ;
Some (read_from conn ?pos ?len buf (Ok msg))
| None ->
try
map_option
(read_from conn ?pos ?len buf)
(Lwt_pipe.pop_now conn.read_queue)
with Lwt_pipe.Closed -> Some (Error [Connection_closed])
let read conn ?pos ?len buf =
match conn.partial_read with
| Some msg ->
conn.partial_read <- None ;
Lwt.return (read_from conn ?pos ?len buf (Ok msg))
| None ->
Lwt.catch
(fun () ->
Lwt_pipe.pop conn.read_queue >|= fun msg ->
read_from conn ?pos ?len buf msg)
(fun _ -> fail Connection_closed)
let read_full conn ?pos ?len buf =
let maxlen = MBytes.length buf in
let pos = unopt 0 pos in
let len = unopt (maxlen - pos) len in
assert (0 <= pos && pos < maxlen) ;
assert (len <= maxlen - pos) ;
let rec loop pos len =
if len = 0 then
return ()
else
read conn ~pos ~len buf >>=? fun read_len ->
loop (pos + read_len) (len - read_len) in
loop pos len
let convert ~ws ~rs =
{ Stat.total_sent = ws.Moving_average.total ;
total_recv = rs.Moving_average.total ;
current_outflow = ws.average ;
current_inflow = rs.average ;
}
let global_stat { read_scheduler ; write_scheduler } =
let rs = Moving_average.stat read_scheduler.counter
and ws = Moving_average.stat write_scheduler.counter in
convert ~rs ~ws
let stat { read_conn ; write_conn} =
let rs = Moving_average.stat read_conn.counter
and ws = Moving_average.stat write_conn.counter in
convert ~rs ~ws
let close conn =
Inttbl.remove conn.sched.connected conn.id ;
Lwt_pipe.close conn.write_queue ;
Canceler.cancelation conn.canceler >>= fun () ->
conn.write_conn.current_push >>= fun res ->
Lwt.return res
let iter_connection { connected } f =
Inttbl.iter f connected
let shutdown st =
st.closed <- true ;
ReadScheduler.shutdown st.read_scheduler >>= fun () ->
WriteScheduler.shutdown st.write_scheduler >>= fun () ->
Inttbl.fold
(fun _gid conn acc -> close conn >>= fun _ -> acc)
st.connected
Lwt.return_unit

93
src/node/net/p2p_io_scheduler.mli Normal file
View File

@ -0,0 +1,93 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
(** IO Scheduling. This module implements generic IO scheduling
between file descriptors. In order to use IO scheduling, the
[register] function must be used to make a file descriptor managed
by a [scheduler].. It will return a value of type [connection]
that must be used to perform IO on the managed file descriptor
using this module's dedicated IO functions (read, write, etc.).
Each connection is allowed a read (resp. write) quota, which is
for now fairly distributed among connections.
To each connection is associated a read (resp. write) queue where
data is copied to (resp. read from), at a rate of
max_download_speed / num_connections (resp. max_upload_speed /
num_connections).
*)
open P2p_types
type connection
(** Type of a connection. *)
type t
(** Type of an IO scheduler. *)
val create:
?max_upload_speed:int ->
?max_download_speed:int ->
?read_queue_size:int ->
?write_queue_size:int ->
read_buffer_size:int ->
unit -> t
(** [create ~max_upload_speed ~max_download_speed ~read_queue_size
~write_queue_size ()] is an IO scheduler with specified (global)
max upload (resp. download) speed, and specified read
(resp. write) queue sizes for connections. *)
val register: t -> Lwt_unix.file_descr -> connection
(** [register sched fd] is a [connection] managed by [sched]. *)
type error += Connection_closed
val write: connection -> MBytes.t -> unit tzresult Lwt.t
(** [write conn msg] returns [Ok ()] when [msg] has been added to
[conn]'s write queue, or fail with an error. *)
val write_now: connection -> MBytes.t -> bool
(** [write_now conn msg] is [true] iff [msg] has been (immediately)
added to [conn]'s write queue, [false] if it has been dropped. *)
val read_now:
connection -> ?pos:int -> ?len:int -> MBytes.t -> int tzresult option
(** [read_now conn ~pos ~len buf] blits at most [len] bytes from
[conn]'s read queue and returns the number of bytes written in
[buf] starting at [pos]. *)
val read:
connection -> ?pos:int -> ?len:int -> MBytes.t -> int tzresult Lwt.t
(** Like [read_now], but waits till [conn] read queue has at least one
element instead of failing. *)
val read_full:
connection -> ?pos:int -> ?len:int -> MBytes.t -> unit tzresult Lwt.t
(** Like [read], but blits exactly [len] bytes in [buf]. *)
val stat: connection -> Stat.t
(** [stat conn] is a snapshot of current bandwidth usage for
[conn]. *)
val global_stat: t -> Stat.t
(** [global_stat sched] is a snapshot of [sched]'s bandwidth usage
(sum of [stat conn] for each [conn] in [sched]). *)
val iter_connection: t -> (int -> connection -> unit) -> unit
(** [iter_connection sched f] applies [f] on each connection managed
by [sched]. *)
val close: connection -> unit tzresult Lwt.t
(** [close conn] cancels [conn] and returns after any pending data has
been sent. *)
val shutdown: t -> unit Lwt.t
(** [shutdown sched] returns after all connections managed by [sched]
have been closed and [sched]'s inner worker has successfully
canceled. *)

191
src/node/net/p2p_maintenance.ml Normal file
View File

@ -0,0 +1,191 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
open P2p_types
open P2p_connection_pool_types
include Logging.Make (struct let name = "p2p.maintenance" end)
type bounds = {
min_threshold: int ;
min_target: int ;
max_target: int ;
max_threshold: int ;
}
type 'meta pool = Pool : ('msg, 'meta) P2p_connection_pool.t -> 'meta pool
type 'meta t = {
canceler: Canceler.t ;
connection_timeout: float ;
bounds: bounds ;
pool: 'meta pool ;
disco: P2p_discovery.t option ;
just_maintained: unit Lwt_condition.t ;
please_maintain: unit Lwt_condition.t ;
mutable worker : unit Lwt.t ;
}
(** Select [expected] points amongst the disconnected known points.
It ignores points which are greylisted, or for which a connection
failed after [start_time]. It first selects points with the oldest
last tentative. *)
let connectable st start_time expected =
let now = Time.now () in
let module Bounded_point_info =
Utils.Bounded(struct
type t = (Time.t option * Point.t)
let compare (t1, _) (t2, _) =
match t1, t2 with
| None, None -> 0
| None, Some _ -> 1
| Some _, None -> -1
| Some t1, Some t2 -> Time.compare t2 t1
end) in
let acc = Bounded_point_info.create expected in
let Pool pool = st.pool in
P2p_connection_pool.Points.fold_known
pool ~init:()
~f:begin fun point pi () ->
match Point_info.State.get pi with
| Disconnected -> begin
match Point_info.last_miss pi with
| Some last when Time.(start_time < last)
&& not (Point_info.greylisted ~now pi) -> ()
| last ->
Bounded_point_info.insert (last, point) acc
end
| _ -> ()
end ;
List.map snd (Bounded_point_info.get acc)
(** Try to create connections to new peers. It tries to create at
least [min_to_contact] connections, and will never creates more
than [max_to_contact]. But, if after trying once all disconnected
peers, it returns [false]. *)
let rec try_to_contact
st ?(start_time = Time.now ())
min_to_contact max_to_contact =
let Pool pool = st.pool in
if min_to_contact <= 0 then
Lwt.return_true
else
let contactable =
connectable st start_time max_to_contact in
if contactable = [] then
Lwt.return_false
else
List.fold_left
(fun acc point ->
P2p_connection_pool.connect
~timeout:st.connection_timeout pool point >>= function
| Ok _ -> acc >|= succ
| Error _ -> acc)
(Lwt.return 0)
contactable >>= fun established ->
try_to_contact st ~start_time
(min_to_contact - established) (max_to_contact - established)
(** Do a maintenance step. It will terminate only when the number
of connections is between `min_threshold` and `max_threshold`. *)
let rec maintain st =
let Pool pool = st.pool in
let n_connected = P2p_connection_pool.active_connections pool in
if n_connected < st.bounds.min_threshold then
too_few_connections st n_connected
else if st.bounds.max_threshold < n_connected then
too_many_connections st n_connected
else begin
(* end of maintenance when enough users have been reached *)
Lwt_condition.broadcast st.just_maintained () ;
lwt_debug "Maintenance step ended" >>= fun () ->
return ()
end
and too_few_connections st n_connected =
let Pool pool = st.pool in
(* too few connections, try and contact many peers *)
lwt_debug "Too few connections (%d)" n_connected >>= fun () ->
let min_to_contact = st.bounds.min_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 ->
if not continue then begin
maintain st
end else begin
(* not enough contacts, ask the pals of our pals,
discover the local network and then wait *)
iter_option ~f:P2p_discovery.restart st.disco ;
P2p_connection_pool.broadcast_bootstrap_msg pool ;
Lwt_utils.protect ~canceler:st.canceler begin fun () ->
Lwt.pick [
P2p_connection_pool.Events.new_point pool ;
Lwt_unix.sleep 5.0 (* TODO exponential back-off ??
or wait for the existence of a
non grey-listed peer ?? *)
] >>= return
end >>=? fun () ->
maintain st
end
and too_many_connections st n_connected =
let Pool pool = st.pool in
(* too many connections, start the russian roulette *)
let to_kill = n_connected - st.bounds.max_target in
lwt_debug "Too many connections, will kill %d" to_kill >>= fun () ->
snd @@ P2p_connection_pool.fold_connections pool
~init:(to_kill, Lwt.return_unit)
~f:(fun _ conn (i, t) ->
if i = 0 then (0, t)
else (i - 1, t >>= fun () -> P2p_connection_pool.disconnect conn))
>>= fun () ->
maintain st
let rec worker_loop st =
begin
let Pool pool = st.pool in
Lwt_utils.protect ~canceler:st.canceler begin fun () ->
Lwt.pick [
Lwt_unix.sleep 120. ; (* every two minutes *)
Lwt_condition.wait st.please_maintain ; (* when asked *)
P2p_connection_pool.Events.too_few_connections pool ; (* limits *)
P2p_connection_pool.Events.too_many_connections pool
] >>= fun () ->
return ()
end >>=? fun () ->
maintain st
end >>= function
| Ok () -> worker_loop st
| Error [Lwt_utils.Canceled] -> Lwt.return_unit
| Error _ -> Lwt.return_unit
let run ?(connection_timeout = 5.) bounds pool disco =
let canceler = Canceler.create () in
let st = {
canceler ; connection_timeout ;
bounds ; pool = Pool pool ; disco ;
just_maintained = Lwt_condition.create () ;
please_maintain = Lwt_condition.create () ;
worker = Lwt.return_unit ;
} in
st.worker <-
Lwt_utils.worker "maintenance"
(fun () -> worker_loop st)
(fun () -> Canceler.cancel canceler);
st
let maintain { just_maintained ; please_maintain } =
let wait = Lwt_condition.wait just_maintained in
Lwt_condition.broadcast please_maintain () ;
wait
let shutdown { canceler ; worker ; just_maintained } =
Canceler.cancel canceler >>= fun () ->
worker >>= fun () ->
Lwt_condition.broadcast just_maintained () ;
Lwt.return_unit

45
src/node/net/p2p_maintenance.mli Normal file
View File

@ -0,0 +1,45 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
(* min <= min_threshold <= min_target <= max_target <= max_threshold <= max *)
(* The 'pool' urges the maintainer to work when the number of
connections reaches `max` or is below `min`. Otherwise, the
maintener is lazy and only lookup for connection every two
minutes. The [maintain] function is another way to signal the
maintainer that a maintenance step is desired.
When the maintener detects that the number of connections is over
`max_threshold`, it randomly kills connections to reach `max_target`.
When the maintener detects that the number of connections is below
`min_threshold`, it creates enough connection to reach at least
`min_target` (and never more than `max_target`). In the process, it
might ask its actual peers for new peers. *)
type bounds = {
min_threshold: int ;
min_target: int ;
max_target: int ;
max_threshold: int ;
}
type 'meta t
(** Type of a maintenance worker. *)
val run:
?connection_timeout:float ->
bounds ->
('msg, 'meta) P2p_connection_pool.t ->
P2p_discovery.t option ->
'meta t
val maintain: 'meta t -> unit Lwt.t
val shutdown: 'meta t -> unit Lwt.t

225
src/node/net/p2p_types.ml Normal file
View File

@ -0,0 +1,225 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
open Logging.Net
module Canceler = Lwt_utils.Canceler
module Version = struct
type t = {
name : string ;
major : int ;
minor : int ;
}
let encoding =
let open Data_encoding in
conv
(fun { name; major; minor } -> (name, major, minor))
(fun (name, major, minor) -> { name; major; minor })
(obj3
(req "name" string)
(req "major" int8)
(req "minor" int8))
(* the common version for a pair of peers, if any, is the maximum one,
in lexicographic order *)
let common la lb =
let la = List.sort (fun l r -> compare r l) la in
let lb = List.sort (fun l r -> compare r l) lb in
let rec find = function
| [], _ | _, [] -> None
| ((a :: ta) as la), ((b :: tb) as lb) ->
if a = b then Some a
else if a < b then find (ta, lb)
else find (la, tb)
in find (la, lb)
end
module Stat = struct
type t = {
total_sent : int ;
total_recv : int ;
current_inflow : int ;
current_outflow : int ;
}
let print_size ppf sz =
let ratio n = (float_of_int sz /. float_of_int (1 lsl n)) in
if sz < 1 lsl 10 then
Format.fprintf ppf "%d B" sz
else if sz < 1 lsl 20 then
Format.fprintf ppf "%.2f kiB" (ratio 10)
else
Format.fprintf ppf "%.2f MiB" (ratio 20)
let pp ppf stat =
Format.fprintf ppf
"sent: %a (%a/s) recv: %a (%a/s)"
print_size stat.total_sent print_size stat.current_outflow
print_size stat.total_recv print_size stat.current_inflow
end
module Gid = struct
include Crypto_box.Public_key_hash
let pp = pp_short
module Map = Map.Make (Crypto_box.Public_key_hash)
module Set = Set.Make (Crypto_box.Public_key_hash)
module Table = Hash.Hash_table (Crypto_box.Public_key_hash)
end
(* public types *)
type addr = Ipaddr.V6.t
type port = int
module Point = struct
module T = struct
(* A net point (address x port). *)
type t = addr * port
let compare (a1, p1) (a2, p2) =
match Ipaddr.V6.compare a1 a2 with
| 0 -> p1 - p2
| x -> x
let equal p1 p2 = compare p1 p2 = 0
let hash = Hashtbl.hash
let pp ppf (addr, port) =
Format.fprintf ppf "[%a]:%d" Ipaddr.V6.pp_hum addr port
let pp_opt ppf = function
| None -> Format.pp_print_string ppf "none"
| Some point -> pp ppf point
let is_local (addr, _) = Ipaddr.V6.is_private addr
let is_global (addr, _) = not @@ Ipaddr.V6.is_private addr
let to_sockaddr (addr, port) = Unix.(ADDR_INET (Ipaddr_unix.V6.to_inet_addr addr, port))
let encoding =
let open Data_encoding in
conv
(fun (addr, port) -> Ipaddr.V6.to_string addr, port)
(fun (addr, port) -> Ipaddr.V6.of_string_exn addr, port)
(obj2
(req "addr" string)
(req "port" int16))
end
include T
(* Run-time point-or-gid indexed storage, one point is bound to at
most one gid, which is the invariant we want to keep both for the
connected peers table and the known peers one *)
module Map = Map.Make (T)
module Set = Set.Make (T)
module Table = Hashtbl.Make (T)
end
module Id_point = struct
module T = struct
(* A net point (address x port). *)
type t = addr * port option
let empty = Ipaddr.V6.unspecified, None
let compare (a1, p1) (a2, p2) =
match Ipaddr.V6.compare a1 a2 with
| 0 -> Pervasives.compare p1 p2
| x -> x
let equal p1 p2 = compare p1 p2 = 0
let hash = Hashtbl.hash
let pp ppf (addr, port) =
match port with
| None ->
Format.fprintf ppf "[%a]:??" Ipaddr.V6.pp_hum addr
| Some port ->
Format.fprintf ppf "[%a]:%d" Ipaddr.V6.pp_hum addr port
let pp_opt ppf = function
| None -> Format.pp_print_string ppf "none"
| Some point -> pp ppf point
let is_local (addr, _) = Ipaddr.V6.is_private addr
let is_global (addr, _) = not @@ Ipaddr.V6.is_private addr
let encoding =
let open Data_encoding in
conv
(fun (addr, port) -> Ipaddr.V6.to_bytes addr, port)
(fun (addr, port) -> Ipaddr.V6.of_bytes_exn addr, port)
(obj2
(req "addr" string)
(opt "port" int16))
end
include T
(* Run-time point-or-gid indexed storage, one point is bound to at
most one gid, which is the invariant we want to keep both for the
connected peers table and the known peers one *)
module Map = Map.Make (T)
module Set = Set.Make (T)
module Table = Hashtbl.Make (T)
end
module Identity = struct
type t = {
gid : Gid.t ;
public_key : Crypto_box.public_key ;
secret_key : Crypto_box.secret_key ;
proof_of_work_stamp : Crypto_box.nonce ;
}
let encoding =
let open Data_encoding in
conv
(fun { public_key ; secret_key ; proof_of_work_stamp } ->
(public_key, secret_key, proof_of_work_stamp))
(fun (public_key, secret_key, proof_of_work_stamp) ->
let gid = Crypto_box.hash public_key in
{ gid ; public_key ; secret_key ; proof_of_work_stamp })
(obj3
(req "public_key" Crypto_box.public_key_encoding)
(req "secret_key" Crypto_box.secret_key_encoding)
(req "proof_of_work_stamp" Crypto_box.nonce_encoding))
let generate target =
let secret_key, public_key, gid = Crypto_box.random_keypair () in
let proof_of_work_stamp =
Crypto_box.generate_proof_of_work public_key target in
{ gid ; public_key ; secret_key ; proof_of_work_stamp }
end
module Connection_info = struct
type t = {
incoming : bool;
gid : Gid.t;
id_point : Id_point.t;
remote_socket_port : port;
versions : Version.t list ;
}
let pp ppf
{ incoming ; id_point = (remote_addr, remote_port) ; gid } =
Format.fprintf ppf "%a:%a {%a}%s"
Ipaddr.V6.pp_hum remote_addr
(fun ppf port ->
match port with
| None -> Format.pp_print_string ppf "??"
| Some port -> Format.pp_print_int ppf port) remote_port
Gid.pp gid
(if incoming then " (incoming)" else "")
end

129
src/node/net/p2p_types.mli Normal file
View File

@ -0,0 +1,129 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
module Canceler = Lwt_utils.Canceler
(** Protocol version *)
module Version : sig
type t = {
name : string ;
major : int ;
minor : int ;
}
(** Type of a protocol version. *)
val encoding : t Data_encoding.t
val common: t list -> t list -> t option
end
(** Gid, i.e. persistent peer identifier *)
module Gid : sig
type t = Crypto_box.Public_key_hash.t
(** Type of a gid, a public key hash. *)
val compare : t -> t -> int
val equal : t -> t -> bool
val pp : Format.formatter -> t -> unit
val encoding : t Data_encoding.t
module Map : Map.S with type key = t
module Set : Set.S with type elt = t
module Table : Hashtbl.S with type key = t
end
type addr = Ipaddr.V6.t
type port = int
(** Point, i.e. socket address *)
module Point : sig
type t = addr * port
val compare : t -> t -> int
val pp : Format.formatter -> t -> unit
val pp_opt : Format.formatter -> t option -> unit
val encoding : t Data_encoding.t
val is_local : t -> bool
val is_global : t -> bool
val to_sockaddr : t -> Unix.sockaddr
module Map : Map.S with type key = t
module Set : Set.S with type elt = t
module Table : Hashtbl.S with type key = t
end
(** Point representing a reachable socket address *)
module Id_point : sig
type t = addr * port option
val compare : t -> t -> int
val equal : t -> t -> bool
val pp : Format.formatter -> t -> unit
val pp_opt : Format.formatter -> t option -> unit
val encoding : t Data_encoding.t
val is_local : t -> bool
val is_global : t -> bool
module Map : Map.S with type key = t
module Set : Set.S with type elt = t
module Table : Hashtbl.S with type key = t
end
(** Identity *)
module Identity : sig
type t = {
gid : Gid.t ;
public_key : Crypto_box.public_key ;
secret_key : Crypto_box.secret_key ;
proof_of_work_stamp : Crypto_box.nonce ;
}
(** Type of an identity, comprising a gid, a crypto keypair, and a
proof of work stamp with enough difficulty so that the network
accept this identity as genuine. *)
val encoding : t Data_encoding.t
val generate : Crypto_box.target -> t
(** [generate target] is a freshly minted identity whose proof of
work stamp difficulty is at least equal to [target]. *)
end
(** Bandwidth usage statistics *)
module Stat : sig
type t = {
total_sent : int ;
total_recv : int ;
current_inflow : int ;
current_outflow : int ;
}
val pp: Format.formatter -> t -> unit
end
(** Information about a connection *)
module Connection_info : sig
type t = {
incoming : bool;
gid : Gid.t;
id_point : Id_point.t;
remote_socket_port : port;
versions : Version.t list ;
}
val pp: Format.formatter -> t -> unit
end

77
src/node/net/p2p_welcome.ml Normal file
View File

@ -0,0 +1,77 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
include Logging.Make (struct let name = "p2p.welcome" end)
open P2p_types
type pool = Pool : ('msg, 'meta) P2p_connection_pool.t -> pool
type t = {
socket: Lwt_unix.file_descr ;
canceler: Canceler.t ;
pool: pool ;
mutable worker: unit Lwt.t ;
}
let rec worker_loop st =
let Pool pool = st.pool in
Lwt_unix.yield () >>= fun () ->
Lwt_utils.protect ~canceler:st.canceler begin fun () ->
Lwt_unix.accept st.socket >>= return
end >>= function
| Ok (fd, addr) ->
let point =
match addr with
| Lwt_unix.ADDR_UNIX _ -> assert false
| Lwt_unix.ADDR_INET (addr, port) ->
(Ipaddr_unix.V6.of_inet_addr_exn addr, port) in
P2p_connection_pool.accept pool fd point ;
worker_loop st
| Error [Lwt_utils.Canceled] ->
Lwt.return_unit
| Error err ->
lwt_log_error "@[<v 2>Unexpected error in the Welcome worker@ %a@]"
pp_print_error err >>= fun () ->
Lwt.return_unit
let create_listening_socket ~backlog ?(addr = Ipaddr.V6.unspecified) port =
let main_socket = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in
Lwt_unix.(setsockopt main_socket SO_REUSEADDR true) ;
Lwt_unix.Versioned.bind_2
main_socket (Point.to_sockaddr (addr, port)) >>= fun () ->
Lwt_unix.listen main_socket backlog ;
Lwt.return main_socket
let run ~backlog pool ?addr port =
Lwt.catch begin fun () ->
create_listening_socket
~backlog ?addr port >>= fun socket ->
let canceler = Canceler.create () in
Canceler.on_cancel canceler begin fun () ->
Lwt_utils.safe_close socket
end ;
let st = {
socket ; canceler ; pool = Pool pool ;
worker = Lwt.return_unit ;
} in
st.worker <-
Lwt_utils.worker "welcome"
(fun () -> worker_loop st)
(fun () -> Canceler.cancel st.canceler) ;
Lwt.return st
end begin fun exn ->
lwt_log_error
"@[<v 2>Cannot accept incoming connections@ %a@]"
pp_exn exn >>= fun () ->
Lwt.fail exn
end
let shutdown st =
Canceler.cancel st.canceler >>= fun () ->
st.worker

27
src/node/net/p2p_welcome.mli Normal file
View File

@ -0,0 +1,27 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
open P2p_types
(** Welcome worker. Accept incoming connections and add them to its
connection pool. *)
type t
(** Type of a welcome worker, parametrized like a
[P2p_connection_pool.pool]. *)
val run:
backlog:int ->
('msg, 'meta) P2p_connection_pool.t ->
?addr:addr -> port -> t Lwt.t
(** [run ~backlog ~addr pool port] returns a running welcome worker
feeding [pool] listening at [(addr, port)]. [backlog] is the
argument passed to [Lwt_unix.accept]. *)
val shutdown: t -> unit Lwt.t

72
src/node/shell/tezos_p2p.ml
View File

@ -1,10 +1,9 @@
module Param = struct
open P2p
type net_id = Store.net_id
type msg =
type net_id = Store.net_id
type msg =
| Discover_blocks of net_id * Block_hash.t list (* Block locator *)
| Block_inventory of net_id * Block_hash.t list
@ -20,7 +19,11 @@ module Param = struct
| Get_protocols of Protocol_hash.t list
| Protocol of MBytes.t
let encodings =
module Message = struct
type t = msg
let encoding =
let open Data_encoding in
let case ?max_length ~tag encoding unwrap wrap =
P2p.Encoding { tag; encoding; wrap; unwrap; max_length } in
@ -71,13 +74,8 @@ module Param = struct
(fun proto -> Protocol proto);
]
type metadata = unit
let initial_metadata = ()
let metadata_encoding = Data_encoding.empty
let score () = 0.
let supported_versions =
let open P2p in
let open P2p.Version in
[ { name = "TEZOS" ;
major = 0 ;
minor = 0 ;
@ -86,5 +84,53 @@ module Param = struct
end
include Param
include P2p.Make(Param)
type metadata = unit
module Metadata = struct
type t = metadata
let initial = ()
let encoding = Data_encoding.empty
let score () = 0.
end
let meta_cfg : _ P2p.meta_config = {
P2p.encoding = Metadata.encoding ;
initial = Metadata.initial ;
}
and msg_cfg : _ P2p.message_config = {
encoding = Message.encoding ;
versions = Message.supported_versions ;
}
type net = (Message.t, Metadata.t) P2p.net
let bootstrap ~config ~limits =
P2p.bootstrap ~config ~limits meta_cfg msg_cfg
let broadcast = P2p.broadcast
let try_send = P2p.try_send
let recv = P2p.recv_any
let send = P2p.send
let set_metadata = P2p.set_metadata
let get_metadata = P2p.get_metadata
let connection_info = P2p.connection_info
let find_connection = P2p.find_connection
let connections = P2p.connections
type connection = (Message.t, Metadata.t) P2p.connection
let shutdown = P2p.shutdown
let roll = P2p.roll
let maintain = P2p.maintain
let faked_network = P2p.faked_network
module Raw = struct
type 'a t = 'a P2p.Raw.t =
| Bootstrap
| Advertise of Point.t list
| Message of 'a
| Disconnect
type message = Message.t t
let encoding = P2p.Raw.encoding msg_cfg.encoding
let supported_versions = msg_cfg.versions
end

60
src/node/shell/tezos_p2p.mli
View File

@ -13,41 +13,30 @@ val bootstrap : config:config -> limits:limits -> net Lwt.t
(** A maintenance operation : try and reach the ideal number of peers *)
val maintain : net -> unit Lwt.t
(** Voluntarily drop some peers and replace them by new buddies *)
(** Voluntarily drop some connections and replace them by new buddies *)
val roll : net -> unit Lwt.t
(** Close all connections properly *)
val shutdown : net -> unit Lwt.t
(** A connection to a peer *)
type peer
type connection
(** Access the domain of active peers *)
val peers : net -> peer list
(** Access the domain of active connections *)
val connections : net -> connection list
(** Return the active peer with identity [gid] *)
val find_peer : net -> gid -> peer option
(** Return the active connection with identity [gid] *)
val find_connection : net -> Gid.t -> connection option
type peer_info = {
gid : gid ;
addr : addr ;
port : port ;
version : version ;
total_sent : int ;
total_recv : int ;
current_inflow : float ;
current_outflow : float ;
}
(** Access the info of an active peer, if available *)
val peer_info : net -> peer -> peer_info
(** Access the info of an active connection. *)
val connection_info : net -> connection -> Connection_info.t
(** Accessors for meta information about a global identifier *)
type metadata = unit
val get_metadata : net -> gid -> metadata option
val set_metadata : net -> gid -> metadata -> unit
val get_metadata : net -> Gid.t -> metadata option
val set_metadata : net -> Gid.t -> metadata -> unit
type net_id = Store.net_id
@ -68,23 +57,28 @@ type msg =
| Get_protocols of Protocol_hash.t list
| Protocol of MBytes.t
(** Wait for a payload from any peer in the network *)
val recv : net -> (peer * msg) Lwt.t
(** Wait for a payload from any connection in the network *)
val recv : net -> (connection * msg) Lwt.t
(** [send net peer msg] is a thread that returns when [msg] has been
(** [send net conn msg] is a thread that returns when [msg] has been
successfully enqueued in the send queue. *)
val send : net -> peer -> msg -> unit Lwt.t
val send : net -> connection -> msg -> unit Lwt.t
(** [try_send net peer msg] is [true] if [msg] has been added to the
(** [try_send net conn msg] is [true] if [msg] has been added to the
send queue for [peer], [false] otherwise *)
val try_send : net -> peer -> msg -> bool
val try_send : net -> connection -> msg -> bool
(** Send a payload to all peers *)
val broadcast : net -> msg -> unit
(** Shutdown the connection to all peers at this address and stop the
communications with this machine for [duration] seconds *)
val blacklist : net -> gid -> unit
(** Keep a connection to this pair as often as possible *)
val whitelist : net -> gid -> unit
(**/**)
module Raw : sig
type 'a t =
| Bootstrap
| Advertise of Point.t list
| Message of 'a
| Disconnect
type message = msg t
val encoding: message Data_encoding.t
val supported_versions: Version.t list
end

117
src/node_main.ml
View File

@ -7,6 +7,8 @@
(* *)
(**************************************************************************)
module V6 = Ipaddr.V6
open Error_monad
open Logging.Node.Main
@ -54,15 +56,15 @@ type cfg = {
min_connections : int ;
max_connections : int ;
expected_connections : int ;
net_addr : Ipaddr.t ;
net_addr : V6.t ;
net_port : int ;
local_discovery : int option ;
peers : (Ipaddr.t * int) list ;
(* local_discovery : (string * int) option ; *)
peers : (V6.t * int) list ;
peers_cache : string ;
closed : bool ;
(* rpc *)
rpc_addr : (Ipaddr.t * int) option ;
rpc_addr : (V6.t * int) option ;
cors_origins : string list ;
cors_headers : string list ;
rpc_crt : string option ;
@ -88,9 +90,9 @@ let default_cfg_of_base_dir base_dir = {
min_connections = 4 ;
max_connections = 400 ;
expected_connections = 20 ;
net_addr = Ipaddr.(V6 V6.unspecified) ;
net_addr = V6.unspecified ;
net_port = 9732 ;
local_discovery = None ;
(* local_discovery = None ; *)
peers = [] ;
closed = false ;
peers_cache = base_dir // "peers_cache" ;
@ -130,16 +132,21 @@ let sockaddr_of_string str =
let addr, port = String.sub str 0 pos, String.sub str (pos+1) (len - pos - 1) in
match Ipaddr.of_string_exn addr, int_of_string port with
| exception Failure _ -> `Error "not a sockaddr"
| ip, port -> `Ok (ip, port)
| V4 ipv4, port -> `Ok (Ipaddr.v6_of_v4 ipv4, port)
| V6 ipv6, port -> `Ok (ipv6, port)
let sockaddr_of_string_exn str =
match sockaddr_of_string str with
| `Ok saddr -> saddr
| `Error msg -> invalid_arg msg
let pp_sockaddr fmt (ip, port) = Format.fprintf fmt "%a:%d" Ipaddr.pp_hum ip port
let pp_sockaddr fmt (ip, port) = Format.fprintf fmt "%a:%d" V6.pp_hum ip port
let string_of_sockaddr saddr = Format.asprintf "%a" pp_sockaddr saddr
let mcast_params_of_string s = match Utils.split ':' s with
| [iface; port] -> iface, int_of_string port
| _ -> invalid_arg "mcast_params_of_string"
module Cfg_file = struct
open Data_encoding
@ -150,12 +157,12 @@ module Cfg_file = struct
(opt "protocol" string)
let net =
obj8
obj7
(opt "min-connections" uint16)
(opt "max-connections" uint16)
(opt "expected-connections" uint16)
(opt "addr" string)
(opt "local-discovery" uint16)
(* (opt "local-discovery" string) *)
(opt "peers" (list string))
(dft "closed" bool false)
(opt "peers-cache" string)
@ -174,21 +181,29 @@ module Cfg_file = struct
conv
(fun { store ; context ; protocol ;
min_connections ; max_connections ; expected_connections ;
net_addr ; net_port ; local_discovery ; peers ;
net_addr ; net_port ;
(* local_discovery ; *)
peers ;
closed ; peers_cache ; rpc_addr ; cors_origins ; cors_headers ; log_output } ->
let net_addr = string_of_sockaddr (net_addr, net_port) in
(* let local_discovery = Utils.map_option local_discovery *)
(* ~f:(fun (iface, port) -> iface ^ ":" ^ string_of_int port) *)
(* in *)
let rpc_addr = Utils.map_option string_of_sockaddr rpc_addr in
let peers = ListLabels.map peers ~f:string_of_sockaddr in
let log_output = string_of_log log_output in
((Some store, Some context, Some protocol),
(Some min_connections, Some max_connections, Some expected_connections,
Some net_addr, local_discovery, Some peers, closed, Some peers_cache),
Some net_addr,
(* local_discovery, *)
Some peers, closed, Some peers_cache),
(rpc_addr, cors_origins, cors_headers),
Some log_output))
(fun (
(store, context, protocol),
(min_connections, max_connections, expected_connections, net_addr,
local_discovery, peers, closed, peers_cache),
(* local_discovery, *)
peers, closed, peers_cache),
(rpc_addr, cors_origins, cors_headers),
log_output) ->
let open Utils in
@ -205,11 +220,14 @@ module Cfg_file = struct
let min_connections = unopt default_cfg.min_connections min_connections in
let max_connections = unopt default_cfg.max_connections max_connections in
let expected_connections = unopt default_cfg.expected_connections expected_connections in
(* let local_discovery = map_option local_discovery ~f:mcast_params_of_string in *)
{ default_cfg with
store ; context ; protocol ;
min_connections; max_connections; expected_connections;
net_addr; net_port ; local_discovery; peers; closed; peers_cache;
rpc_addr; cors_origins ; cors_headers ; log_output
min_connections ; max_connections ; expected_connections ;
net_addr ; net_port ;
(* local_discovery ; *)
peers ; closed ; peers_cache ;
rpc_addr ; cors_origins ; cors_headers ; log_output ;
}
)
(obj4
@ -266,9 +284,9 @@ module Cmdline = struct
let net_addr =
let doc = "The TCP address and port at which this instance can be reached." in
Arg.(value & opt (some sockaddr_converter) None & info ~docs:"NETWORK" ~doc ~docv:"ADDR:PORT" ["net-addr"])
let local_discovery =
let doc = "Automatic discovery of peers on the local network." in
Arg.(value & opt (some int) None & info ~docs:"NETWORK" ~doc ~docv:"ADDR:PORT" ["local-discovery"])
(* let local_discovery = *)
(* let doc = "Automatic discovery of peers on the local network." in *)
(* Arg.(value & opt (some @@ pair string int) None & info ~docs:"NETWORK" ~doc ~docv:"IFACE:PORT" ["local-discovery"]) *)
let peers =
let doc = "A peer to bootstrap the network from. Can be used several times to add several peers." in
Arg.(value & opt_all sockaddr_converter [] & info ~docs:"NETWORK" ~doc ~docv:"ADDR:PORT" ["peer"])
@ -298,7 +316,9 @@ module Cmdline = struct
let parse base_dir config_file sandbox sandbox_param log_level
min_connections max_connections expected_connections
net_saddr local_discovery peers closed rpc_addr tls cors_origins cors_headers reset_cfg update_cfg =
net_saddr
(* local_discovery *)
peers closed rpc_addr tls cors_origins cors_headers reset_cfg update_cfg =
let base_dir = Utils.(unopt (unopt default_cfg.base_dir base_dir) sandbox) in
let config_file = Utils.(unopt ((unopt base_dir sandbox) // "config")) config_file in
@ -340,7 +360,7 @@ module Cmdline = struct
expected_connections = Utils.unopt cfg.expected_connections expected_connections ;
net_addr = (match net_saddr with None -> cfg.net_addr | Some (addr, _) -> addr) ;
net_port = (match net_saddr with None -> cfg.net_port | Some (_, port) -> port) ;
local_discovery = Utils.first_some local_discovery cfg.local_discovery ;
(* local_discovery = Utils.first_some local_discovery cfg.local_discovery ; *)
peers = (match peers with [] -> cfg.peers | _ -> peers) ;
closed = closed || cfg.closed ;
rpc_addr = Utils.first_some rpc_addr cfg.rpc_addr ;
@ -359,7 +379,9 @@ module Cmdline = struct
ret (const parse $ base_dir $ config_file
$ sandbox $ sandbox_param $ v
$ min_connections $ max_connections $ expected_connections
$ net_addr $ local_discovery $ peers $ closed
$ net_addr
(* $ local_discovery *)
$ peers $ closed
$ rpc_addr $ rpc_tls $ cors_origins $ cors_headers
$ reset_config $ update_config
),
@ -391,10 +413,11 @@ let init_logger { log_output ; log_level } =
| `Null -> Logging.init Null
| `Syslog -> Logging.init Syslog
let init_node { sandbox ; sandbox_param ;
let init_node
{ sandbox ; sandbox_param ;
store ; context ;
min_connections ; max_connections ; expected_connections ;
net_port ; peers ; peers_cache ; local_discovery ; closed } =
net_port ; peers ; peers_cache ; closed } =
let patch_context json ctxt =
let module Proto = (val Updater.get_exn genesis_protocol) in
Lwt.catch
@ -428,20 +451,48 @@ let init_node { sandbox ; sandbox_param ;
match sandbox with
| Some _ -> None
| None ->
(* TODO add parameters... *)
let authentification_timeout = 5.
and backlog = 20
and max_incoming_connections = 20
and max_download_speed = None
and max_upload_speed = None
and read_buffer_size = 1 lsl 14
and read_queue_size = None
and write_queue_size = None
and incoming_app_message_queue_size = None
and incoming_message_queue_size = None
and outgoing_message_queue_size = None in
let limits =
{ max_message_size = 10_000 ;
peer_answer_timeout = 5. ;
expected_connections ;
{ authentification_timeout ;
min_connections ;
expected_connections ;
max_connections ;
blacklist_time = 30. }
backlog ;
max_incoming_connections ;
max_download_speed ;
max_upload_speed ;
read_buffer_size ;
read_queue_size ;
write_queue_size ;
incoming_app_message_queue_size ;
incoming_message_queue_size ;
outgoing_message_queue_size ;
}
in
(* TODO add parameters... *)
let identity = P2p.Identity.generate Crypto_box.default_target
and listening_addr = None
and proof_of_work_target = Crypto_box.default_target in
let config =
{ incoming_port = Some net_port ;
discovery_port = local_discovery ;
known_peers = peers ;
{ listening_port = Some net_port ;
listening_addr ;
identity ;
trusted_points = peers ;
peers_file = peers_cache ;
closed_network = closed }
closed_network = closed ;
proof_of_work_target ;
}
in
Some (config, limits) in
Node.create
@ -458,7 +509,7 @@ let init_rpc { rpc_addr ; rpc_crt; rpc_key ; cors_origins ; cors_headers } node
lwt_log_notice "Starting the RPC server listening on port %d (TLS enabled)." port >>= fun () ->
let dir = Node_rpc.build_rpc_directory node in
let mode = `TLS (`Crt_file_path crt, `Key_file_path key, `No_password, `Port port) in
let host = Ipaddr.to_string addr in
let host = Ipaddr.V6.to_string addr in
let () =
let old_hook = !Lwt.async_exception_hook in
Lwt.async_exception_hook := function

15
src/tezos-deps.opam
View File

@ -18,21 +18,24 @@ depends: [
"calendar"
"cohttp" {>= "0.21" }
"config-file"
"conduit" {= "0.14.0" } # Version 0.14.1 doas not compile with `ssl` (17/01/02)
"conduit"
"git"
"git-unix"
"ipv6-multicast"
"irmin-watcher" (* for `irmin.unix` *)
"irmin" {>= "0.12"}
"irmin" {>= "0.12" }
"lwt" {>= "2.7.0" }
"lwt_ssl"
"menhir"
"ocp-ocamlres" {>= "dev"}
"mtime"
"ocp-ocamlres" {>= "dev" }
"ocplib-endian"
"ocplib-json-typed"
"ocplib-resto" {>= "dev"}
"ocplib-resto" {>= "dev" }
"reactiveData"
"tyxml"
"js_of_ocaml"
"sodium" {>= "0.3.0"}
"ssl"
"sodium" {>= "0.3.0" }
"kaputt" # { test }
"bisect_ppx" # { test }
]

1
src/utils/base48.ml
View File

@ -230,6 +230,7 @@ module Prefix = struct
let operation_hash = "\001"
let protocol_hash = "\002"
let ed25519_public_key_hash = "\003"
let cryptobox_public_key_hash = "\004"
let ed25519_public_key = "\012"
let ed25519_secret_key = "\013"
let ed25519_signature = "\014"

3
src/utils/base48.mli
View File

@ -37,6 +37,9 @@ module Prefix : sig
val ed25519_public_key_hash: string
(** Prefix for Ed25519 public key hashes: "\003". *)
val cryptobox_public_key_hash: string
(** Prefix for Ed25519 public key hashes: "\004". *)
val ed25519_public_key: string
(** Prefix for Ed25519 public key: "\012". *)

20
src/utils/crypto_box.ml
View File

@ -18,7 +18,19 @@ type nonce = Sodium.Box.nonce
type target = int64 list (* used as unsigned intergers... *)
exception TargetNot256Bit
let random_keypair = Sodium.Box.random_keypair
module Public_key_hash = Hash.Make_Blake2B (Base48) (struct
let name = "Crypto_box.Public_key_hash"
let title = "A Cryptobox public key ID"
let b48check_prefix = Base48.Prefix.cryptobox_public_key_hash
let size = Some 16
end)
let hash pk =
Public_key_hash.hash_bytes [Sodium.Box.Bigbytes.of_public_key pk]
let random_keypair () =
let sk, pk = Sodium.Box.random_keypair () in
sk, pk, hash pk
let random_nonce = Sodium.Box.random_nonce
let increment_nonce = Sodium.Box.increment_nonce
let box = Sodium.Box.Bigbytes.box
@ -26,6 +38,12 @@ let box_open sk pk msg nonce =
try Some (Sodium.Box.Bigbytes.box_open sk pk msg nonce) with
| Sodium.Verification_failure -> None
let precompute = Sodium.Box.precompute
let fast_box = Sodium.Box.Bigbytes.fast_box
let fast_box_open ck msg nonce =
try Some (Sodium.Box.Bigbytes.fast_box_open ck msg nonce) with
| Sodium.Verification_failure -> None
let make_target target =
if List.length target > 8 then raise TargetNot256Bit ;
target

11
src/utils/crypto_box.mli
View File

@ -21,15 +21,22 @@ val default_target : target
type secret_key
type public_key
module Public_key_hash : Hash.HASH
type channel_key
val public_key_encoding : public_key Data_encoding.t
val secret_key_encoding : secret_key Data_encoding.t
val random_keypair : unit -> secret_key * public_key
val hash : public_key -> Public_key_hash.t
val random_keypair : unit -> secret_key * public_key * Public_key_hash.t
val box : secret_key -> public_key -> MBytes.t -> nonce -> MBytes.t
val box_open : secret_key -> public_key -> MBytes.t -> nonce -> MBytes.t option
val precompute : secret_key -> public_key -> channel_key
val fast_box : channel_key -> MBytes.t -> nonce -> MBytes.t
val fast_box_open : channel_key -> MBytes.t -> nonce -> MBytes.t option
val check_proof_of_work : public_key -> nonce -> target -> bool
val generate_proof_of_work : public_key -> target -> nonce

13
src/utils/error_monad.ml
View File

@ -174,6 +174,11 @@ module Make() = struct
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 =
match v with
| Error _ as err -> err
@ -286,6 +291,9 @@ module Make() = struct
let fail_unless cond exn =
if cond then return () else fail exn
let unless cond f =
if cond then return () else f ()
let pp_print_error ppf errors =
Format.fprintf ppf "@[<v 2>Error, dumping error stack:@,%a@]@."
(Format.pp_print_list pp)
@ -332,15 +340,20 @@ let error_exn s = Error [ Exn s ]
let trace_exn exn f = trace (Exn exn) f
let record_trace_exn exn f = record_trace (Exn exn) f
let pp_exn ppf exn = pp ppf (Exn exn)
let () =
register_error_kind
`Temporary
~id:"failure"
~title:"Generic error"
~description:"Unclassified error"
~pp:Format.pp_print_string
Data_encoding.(obj1 (req "msg" string))
(function
| Exn (Failure msg) -> Some msg
| Exn (Unix.Unix_error (err, fn, _)) ->
Some ("Unix error in " ^ fn ^ ": " ^ Unix.error_message err)
| Exn exn -> Some (Printexc.to_string exn)
| _ -> None)
(fun msg -> Exn (Failure msg))

1
src/utils/error_monad.mli
View File

@ -29,6 +29,7 @@ val failwith :
val error_exn : exn -> 'a tzresult
val record_trace_exn : exn -> 'a tzresult -> 'a tzresult
val trace_exn : exn -> 'b tzresult Lwt.t -> 'b tzresult Lwt.t
val pp_exn : Format.formatter -> exn -> unit
type error += Exn of exn
type error += Unclassified of string

6
src/utils/error_monad_sig.ml
View File

@ -100,6 +100,12 @@ module type S = sig
(** Erroneous return on failed assertion *)
val fail_unless : bool -> error -> unit tzresult Lwt.t
val unless : bool -> (unit -> unit tzresult Lwt.t) -> unit tzresult Lwt.t
val protect :
on_error: (error list -> 'a tzresult Lwt.t) ->
'a tzresult Lwt.t -> 'a tzresult Lwt.t
(** {2 In-monad list iterators} ********************************************)
(** A {!List.iter} in the monad *)

2
src/utils/hash.ml
View File

@ -254,7 +254,7 @@ module Hash_map (Hash : HASH) = struct
Data_encoding.(list (tup2 Hash.encoding arg_encoding))
end
module Hash_table (Hash : HASH)
module Hash_table (Hash : MINIMAL_HASH)
: Hashtbl.S with type key = Hash.t
= Hashtbl.Make (struct
type t = Hash.t

2
src/utils/hash.mli
View File

@ -103,7 +103,7 @@ module Hash_map (Hash : HASH) : sig
end
(** Builds a Hashtbl using some Hash type as keys. *)
module Hash_table (Hash : HASH) : Hashtbl.S with type key = Hash.t
module Hash_table (Hash : MINIMAL_HASH) : Hashtbl.S with type key = Hash.t
(** {2 Predefined Hashes } ****************************************************)

17
src/utils/logging.ml
View File

@ -30,7 +30,7 @@ let log_f
Format.ikfprintf (fun _ -> Lwt.return_unit) Format.std_formatter format
else
Format.kasprintf
(Lwt_log.log ?exn ~section ?location ?logger ~level)
(fun msg -> Lwt_log.log ?exn ~section ?location ?logger ~level msg)
format
let ign_log_f
@ -39,8 +39,7 @@ let ign_log_f
Format.ikfprintf (fun _ -> ()) Format.std_formatter format
else
Format.kasprintf
(fun s ->
Lwt_log.ign_log ?exn ~section ?location ?logger ~level s)
(fun msg -> Lwt_log.ign_log ?exn ~section ?location ?logger ~level msg)
format
module Make(S : sig val name: string end) : LOG = struct
@ -87,8 +86,10 @@ module Client = struct
end
module Webclient = Make(struct let name = "webclient" end)
let template = "$(date) $(name)[$(pid)]: $(message)"
let default_logger () =
Lwt_log.channel ~close_mode:`Keep ~channel:Lwt_io.stderr ()
Lwt_log.channel ~template ~close_mode:`Keep ~channel:Lwt_io.stderr ()
type kind =
| Null
@ -96,6 +97,7 @@ type kind =
| Stderr
| File of string
| Syslog
| Manual of Lwt_log.logger
let init kind =
let logger =
@ -103,12 +105,13 @@ let init kind =
| Stderr ->
default_logger ()
| Stdout ->
Lwt_log.channel ~close_mode:`Keep ~channel:Lwt_io.stdout ()
Lwt_log.channel ~template ~close_mode:`Keep ~channel:Lwt_io.stdout ()
| File file_name ->
Lwt_main.run (Lwt_log.file ~file_name ())
Lwt_main.run (Lwt_log.file ~file_name ~template ())
| Null ->
Lwt_log.null
| Syslog ->
Printf.eprintf "Warning: log_kind \"syslog\" not yet implemented.\n%!";
default_logger () in
default_logger ()
| Manual logger -> logger in
Lwt_log.default := logger

1
src/utils/logging.mli
View File

@ -54,5 +54,6 @@ type kind =
| Stderr
| File of string
| Syslog
| Manual of Lwt_log.logger
val init: kind -> unit

11
src/utils/lwt_exit.ml
View File

@ -7,7 +7,6 @@
(* *)
(**************************************************************************)
exception Exit
let termination_thread, exit_wakener = Lwt.wait ()
@ -18,6 +17,12 @@ let () =
(function
| Exit -> ()
| exn ->
Printf.eprintf "Uncaught (asynchronous) exception: %S\n%s\n%!"
(Printexc.to_string exn) (Printexc.get_backtrace ());
Format.eprintf
"@[Uncaught (asynchronous) exception (%d):@ %a@]"
(Unix.getpid ())
Error_monad.pp_exn exn ;
let backtrace = Printexc.get_backtrace () in
if String.length backtrace <> 0 then
Format.eprintf "\n%s" backtrace ;
Format.eprintf "@." ;
Lwt.wakeup exit_wakener 1)

143
src/utils/lwt_pipe.ml
View File

@ -11,15 +11,25 @@ open Lwt.Infix
type 'a t =
{ queue : 'a Queue.t ;
size : int ;
size : int option ;
mutable closed : bool ;
mutable push_waiter : (unit Lwt.t * unit Lwt.u) option ;
mutable pop_waiter : (unit Lwt.t * unit Lwt.u) option }
mutable pop_waiter : (unit Lwt.t * unit Lwt.u) option ;
empty: unit Lwt_condition.t ;
full: unit Lwt_condition.t ;
not_full : unit Lwt_condition.t ;
}
let create ~size =
let create ?size () =
{ queue = Queue.create () ;
size ;
closed = false ;
push_waiter = None ;
pop_waiter = None }
pop_waiter = None ;
empty = Lwt_condition.create () ;
full = Lwt_condition.create () ;
not_full = Lwt_condition.create () ;
}
let notify_push q =
match q.push_waiter with
@ -37,69 +47,164 @@ let notify_pop q =
let wait_push q =
match q.push_waiter with
| Some (t, _) -> t
| Some (t, _) -> Lwt.protected t
| None ->
let waiter, wakener = Lwt.wait () in
q.push_waiter <- Some (waiter, wakener) ;
waiter
Lwt.protected waiter
let wait_pop q =
match q.pop_waiter with
| Some (t, _) -> t
| Some (t, _) -> Lwt.protected t
| None ->
let waiter, wakener = Lwt.wait () in
q.pop_waiter <- Some (waiter, wakener) ;
waiter
Lwt.protected waiter
let rec push ({ queue ; size } as q) elt =
if Queue.length queue < size then begin
let available_space { size } len =
match size with
| None -> true
| Some size -> len < size
let length { queue } = Queue.length queue
let is_empty { queue } = Queue.is_empty queue
let is_full ({ queue } as q) = not (available_space q (Queue.length queue))
let rec empty q =
if is_empty q
then Lwt.return_unit
else (Lwt_condition.wait q.empty >>= fun () -> empty q)
let rec full q =
if is_full q
then Lwt.return_unit
else (Lwt_condition.wait q.full >>= fun () -> full q)
let rec not_full q =
if not (is_empty q)
then Lwt.return_unit
else (Lwt_condition.wait q.not_full >>= fun () -> not_full q)
exception Closed
let rec push ({ closed ; queue ; full } as q) elt =
let len = Queue.length queue in
if closed then Lwt.fail Closed
else if available_space q len then begin
Queue.push elt queue ;
notify_push q ;
(if not (available_space q (len + 1)) then Lwt_condition.signal full ());
Lwt.return_unit
end else
wait_pop q >>= fun () ->
push q elt
let rec push_now ({ queue; size } as q) elt =
Queue.length queue < size && begin
let rec push_now ({ closed ; queue ; full } as q) elt =
if closed then raise Closed ;
let len = Queue.length queue in
available_space q len && begin
Queue.push elt queue ;
notify_push q ;
(if not (available_space q (len + 1)) then Lwt_condition.signal full ()) ;
true
end
let rec pop ({ queue } as q) =
exception Full
let push_now_exn q elt =
if not (push_now q elt) then raise Full
let rec pop_all ({ closed ; queue ; empty ; not_full } as q) =
let was_full = is_full q in
if not (Queue.is_empty queue) then
let queue_copy = Queue.copy queue in
Queue.clear queue;
notify_pop q ;
(if was_full then Lwt_condition.signal not_full ());
Lwt_condition.signal empty ();
Lwt.return queue_copy
else if closed then
Lwt.fail Closed
else
wait_push q >>= fun () ->
pop_all q
let rec pop ({ closed ; queue ; empty ; not_full } as q) =
let was_full = is_full q in
if not (Queue.is_empty queue) then
let elt = Queue.pop queue in
notify_pop q ;
(if was_full then Lwt_condition.signal not_full ());
(if Queue.length queue = 0 then Lwt_condition.signal empty ());
Lwt.return elt
else if closed then
Lwt.fail Closed
else
wait_push q >>= fun () ->
pop q
let rec peek ({ queue } as q) =
let rec peek ({ closed ; queue } as q) =
if not (Queue.is_empty queue) then
let elt = Queue.peek queue in
Lwt.return elt
else if closed then
Lwt.fail Closed
else
wait_push q >>= fun () ->
peek q
let pop_now_exn ({ queue } as q) =
exception Empty
let pop_now_exn ({ closed ; queue ; empty ; not_full } as q) =
let was_full = is_full q in
if Queue.is_empty queue then
(if closed then raise Closed else raise Empty) ;
let elt = Queue.pop queue in
(if was_full then Lwt_condition.signal not_full ());
(if Queue.length queue = 0 then Lwt_condition.signal empty ());
notify_pop q ;
elt
let pop_all_now ({ closed ; queue ; empty ; not_full } as q) =
let was_empty = is_empty q in
let was_full = is_full q in
if Queue.is_empty queue then
(if closed then raise Closed else raise Empty) ;
let queue_copy = Queue.copy queue in
Queue.clear queue ;
(if was_full then Lwt_condition.signal not_full ());
(if not was_empty then Lwt_condition.signal empty ());
notify_pop q ;
queue_copy
let pop_now q =
match pop_now_exn q with
| exception Queue.Empty -> None
| exception Empty -> None
| elt -> Some elt
let length { queue } = Queue.length queue
let is_empty { queue } = Queue.is_empty queue
let rec values_available q =
if is_empty q then
if q.closed then
raise Closed
else
wait_push q >>= fun () ->
values_available q
else
Lwt.return_unit
let close q =
if not q.closed then begin
q.closed <- true ;
notify_push q ;
notify_pop q ;
Lwt_condition.broadcast_exn q.full Closed ;
end
let rec iter q ~f =
Lwt.catch begin fun () ->
pop q >>= fun elt ->
f elt >>= fun () ->
iter q ~f
end begin function
| Closed -> Lwt.return_unit
| exn -> Lwt.fail exn
end

45
src/utils/lwt_pipe.mli
View File

@ -14,7 +14,7 @@
type 'a t
(** Type of queues holding values of type ['a]. *)
val create : size:int -> 'a t
val create : ?size:int -> unit -> 'a t
(** [create ~size] is an empty queue that can hold max [size]
elements. *)
@ -22,6 +22,10 @@ val push : 'a t -> 'a -> unit Lwt.t
(** [push q v] is a thread that blocks while [q] contains more
than [size] elements, then adds [v] at the end of [q]. *)
val pop_all : 'a t -> 'a Queue.t Lwt.t
(** [pop' q] is a thread that returns all elements in [q] or waits
till there is at least one element in [q]. *)
val pop : 'a t -> 'a Lwt.t
(** [pop q] is a thread that blocks while [q] is empty, then
removes and returns the first element in [q]. *)
@ -38,10 +42,22 @@ val push_now : 'a t -> 'a -> bool
(** [push_now q v] adds [v] at the ends of [q] immediately and returns
[false] if [q] is currently full, [true] otherwise. *)
exception Full
val push_now_exn : 'a t -> 'a -> unit
(** [push_now q v] adds [v] at the ends of [q] immediately or
raise [Full] if [q] is currently full. *)
val pop_all_now : 'a t -> 'a Queue.t
(** [pop_all_now q] is a copy of [q]'s internal queue, that may be
empty. *)
val pop_now : 'a t -> 'a option
(** [pop_now q] maybe removes and returns the first element in [q] if
[q] contains at least one element. *)
exception Empty
val pop_now_exn : 'a t -> 'a
(** [pop_now_exn q] removes and returns the first element in [q] if
[q] contains at least one element, or raise [Empty] otherwise. *)
@ -52,3 +68,30 @@ val length : 'a t -> int
val is_empty : 'a t -> bool
(** [is_empty q] is [true] if [q] is empty, [false] otherwise. *)
val is_full : 'a t -> bool
(** [is_full q] is [true] if [q] is full, [false] otherwise. *)
val empty : 'a t -> unit Lwt.t
(** [empty q] returns when [q] becomes empty. *)
val full : 'a t -> unit Lwt.t
(** [full q] returns when [q] becomes full. *)
val not_full : 'a t -> unit Lwt.t
(** [not_full q] returns when [q] stop being full. *)
val iter : 'a t -> f:('a -> unit Lwt.t) -> unit Lwt.t
(** [iter q ~f] pops all elements of [q] and applies [f] on them. *)
exception Closed
val close : 'a t -> unit
(** [close q] the write end of [q]:
* Future write attempts will fail with [Closed].
* If there are reads blocked, they will unblock and fail with [Closed].
* Future read attempts will drain the data until there is no data left.
Thus, after a pipe has been closed, reads never block.
Close is idempotent.
*)

118
src/utils/lwt_utils.ml
View File

@ -12,7 +12,7 @@ module LC = Lwt_condition
open Lwt.Infix
open Logging.Core
let may f = function
let may ~f = function
| None -> Lwt.return_unit
| Some x -> f x
@ -39,10 +39,13 @@ let canceler ()
else begin
canceling := true ;
LC.broadcast cancelation () ;
!cancel_hook () >>= fun () ->
Lwt.finalize
!cancel_hook
(fun () ->
canceled := true ;
LC.broadcast cancelation_complete () ;
Lwt.return ()
Lwt.return ()) >>= fun () ->
Lwt.return_unit
end
in
let on_cancel cb =
@ -55,6 +58,53 @@ let canceler ()
in
cancelation, cancel, on_cancel
module Canceler = struct
type t = {
cancelation: unit Lwt_condition.t ;
cancelation_complete: unit Lwt_condition.t ;
mutable cancel_hook: unit -> unit Lwt.t ;
mutable canceling: bool ;
mutable canceled: bool ;
}
let create () =
let cancelation = LC.create () in
let cancelation_complete = LC.create () in
{ cancelation ; cancelation_complete ;
cancel_hook = (fun () -> Lwt.return ()) ;
canceling = false ;
canceled = false ;
}
let cancel st =
if st.canceled then
Lwt.return ()
else if st.canceling then
LC.wait st.cancelation_complete
else begin
st.canceling <- true ;
LC.broadcast st.cancelation () ;
Lwt.finalize
st.cancel_hook
(fun () ->
st.canceled <- true ;
LC.broadcast st.cancelation_complete () ;
Lwt.return ())
end
let on_cancel st cb =
let hook = st.cancel_hook in
st.cancel_hook <- (fun () -> hook () >>= cb)
let cancelation st =
if st.canceling then Lwt.return ()
else LC.wait st.cancelation
let canceled st = st.canceling
end
type trigger =
| Absent
| Present
@ -114,12 +164,11 @@ let queue () : ('a -> unit) * (unit -> 'a list Lwt.t) =
queue, wait
(* A worker launcher, takes a cancel callback to call upon *)
let worker ?(safe=false) name ~run ~cancel =
let worker name ~run ~cancel =
let stop = LC.create () in
let fail e =
log_error "%s worker failed with %s" name (Printexc.to_string e) ;
cancel () >>= fun () ->
if safe then Lwt.return_unit else Lwt.fail e
cancel ()
in
let waiter = LC.wait stop in
log_info "%s worker started" name ;
@ -263,6 +312,17 @@ let write_mbytes ?(pos=0) ?len descr buf =
| nb_written -> inner (pos + nb_written) (len - nb_written) in
inner pos len
let write_bytes ?(pos=0) ?len descr buf =
let len = match len with None -> Bytes.length buf - pos | Some l -> l in
let rec inner pos len =
if len = 0 then
Lwt.return_unit
else
Lwt_unix.write descr buf pos len >>= function
| 0 -> Lwt.fail End_of_file (* other endpoint cleanly closed its connection *)
| nb_written -> inner (pos + nb_written) (len - nb_written) in
inner pos len
let (>>=) = Lwt.bind
let remove_dir dir =
@ -297,3 +357,49 @@ let create_file ?(perm = 0o644) name content =
Lwt_unix.openfile name Unix.([O_TRUNC; O_CREAT; O_WRONLY]) perm >>= fun fd ->
Lwt_unix.write_string fd content 0 (String.length content) >>= fun _ ->
Lwt_unix.close fd
let safe_close fd =
Lwt.catch
(fun () -> Lwt_unix.close fd)
(fun _ -> Lwt.return_unit)
open Error_monad
type error += Canceled
let protect ?on_error ?canceler t =
let cancelation =
match canceler with
| None -> never_ending
| Some canceler ->
( Canceler.cancelation canceler >>= fun () ->
fail Canceled ) in
let res =
Lwt.pick [ cancelation ;
Lwt.catch t (fun exn -> fail (Exn exn)) ] in
res >>= function
| Ok _ -> res
| Error err ->
let canceled =
Utils.unopt_map canceler ~default:false ~f:Canceler.canceled in
let err = if canceled then [Canceled] else err in
match on_error with
| None -> Lwt.return (Error err)
| Some on_error -> on_error err
type error += Timeout
let with_timeout ?(canceler = Canceler.create ()) timeout f =
let t = Lwt_unix.sleep timeout in
Lwt.choose [
(t >|= fun () -> None) ;
(f canceler >|= fun x -> Some x)
] >>= function
| Some x when Lwt.state t = Lwt.Sleep ->
Lwt.cancel t ;
Lwt.return x
| _ ->
Canceler.cancel canceler >>= fun () ->
fail Timeout

32
src/utils/lwt_utils.mli
View File

@ -7,7 +7,7 @@
(* *)
(**************************************************************************)
val may : ('a -> unit Lwt.t) -> 'a option -> unit Lwt.t
val may: f:('a -> unit Lwt.t) -> 'a option -> unit Lwt.t
val never_ending: 'a Lwt.t
@ -16,8 +16,18 @@ val canceler : unit ->
(unit -> unit Lwt.t) *
((unit -> unit Lwt.t) -> unit)
module Canceler : sig
type t
val create : unit -> t
val cancel : t -> unit Lwt.t
val cancelation : t -> unit Lwt.t
val on_cancel : t -> (unit -> unit Lwt.t) -> unit
val canceled : t -> bool
end
val worker:
?safe:bool ->
string ->
run:(unit -> unit Lwt.t) ->
cancel:(unit -> unit Lwt.t) ->
@ -33,9 +43,27 @@ val read_bytes:
val read_mbytes:
?pos:int -> ?len:int -> Lwt_unix.file_descr -> MBytes.t -> unit Lwt.t
val write_bytes:
?pos:int -> ?len:int -> Lwt_unix.file_descr -> bytes -> unit Lwt.t
val write_mbytes:
?pos:int -> ?len:int -> Lwt_unix.file_descr -> MBytes.t -> unit Lwt.t
val remove_dir: string -> unit Lwt.t
val create_dir: ?perm:int -> string -> unit Lwt.t
val create_file: ?perm:int -> string -> string -> unit Lwt.t
val safe_close: Lwt_unix.file_descr -> unit Lwt.t
open Error_monad
type error += Canceled
val protect :
?on_error:(error list -> 'a tzresult Lwt.t) ->
?canceler:Canceler.t ->
(unit -> 'a tzresult Lwt.t) -> 'a tzresult Lwt.t
type error += Timeout
val with_timeout:
?canceler:Canceler.t ->
float -> (Canceler.t -> 'a tzresult Lwt.t) -> 'a tzresult Lwt.t

97
src/utils/moving_average.ml
View File

@ -7,31 +7,80 @@
(* *)
(**************************************************************************)
class type ma = object
method add_float : float -> unit
method add_int : int -> unit
method get : float
end
open Lwt.Infix
class virtual base ?(init = 0.) () = object (self)
val mutable acc : float = init
method virtual add_float : float -> unit
method add_int x = self#add_float (float_of_int x)
method get = acc
end
module Inttbl = Hashtbl.Make(struct
type t = int
let equal (x: int) (y: int) = x = y
let hash = Hashtbl.hash
end)
class sma ?init () = object
inherit base ?init ()
val mutable i = match init with None -> 0 | _ -> 1
method add_float x =
acc <- (acc +. (x -. acc) /. (float_of_int @@ succ i)) ;
i <- succ i
end
type t = {
id: int;
alpha: int ;
mutable total: int ;
mutable current: int ;
mutable average: int ;
}
class ema ?init ~alpha () = object
inherit base ?init ()
val alpha = alpha
method add_float x =
acc <- alpha *. x +. (1. -. alpha) *. acc
end
let counters = Inttbl.create 51
let updated = Lwt_condition.create ()
let update_hook = ref []
let on_update f = update_hook := f :: !update_hook
let worker_loop () =
let prev = ref @@ Mtime.elapsed () in
let rec inner sleep =
sleep >>= fun () ->
let sleep = Lwt_unix.sleep 1. in
let now = Mtime.elapsed () in
let elapsed = int_of_float (Mtime.(to_ms now -. to_ms !prev)) in
prev := now;
Inttbl.iter
(fun _ c ->
c.average <-
(c.alpha * c.current) / elapsed + (1000 - c.alpha) * c.average / 1000;
c.current <- 0)
counters ;
List.iter (fun f -> f ()) !update_hook ;
Lwt_condition.broadcast updated () ;
inner sleep
in
inner (Lwt_unix.sleep 1.)
let worker =
lazy begin
Lwt.async begin fun () ->
let (_cancelation, cancel, _on_cancel) = Lwt_utils.canceler () in
Lwt_utils.worker "counter" ~run:worker_loop ~cancel
end
end
let create =
let cpt = ref 0 in
fun ~init ~alpha ->
Lazy.force worker ;
let id = !cpt in
incr cpt ;
assert (0. < alpha && alpha <= 1.) ;
let alpha = int_of_float (1000. *. alpha) in
let c = { id ; alpha ; total = 0 ; current = 0 ; average = init } in
Inttbl.add counters id c ;
c
let add c x =
c.total <- c.total + x ;
c.current <- c.current + x
let destroy c =
Inttbl.remove counters c.id
type stat = {
total: int ;
average: int ;
}
let stat ({ total ; average } : t) : stat =
{ total ; average }

34
src/utils/moving_average.mli
View File

@ -7,28 +7,18 @@
(* *)
(**************************************************************************)
(** Moving averages. The formulas are from Wikipedia
[https://en.wikipedia.org/wiki/Moving_average] *)
type t
class type ma = object
method add_float : float -> unit
method add_int : int -> unit
method get : float
end
(** Common class type for objects computing a cumulative moving
average of some flavor. In a cumulative moving average, the data
arrive in an ordered datum stream, and the user would like to get
the average of all of the data up until the current datum
point. The method [add_float] and [add_int] are used to add the
next datum. The method [get] and [get_exn] are used to compute the
moving average up until the current datum point. *)
val create: init:int -> alpha:float -> t
val destroy: t -> unit
class sma : ?init:float -> unit -> ma
(** [sma ?init ()] is an object that computes the Simple Moving
Average of a datum stream. [SMA(n+1) = SMA(n) + (x_(n+1) / SMA(n))
/ (n+1)] *)
val add: t -> int -> unit
class ema : ?init:float -> alpha:float -> unit -> ma
(** [ema ?init ~alpha ()] is an object that computes the Exponential
Moving Average of a datum stream. [EMA(n+1) = alpha * x_(n+1) +
(1 - alpha) * x_n] *)
val on_update: (unit -> unit) -> unit
val updated: unit Lwt_condition.t
type stat = {
total: int ;
average: int ;
}
val stat: t -> stat

59
src/utils/ring.ml Normal file
View File

@ -0,0 +1,59 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
type 'a raw =
| Empty of int
| Inited of {
data : 'a array ;
mutable pos : int ;
}
type 'a t = 'a raw ref
let create size = ref (Empty size)
let add r v =
match !r with
| Empty size ->
r := Inited { data = Array.make size v ; pos = 0 }
| Inited s ->
s.pos <-
if s.pos = 2 * Array.length s.data - 1 then
Array.length s.data
else
s.pos + 1 ;
s.data.(s.pos mod Array.length s.data) <- v
let add_list r l = List.iter (add r) l
let last r =
match !r with
| Empty _ -> None
| Inited { data ; pos } -> Some data.(pos mod Array.length data)
let fold r ~init ~f =
match !r with
| Empty _ -> init
| Inited { data ; pos } ->
let size = Array.length data in
let acc = ref init in
for i = 0 to min pos (size - 1) do
acc := f !acc data.((pos - i) mod size)
done ;
!acc
let elements t =
fold t ~init:[] ~f:(fun acc elt -> elt :: acc)
exception Empty
let last_exn r =
match last r with
| None -> raise Empty
| Some d -> d

20
src/utils/ring.mli Normal file
View File

@ -0,0 +1,20 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
(** Imperative Ring Buffer *)
type 'a t
val create : int -> 'a t
val add : 'a t -> 'a -> unit
val add_list : 'a t -> 'a list -> unit
val last : 'a t -> 'a option
exception Empty
val last_exn : 'a t -> 'a
val fold : 'a t -> init:'b -> f:('b -> 'a -> 'b) -> 'b
val elements : 'a t -> 'a list

81
src/utils/time.ml
View File

@ -10,52 +10,65 @@
open Error_monad
open CalendarLib
type t = int64
module T = struct
include Int64
let compare = Int64.compare
let (=) x y = compare x y = 0
let equal = (=)
let (<>) x y = compare x y <> 0
let (<) x y = compare x y < 0
let (<=) x y = compare x y <= 0
let (>=) x y = compare x y >= 0
let (>) x y = compare x y > 0
let min x y = if x <= y then x else y
let max x y = if x <= y then y else x
let diff a b =
let sign = a >= b in
let res = Int64.sub a b in
let res_sign = res >= 0L in
if sign = res_sign then res else invalid_arg "Time.diff" ;;
let add = Int64.add
let diff = Int64.sub
let add a d =
let sign = d >= 0L in
let res = Int64.add a d in
let incr_sign = res >= a in
if sign = incr_sign then res else invalid_arg "Time.add" ;;
let now () = Int64.of_float (Unix.gettimeofday ())
let hash = to_int
let (=) = equal
let (<>) x y = compare x y <> 0
let (<) x y = compare x y < 0
let (<=) x y = compare x y <= 0
let (>=) x y = compare x y >= 0
let (>) x y = compare x y > 0
let min x y = if x <= y then x else y
let max x y = if x <= y then y else x
let of_seconds x = x
let to_seconds x = x
let min_value = min_int
let epoch = 0L
let max_value = max_int
let formats =
let now () = Int64.of_float (Unix.gettimeofday ())
let of_seconds x = x
let to_seconds x = x
let formats =
[ "%Y-%m-%dT%H:%M:%SZ" ; "%Y-%m-%d %H:%M:%SZ";
"%Y-%m-%dT%H:%M:%S%:z"; "%Y-%m-%d %H:%M:%S%:z"; ]
let int64_of_calendar c =
let int64_of_calendar c =
let round fc =
let f, i = modf fc in
Int64.(add (of_float i) Pervasives.(if f < 0.5 then 0L else 1L)) in
round @@ Calendar.Precise.to_unixfloat c
let rec iter_formats s = function
let rec iter_formats s = function
| [] -> None
| f :: fs ->
try
Some (int64_of_calendar @@ Printer.Precise_Calendar.from_fstring f s)
with _ -> iter_formats s fs
let of_notation s =
let of_notation s =
iter_formats s formats
let of_notation_exn s =
let of_notation_exn s =
match of_notation s with
| None -> invalid_arg "Time.of_notation: can't parse."
| Some t -> t
let to_notation t =
let to_notation t =
let ft = Int64.to_float t in
if Int64.of_float ft <> t then
"out_of_range"
@ -64,13 +77,13 @@ let to_notation t =
"%Y-%m-%dT%H:%M:%SZ"
(Calendar.Precise.from_unixfloat ft)
let rfc_encoding =
let rfc_encoding =
let open Data_encoding in
def
"timestamp" @@
describe
~title:
"RFC 339 formatted timestamp"
"RFC 3339 formatted timestamp"
~description:
"A date in human readble form as specified in RFC 3339." @@
conv
@ -80,7 +93,7 @@ let rfc_encoding =
| None -> Data_encoding.Json.cannot_destruct "Time.of_notation")
string
let encoding =
let encoding =
let open Data_encoding in
splitted
~binary: int64
@ -96,20 +109,26 @@ let encoding =
(fun i -> i) ;
])
type 'a timed_data = {
type 'a timed_data = {
data: 'a ;
time: t ;
}
}
let timed_encoding arg_encoding =
let timed_encoding arg_encoding =
let open Data_encoding in
conv
(fun {time; data} -> (time, data))
(fun (time, data) -> {time; data})
(tup2 encoding arg_encoding)
let make_timed data = {
let make_timed data = {
data ; time = now () ;
}
}
let pp_hum ppf t = Format.pp_print_string ppf (to_notation t)
let pp_hum ppf t = Format.pp_print_string ppf (to_notation t)
end
include T
module Set = Set.Make(T)
module Map = Map.Make(T)
module Table = Hashtbl.Make(T)

8
src/utils/time.mli
View File

@ -9,6 +9,10 @@
type t
val min_value : t
val epoch : t
val max_value : t
val add : t -> int64 -> t
val diff : t -> t -> int64
@ -46,3 +50,7 @@ type 'a timed_data = {
val make_timed : 'a -> 'a timed_data
val timed_encoding : 'a Data_encoding.t -> 'a timed_data Data_encoding.t
module Set : Set.S with type elt = t
module Map : Map.S with type key = t
module Table : Hashtbl.S with type key = t

80
test/Makefile
View File

@ -1,5 +1,11 @@
TESTS := data-encoding store context state basic basic.sh
TESTS := \
data-encoding \
store context state \
basic basic.sh \
p2p-io-scheduler \
p2p-connection \
p2p-connection-pool
all: test
@ -33,9 +39,11 @@ PACKAGES := \
dynlink \
ezjsonm \
git \
ipv6-multicast \
irmin.unix \
lwt \
lwt.unix \
mtime.os \
ocplib-endian \
ocplib-ocamlres \
ocplib-json-typed.bson \
@ -66,9 +74,9 @@ ${NODELIB} ${CLIENTLIB}:
${MAKE} -C ../src $@
.PHONY: build-test run-test test
build-test: ${addprefix build-test-,${TESTS}} test-p2p
build-test: ${addprefix build-test-,${TESTS}}
run-test:
@$(patsubst %,${MAKE} run-test-% ; , ${TESTS}) \
@$(patsubst %,${MAKE} run-test-% && , ${TESTS}) \
echo && echo "Success" && echo
test:
@${MAKE} --no-print-directory build-test
@ -177,13 +185,63 @@ clean::
############################################################################
## p2p test program
TEST_P2P_INTFS =
.PHONY:build-test-p2p-io-scheduler run-test-p2p-io-scheduler
build-test-p2p-io-scheduler: test-p2p-io-scheduler
run-test-p2p-io-scheduler:
./test-p2p-io-scheduler \
--delay 20 --clients 8 \
--max-upload-speed $$((1 << 18)) \
--max-download-speed $$((1 << 20))
TEST_P2P_IMPLS = \
test_p2p.ml
.PHONY:build-test-p2p-connection run-test-p2p-connection
build-test-p2p-connection: test-p2p-connection
run-test-p2p-connection:
./test-p2p-connection
.PHONY:build-test-p2p-connection-pool run-test-p2p-connection-pool
build-test-p2p-connection-pool: test-p2p-connection-pool
run-test-p2p-connection-pool:
./test-p2p-connection-pool --clients 10 --repeat 5
TEST_P2P_IO_SCHEDULER_IMPLS = \
lib/process.ml \
test_p2p_io_scheduler.ml
TEST_P2P_CONNECTION_IMPLS = \
lib/process.ml \
test_p2p_connection.ml
TEST_P2P_CONNECTION_POOL_IMPLS = \
lib/process.ml \
test_p2p_connection_pool.ml
${TEST_P2P_IO_SCHEDULER_IMPLS:.ml=.cmx}: ${NODELIB}
test-p2p-io-scheduler: ${NODELIB} ${TEST_P2P_IO_SCHEDULER_IMPLS:.ml=.cmx}
ocamlfind ocamlopt -linkall -linkpkg ${OCAMLFLAGS} -o $@ $^
${TEST_P2P_CONNECTION_IMPLS:.ml=.cmx}: ${NODELIB}
test-p2p-connection: ${NODELIB} ${TEST_P2P_CONNECTION_IMPLS:.ml=.cmx}
ocamlfind ocamlopt -linkall -linkpkg ${OCAMLFLAGS} -o $@ $^
${TEST_P2P_CONNECTION_POOL_IMPLS:.ml=.cmx}: ${NODELIB}
test-p2p-connection-pool: ${NODELIB} ${TEST_P2P_CONNECTION_POOL_IMPLS:.ml=.cmx}
ocamlfind ocamlopt -linkall -linkpkg ${OCAMLFLAGS} -o $@ $^
clean::
-rm -f test-p2p-io_scheduler
-rm -f test-p2p-connection
-rm -f test-p2p-connection-pool
############################################################################
## lwt pipe test program
build-test-lwt-pipe: test-lwt-pipe
TEST_PIPE_IMPLS = \
test_lwt_pipe.ml
${TEST_BASIC_IMPLS:.ml=.cmx}: ${NODELIB}
test-p2p: ${NODELIB} ${TEST_P2P_IMPLS:.ml=.cmx}
test-lwt-pipe: ${NODELIB} ${TEST_PIPE_IMPLS:.ml=.cmx}
ocamlfind ocamlopt -linkall -linkpkg ${OCAMLFLAGS} -o $@ $^
clean::
@ -233,6 +291,14 @@ bisect:
bisect-ppx-report $(COVERAGESRCDIR) \
-ignore-missing-files -html reports bisect*.out
#####
lib/assert.cmx: lib/assert.cmi
lib/assert.cmi: ../src/node/db/persist.cmi
lib/process.cmx: lib/process.cmi
lib/test.cmx: lib/test.cmi
############################################################################
## Generic rules

79
test/lib/process.ml Normal file
View File

@ -0,0 +1,79 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
include Logging.Make (struct let name = "process" end)
open Error_monad
exception Exited of int
let detach ?(prefix = "") f =
Lwt_io.flush_all () >>= fun () ->
match Lwt_unix.fork () with
| 0 ->
Random.self_init () ;
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_log_notice "PID: %d" (Unix.getpid ()) >>= fun () ->
f ()
end ;
exit 0
| pid ->
Lwt.catch
(fun () ->
Lwt_unix.waitpid [] pid >>= function
| (_,Lwt_unix.WEXITED 0) ->
Lwt.return_unit
| (_,Lwt_unix.WEXITED n) ->
Lwt.fail (Exited n)
| (_,Lwt_unix.WSIGNALED _)
| (_,Lwt_unix.WSTOPPED _) ->
Lwt.fail Exit)
(function
| Lwt.Canceled ->
Unix.kill pid Sys.sigkill ;
Lwt.return_unit
| exn -> Lwt.fail exn)
let handle_error f =
Lwt.catch
f
(fun exn -> Lwt.return (error_exn exn)) >>= function
| Ok () -> Lwt.return_unit
| Error err ->
lwt_log_error "%a" Error_monad.pp_print_error err >>= fun () ->
exit 1
let rec wait processes =
Lwt.catch
(fun () ->
Lwt.nchoose_split processes >>= function
| (_, []) -> lwt_log_notice "All done!"
| (_, processes) -> wait processes)
(function
| Exited n ->
lwt_log_notice "Early error!" >>= fun () ->
List.iter Lwt.cancel processes ;
Lwt.catch
(fun () -> Lwt.join processes)
(fun _ -> Lwt.return_unit) >>= fun () ->
lwt_log_notice "A process finished with error %d !" n >>= fun () ->
Pervasives.exit n
| exn ->
lwt_log_notice "Unexpected error!%a"
Error_monad.pp_exn exn >>= fun () ->
List.iter Lwt.cancel processes ;
Lwt.catch
(fun () -> Lwt.join processes)
(fun _ -> Lwt.return_unit) >>= fun () ->
Pervasives.exit 2)

15
test/lib/process.mli Normal file
View File

@ -0,0 +1,15 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
open Error_monad
exception Exited of int
val detach: ?prefix:string -> (unit -> unit Lwt.t) -> unit Lwt.t
val handle_error: (unit -> (unit, error list) result Lwt.t) -> unit Lwt.t
val wait: unit Lwt.t list -> unit Lwt.t

50
test/test_lwt_pipe.ml Normal file
View File

@ -0,0 +1,50 @@
open Lwt.Infix
include Logging.Make (struct let name = "test-pipe" end)
let rec producer queue = function
| 0 ->
lwt_log_notice "Done producing."
| n ->
Lwt_pipe.push queue () >>= fun () ->
producer queue (pred n)
let rec consumer queue = function
| 0 ->
lwt_log_notice "Done consuming."
| n ->
Lwt_pipe.pop queue >>= fun _ ->
consumer queue (pred n)
let rec gen acc f = function
| 0 -> acc
| n -> gen (f () :: acc) f (pred n)
let run qsize nbp nbc p c =
let q = Lwt_pipe.create qsize in
let producers = gen [] (fun () -> producer q p) nbp in
let consumers = gen [] (fun () -> consumer q c) nbc in
Lwt.join producers <&> Lwt.join consumers
let main () =
let qsize = ref 10 in
let nb_producers = ref 10 in
let nb_consumers = ref 10 in
let produced_per_producer = ref 10 in
let consumed_per_consumer = ref 10 in
let spec = Arg.[
"-qsize", Set_int qsize, "<int> Size of the pipe";
"-nc", Set_int nb_consumers, "<int> Number of consumers";
"-np", Set_int nb_producers, "<int> Number of producers";
"-n", Set_int consumed_per_consumer, "<int> Number of consumed items per consumers";
"-p", Set_int produced_per_producer, "<int> Number of produced items per producers";
"-v", Unit (fun () -> Lwt_log_core.(add_rule "*" Info)), " Log up to info msgs";
"-vv", Unit (fun () -> Lwt_log_core.(add_rule "*" Debug)), " Log up to debug msgs";
]
in
let anon_fun _ = () in
let usage_msg = "Usage: %s <num_peers>.\nArguments are:" in
Arg.parse spec anon_fun usage_msg;
run !qsize !nb_producers
!nb_consumers !produced_per_producer !consumed_per_consumer
let () = Lwt_main.run @@ main ()

167
test/test_p2p.ml
View File

@ -1,167 +0,0 @@
open Lwt.Infix
open P2p
include Logging.Make (struct let name = "test-p2p" end)
module Param = struct
let dump_encoding = Data_encoding.(Variable.list (tup2 string string))
type msg =
| Create of string * string
| Update of string * string
| Delete of string
| Dump of (string * string) list
let encodings = [
Encoding { tag = 0x10;
encoding = Data_encoding.(tup2 string string);
wrap = (function (k, v) -> Create (k, v));
unwrap = (function Create (k, v) -> Some (k, v) | _ -> None);
max_length = Some 0x400;
};
Encoding { tag = 0x11;
encoding = Data_encoding.(tup2 string string);
wrap = (function (k, v) -> Update (k, v));
unwrap = (function Create (k, v) -> Some (k, v) | _ -> None);
max_length = Some 0x400;
};
Encoding { tag = 0x12;
encoding = Data_encoding.string;
wrap = (function x -> Delete x);
unwrap = (function Delete x -> Some x | _ -> None);
max_length = Some 0x400;
};
Encoding { tag = 0x13;
encoding = dump_encoding;
wrap = (function x -> Dump x);
unwrap = (function Dump x -> Some x | _ -> None);
max_length = Some 0x10000;
};
]
type metadata = unit
let initial_metadata = ()
let metadata_encoding = Data_encoding.empty
let score () = 0.
let supported_versions = [ { name = "TEST"; major = 0; minor = 0; } ]
end
module Net = Make(Param)
let print_peer_info { Net.gid; addr; port; version = { name; major; minor } } =
Printf.sprintf "%s:%d (%s.%d.%d)" (Ipaddr.to_string addr) port name major minor
let string_of_gid gid = Format.asprintf "%a" pp_gid gid
let net_monitor config limits num_nets net =
let my_gid_str = string_of_gid @@ Net.gid net in
let send_msgs_to_neighbours neighbours =
Lwt_list.iter_p begin fun p ->
let { Net.gid } = Net.peer_info net p in
let remote_gid_str = string_of_gid gid in
Net.send net p (Create (my_gid_str, remote_gid_str)) >>= fun _ ->
lwt_log_notice "(%s) Done sending msg to %s" my_gid_str remote_gid_str
end neighbours >>= fun () ->
lwt_log_notice "(%s) Done sending all msgs." my_gid_str
in
let rec inner () =
let neighbours = Net.peers net in
let nb_neighbours = List.length neighbours in
if nb_neighbours < num_nets - 1 then begin
log_notice "(%s) I have %d peers" my_gid_str nb_neighbours;
Lwt_unix.sleep 1. >>= inner end
else begin
log_notice "(%s) I know all my %d peers" my_gid_str nb_neighbours;
Lwt.async (fun () -> send_msgs_to_neighbours neighbours);
let rec recv_peer_msgs acc =
if List.length acc = num_nets - 1 then begin
(* Print total sent/recv *)
let peers = Net.peers net in
ListLabels.iter peers ~f:begin fun p ->
let pi = Net.peer_info net p in
log_info "%a -> %a %d %d %.2f %.2f" pp_gid (Net.gid net) pp_gid pi.gid
pi.total_sent pi.total_recv pi.current_inflow pi.current_outflow;
end;
ListLabels.iter acc ~f:(fun (k, v) -> log_info "%s %s" k v);
Lwt.return_unit
end
else begin
lwt_log_notice "(%s) recv_peers_msgs: Got %d, need %d"
my_gid_str (List.length acc) (num_nets - 1) >>= fun () ->
Net.recv net >>= function
| p, (Create (their_gid, my_gid)) ->
lwt_log_notice "(%s) Got a message from %s" my_gid_str their_gid >>= fun () ->
recv_peer_msgs ((their_gid, my_gid) :: acc)
| _ -> assert false
end
in
recv_peer_msgs []
end
in inner ()
let range n =
let rec inner acc = function
| -1 -> acc
| n -> inner (n :: acc) (pred n)
in
if n < 0 then invalid_arg "range"
else inner [] (pred n)
let main () =
let incoming_port = ref @@ Some 11732 in
let discovery_port = ref @@ Some 10732 in
let closed_network = ref false in
let max_packet_size = ref 1024 in
let peer_answer_timeout = ref 10. in
let blacklist_time = ref 100. in
let num_networks = ref 0 in
let make_net nb_neighbours n =
let config = {
incoming_port = Utils.map_option !incoming_port ~f:(fun p -> p + n);
discovery_port = !discovery_port;
known_peers = [];
peers_file = "";
closed_network = !closed_network;
}
in
let limits = {
max_message_size = !max_packet_size;
peer_answer_timeout = !peer_answer_timeout;
expected_connections = nb_neighbours;
min_connections = nb_neighbours;
max_connections = nb_neighbours;
blacklist_time = !blacklist_time;
}
in
Net.bootstrap ~config ~limits >|= fun net ->
config, limits, net
in
let spec = Arg.[
"-start-port", Int (fun p -> incoming_port := Some p), " Incoming port";
"-dport", Int (fun p -> discovery_port := Some p), " Discovery port";
"-closed", Set closed_network, " Closed network mode";
"-max-packet-size", Set_int max_packet_size, "int Max size of packets";
"-peer-answer-timeout", Set_float peer_answer_timeout, "float Number of seconds";
"-blacklist-time", Set_float blacklist_time, "float Number of seconds";
"-v", Unit (fun () -> Lwt_log_core.(add_rule "*" Info)), " Log up to info msgs";
"-vv", Unit (fun () -> Lwt_log_core.(add_rule "*" Debug)), " Log up to debug msgs";
]
in
let anon_fun num_peers = num_networks := int_of_string num_peers in
let usage_msg = "Usage: %s <num_peers>.\nArguments are:" in
Arg.parse spec anon_fun usage_msg;
let nets = range !num_networks in
Lwt_list.map_p (make_net (pred !num_networks)) nets >>= fun nets ->
Lwt_list.iter_p (fun (cfg, limits, net) -> net_monitor cfg limits !num_networks net) nets >>= fun () ->
lwt_log_notice "All done!"
let () =
Sys.catch_break true;
try
Lwt_main.run @@ main ()
with _ -> ()

204
test/test_p2p_connection.ml Normal file
View File

@ -0,0 +1,204 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
(* TODO Use Kaputt on the client side and remove `assert` from the
server. *)
open Error_monad
open P2p_types
include Logging.Make (struct let name = "test-p2p-connection" end)
let proof_of_work_target =
Crypto_box.make_target [Int64.shift_left 1L 48]
let id1 = Identity.generate proof_of_work_target
let id2 = Identity.generate proof_of_work_target
let id0 =
(* Luckilly, this will be an insuficient proof of work! *)
Identity.generate (Crypto_box.make_target [])
let versions = Version.[{ name = "TEST" ; minor = 0 ; major = 0 }]
let rec listen ?port addr =
let tentative_port =
match port with
| None -> 1024 + Random.int 8192
| Some port -> port in
let uaddr = Ipaddr_unix.V6.to_inet_addr addr in
let main_socket = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in
Lwt_unix.(setsockopt main_socket SO_REUSEADDR true) ;
Lwt.catch begin fun () ->
Lwt_unix.Versioned.bind_2 main_socket
(ADDR_INET (uaddr, tentative_port)) >>= fun () ->
Lwt_unix.listen main_socket 1 ;
Lwt.return (main_socket, tentative_port)
end begin function
| Unix.Unix_error
((Unix.EADDRINUSE | Unix.EADDRNOTAVAIL), _, _) when port = None ->
listen addr
| exn -> Lwt.fail exn
end
let raw_accept sched main_socket =
Lwt_unix.accept main_socket >>= fun (fd, sockaddr) ->
let fd = P2p_io_scheduler.register sched fd in
let point =
match sockaddr with
| Lwt_unix.ADDR_UNIX _ -> assert false
| Lwt_unix.ADDR_INET (addr, port) ->
Ipaddr_unix.V6.of_inet_addr_exn addr, port in
Lwt.return (fd, point)
let accept sched main_socket =
raw_accept sched main_socket >>= fun (fd, point) ->
P2p_connection.authenticate
~proof_of_work_target
~incoming:true fd point id1 versions
let raw_connect sched addr port =
let fd = Lwt_unix.socket PF_INET6 SOCK_STREAM 0 in
let uaddr =
Lwt_unix.ADDR_INET (Ipaddr_unix.V6.to_inet_addr addr, port) in
Lwt_unix.connect fd uaddr >>= fun () ->
let fd = P2p_io_scheduler.register sched fd in
Lwt.return fd
let connect sched addr port id =
raw_connect sched addr port >>= fun fd ->
P2p_connection.authenticate
~proof_of_work_target
~incoming:false fd (addr, port) id versions >>=? fun (info, auth_fd) ->
assert (not info.incoming) ;
assert (Gid.compare info.gid id1.gid = 0) ;
return auth_fd
let simple_msg =
MBytes.create (1 lsl 1)
let is_rejected = function
| Error [P2p_connection.Rejected] -> true
| Ok _ | Error _ -> false
let is_connection_closed = function
| Error [P2p_io_scheduler.Connection_closed] -> true
| Ok _ | Error _ -> false
let bytes_encoding = Data_encoding.Variable.bytes
let server main_socket =
let sched = P2p_io_scheduler.create ~read_buffer_size:(1 lsl 12) () in
(* Low-level test. *)
raw_accept sched main_socket >>= fun (fd, point) ->
lwt_log_notice "Low_level" >>= fun () ->
P2p_io_scheduler.write fd simple_msg >>=? fun () ->
P2p_io_scheduler.close fd >>=? fun _ ->
lwt_log_notice "Low_level OK" >>= fun () ->
(* Kick the first connection. *)
accept sched main_socket >>=? fun (info, auth_fd) ->
lwt_log_notice "Kick" >>= fun () ->
assert (info.incoming) ;
assert (Gid.compare info.gid id2.gid = 0) ;
P2p_connection.kick auth_fd >>= fun () ->
lwt_log_notice "Kick OK" >>= fun () ->
(* Let's be rejected. *)
accept sched main_socket >>=? fun (info, auth_fd) ->
P2p_connection.accept auth_fd bytes_encoding >>= fun conn ->
assert (is_rejected conn) ;
lwt_log_notice "Kicked OK" >>= fun () ->
(* Accept and send a single message. *)
accept sched main_socket >>=? fun (info, auth_fd) ->
lwt_log_notice "Single" >>= fun () ->
P2p_connection.accept auth_fd bytes_encoding >>=? fun conn ->
P2p_connection.write_sync conn simple_msg >>=? fun () ->
P2p_connection.close conn >>= fun _stat ->
lwt_log_notice "Single OK" >>= fun () ->
(* Accept and send a single message, while the client expected 2. *)
accept sched main_socket >>=? fun (info, auth_fd) ->
lwt_log_notice "Early close (read)" >>= fun () ->
P2p_connection.accept auth_fd bytes_encoding >>=? fun conn ->
P2p_connection.write_sync conn simple_msg >>=? fun () ->
P2p_connection.close conn >>= fun _stat ->
lwt_log_notice "Early close (read) OK" >>= fun () ->
(* Accept and wait for the client to close the connection. *)
accept sched main_socket >>=? fun (info, auth_fd) ->
lwt_log_notice "Early close (write)" >>= fun () ->
P2p_connection.accept auth_fd bytes_encoding >>=? fun conn ->
P2p_connection.close conn >>= fun _stat ->
lwt_log_notice "Early close (write) OK" >>= fun () ->
P2p_io_scheduler.shutdown sched >>= fun () ->
Lwt_unix.sleep 0.2 >>= fun () ->
lwt_log_notice "Success" >>= fun () ->
return ()
let client addr port =
let msg = MBytes.create (MBytes.length simple_msg) in
let sched = P2p_io_scheduler.create ~read_buffer_size:(1 lsl 12) () in
raw_connect sched addr port >>= fun fd ->
P2p_io_scheduler.read_full fd msg >>=? fun () ->
assert (MBytes.compare simple_msg msg = 0) ;
P2p_io_scheduler.close fd >>=? fun () ->
lwt_log_notice "Low_level OK" >>= fun () ->
(* let's be rejected. *)
connect sched addr port id2 >>=? fun auth_fd ->
P2p_connection.accept auth_fd bytes_encoding >>= fun conn ->
assert (is_rejected conn) ;
lwt_log_notice "Kick OK" >>= fun () ->
(* let's reject! *)
lwt_log_notice "Kicked" >>= fun () ->
connect sched addr port id2 >>=? fun auth_fd ->
P2p_connection.kick auth_fd >>= fun () ->
(* let's exchange a simple message. *)
connect sched addr port id2 >>=? fun auth_fd ->
P2p_connection.accept auth_fd bytes_encoding >>=? fun conn ->
P2p_connection.read conn >>=? fun msg ->
assert (MBytes.compare simple_msg msg = 0) ;
P2p_connection.close conn >>= fun _stat ->
lwt_log_notice "Simple OK" >>= fun () ->
(* let's detect a closed connection on `read`. *)
connect sched addr port id2 >>=? fun auth_fd ->
P2p_connection.accept auth_fd bytes_encoding >>=? fun conn ->
P2p_connection.read conn >>=? fun msg ->
assert (MBytes.compare simple_msg msg = 0) ;
P2p_connection.read conn >>= fun msg ->
assert (is_connection_closed msg) ;
P2p_connection.close conn >>= fun _stat ->
lwt_log_notice "Early close (read) OK" >>= fun () ->
(* let's detect a closed connection on `write`. *)
connect sched addr port id2 >>=? fun auth_fd ->
P2p_connection.accept auth_fd bytes_encoding >>=? fun conn ->
Lwt_unix.sleep 0.1 >>= fun () ->
P2p_connection.write_sync conn simple_msg >>= fun unit ->
assert (is_connection_closed unit) ;
P2p_connection.close conn >>= fun _stat ->
lwt_log_notice "Early close (write) OK" >>= fun () ->
P2p_io_scheduler.shutdown sched >>= fun () ->
lwt_log_notice "Success" >>= fun () ->
return ()
let default_addr = Ipaddr.V6.localhost
let main () =
listen default_addr >>= fun (main_socket, port) ->
let server =
Process.detach ~prefix:"server " begin fun () ->
Process.handle_error begin fun () ->
server main_socket
end
end in
let client =
Process.detach ~prefix:"client " begin fun () ->
Lwt_utils.safe_close main_socket >>= fun () ->
Process.handle_error begin fun () ->
client default_addr port
end
end in
Process.wait [ server ; client ]
let () =
Lwt_main.run (main ())

196
test/test_p2p_connection_pool.ml Normal file
View File

@ -0,0 +1,196 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
open Error_monad
open P2p_types
include Logging.Make (struct let name = "test-p2p-connection-pool" end)
type message =
| Ping
let msg_config : message P2p_connection_pool.message_config = {
encoding = [
P2p_connection_pool.Encoding {
tag = 0x10 ;
encoding = Data_encoding.empty ;
wrap = (function () -> Ping) ;
unwrap = (function Ping -> Some ()) ;
max_length = None ;
} ;
] ;
versions = Version.[ { name = "TEST" ; major = 0 ; minor = 0 } ] ;
}
type metadata = unit
let meta_config : metadata P2p_connection_pool.meta_config = {
encoding = Data_encoding.empty ;
initial = () ;
}
let rec connect ~timeout pool point =
lwt_log_info "Connect to %a" Point.pp point >>= fun () ->
P2p_connection_pool.connect pool point ~timeout >>= function
| Error [P2p_connection_pool.Connected] -> begin
match P2p_connection_pool.Points.find_connection pool point with
| Some conn -> return conn
| None -> failwith "Woops..."
end
| Error ([ P2p_connection_pool.Connection_refused
| P2p_connection_pool.Pending_connection
| P2p_connection.Rejected
| Lwt_utils.Canceled
| Lwt_utils.Timeout
| P2p_connection_pool.Rejected _
] as err) ->
lwt_log_info "@[Connection to %a failed:@ %a@]"
Point.pp point pp_print_error err >>= fun () ->
Lwt_unix.sleep (0.5 +. Random.float 2.) >>= fun () ->
connect ~timeout pool point
| Ok _ | Error _ as res -> Lwt.return res
let connect_all ~timeout pool points =
map_p (connect ~timeout pool) points
type error += Connect | Write | Read
let write_all conns msg =
iter_p
(fun conn ->
trace Write @@ P2p_connection_pool.write_sync conn msg)
conns
let read_all conns =
iter_p
(fun conn ->
trace Read @@ P2p_connection_pool.read conn >>=? fun Ping ->
return ())
conns
let rec connect_random pool total rem point n =
Lwt_unix.sleep (0.2 +. Random.float 1.0) >>= fun () ->
(trace Connect @@ connect ~timeout:2. pool point) >>=? fun conn ->
(trace Write @@ P2p_connection_pool.write conn Ping) >>= fun _ ->
(trace Read @@ P2p_connection_pool.read conn) >>=? fun Ping ->
Lwt_unix.sleep (0.2 +. Random.float 1.0) >>= fun () ->
P2p_connection_pool.disconnect conn >>= fun () ->
begin
decr rem ;
if !rem mod total = 0 then
lwt_log_notice "Remaining: %d." (!rem / total)
else
Lwt.return ()
end >>= fun () ->
if n > 1 then
connect_random pool total rem point (pred n)
else
return ()
let connect_random_all pool points n =
let total = List.length points in
let rem = ref (n * total) in
iter_p (fun point -> connect_random pool total rem point n) points
let close_all conns =
Lwt_list.iter_p P2p_connection_pool.disconnect conns
let run_net config repeat points addr port =
Lwt_unix.sleep (Random.float 2.0) >>= fun () ->
let sched = P2p_io_scheduler.create ~read_buffer_size:(1 lsl 12) () in
P2p_connection_pool.create
config meta_config msg_config sched >>= fun pool ->
P2p_welcome.run ~backlog:10 pool ~addr port >>= fun welcome ->
connect_all ~timeout:2. pool points >>=? fun conns ->
lwt_log_notice "Bootstrap OK" >>= fun () ->
write_all conns Ping >>=? fun () ->
lwt_log_notice "Sent all messages." >>= fun () ->
read_all conns >>=? fun () ->
lwt_log_notice "Read all messages." >>= fun () ->
close_all conns >>= fun () ->
lwt_log_notice "Begin random connections." >>= fun () ->
connect_random_all pool points repeat >>=? fun () ->
lwt_log_notice "Shutting down" >>= fun () ->
P2p_welcome.shutdown welcome >>= fun () ->
P2p_connection_pool.destroy pool >>= fun () ->
P2p_io_scheduler.shutdown sched >>= fun () ->
lwt_log_notice "Shutdown Ok" >>= fun () ->
return ()
let make_net points repeat n =
let point, points = Utils.select n points in
let proof_of_work_target = Crypto_box.make_target [] in
let identity = Identity.generate proof_of_work_target in
let config = P2p_connection_pool.{
identity ;
proof_of_work_target ;
trusted_points = points ;
peers_file = "/dev/null" ;
closed_network = true ;
listening_port = Some (snd point) ;
min_connections = List.length points ;
max_connections = List.length points ;
max_incoming_connections = List.length points ;
authentification_timeout = 2. ;
incoming_app_message_queue_size = None ;
incoming_message_queue_size = None ;
outgoing_message_queue_size = None ;
} in
Process.detach
~prefix:(Format.asprintf "%a " Gid.pp identity.gid)
begin fun () ->
run_net config repeat points (fst point) (snd point) >>= function
| Ok () -> Lwt.return_unit
| Error err ->
lwt_log_error "@[<v 2>Unexpected error: %d@ %a@]"
(List.length err)
pp_print_error err >>= fun () ->
exit 1
end
let addr = ref Ipaddr.V6.localhost
let port = ref (1024 + Random.int 8192)
let clients = ref 10
let repeat = ref 5
let spec = Arg.[
"--port", Int (fun p -> port := p), " Listening port of the first peer.";
"--addr", String (fun p -> addr := Ipaddr.V6.of_string_exn p),
" Listening addr";
"--clients", Set_int clients, " Number of concurrent clients." ;
"--repeat", Set_int repeat, " Number of connections/disconnections." ;
"-v", Unit (fun () -> Lwt_log_core.(add_rule "p2p.connection-pool" Info)),
" Log up to info msgs" ;
"-vv", Unit (fun () -> Lwt_log_core.(add_rule "p2p.connection-pool" Debug)),
" Log up to debug msgs";
]
let main () =
let open Utils in
let anon_fun num_peers = raise (Arg.Bad "No anonymous argument.") in
let usage_msg = "Usage: %s <num_peers>.\nArguments are:" in
Arg.parse spec anon_fun usage_msg ;
let ports = !port -- (!port + !clients - 1) in
let points = List.map (fun port -> !addr, port) ports in
Lwt_list.iter_p (make_net points !repeat) (0 -- (!clients - 1))
let () =
Sys.catch_break true ;
try
Logging.init Stderr ;
Lwt_main.run @@ main ()
with _ -> ()

232
test/test_p2p_io_scheduler.ml Normal file
View File

@ -0,0 +1,232 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
open Error_monad
open P2p_types
include Logging.Make (struct let name = "test-p2p-io-scheduler" end)
exception Error of error list
let rec listen ?port addr =
let tentative_port =
match port with
| None -> 1024 + Random.int 8192
| Some port -> port in
let uaddr = Ipaddr_unix.V6.to_inet_addr addr in
let main_socket = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in
Lwt_unix.(setsockopt main_socket SO_REUSEADDR true) ;
Lwt.catch begin fun () ->
Lwt_unix.Versioned.bind_2 main_socket
(ADDR_INET (uaddr, tentative_port)) >>= fun () ->
Lwt_unix.listen main_socket 50 ;
Lwt.return (main_socket, tentative_port)
end begin function
| Unix.Unix_error
((Unix.EADDRINUSE | Unix.EADDRNOTAVAIL), _, _) when port = None ->
listen addr
| exn -> Lwt.fail exn
end
let accept main_socket =
Lwt_unix.accept main_socket >>= fun (fd, sockaddr) ->
return fd
let rec accept_n main_socket n =
if n <= 0 then
return []
else
accept_n main_socket (n-1) >>=? fun acc ->
accept main_socket >>=? fun conn ->
return (conn :: acc)
let connect addr port =
let fd = Lwt_unix.socket PF_INET6 SOCK_STREAM 0 in
let uaddr =
Lwt_unix.ADDR_INET (Ipaddr_unix.V6.to_inet_addr addr, port) in
Lwt_unix.connect fd uaddr >>= fun () ->
return fd
let simple_msgs =
[|
MBytes.create (1 lsl 6) ;
MBytes.create (1 lsl 7) ;
MBytes.create (1 lsl 8) ;
MBytes.create (1 lsl 9) ;
MBytes.create (1 lsl 10) ;
MBytes.create (1 lsl 11) ;
MBytes.create (1 lsl 12) ;
MBytes.create (1 lsl 13) ;
MBytes.create (1 lsl 14) ;
MBytes.create (1 lsl 15) ;
MBytes.create (1 lsl 16) ;
|]
let nb_simple_msgs = Array.length simple_msgs
let receive conn =
let buf = MBytes.create (1 lsl 16) in
let rec loop () =
P2p_io_scheduler.read conn buf >>= function
| Ok _ -> loop ()
| Error [P2p_io_scheduler.Connection_closed] ->
Lwt.return ()
| Error err -> Lwt.fail (Error err)
in
loop ()
let server
?(display_client_stat = true)
?max_download_speed ?read_queue_size ~read_buffer_size
main_socket n =
let sched =
P2p_io_scheduler.create
?max_download_speed
?read_queue_size
~read_buffer_size
() in
Moving_average.on_update begin fun () ->
log_notice "Stat: %a" Stat.pp (P2p_io_scheduler.global_stat sched) ;
if display_client_stat then
P2p_io_scheduler.iter_connection sched
(fun id conn ->
log_notice " client(%d) %a" id Stat.pp (P2p_io_scheduler.stat conn)) ;
end ;
(* Accept and read message until the connection is closed. *)
accept_n main_socket n >>=? fun conns ->
let conns = List.map (P2p_io_scheduler.register sched) conns in
Lwt.join (List.map receive conns) >>= fun () ->
iter_p P2p_io_scheduler.close conns >>=? fun () ->
log_notice "OK %a" Stat.pp (P2p_io_scheduler.global_stat sched) ;
return ()
let max_size ?max_upload_speed () =
match max_upload_speed with
| None -> nb_simple_msgs
| Some max_upload_speed ->
let rec loop n =
if n <= 1 then 1
else if MBytes.length simple_msgs.(n-1) <= max_upload_speed then n
else loop (n - 1)
in
loop nb_simple_msgs
let rec send conn nb_simple_msgs =
Lwt_main.yield () >>= fun () ->
let msg = simple_msgs.(Random.int nb_simple_msgs) in
P2p_io_scheduler.write conn msg >>=? fun () ->
send conn nb_simple_msgs
let client ?max_upload_speed ?write_queue_size addr port time n =
let sched =
P2p_io_scheduler.create
?max_upload_speed ?write_queue_size ~read_buffer_size:(1 lsl 12) () in
connect addr port >>=? fun conn ->
let conn = P2p_io_scheduler.register sched conn in
let nb_simple_msgs = max_size ?max_upload_speed () in
Lwt.pick [ send conn nb_simple_msgs ;
Lwt_unix.sleep time >>= return ] >>=? fun () ->
P2p_io_scheduler.close conn >>=? fun () ->
let stat = P2p_io_scheduler.stat conn in
lwt_log_notice "Client OK %a" Stat.pp stat >>= fun () ->
return ()
let run
?display_client_stat
?max_download_speed ?max_upload_speed
~read_buffer_size ?read_queue_size ?write_queue_size
addr port time n =
Logging.init Stderr ;
listen ?port addr >>= fun (main_socket, port) ->
let server =
Process.detach ~prefix:"server " begin fun () ->
Process.handle_error begin fun () ->
server
?display_client_stat ?max_download_speed
~read_buffer_size ?read_queue_size
main_socket n
end
end in
let client n =
let prefix = Printf.sprintf "client(%d) " n in
Process.detach ~prefix begin fun () ->
Lwt_utils.safe_close main_socket >>= fun () ->
Process.handle_error begin fun () ->
client ?max_upload_speed ?write_queue_size addr port time n
end
end in
Process.wait (server :: List.map client Utils.(1 -- n))
let () = Random.self_init ()
let addr = ref Ipaddr.V6.localhost
let port = ref None
let max_download_speed = ref None
let max_upload_speed = ref None
let read_buffer_size = ref (1 lsl 14)
let read_queue_size = ref (Some 1)
let write_queue_size = ref (Some 1)
let delay = ref 60.
let clients = ref 8
let display_client_stat = ref None
let spec =
Arg.[
"--port", Int (fun p -> port := Some p), " Listening port";
"--addr", String (fun p -> addr := Ipaddr.V6.of_string_exn p),
" Listening addr";
"--max-download-speed", Int (fun i -> max_download_speed := Some i),
" Max download speed in B/s (default: unbounded)";
"--max-upload-speed", Int (fun i -> max_upload_speed := Some i),
" Max upload speed in B/s (default: unbounded)";
"--read-buffer-size", Set_int read_buffer_size,
" Size of the read buffers";
"--read-queue-size", Int (fun i ->
read_queue_size := if i <= 0 then None else Some i),
" Size of the read queue (0=unbounded)";
"--write-queue-size", Int (fun i ->
write_queue_size := if i <= 0 then None else Some i),
" Size of the write queue (0=unbounded)";
"--delay", Set_float delay, " Client execution time.";
"--clients", Set_int clients, " Number of concurrent clients.";
"--hide-clients-stat", Unit (fun () -> display_client_stat := Some false),
" Hide the client bandwidth statistic." ;
"--display_clients_stat", Unit (fun () -> display_client_stat := Some true),
" Display the client bandwidth statistic." ;
]
let () =
let anon_fun num_peers = raise (Arg.Bad "No anonymous argument.") in
let usage_msg = "Usage: %s <num_peers>.\nArguments are:" in
Arg.parse spec anon_fun usage_msg
let () =
Sys.catch_break true ;
Lwt_main.run
(run
?display_client_stat:!display_client_stat
?max_download_speed:!max_download_speed
?max_upload_speed:!max_upload_speed
~read_buffer_size:!read_buffer_size
?read_queue_size:!read_queue_size
?write_queue_size:!write_queue_size
!addr !port !delay !clients)