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

Refactor: Move/split P2p_types into lib_base

Browse Source
This commit is contained in:
Grégoire Henry 2018-01-24 12:48:25 +01:00
parent be9f068478
commit 7277c9889b
79 changed files with 2711 additions and 2651 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
.gitlab-ci.yml
View File

@ -111,15 +111,15 @@ test:p2p:io-scheduler:
script:
- jbuilder build @test/p2p/runtest_p2p_io_scheduler
test:p2p:connection:
test:p2p:socket:
<<: *test_definition
script:
- jbuilder build @test/p2p/runtest_p2p_connection
- jbuilder build @test/p2p/runtest_p2p_socket
test:p2p:connection-pool:
test:p2p:pool:
<<: *test_definition
script:
- jbuilder build @test/p2p/runtest_p2p_connection_pool
- jbuilder build @test/p2p/runtest_p2p_pool
test:proto_alpha:transaction:
<<: *test_definition

2
src/bin_attacker/attacker_minimal.ml
View File

@ -103,7 +103,7 @@ let ballot_forged period prop vote =
operations = [ballot] }) in
forge { net_id = network } op
let identity = P2p_types.Identity.generate Crypto_box.default_target
let identity = P2p_identity.generate Crypto_box.default_target
(* connect to the network, run an action and then disconnect *)
let try_action addr port action =

2
src/bin_node/node_config_file.ml
View File

@ -529,7 +529,7 @@ let update
return { data_dir ; net ; rpc ; log ; shell }
let resolve_addr ?default_port ?(passive = false) peer =
let addr, port = P2p.Point.parse_addr_port peer in
let addr, port = P2p_point.Id.parse_addr_port peer in
let node = if addr = "" || addr = "_" then "::" else addr
and service =
match port, default_port with

6
src/bin_node/node_config_file.mli
View File

@ -80,8 +80,8 @@ val to_string: t -> string
val read: string -> t tzresult Lwt.t
val write: string -> t -> unit tzresult Lwt.t
val resolve_listening_addrs: string -> (P2p_types.addr * int) list Lwt.t
val resolve_rpc_listening_addrs: string -> (P2p_types.addr * int) list Lwt.t
val resolve_bootstrap_addrs: string list -> (P2p_types.addr * int) list Lwt.t
val resolve_listening_addrs: string -> (P2p_addr.t * int) list Lwt.t
val resolve_rpc_listening_addrs: string -> (P2p_addr.t * int) list Lwt.t
val resolve_bootstrap_addrs: string list -> (P2p_addr.t * int) list Lwt.t
val check: t -> unit Lwt.t

8
src/bin_node/node_identity_command.ml
View File

@ -15,7 +15,7 @@ let identity_file data_dir = data_dir // Node_data_version.default_identity_file
let show { Node_config_file.data_dir } =
Node_identity_file.read (identity_file data_dir) >>=? fun id ->
Format.printf "Peer_id: %a.@." P2p_types.Peer_id.pp id.peer_id ;
Format.printf "Peer_id: %a.@." P2p_peer.Id.pp id.peer_id ;
return ()
let generate { Node_config_file.data_dir ; net } =
@ -26,11 +26,11 @@ let generate { Node_config_file.data_dir ; net } =
let target = Crypto_box.make_target net.expected_pow in
Format.eprintf "Generating a new identity... (level: %.2f) " net.expected_pow ;
let id =
P2p.Identity.generate_with_animation Format.err_formatter target in
P2p_identity.generate_with_animation Format.err_formatter target in
Node_identity_file.write identity_file id >>=? fun () ->
Format.eprintf
"Stored the new identity (%a) into '%s'.@."
P2p.Peer_id.pp id.peer_id identity_file ;
P2p_peer.Id.pp id.peer_id identity_file ;
return ()
let check { Node_config_file.data_dir ; net = { expected_pow } } =
@ -38,7 +38,7 @@ let check { Node_config_file.data_dir ; net = { expected_pow } } =
~expected_pow (identity_file data_dir) >>=? fun id ->
Format.printf
"Peer_id: %a. Proof of work is higher than %.2f.@."
P2p_types.Peer_id.pp id.peer_id expected_pow ;
P2p_peer.Id.pp id.peer_id expected_pow ;
return ()
(** Main *)

4
src/bin_node/node_identity_file.ml
View File

@ -47,7 +47,7 @@ let read ?expected_pow file =
fail (No_identity_file file)
| true ->
Data_encoding_ezjsonm.read_file file >>=? fun json ->
let id = Data_encoding.Json.destruct P2p.Identity.encoding json in
let id = Data_encoding.Json.destruct P2p_identity.encoding json in
match expected_pow with
| None -> return id
| Some expected ->
@ -81,4 +81,4 @@ let write file identity =
else
Node_data_version.ensure_data_dir (Filename.dirname file) >>=? fun () ->
Data_encoding_ezjsonm.write_file file
(Data_encoding.Json.construct P2p.Identity.encoding identity)
(Data_encoding.Json.construct P2p_identity.encoding identity)

4
src/bin_node/node_identity_file.mli
View File

@ -12,8 +12,8 @@ type error += Insufficient_proof_of_work of { expected: float }
val read:
?expected_pow:float ->
string -> P2p.Identity.t tzresult Lwt.t
string -> P2p_identity.t tzresult Lwt.t
type error += Existent_identity_file of string
val write: string -> P2p.Identity.t -> unit tzresult Lwt.t
val write: string -> P2p_identity.t -> unit tzresult Lwt.t

10
src/bin_node/node_run_command.ml
View File

@ -20,8 +20,8 @@ let genesis : State.Net.genesis = {
"ProtoGenesisGenesisGenesisGenesisGenesisGenesk612im" ;
}
type error += Non_private_sandbox of P2p_types.addr
type error += RPC_Port_already_in_use of P2p_types.addr
type error += Non_private_sandbox of P2p_addr.t
type error += RPC_Port_already_in_use of P2p_addr.t
let () =
register_error_kind
@ -36,7 +36,7 @@ let () =
See `%s run --help` on how to change the listening address."
Ipaddr.V6.pp_hum addr Sys.argv.(0)
end
Data_encoding.(obj1 (req "addr" P2p_types.addr_encoding))
Data_encoding.(obj1 (req "addr" P2p_addr.encoding))
(function Non_private_sandbox addr -> Some addr | _ -> None)
(fun addr -> Non_private_sandbox addr);
register_error_kind
@ -50,7 +50,7 @@ let () =
Please choose another RPC port."
Ipaddr.V6.pp_hum addr
end
Data_encoding.(obj1 (req "addr" P2p_types.addr_encoding))
Data_encoding.(obj1 (req "addr" P2p_addr.encoding))
(function RPC_Port_already_in_use addr -> Some addr | _ -> None)
(fun addr -> RPC_Port_already_in_use addr)
@ -146,7 +146,7 @@ let init_node ?sandbox (config : Node_config_file.t) =
Node_data_version.default_identity_file_name) >>=? fun identity ->
lwt_log_notice
"Peer's global id: %a"
P2p.Peer_id.pp identity.peer_id >>= fun () ->
P2p_peer.Id.pp identity.peer_id >>= fun () ->
let p2p_config : P2p.config =
{ listening_addr ;
listening_port ;

28
src/lib_base/p2p_addr.ml Normal file
View File

@ -0,0 +1,28 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
type t = Ipaddr.V6.t
let encoding =
let open Data_encoding in
splitted
~json:begin
conv
Ipaddr.V6.to_string
Ipaddr.V6.of_string_exn
string
end
~binary:begin
conv
Ipaddr.V6.to_bytes
Ipaddr.V6.of_bytes_exn
string
end
type port = int

13
src/lib_base/p2p_addr.mli Normal file
View File

@ -0,0 +1,13 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
type t = Ipaddr.V6.t
type port = int
val encoding : t Data_encoding.t

252
src/lib_base/p2p_connection.ml Normal file
View File

@ -0,0 +1,252 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
type peer_id = Crypto_box.Public_key_hash.t
let peer_id_encoding = Crypto_box.Public_key_hash.encoding
let peer_id_pp = Crypto_box.Public_key_hash.pp
module Id = struct
(* A net point (address x port). *)
type t = P2p_addr.t * P2p_addr.port option
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 to_string t = Format.asprintf "%a" pp t
let is_local (addr, _) = Ipaddr.V6.is_private addr
let is_global (addr, _) = not @@ Ipaddr.V6.is_private addr
let of_point (addr, port) = addr, Some port
let to_point = function
| _, None -> None
| addr, Some port -> Some (addr, port)
let to_point_exn = function
| _, None -> invalid_arg "to_point_exn"
| addr, Some port -> addr, port
let encoding =
let open Data_encoding in
(obj2
(req "addr" P2p_addr.encoding)
(opt "port" uint16))
end
module Map = Map.Make (Id)
module Set = Set.Make (Id)
module Table = Hashtbl.Make (Id)
module Info = struct
type t = {
incoming : bool;
peer_id : peer_id;
id_point : Id.t;
remote_socket_port : P2p_addr.port;
versions : P2p_version.t list ;
}
let encoding =
let open Data_encoding in
conv
(fun { incoming ; peer_id ; id_point ; remote_socket_port ; versions } ->
(incoming, peer_id, id_point, remote_socket_port, versions))
(fun (incoming, peer_id, id_point, remote_socket_port, versions) ->
{ incoming ; peer_id ; id_point ; remote_socket_port ; versions })
(obj5
(req "incoming" bool)
(req "peer_id" peer_id_encoding)
(req "id_point" Id.encoding)
(req "remote_socket_port" uint16)
(req "versions" (list P2p_version.encoding)))
let pp ppf
{ incoming ; id_point = (remote_addr, remote_port) ;
remote_socket_port ; peer_id ; versions } =
let version = List.hd versions in
let point = match remote_port with
| None -> remote_addr, remote_socket_port
| Some port -> remote_addr, port in
Format.fprintf ppf "%s %a %a (%a)"
(if incoming then "↘" else "↗")
peer_id_pp peer_id
P2p_point.Id.pp point
P2p_version.pp version
end
module Pool_event = struct
(** Pool-level events *)
type t =
| Too_few_connections
| Too_many_connections
| New_point of P2p_point.Id.t
| New_peer of peer_id
| Gc_points
| Gc_peer_ids
| Incoming_connection of P2p_point.Id.t
| Outgoing_connection of P2p_point.Id.t
| Authentication_failed of P2p_point.Id.t
| Accepting_request of P2p_point.Id.t * Id.t * peer_id
| Rejecting_request of P2p_point.Id.t * Id.t * peer_id
| Request_rejected of P2p_point.Id.t * (Id.t * peer_id) option
| Connection_established of Id.t * peer_id
| Swap_request_received of { source : peer_id }
| Swap_ack_received of { source : peer_id }
| Swap_request_sent of { source : peer_id }
| Swap_ack_sent of { source : peer_id }
| Swap_request_ignored of { source : peer_id }
| Swap_success of { source : peer_id }
| Swap_failure of { source : peer_id }
| Disconnection of peer_id
| External_disconnection of peer_id
let encoding =
let open Data_encoding in
let branch_encoding name obj =
conv (fun x -> (), x) (fun ((), x) -> x)
(merge_objs
(obj1 (req "event" (constant name))) obj) in
union ~tag_size:`Uint8 [
case (Tag 0) (branch_encoding "too_few_connections" empty)
(function Too_few_connections -> Some () | _ -> None)
(fun () -> Too_few_connections) ;
case (Tag 1) (branch_encoding "too_many_connections" empty)
(function Too_many_connections -> Some () | _ -> None)
(fun () -> Too_many_connections) ;
case (Tag 2) (branch_encoding "new_point"
(obj1 (req "point" P2p_point.Id.encoding)))
(function New_point p -> Some p | _ -> None)
(fun p -> New_point p) ;
case (Tag 3) (branch_encoding "new_peer"
(obj1 (req "peer_id" peer_id_encoding)))
(function New_peer p -> Some p | _ -> None)
(fun p -> New_peer p) ;
case (Tag 4) (branch_encoding "incoming_connection"
(obj1 (req "point" P2p_point.Id.encoding)))
(function Incoming_connection p -> Some p | _ -> None)
(fun p -> Incoming_connection p) ;
case (Tag 5) (branch_encoding "outgoing_connection"
(obj1 (req "point" P2p_point.Id.encoding)))
(function Outgoing_connection p -> Some p | _ -> None)
(fun p -> Outgoing_connection p) ;
case (Tag 6) (branch_encoding "authentication_failed"
(obj1 (req "point" P2p_point.Id.encoding)))
(function Authentication_failed p -> Some p | _ -> None)
(fun p -> Authentication_failed p) ;
case (Tag 7) (branch_encoding "accepting_request"
(obj3
(req "point" P2p_point.Id.encoding)
(req "id_point" Id.encoding)
(req "peer_id" peer_id_encoding)))
(function Accepting_request (p, id_p, g) ->
Some (p, id_p, g) | _ -> None)
(fun (p, id_p, g) -> Accepting_request (p, id_p, g)) ;
case (Tag 8) (branch_encoding "rejecting_request"
(obj3
(req "point" P2p_point.Id.encoding)
(req "id_point" Id.encoding)
(req "peer_id" peer_id_encoding)))
(function Rejecting_request (p, id_p, g) ->
Some (p, id_p, g) | _ -> None)
(fun (p, id_p, g) -> Rejecting_request (p, id_p, g)) ;
case (Tag 9) (branch_encoding "request_rejected"
(obj2
(req "point" P2p_point.Id.encoding)
(opt "identity"
(tup2 Id.encoding peer_id_encoding))))
(function Request_rejected (p, id) -> Some (p, id) | _ -> None)
(fun (p, id) -> Request_rejected (p, id)) ;
case (Tag 10) (branch_encoding "connection_established"
(obj2
(req "id_point" Id.encoding)
(req "peer_id" peer_id_encoding)))
(function Connection_established (id_p, g) ->
Some (id_p, g) | _ -> None)
(fun (id_p, g) -> Connection_established (id_p, g)) ;
case (Tag 11) (branch_encoding "disconnection"
(obj1 (req "peer_id" peer_id_encoding)))
(function Disconnection g -> Some g | _ -> None)
(fun g -> Disconnection g) ;
case (Tag 12) (branch_encoding "external_disconnection"
(obj1 (req "peer_id" peer_id_encoding)))
(function External_disconnection g -> Some g | _ -> None)
(fun g -> External_disconnection g) ;
case (Tag 13) (branch_encoding "gc_points" empty)
(function Gc_points -> Some () | _ -> None)
(fun () -> Gc_points) ;
case (Tag 14) (branch_encoding "gc_peer_ids" empty)
(function Gc_peer_ids -> Some () | _ -> None)
(fun () -> Gc_peer_ids) ;
case (Tag 15) (branch_encoding "swap_request_received"
(obj1 (req "source" peer_id_encoding)))
(function
| Swap_request_received { source } -> Some source
| _ -> None)
(fun source -> Swap_request_received { source }) ;
case (Tag 16) (branch_encoding "swap_ack_received"
(obj1 (req "source" peer_id_encoding)))
(function
| Swap_ack_received { source } -> Some source
| _ -> None)
(fun source -> Swap_ack_received { source }) ;
case (Tag 17) (branch_encoding "swap_request_sent"
(obj1 (req "source" peer_id_encoding)))
(function
| Swap_request_sent { source } -> Some source
| _ -> None)
(fun source -> Swap_request_sent { source }) ;
case (Tag 18) (branch_encoding "swap_ack_sent"
(obj1 (req "source" peer_id_encoding)))
(function
| Swap_ack_sent { source } -> Some source
| _ -> None)
(fun source -> Swap_ack_sent { source }) ;
case (Tag 19) (branch_encoding "swap_request_ignored"
(obj1 (req "source" peer_id_encoding)))
(function
| Swap_request_ignored { source } -> Some source
| _ -> None)
(fun source -> Swap_request_ignored { source }) ;
case (Tag 20) (branch_encoding "swap_success"
(obj1 (req "source" peer_id_encoding)))
(function
| Swap_success { source } -> Some source
| _ -> None)
(fun source -> Swap_success { source }) ;
case (Tag 21) (branch_encoding "swap_failure"
(obj1 (req "source" peer_id_encoding)))
(function
| Swap_failure { source } -> Some source
| _ -> None)
(fun source -> Swap_failure { source }) ;
]
end

107
src/lib_base/p2p_connection.mli Normal file
View File

@ -0,0 +1,107 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
type peer_id = Crypto_box.Public_key_hash.t
(* = P2p_peer.Id.t, but we should break cycles *)
module Id : sig
type t = P2p_addr.t * P2p_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 to_string : t -> string
val encoding : t Data_encoding.t
val is_local : t -> bool
val is_global : t -> bool
val of_point : P2p_point.Id.t -> t
val to_point : t -> P2p_point.Id.t option
val to_point_exn : t -> P2p_point.Id.t
end
module Map : Map.S with type key = Id.t
module Set : Set.S with type elt = Id.t
module Table : Hashtbl.S with type key = Id.t
(** Information about a connection *)
module Info : sig
type t = {
incoming : bool;
peer_id : peer_id;
id_point : Id.t;
remote_socket_port : P2p_addr.port;
versions : P2p_version.t list ;
}
val pp : Format.formatter -> t -> unit
val encoding : t Data_encoding.t
end
module Pool_event : sig
type t =
| Too_few_connections
| Too_many_connections
| New_point of P2p_point.Id.t
| New_peer of peer_id
| Gc_points
(** Garbage collection of known point table has been triggered. *)
| Gc_peer_ids
(** Garbage collection of known peer_ids table has been triggered. *)
(* Connection-level events *)
| Incoming_connection of P2p_point.Id.t
(** We accept(2)-ed an incoming connection *)
| Outgoing_connection of P2p_point.Id.t
(** We connect(2)-ed to a remote endpoint *)
| Authentication_failed of P2p_point.Id.t
(** Remote point failed authentication *)
| Accepting_request of P2p_point.Id.t * Id.t * peer_id
(** We accepted a connection after authentifying the remote peer. *)
| Rejecting_request of P2p_point.Id.t * Id.t * peer_id
(** We rejected a connection after authentifying the remote peer. *)
| Request_rejected of P2p_point.Id.t * (Id.t * peer_id) option
(** The remote peer rejected our connection. *)
| Connection_established of Id.t * peer_id
(** We succesfully established a authentified connection. *)
| Swap_request_received of { source : peer_id }
(** A swap request has been received. *)
| Swap_ack_received of { source : peer_id }
(** A swap ack has been received *)
| Swap_request_sent of { source : peer_id }
(** A swap request has been sent *)
| Swap_ack_sent of { source : peer_id }
(** A swap ack has been sent *)
| Swap_request_ignored of { source : peer_id }
(** A swap request has been ignored *)
| Swap_success of { source : peer_id }
(** A swap operation has succeeded *)
| Swap_failure of { source : peer_id }
(** A swap operation has failed *)
| Disconnection of peer_id
(** We decided to close the connection. *)
| External_disconnection of peer_id
(** The connection was closed for external reason. *)
val encoding : t Data_encoding.t
end

9
src/lib_base/p2p_connection_id.ml Normal file
View File

@ -0,0 +1,9 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)

11
src/lib_base/p2p_connection_id.mli Normal file
View File

@ -0,0 +1,11 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
(** P2p_point representing a reachable socket address *)

0
src/lib_base/p2p_id_point.ml Normal file
View File

9
src/lib_base/p2p_id_point.mli Normal file
View File

@ -0,0 +1,9 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)

77
src/lib_base/p2p_identity.ml Normal file
View File

@ -0,0 +1,77 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
type t = {
peer_id : P2p_peer.Id.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 peer_id = Tezos_crypto.Crypto_box.hash public_key in
{ peer_id ; 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 ?max target =
let secret_key, public_key, peer_id = Crypto_box.random_keypair () in
let proof_of_work_stamp =
Crypto_box.generate_proof_of_work ?max public_key target in
{ peer_id ; public_key ; secret_key ; proof_of_work_stamp }
let animation = [|
"|.....|" ;
"|o....|" ;
"|oo...|" ;
"|ooo..|" ;
"|.ooo.|" ;
"|..ooo|" ;
"|...oo|" ;
"|....o|" ;
"|.....|" ;
"|.....|" ;
"|.....|" ;
"|.....|" ;
|]
let init = String.make (String.length animation.(0)) '\ '
let clean = String.make (String.length animation.(0)) '\b'
let animation = Array.map (fun x -> clean ^ x) animation
let animation_size = Array.length animation
let duration = 1200 / animation_size
let generate_with_animation ppf target =
Format.fprintf ppf "%s%!" init ;
let count = ref 10000 in
let rec loop n =
let start = Mtime_clock.counter () in
Format.fprintf ppf "%s%!" animation.(n mod animation_size);
try generate ~max:!count target
with Not_found ->
let time = Mtime.Span.to_ms (Mtime_clock.count start) in
count :=
if time <= 0. then
!count * 10
else
!count * duration / int_of_float time ;
loop (n+1)
in
let id = loop 0 in
Format.fprintf ppf "%s%s\n%!" clean init ;
id
let generate target = generate target

29
src/lib_base/p2p_identity.mli Normal file
View File

@ -0,0 +1,29 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
type t = {
peer_id : P2p_peer.Id.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 peer_id, 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]. *)
val generate_with_animation :
Format.formatter -> Crypto_box.target -> t
(** [generate_with_animation ppf target] is a freshly minted identity
whose proof of work stamp difficulty is at least equal to [target]. *)

339
src/lib_base/p2p_peer.ml Normal file
View File

@ -0,0 +1,339 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
open Error_monad
module Id = Tezos_crypto.Crypto_box.Public_key_hash
module Table = Id.Table
module Map = Id.Map
module Set = Id.Set
module State = struct
type t =
| Accepted
| Running
| Disconnected
let pp_digram ppf = function
| Accepted -> Format.fprintf ppf "⚎"
| Running -> Format.fprintf ppf "⚌"
| Disconnected -> Format.fprintf ppf "⚏"
let encoding =
let open Data_encoding in
string_enum [
"accepted", Accepted ;
"running", Running ;
"disconnected", Disconnected ;
]
end
module Info = struct
type t = {
score : float ;
trusted : bool ;
state : State.t ;
id_point : P2p_connection.Id.t option ;
stat : P2p_stat.t ;
last_failed_connection : (P2p_connection.Id.t * Time.t) option ;
last_rejected_connection : (P2p_connection.Id.t * Time.t) option ;
last_established_connection : (P2p_connection.Id.t * Time.t) option ;
last_disconnection : (P2p_connection.Id.t * Time.t) option ;
last_seen : (P2p_connection.Id.t * Time.t) option ;
last_miss : (P2p_connection.Id.t * Time.t) option ;
}
let encoding =
let open Data_encoding in
conv
(fun (
{ score ; trusted ; state ; id_point ; stat ;
last_failed_connection ; last_rejected_connection ;
last_established_connection ; last_disconnection ;
last_seen ; last_miss }) ->
((score, trusted, state, id_point, stat),
(last_failed_connection, last_rejected_connection,
last_established_connection, last_disconnection,
last_seen, last_miss)))
(fun ((score, trusted, state, id_point, stat),
(last_failed_connection, last_rejected_connection,
last_established_connection, last_disconnection,
last_seen, last_miss)) ->
{ score ; trusted ; state ; id_point ; stat ;
last_failed_connection ; last_rejected_connection ;
last_established_connection ; last_disconnection ;
last_seen ; last_miss })
(merge_objs
(obj5
(req "score" float)
(req "trusted" bool)
(req "state" State.encoding)
(opt "reachable_at" P2p_connection.Id.encoding)
(req "stat" P2p_stat.encoding))
(obj6
(opt "last_failed_connection" (tup2 P2p_connection.Id.encoding Time.encoding))
(opt "last_rejected_connection" (tup2 P2p_connection.Id.encoding Time.encoding))
(opt "last_established_connection" (tup2 P2p_connection.Id.encoding Time.encoding))
(opt "last_disconnection" (tup2 P2p_connection.Id.encoding Time.encoding))
(opt "last_seen" (tup2 P2p_connection.Id.encoding Time.encoding))
(opt "last_miss" (tup2 P2p_connection.Id.encoding Time.encoding))))
end
module Event = struct
type kind =
| Accepting_request
| Rejecting_request
| Request_rejected
| Connection_established
| Disconnection
| External_disconnection
let kind_encoding =
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 : P2p_connection.Id.t ;
}
let encoding =
let open Data_encoding in
conv
(fun { kind ; timestamp ; point = (addr, port) } ->
(kind, timestamp, addr, port))
(fun (kind, timestamp, addr, port) ->
{ kind ; timestamp ; point = (addr, port) })
(obj4
(req "kind" kind_encoding)
(req "timestamp" Time.encoding)
(req "addr" P2p_addr.encoding)
(opt "port" int16))
end
module Pool_info = struct
type 'data state =
| Accepted of { current_point: P2p_connection.Id.t ;
cancel: Lwt_canceler.t }
| Running of { data: 'data ;
current_point: P2p_connection.Id.t }
| Disconnected
type ('conn, 'meta) t = {
peer_id : Id.t ;
created : Time.t ;
mutable state : 'conn state ;
mutable metadata : 'meta ;
mutable trusted : bool ;
mutable last_failed_connection : (P2p_connection.Id.t * Time.t) option ;
mutable last_rejected_connection : (P2p_connection.Id.t * Time.t) option ;
mutable last_established_connection : (P2p_connection.Id.t * Time.t) option ;
mutable last_disconnection : (P2p_connection.Id.t * Time.t) option ;
events : Event.t Ring.t ;
watchers : Event.t Lwt_watcher.input ;
}
type ('conn, 'meta) peer_info = ('conn, 'meta) t
let compare gi1 gi2 = Id.compare gi1.peer_id gi2.peer_id
let log_size = 100
let create ?(created = Time.now ()) ?(trusted = false) ~metadata peer_id =
{ peer_id ;
created ;
state = Disconnected ;
metadata ;
trusted ;
last_failed_connection = None ;
last_rejected_connection = None ;
last_established_connection = None ;
last_disconnection = None ;
events = Ring.create log_size ;
watchers = Lwt_watcher.create_input () ;
}
let encoding metadata_encoding =
let open Data_encoding in
conv
(fun { peer_id ; trusted ; metadata ; events ; created ;
last_failed_connection ; last_rejected_connection ;
last_established_connection ; last_disconnection ; _ } ->
(peer_id, created, trusted, metadata, Ring.elements events,
last_failed_connection, last_rejected_connection,
last_established_connection, last_disconnection))
(fun (peer_id, created, trusted, metadata, event_list,
last_failed_connection, last_rejected_connection,
last_established_connection, last_disconnection) ->
let info = create ~trusted ~metadata peer_id in
let events = Ring.create log_size in
Ring.add_list info.events event_list ;
{ state = Disconnected ;
trusted ; peer_id ; metadata ; created ;
last_failed_connection ;
last_rejected_connection ;
last_established_connection ;
last_disconnection ;
events ;
watchers = Lwt_watcher.create_input () ;
})
(obj9
(req "peer_id" Id.encoding)
(req "created" Time.encoding)
(dft "trusted" bool false)
(req "metadata" metadata_encoding)
(dft "events" (list Event.encoding) [])
(opt "last_failed_connection"
(tup2 P2p_connection.Id.encoding Time.encoding))
(opt "last_rejected_connection"
(tup2 P2p_connection.Id.encoding Time.encoding))
(opt "last_established_connection"
(tup2 P2p_connection.Id.encoding Time.encoding))
(opt "last_disconnection"
(tup2 P2p_connection.Id.encoding Time.encoding)))
let peer_id { peer_id ; _ } = peer_id
let created { created ; _ } = created
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 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 last_seen s =
Time.recent
s.last_established_connection
(Time.recent s.last_rejected_connection s.last_disconnection)
let last_miss s =
Time.recent
s.last_failed_connection
(Time.recent s.last_rejected_connection s.last_disconnection)
let log { events ; watchers ; _ } ?(timestamp = Time.now ()) point kind =
let event = { Event.kind ; timestamp ; point } in
Ring.add events event ;
Lwt_watcher.notify watchers event
let log_incoming_rejection ?timestamp peer_info point =
log peer_info ?timestamp point Rejecting_request
module File = struct
let load path metadata_encoding =
let enc = Data_encoding.list (encoding metadata_encoding) in
if path <> "/dev/null" && Sys.file_exists path then
Data_encoding_ezjsonm.read_file path >>=? fun json ->
return (Data_encoding.Json.destruct enc json)
else
return []
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
module Pool_event = struct
include Event
let watch { Pool_info.watchers ; _ } = Lwt_watcher.create_stream watchers
let fold { Pool_info.events ; _ } ~init ~f = Ring.fold events ~init ~f
end
module Pool_state = struct
type 'data t = 'data Pool_info.state =
| Accepted of { current_point: P2p_connection.Id.t ;
cancel: Lwt_canceler.t }
| Running of { data: 'data ;
current_point: P2p_connection.Id.t }
| Disconnected
type 'data state = 'data t
let pp ppf = function
| Accepted { current_point ; _ } ->
Format.fprintf ppf "accepted %a" P2p_connection.Id.pp current_point
| Running { current_point ; _ } ->
Format.fprintf ppf "running %a" P2p_connection.Id.pp current_point
| Disconnected ->
Format.fprintf ppf "disconnected"
let get { Pool_info.state ; _ } = state
let is_disconnected { Pool_info.state ; _ } =
match state with
| Disconnected -> true
| Accepted _ | Running _ -> false
let set_accepted
?(timestamp = Time.now ())
peer_info current_point cancel =
assert begin
match peer_info.Pool_info.state with
| Accepted _ | Running _ -> false
| Disconnected -> true
end ;
peer_info.state <- Accepted { current_point ; cancel } ;
Pool_info.log peer_info ~timestamp current_point Accepting_request
let set_running
?(timestamp = Time.now ())
peer_info point data =
assert begin
match peer_info.Pool_info.state with
| Disconnected -> true (* request to unknown peer_id. *)
| Running _ -> false
| Accepted { current_point ; _ } ->
P2p_connection.Id.equal point current_point
end ;
peer_info.state <- Running { data ; current_point = point } ;
peer_info.last_established_connection <- Some (point, timestamp) ;
Pool_info.log peer_info ~timestamp point Connection_established
let set_disconnected
?(timestamp = Time.now ()) ?(requested = false) peer_info =
let current_point, (event : Event.kind) =
match peer_info.Pool_info.state with
| Accepted { current_point ; _ } ->
peer_info.last_rejected_connection <-
Some (current_point, timestamp) ;
current_point, Request_rejected
| Running { current_point ; _ } ->
peer_info.last_disconnection <-
Some (current_point, timestamp) ;
current_point,
if requested then Disconnection else External_disconnection
| Disconnected -> assert false
in
peer_info.state <- Disconnected ;
Pool_info.log peer_info ~timestamp current_point event
end

184
src/lib_base/p2p_peer.mli Normal file
View File

@ -0,0 +1,184 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
open Error_monad
module Id = Tezos_crypto.Crypto_box.Public_key_hash
module Map = Id.Map
module Set = Id.Set
module Table = Id.Table
module State : sig
type t =
| Accepted
| Running
| Disconnected
val pp_digram : Format.formatter -> t -> unit
val encoding : t Data_encoding.t
end
module Info : sig
type t = {
score : float ;
trusted : bool ;
state : State.t ;
id_point : P2p_connection.Id.t option ;
stat : P2p_stat.t ;
last_failed_connection : (P2p_connection.Id.t * Time.t) option ;
last_rejected_connection : (P2p_connection.Id.t * Time.t) option ;
last_established_connection : (P2p_connection.Id.t * Time.t) option ;
last_disconnection : (P2p_connection.Id.t * Time.t) option ;
last_seen : (P2p_connection.Id.t * Time.t) option ;
last_miss : (P2p_connection.Id.t * Time.t) option ;
}
val encoding : t Data_encoding.t
end
(** P2p_peer.Id info: current and historical information about a peer_id *)
module Pool_info : sig
type ('conn, 'meta) t
type ('conn, 'meta) peer_info = ('conn, 'meta) t
val compare : ('conn, 'meta) t -> ('conn, 'meta) t -> int
val create :
?created:Time.t ->
?trusted:bool ->
metadata:'meta ->
Id.t -> ('conn, 'meta) peer_info
(** [create ~trusted ~meta peer_id] is a freshly minted peer_id info for
[peer_id]. *)
val peer_id : ('conn, 'meta) peer_info -> Id.t
val created : ('conn, 'meta) peer_info -> Time.t
val metadata : ('conn, 'meta) peer_info -> 'meta
val set_metadata : ('conn, 'meta) peer_info -> 'meta -> unit
val trusted : ('conn, 'meta) peer_info -> bool
val set_trusted : ('conn, 'meta) peer_info -> unit
val unset_trusted : ('conn, 'meta) peer_info -> unit
val last_failed_connection :
('conn, 'meta) peer_info -> (P2p_connection.Id.t * Time.t) option
val last_rejected_connection :
('conn, 'meta) peer_info -> (P2p_connection.Id.t * Time.t) option
val last_established_connection :
('conn, 'meta) peer_info -> (P2p_connection.Id.t * Time.t) option
val last_disconnection :
('conn, 'meta) peer_info -> (P2p_connection.Id.t * Time.t) option
val last_seen :
('conn, 'meta) peer_info -> (P2p_connection.Id.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) peer_info -> (P2p_connection.Id.t * Time.t) option
(** [last_miss gi] is the most recent of:
* last failed connection
* last rejected connection
* last disconnection
*)
val log_incoming_rejection :
?timestamp:Time.t ->
('conn, 'meta) peer_info -> P2p_connection.Id.t -> unit
module File : sig
val load :
string -> 'meta Data_encoding.t ->
('conn, 'meta) peer_info list tzresult Lwt.t
val save :
string -> 'meta Data_encoding.t ->
('conn, 'meta) peer_info list -> unit tzresult Lwt.t
end
end
module Pool_state : sig
type 'conn t =
| Accepted of { current_point: P2p_connection.Id.t ;
cancel: Lwt_canceler.t }
(** We accepted a incoming connection, we greeted back and
we are waiting for an acknowledgement. *)
| Running of { data: 'conn ;
current_point: P2p_connection.Id.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) Pool_info.t -> 'conn state
val is_disconnected : ('conn, 'meta) Pool_info.t -> bool
val set_accepted :
?timestamp:Time.t ->
('conn, 'meta) Pool_info.t -> P2p_connection.Id.t -> Lwt_canceler.t -> unit
val set_running :
?timestamp:Time.t ->
('conn, 'meta) Pool_info.t -> P2p_connection.Id.t -> 'conn -> unit
val set_disconnected :
?timestamp:Time.t ->
?requested:bool ->
('conn, 'meta) Pool_info.t -> unit
end
module Pool_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 : P2p_connection.Id.t ;
}
val encoding : t Data_encoding.t
val fold :
('conn, 'meta) Pool_info.t -> init:'a -> f:('a -> t -> 'a) -> 'a
val watch :
('conn, 'meta) Pool_info.t -> t Lwt_stream.t * Lwt_watcher.stopper
end

477
src/lib_base/p2p_point.ml Normal file
View File

@ -0,0 +1,477 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
type peer_id = Crypto_box.Public_key_hash.t
let peer_id_encoding = Crypto_box.Public_key_hash.encoding
let peer_id_pp = Crypto_box.Public_key_hash.pp
let peer_id_equal = Crypto_box.Public_key_hash.equal
module Id = struct
(* A net point (address x port). *)
type t = P2p_addr.t * P2p_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) =
match Ipaddr.v4_of_v6 addr with
| Some addr ->
Format.fprintf ppf "%a:%d" Ipaddr.V4.pp_hum addr port
| None ->
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 check_port port =
if TzString.mem_char port '[' ||
TzString.mem_char port ']' ||
TzString.mem_char port ':' then
invalid_arg "Utils.parse_addr_port (invalid character in port)"
let parse_addr_port s =
let len = String.length s in
if len = 0 then
("", "")
else if s.[0] = '[' then begin (* inline IPv6 *)
match String.rindex s ']' with
| exception Not_found ->
invalid_arg "Utils.parse_addr_port (missing ']')"
| pos ->
let addr = String.sub s 1 (pos - 1) in
let port =
if pos = len - 1 then
""
else if s.[pos+1] <> ':' then
invalid_arg "Utils.parse_addr_port (unexpected char after ']')"
else
String.sub s (pos + 2) (len - pos - 2) in
check_port port ;
addr, port
end else begin
match String.rindex s ']' with
| _pos ->
invalid_arg "Utils.parse_addr_port (unexpected char ']')"
| exception Not_found ->
match String.index s ':' with
| exception _ -> s, ""
| pos ->
match String.index_from s (pos+1) ':' with
| exception _ ->
let addr = String.sub s 0 pos in
let port = String.sub s (pos + 1) (len - pos - 1) in
check_port port ;
addr, port
| _pos ->
invalid_arg "Utils.parse_addr_port: IPv6 addresses must be bracketed"
end
let of_string_exn str =
let addr, port = parse_addr_port str in
let port = int_of_string port in
if port < 0 && port > 1 lsl 16 - 1 then
invalid_arg "port must be between 0 and 65535" ;
match Ipaddr.of_string_exn addr with
| V4 addr -> Ipaddr.v6_of_v4 addr, port
| V6 addr -> addr, port
let of_string str =
try Ok (of_string_exn str) with
| Invalid_argument s -> Error s
| Failure s -> Error s
| _ -> Error "P2p_point.of_string"
let to_string saddr = Format.asprintf "%a" pp saddr
let encoding =
Data_encoding.conv to_string of_string_exn Data_encoding.string
end
module Map = Map.Make (Id)
module Set = Set.Make (Id)
module Table = Hashtbl.Make (Id)
module State = struct
type t =
| Requested
| Accepted of peer_id
| Running of peer_id
| Disconnected
let of_peer_id = function
| Requested -> None
| Accepted pi -> Some pi
| Running pi -> Some pi
| Disconnected -> None
let of_peerid_state state pi =
match state, pi with
| Requested, _ -> Requested
| Accepted _, Some pi -> Accepted pi
| Running _, Some pi -> Running pi
| Disconnected, _ -> Disconnected
| _ -> invalid_arg "state_of_state_peerid"
let pp_digram ppf = function
| Requested -> Format.fprintf ppf "⚎"
| Accepted _ -> Format.fprintf ppf "⚍"
| Running _ -> Format.fprintf ppf "⚌"
| Disconnected -> Format.fprintf ppf "⚏"
let encoding =
let open Data_encoding in
let branch_encoding name obj =
conv (fun x -> (), x) (fun ((), x) -> x)
(merge_objs
(obj1 (req "event_kind" (constant name))) obj) in
union ~tag_size:`Uint8 [
case (Tag 0) (branch_encoding "requested" empty)
(function Requested -> Some () | _ -> None)
(fun () -> Requested) ;
case (Tag 1) (branch_encoding "accepted"
(obj1 (req "peer_id" peer_id_encoding)))
(function Accepted peer_id -> Some peer_id | _ -> None)
(fun peer_id -> Accepted peer_id) ;
case (Tag 2) (branch_encoding "running"
(obj1 (req "peer_id" peer_id_encoding)))
(function Running peer_id -> Some peer_id | _ -> None)
(fun peer_id -> Running peer_id) ;
case (Tag 3) (branch_encoding "disconnected" empty)
(function Disconnected -> Some () | _ -> None)
(fun () -> Disconnected) ;
]
end
module Info = struct
type t = {
trusted : bool ;
greylisted_until : Time.t ;
state : State.t ;
last_failed_connection : Time.t option ;
last_rejected_connection : (peer_id * Time.t) option ;
last_established_connection : (peer_id * Time.t) option ;
last_disconnection : (peer_id * Time.t) option ;
last_seen : (peer_id * Time.t) option ;
last_miss : Time.t option ;
}
let encoding =
let open Data_encoding in
conv
(fun { trusted ; greylisted_until ; state ;
last_failed_connection ; last_rejected_connection ;
last_established_connection ; last_disconnection ;
last_seen ; last_miss } ->
let peer_id = State.of_peer_id state in
(trusted, greylisted_until, state, peer_id,
last_failed_connection, last_rejected_connection,
last_established_connection, last_disconnection,
last_seen, last_miss))
(fun (trusted, greylisted_until, state, peer_id,
last_failed_connection, last_rejected_connection,
last_established_connection, last_disconnection,
last_seen, last_miss) ->
let state = State.of_peerid_state state peer_id in
{ trusted ; greylisted_until ; state ;
last_failed_connection ; last_rejected_connection ;
last_established_connection ; last_disconnection ;
last_seen ; last_miss })
(obj10
(req "trusted" bool)
(dft "greylisted_until" Time.encoding Time.epoch)
(req "state" State.encoding)
(opt "peer_id" peer_id_encoding)
(opt "last_failed_connection" Time.encoding)
(opt "last_rejected_connection" (tup2 peer_id_encoding Time.encoding))
(opt "last_established_connection" (tup2 peer_id_encoding Time.encoding))
(opt "last_disconnection" (tup2 peer_id_encoding Time.encoding))
(opt "last_seen" (tup2 peer_id_encoding Time.encoding))
(opt "last_miss" Time.encoding))
end
module Event = struct
type kind =
| Outgoing_request
| Accepting_request of peer_id
| Rejecting_request of peer_id
| Request_rejected of peer_id option
| Connection_established of peer_id
| Disconnection of peer_id
| External_disconnection of peer_id
let kind_encoding =
let open Data_encoding in
let branch_encoding name obj =
conv (fun x -> (), x) (fun ((), x) -> x)
(merge_objs
(obj1 (req "event_kind" (constant name))) obj) in
union ~tag_size:`Uint8 [
case (Tag 0) (branch_encoding "outgoing_request" empty)
(function Outgoing_request -> Some () | _ -> None)
(fun () -> Outgoing_request) ;
case (Tag 1) (branch_encoding "accepting_request"
(obj1 (req "peer_id" peer_id_encoding)))
(function Accepting_request peer_id -> Some peer_id | _ -> None)
(fun peer_id -> Accepting_request peer_id) ;
case (Tag 2) (branch_encoding "rejecting_request"
(obj1 (req "peer_id" peer_id_encoding)))
(function Rejecting_request peer_id -> Some peer_id | _ -> None)
(fun peer_id -> Rejecting_request peer_id) ;
case (Tag 3) (branch_encoding "request_rejected"
(obj1 (opt "peer_id" peer_id_encoding)))
(function Request_rejected peer_id -> Some peer_id | _ -> None)
(fun peer_id -> Request_rejected peer_id) ;
case (Tag 4) (branch_encoding "rejecting_request"
(obj1 (req "peer_id" peer_id_encoding)))
(function Connection_established peer_id -> Some peer_id | _ -> None)
(fun peer_id -> Connection_established peer_id) ;
case (Tag 5) (branch_encoding "rejecting_request"
(obj1 (req "peer_id" peer_id_encoding)))
(function Disconnection peer_id -> Some peer_id | _ -> None)
(fun peer_id -> Disconnection peer_id) ;
case (Tag 6) (branch_encoding "rejecting_request"
(obj1 (req "peer_id" peer_id_encoding)))
(function External_disconnection peer_id -> Some peer_id | _ -> None)
(fun peer_id -> External_disconnection peer_id) ;
]
type t = {
kind : kind ;
timestamp : Time.t ;
}
let encoding =
let open Data_encoding in
conv
(fun { kind ; timestamp ; } -> (kind, timestamp))
(fun (kind, timestamp) -> { kind ; timestamp ; })
(obj2
(req "kind" kind_encoding)
(req "timestamp" Time.encoding))
end
module Pool_info = struct
type 'data state =
| Requested of { cancel: Lwt_canceler.t }
| Accepted of { current_peer_id: peer_id ;
cancel: Lwt_canceler.t }
| Running of { data: 'data ;
current_peer_id: peer_id }
| Disconnected
type greylisting_config = {
factor: float ;
initial_delay: int ;
disconnection_delay: int ;
}
type 'data t = {
point : Id.t ;
mutable trusted : bool ;
mutable state : 'data state ;
mutable last_failed_connection : Time.t option ;
mutable last_rejected_connection : (peer_id * Time.t) option ;
mutable last_established_connection : (peer_id * Time.t) option ;
mutable last_disconnection : (peer_id * Time.t) option ;
greylisting : greylisting_config ;
mutable greylisting_delay : float ;
mutable greylisting_end : Time.t ;
events : Event.t Ring.t ;
watchers : Event.t Lwt_watcher.input ;
}
type 'data point_info = 'data t
let compare pi1 pi2 = Id.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.epoch ;
watchers = Lwt_watcher.create_input () ;
}
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 greylisted_until s = s.greylisting_end
let last_seen s =
Time.recent s.last_rejected_connection
(Time.recent s.last_established_connection s.last_disconnection)
let last_miss s =
match
s.last_failed_connection,
(Option.map ~f:(fun (_, time) -> 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 log { events ; watchers ; _ } ?(timestamp = Time.now ()) kind =
let event = { Event.kind ; timestamp } in
Ring.add events event ;
Lwt_watcher.notify watchers event
let log_incoming_rejection ?timestamp point_info peer_id =
log point_info ?timestamp (Rejecting_request peer_id)
end
module Pool_event = struct
include Event
let fold { Pool_info.events ; _ } ~init ~f = Ring.fold events ~init ~f
let watch { Pool_info.watchers ; _ } = Lwt_watcher.create_stream watchers
end
module Pool_state = struct
type 'data t = 'data Pool_info.state =
| Requested of { cancel: Lwt_canceler.t }
| Accepted of { current_peer_id: peer_id ;
cancel: Lwt_canceler.t }
| Running of { data: 'data ;
current_peer_id: peer_id }
| Disconnected
type 'data state = 'data t
let pp ppf = function
| Requested _ ->
Format.fprintf ppf "requested"
| Accepted { current_peer_id ; _ } ->
Format.fprintf ppf "accepted %a" peer_id_pp current_peer_id
| Running { current_peer_id ; _ } ->
Format.fprintf ppf "running %a" peer_id_pp current_peer_id
| Disconnected ->
Format.fprintf ppf "disconnected"
let get { Pool_info.state ; _ } = state
let is_disconnected { Pool_info.state ; _ } =
match state with
| Disconnected -> true
| Requested _ | Accepted _ | Running _ -> false
let set_requested ?timestamp point_info cancel =
assert begin
match point_info.Pool_info.state with
| Requested _ -> true
| Accepted _ | Running _ -> false
| Disconnected -> true
end ;
point_info.state <- Requested { cancel } ;
Pool_info.log point_info ?timestamp Outgoing_request
let set_accepted
?(timestamp = Time.now ())
point_info current_peer_id cancel =
(* log_notice "SET_ACCEPTED %a@." P2p_point.pp point_info.point ; *)
assert begin
match point_info.Pool_info.state with
| Accepted _ | Running _ -> false
| Requested _ | Disconnected -> true
end ;
point_info.state <- Accepted { current_peer_id ; cancel } ;
Pool_info.log point_info ~timestamp (Accepting_request current_peer_id)
let set_running
?(timestamp = Time.now ())
point_info peer_id data =
assert begin
match point_info.Pool_info.state with
| Disconnected -> true (* request to unknown peer_id. *)
| Running _ -> false
| Accepted { current_peer_id ; _ } -> peer_id_equal peer_id current_peer_id
| Requested _ -> true
end ;
point_info.state <- Running { data ; current_peer_id = peer_id } ;
point_info.last_established_connection <- Some (peer_id, timestamp) ;
Pool_info.log point_info ~timestamp (Connection_established peer_id)
let set_greylisted timestamp point_info =
point_info.Pool_info.greylisting_end <-
Time.add
timestamp
(Int64.of_float point_info.Pool_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.Pool_info.state with
| Requested _ ->
set_greylisted timestamp point_info ;
point_info.last_failed_connection <- Some timestamp ;
Request_rejected None
| Accepted { current_peer_id ; _ } ->
set_greylisted timestamp point_info ;
point_info.last_rejected_connection <-
Some (current_peer_id, timestamp) ;
Request_rejected (Some current_peer_id)
| Running { current_peer_id ; _ } ->
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_peer_id, timestamp) ;
if requested
then Disconnection current_peer_id
else External_disconnection current_peer_id
| Disconnected ->
assert false
in
point_info.state <- Disconnected ;
Pool_info.log point_info ~timestamp event
end

207
src/lib_base/p2p_point.mli Normal file
View File

@ -0,0 +1,207 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
type peer_id = Crypto_box.Public_key_hash.t
(* = P2p_peer.Id.t, but we should break cycles *)
module Id : sig
type t = P2p_addr.t * P2p_addr.port
val compare : t -> t -> int
val pp : Format.formatter -> t -> unit
val pp_opt : Format.formatter -> t option -> unit
val of_string_exn : string -> t
val of_string : string -> (t, string) result
val to_string : t -> string
val encoding : t Data_encoding.t
val is_local : t -> bool
val is_global : t -> bool
val parse_addr_port : string -> string * string
end
module Map : Map.S with type key = Id.t
module Set : Set.S with type elt = Id.t
module Table : Hashtbl.S with type key = Id.t
module State : sig
type t =
| Requested
| Accepted of peer_id
| Running of peer_id
| Disconnected
val pp_digram : Format.formatter -> t -> unit
val encoding : t Data_encoding.t
val of_peer_id : t -> peer_id option
val of_peerid_state : t -> peer_id option -> t
end
module Info : sig
type t = {
trusted : bool ;
greylisted_until : Time.t ;
state : State.t ;
last_failed_connection : Time.t option ;
last_rejected_connection : (peer_id * Time.t) option ;
last_established_connection : (peer_id * Time.t) option ;
last_disconnection : (peer_id * Time.t) option ;
last_seen : (peer_id * Time.t) option ;
last_miss : Time.t option ;
}
val encoding: t Data_encoding.t
end
module Pool_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 ->
P2p_addr.t -> P2p_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 -> (peer_id * Time.t) option
val last_established_connection :
'conn point_info -> (peer_id * Time.t) option
val last_disconnection :
'conn point_info -> (peer_id * Time.t) option
val last_seen :
'conn point_info -> (peer_id * 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
(** [last_miss pi] is the most recent of:
* last failed connection
* last rejected connection
* last disconnection
*)
val greylisted :
?now:Time.t -> 'conn point_info -> bool
val greylisted_until : 'conn point_info -> Time.t
val point : 'conn point_info -> Id.t
val log_incoming_rejection :
?timestamp:Time.t -> 'conn point_info -> peer_id -> unit
end
module Pool_state : sig
type 'conn t =
| Requested of { cancel: Lwt_canceler.t }
(** We initiated a connection. *)
| Accepted of { current_peer_id: peer_id ;
cancel: Lwt_canceler.t }
(** We accepted a incoming connection. *)
| Running of { data: 'conn ;
current_peer_id: peer_id }
(** 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 Pool_info.t -> 'conn state
val is_disconnected : 'conn Pool_info.t -> bool
val set_requested :
?timestamp:Time.t ->
'conn Pool_info.t -> Lwt_canceler.t -> unit
val set_accepted :
?timestamp:Time.t ->
'conn Pool_info.t -> peer_id -> Lwt_canceler.t -> unit
val set_running :
?timestamp:Time.t -> 'conn Pool_info.t -> peer_id -> 'conn -> unit
val set_disconnected :
?timestamp:Time.t -> ?requested:bool -> 'conn Pool_info.t -> unit
end
module Pool_event : sig
type kind =
| Outgoing_request
(** We initiated a connection. *)
| Accepting_request of peer_id
(** We accepted a connection after authentifying the remote peer. *)
| Rejecting_request of peer_id
(** We rejected a connection after authentifying the remote peer. *)
| Request_rejected of peer_id option
(** The remote peer rejected our connection. *)
| Connection_established of peer_id
(** We succesfully established a authentified connection. *)
| Disconnection of peer_id
(** We decided to close the connection. *)
| External_disconnection of peer_id
(** The connection was closed for external reason. *)
type t = {
kind : kind ;
timestamp : Time.t ;
}
val encoding : t Data_encoding.t
val fold :
'conn Pool_info.t -> init:'a -> f:('a -> t -> 'a) -> 'a
val watch :
'conn Pool_info.t -> t Lwt_stream.t * Lwt_watcher.stopper
end

64
src/lib_base/p2p_stat.ml Normal file
View File

@ -0,0 +1,64 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
type t = {
total_sent : int64 ;
total_recv : int64 ;
current_inflow : int ;
current_outflow : int ;
}
let empty = {
total_sent = 0L ;
total_recv = 0L ;
current_inflow = 0 ;
current_outflow = 0 ;
}
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 print_size64 ppf sz =
let open Int64 in
let ratio n = (to_float sz /. float_of_int (1 lsl n)) in
if sz < shift_left 1L 10 then
Format.fprintf ppf "%Ld B" sz
else if sz < shift_left 1L 20 then
Format.fprintf ppf "%.2f kiB" (ratio 10)
else if sz < shift_left 1L 30 then
Format.fprintf ppf "%.2f MiB" (ratio 20)
else if sz < shift_left 1L 40 then
Format.fprintf ppf "%.2f GiB" (ratio 30)
else
Format.fprintf ppf "%.2f TiB" (ratio 40)
let pp ppf stat =
Format.fprintf ppf
"↗ %a (%a/s) ↘ %a (%a/s)"
print_size64 stat.total_sent print_size stat.current_outflow
print_size64 stat.total_recv print_size stat.current_inflow
let encoding =
let open Data_encoding in
conv
(fun { total_sent ; total_recv ; current_inflow ; current_outflow } ->
(total_sent, total_recv, current_inflow, current_outflow))
(fun (total_sent, total_recv, current_inflow, current_outflow) ->
{ total_sent ; total_recv ; current_inflow ; current_outflow })
(obj4
(req "total_sent" int64)
(req "total_recv" int64)
(req "current_inflow" int31)
(req "current_outflow" int31))

21
src/lib_base/p2p_stat.mli Normal file
View File

@ -0,0 +1,21 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
(** Bandwidth usage statistics *)
type t = {
total_sent : int64 ;
total_recv : int64 ;
current_inflow : int ;
current_outflow : int ;
}
val empty : t
val pp : Format.formatter -> t -> unit
val encoding : t Data_encoding.t

40
src/lib_base/p2p_version.ml Normal file
View File

@ -0,0 +1,40 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
type t = {
name : string ;
major : int ;
minor : int ;
}
let pp ppf { name ; major ; minor } =
Format.fprintf ppf "%s.%d.%d" name major minor
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)

22
src/lib_base/p2p_version.mli Normal file
View File

@ -0,0 +1,22 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
(** Protocol version *)
type t = {
name : string ;
major : int ;
minor : int ;
}
(** Type of a protocol version. *)
val pp : Format.formatter -> t -> unit
val encoding : t Data_encoding.t
val common : t list -> t list -> t option

8
src/lib_base/time.ml
View File

@ -24,6 +24,14 @@ module T = struct
let incr_sign = res >= a in
if sign = incr_sign then res else invalid_arg "Time.add" ;;
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 compare t1 t2 < 0 then a2 else a1
let hash = to_int
let (=) = equal
let (<>) x y = compare x y <> 0

3
src/lib_base/time.mli
View File

@ -56,3 +56,6 @@ 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
val recent :
('a * t) option -> ('a * t) option -> ('a * t) option

8
src/lib_base/tzPervasives.ml
View File

@ -44,5 +44,13 @@ module Preapply_result = Preapply_result
module Block_locator = Block_locator
module Mempool = Mempool
module P2p_addr = P2p_addr
module P2p_identity = P2p_identity
module P2p_peer = P2p_peer
module P2p_point = P2p_point
module P2p_connection = P2p_connection
module P2p_stat = P2p_stat
module P2p_version = P2p_version
include Utils.Infix
include Error_monad

8
src/lib_base/tzPervasives.mli
View File

@ -42,5 +42,13 @@ module Operation_list_list_hash = Operation_list_list_hash
module Context_hash = Context_hash
module Protocol_hash = Protocol_hash
module P2p_addr = P2p_addr
module P2p_identity = P2p_identity
module P2p_peer = P2p_peer
module P2p_point = P2p_point
module P2p_connection = P2p_connection
module P2p_stat = P2p_stat
module P2p_version = P2p_version
include (module type of (struct include Utils.Infix end))
include (module type of (struct include Error_monad end))

34
src/lib_client_base/client_network.ml
View File

@ -7,8 +7,6 @@
(* *)
(**************************************************************************)
open P2p_types
let group =
{ Cli_entries.name = "network" ;
title = "Commands for monitoring and controlling network state" }
@ -23,47 +21,47 @@ let commands () = [
Client_node_rpcs.Network.peers cctxt >>=? fun peers ->
Client_node_rpcs.Network.points cctxt >>=? fun points ->
cctxt#message "GLOBAL STATS" >>= fun () ->
cctxt#message " %a" Stat.pp stat >>= fun () ->
cctxt#message " %a" P2p_stat.pp stat >>= fun () ->
cctxt#message "CONNECTIONS" >>= fun () ->
let incoming, outgoing =
List.partition (fun c -> c.Connection_info.incoming) conns in
List.partition (fun c -> c.P2p_connection.Info.incoming) conns in
Lwt_list.iter_s begin fun conn ->
cctxt#message " %a" Connection_info.pp conn
cctxt#message " %a" P2p_connection.Info.pp conn
end incoming >>= fun () ->
Lwt_list.iter_s begin fun conn ->
cctxt#message " %a" Connection_info.pp conn
cctxt#message " %a" P2p_connection.Info.pp conn
end outgoing >>= fun () ->
cctxt#message "KNOWN PEERS" >>= fun () ->
Lwt_list.iter_s begin fun (p, pi) ->
cctxt#message " %a %.0f %a %a %s"
Peer_state.pp_digram pi.Peer_info.state
P2p_peer.State.pp_digram pi.P2p_peer.Info.state
pi.score
Peer_id.pp p
Stat.pp pi.stat
P2p_peer.Id.pp p
P2p_stat.pp pi.stat
(if pi.trusted then "★" else " ")
end peers >>= fun () ->
cctxt#message "KNOWN POINTS" >>= fun () ->
Lwt_list.iter_s begin fun (p, pi) ->
match pi.Point_info.state with
match pi.P2p_point.Info.state with
| Running peer_id ->
cctxt#message " %a %a %a %s"
Point_state.pp_digram pi.state
Point.pp p
Peer_id.pp peer_id
P2p_point.State.pp_digram pi.state
P2p_point.Id.pp p
P2p_peer.Id.pp peer_id
(if pi.trusted then "★" else " ")
| _ ->
match pi.last_seen with
| Some (peer_id, ts) ->
cctxt#message " %a %a (last seen: %a %a) %s"
Point_state.pp_digram pi.state
Point.pp p
Peer_id.pp peer_id
P2p_point.State.pp_digram pi.state
P2p_point.Id.pp p
P2p_peer.Id.pp peer_id
Time.pp_hum ts
(if pi.trusted then "★" else " ")
| None ->
cctxt#message " %a %a %s"
Point_state.pp_digram pi.state
Point.pp p
P2p_point.State.pp_digram pi.state
P2p_point.Id.pp p
(if pi.trusted then "★" else " ")
end points >>= fun () ->
return ()

10
src/lib_client_base/client_node_rpcs.mli
View File

@ -155,19 +155,17 @@ val bootstrapped:
module Network : sig
open P2p_types
val stat:
#Client_rpcs.ctxt -> Stat.t tzresult Lwt.t
#Client_rpcs.ctxt -> P2p_stat.t tzresult Lwt.t
val connections:
#Client_rpcs.ctxt -> Connection_info.t list tzresult Lwt.t
#Client_rpcs.ctxt -> P2p_connection.Info.t list tzresult Lwt.t
val peers:
#Client_rpcs.ctxt -> (Peer_id.t * P2p_types.Peer_info.t) list tzresult Lwt.t
#Client_rpcs.ctxt -> (P2p_peer.Id.t * P2p_peer.Info.t) list tzresult Lwt.t
val points:
#Client_rpcs.ctxt -> (Point.t * P2p_types.Point_info.t) list tzresult Lwt.t
#Client_rpcs.ctxt -> (P2p_point.Id.t * P2p_point.Info.t) list tzresult Lwt.t
end

215
src/lib_p2p/p2p.ml
View File

@ -7,17 +7,15 @@
(* *)
(**************************************************************************)
include P2p_types
include Logging.Make(struct let name = "p2p" end)
type 'meta meta_config = 'meta P2p_connection_pool.meta_config = {
type 'meta meta_config = 'meta P2p_pool.meta_config = {
encoding : 'meta Data_encoding.t;
initial : 'meta;
score : 'meta -> float
}
type 'msg app_message_encoding = 'msg P2p_connection_pool.encoding =
type 'msg app_message_encoding = 'msg P2p_pool.encoding =
Encoding : {
tag: int ;
encoding: 'a Data_encoding.t ;
@ -26,18 +24,18 @@ type 'msg app_message_encoding = 'msg P2p_connection_pool.encoding =
max_length: int option ;
} -> 'msg app_message_encoding
type 'msg message_config = 'msg P2p_connection_pool.message_config = {
type 'msg message_config = 'msg P2p_pool.message_config = {
encoding : 'msg app_message_encoding list ;
versions : Version.t list;
versions : P2p_version.t list;
}
type config = {
listening_port : port option;
listening_addr : addr option;
trusted_points : Point.t list ;
listening_port : P2p_addr.port option;
listening_addr : P2p_addr.t option;
trusted_points : P2p_point.Id.t list ;
peers_file : string ;
closed_network : bool ;
identity : Identity.t ;
identity : P2p_identity.t ;
proof_of_work_target : Crypto_box.target ;
}
@ -87,7 +85,7 @@ let create_scheduler limits =
let create_connection_pool config limits meta_cfg msg_cfg io_sched =
let pool_cfg = {
P2p_connection_pool.identity = config.identity ;
P2p_pool.identity = config.identity ;
proof_of_work_target = config.proof_of_work_target ;
listening_port = config.listening_port ;
trusted_points = config.trusted_points ;
@ -109,7 +107,7 @@ let create_connection_pool config limits meta_cfg msg_cfg io_sched =
}
in
let pool =
P2p_connection_pool.create pool_cfg meta_cfg msg_cfg io_sched in
P2p_pool.create pool_cfg meta_cfg msg_cfg io_sched in
pool
let bounds ~min ~expected ~max =
@ -149,7 +147,7 @@ let may_create_welcome_worker config limits pool =
port >>= fun w ->
Lwt.return (Some w)
type ('msg, 'meta) connection = ('msg, 'meta) P2p_connection_pool.connection
type ('msg, 'meta) connection = ('msg, 'meta) P2p_pool.connection
module Real = struct
@ -157,7 +155,7 @@ module Real = struct
config: config ;
limits: limits ;
io_sched: P2p_io_scheduler.t ;
pool: ('msg, 'meta) P2p_connection_pool.t ;
pool: ('msg, 'meta) P2p_pool.t ;
discoverer: P2p_discovery.t option ;
maintenance: 'meta P2p_maintenance.t ;
welcome: P2p_welcome.t option ;
@ -193,119 +191,119 @@ module Real = struct
Lwt_utils.may ~f:P2p_welcome.shutdown net.welcome >>= fun () ->
P2p_maintenance.shutdown net.maintenance >>= fun () ->
Lwt_utils.may ~f:P2p_discovery.shutdown net.discoverer >>= fun () ->
P2p_connection_pool.destroy net.pool >>= fun () ->
P2p_pool.destroy net.pool >>= fun () ->
P2p_io_scheduler.shutdown ~timeout:3.0 net.io_sched
let connections { pool } () =
P2p_connection_pool.Connection.fold pool
P2p_pool.Connection.fold pool
~init:[] ~f:(fun _peer_id c acc -> c :: acc)
let find_connection { pool } peer_id =
P2p_connection_pool.Connection.find_by_peer_id pool peer_id
P2p_pool.Connection.find_by_peer_id pool peer_id
let disconnect ?wait conn =
P2p_connection_pool.disconnect ?wait conn
P2p_pool.disconnect ?wait conn
let connection_info _net conn =
P2p_connection_pool.Connection.info conn
P2p_pool.Connection.info conn
let connection_stat _net conn =
P2p_connection_pool.Connection.stat conn
P2p_pool.Connection.stat conn
let global_stat { pool } () =
P2p_connection_pool.pool_stat pool
P2p_pool.pool_stat pool
let set_metadata { pool } conn meta =
P2p_connection_pool.Peer_ids.set_metadata pool conn meta
P2p_pool.Peers.set_metadata pool conn meta
let get_metadata { pool } conn =
P2p_connection_pool.Peer_ids.get_metadata pool conn
P2p_pool.Peers.get_metadata pool conn
let recv _net conn =
P2p_connection_pool.read conn >>=? fun msg ->
P2p_pool.read conn >>=? fun msg ->
lwt_debug "message read from %a"
Connection_info.pp
(P2p_connection_pool.Connection.info conn) >>= fun () ->
P2p_connection.Info.pp
(P2p_pool.Connection.info conn) >>= fun () ->
return msg
let rec recv_any net () =
let pipes =
P2p_connection_pool.Connection.fold
P2p_pool.Connection.fold
net.pool ~init:[]
~f:begin fun _peer_id conn acc ->
(P2p_connection_pool.is_readable conn >>= function
(P2p_pool.is_readable conn >>= function
| Ok () -> Lwt.return (Some conn)
| Error _ -> Lwt_utils.never_ending) :: acc
end in
Lwt.pick (
( P2p_connection_pool.Pool_event.wait_new_connection net.pool >>= fun () ->
( P2p_pool.Pool_event.wait_new_connection net.pool >>= fun () ->
Lwt.return_none )::
pipes) >>= function
| None -> recv_any net ()
| Some conn ->
P2p_connection_pool.read conn >>= function
P2p_pool.read conn >>= function
| Ok msg ->
lwt_debug "message read from %a"
Connection_info.pp
(P2p_connection_pool.Connection.info conn) >>= fun () ->
P2p_connection.Info.pp
(P2p_pool.Connection.info conn) >>= fun () ->
Lwt.return (conn, msg)
| Error _ ->
lwt_debug "error reading message from %a"
Connection_info.pp
(P2p_connection_pool.Connection.info conn) >>= fun () ->
P2p_connection.Info.pp
(P2p_pool.Connection.info conn) >>= fun () ->
Lwt_unix.yield () >>= fun () ->
recv_any net ()
let send _net conn m =
P2p_connection_pool.write conn m >>= function
P2p_pool.write conn m >>= function
| Ok () ->
lwt_debug "message sent to %a"
Connection_info.pp
(P2p_connection_pool.Connection.info conn) >>= fun () ->
P2p_connection.Info.pp
(P2p_pool.Connection.info conn) >>= fun () ->
return ()
| Error err ->
lwt_debug "error sending message from %a: %a"
Connection_info.pp
(P2p_connection_pool.Connection.info conn)
P2p_connection.Info.pp
(P2p_pool.Connection.info conn)
pp_print_error err >>= fun () ->
Lwt.return (Error err)
let try_send _net conn v =
match P2p_connection_pool.write_now conn v with
match P2p_pool.write_now conn v with
| Ok v ->
debug "message trysent to %a"
Connection_info.pp
(P2p_connection_pool.Connection.info conn) ;
P2p_connection.Info.pp
(P2p_pool.Connection.info conn) ;
v
| Error err ->
debug "error trysending message to %a@ %a"
Connection_info.pp
(P2p_connection_pool.Connection.info conn)
P2p_connection.Info.pp
(P2p_pool.Connection.info conn)
pp_print_error err ;
false
let broadcast { pool } msg =
P2p_connection_pool.write_all pool msg ;
P2p_pool.write_all pool msg ;
debug "message broadcasted"
let fold_connections { pool } ~init ~f =
P2p_connection_pool.Connection.fold pool ~init ~f
P2p_pool.Connection.fold pool ~init ~f
let iter_connections { pool } f =
P2p_connection_pool.Connection.fold pool
P2p_pool.Connection.fold pool
~init:()
~f:(fun gid conn () -> f gid conn)
let on_new_connection { pool } f =
P2p_connection_pool.on_new_connection pool f
P2p_pool.on_new_connection pool f
let pool { pool } = pool
end
module Fake = struct
let id = Identity.generate (Crypto_box.make_target 0.)
let id = P2p_identity.generate (Crypto_box.make_target 0.)
let empty_stat = {
Stat.total_sent = 0L ;
P2p_stat.total_sent = 0L ;
total_recv = 0L ;
current_inflow = 0 ;
current_outflow = 0 ;
}
let connection_info = {
Connection_info.incoming = false ;
P2p_connection.Info.incoming = false ;
peer_id = id.peer_id ;
id_point = (Ipaddr.V6.unspecified, None) ;
remote_socket_port = 0 ;
@ -315,28 +313,28 @@ module Fake = struct
end
type ('msg, 'meta) t = {
peer_id : Peer_id.t ;
peer_id : P2p_peer.Id.t ;
maintain : unit -> unit Lwt.t ;
roll : unit -> unit Lwt.t ;
shutdown : unit -> unit Lwt.t ;
connections : unit -> ('msg, 'meta) connection list ;
find_connection : Peer_id.t -> ('msg, 'meta) connection option ;
find_connection : P2p_peer.Id.t -> ('msg, 'meta) connection option ;
disconnect : ?wait:bool -> ('msg, 'meta) connection -> unit Lwt.t ;
connection_info : ('msg, 'meta) connection -> Connection_info.t ;
connection_stat : ('msg, 'meta) connection -> Stat.t ;
global_stat : unit -> Stat.t ;
get_metadata : Peer_id.t -> 'meta ;
set_metadata : Peer_id.t -> 'meta -> unit ;
connection_info : ('msg, 'meta) connection -> P2p_connection.Info.t ;
connection_stat : ('msg, 'meta) connection -> P2p_stat.t ;
global_stat : unit -> P2p_stat.t ;
get_metadata : P2p_peer.Id.t -> 'meta ;
set_metadata : P2p_peer.Id.t -> 'meta -> unit ;
recv : ('msg, 'meta) connection -> 'msg tzresult Lwt.t ;
recv_any : unit -> (('msg, 'meta) connection * 'msg) Lwt.t ;
send : ('msg, 'meta) connection -> 'msg -> unit tzresult Lwt.t ;
try_send : ('msg, 'meta) connection -> 'msg -> bool ;
broadcast : 'msg -> unit ;
pool : ('msg, 'meta) P2p_connection_pool.t option ;
pool : ('msg, 'meta) P2p_pool.t option ;
fold_connections :
'a. init:'a -> f:(Peer_id.t -> ('msg, 'meta) connection -> 'a -> 'a) -> 'a ;
iter_connections : (Peer_id.t -> ('msg, 'meta) connection -> unit) -> unit ;
on_new_connection : (Peer_id.t -> ('msg, 'meta) connection -> unit) -> unit ;
'a. init:'a -> f:(P2p_peer.Id.t -> ('msg, 'meta) connection -> 'a -> 'a) -> 'a ;
iter_connections : (P2p_peer.Id.t -> ('msg, 'meta) connection -> unit) -> unit ;
on_new_connection : (P2p_peer.Id.t -> ('msg, 'meta) connection -> unit) -> unit ;
}
type ('msg, 'meta) net = ('msg, 'meta) t
@ -374,7 +372,7 @@ let check_limits =
begin
match c.binary_chunks_size with
| None -> return ()
| Some size -> P2p_connection.check_binary_chunks_size size
| Some size -> P2p_socket.check_binary_chunks_size size
end >>=? fun () ->
return ()
@ -420,7 +418,7 @@ let faked_network meta_config = {
set_metadata = (fun _ _ -> ()) ;
recv = (fun _ -> Lwt_utils.never_ending) ;
recv_any = (fun () -> Lwt_utils.never_ending) ;
send = (fun _ _ -> fail P2p_connection_pool.Connection_closed) ;
send = (fun _ _ -> fail P2p_pool.Connection_closed) ;
try_send = (fun _ _ -> false) ;
fold_connections = (fun ~init ~f:_ -> init) ;
iter_connections = (fun _f -> ()) ;
@ -451,35 +449,33 @@ let iter_connections net = net.iter_connections
let on_new_connection net = net.on_new_connection
module Raw = struct
type 'a t = 'a P2p_connection_pool.Message.t =
type 'a t = 'a P2p_pool.Message.t =
| Bootstrap
| Advertise of P2p_types.Point.t list
| Swap_request of Point.t * Peer_id.t
| Swap_ack of Point.t * Peer_id.t
| Advertise of P2p_point.Id.t list
| Swap_request of P2p_point.Id.t * P2p_peer.Id.t
| Swap_ack of P2p_point.Id.t * P2p_peer.Id.t
| Message of 'a
| Disconnect
let encoding = P2p_connection_pool.Message.encoding
let encoding = P2p_pool.Message.encoding
end
module RPC = struct
let stat net =
match net.pool with
| None -> Stat.empty
| Some pool -> P2p_connection_pool.pool_stat pool
module Event = P2p_connection_pool.Log_event
| None -> P2p_stat.empty
| Some pool -> P2p_pool.pool_stat pool
let watch net =
match net.pool with
| None -> Lwt_watcher.create_fake_stream ()
| Some pool -> P2p_connection_pool.watch pool
| Some pool -> P2p_pool.watch pool
let connect net point timeout =
match net.pool with
| None -> failwith "fake net"
| Some pool ->
P2p_connection_pool.connect ~timeout pool point >>|? ignore
P2p_pool.connect ~timeout pool point >>|? ignore
module Connection = struct
let info net peer_id =
@ -487,46 +483,45 @@ module RPC = struct
| None -> None
| Some pool ->
Option.map
(P2p_connection_pool.Connection.find_by_peer_id pool peer_id)
~f:P2p_connection_pool.Connection.info
(P2p_pool.Connection.find_by_peer_id pool peer_id)
~f:P2p_pool.Connection.info
let kick net peer_id wait =
match net.pool with
| None -> Lwt.return_unit
| Some pool ->
match P2p_connection_pool.Connection.find_by_peer_id pool peer_id with
match P2p_pool.Connection.find_by_peer_id pool peer_id with
| None -> Lwt.return_unit
| Some conn -> P2p_connection_pool.disconnect ~wait conn
| Some conn -> P2p_pool.disconnect ~wait conn
let list net =
match net.pool with
| None -> []
| Some pool ->
P2p_connection_pool.Connection.fold
P2p_pool.Connection.fold
pool ~init:[]
~f:begin fun _peer_id c acc ->
P2p_connection_pool.Connection.info c :: acc
P2p_pool.Connection.info c :: acc
end
let count net =
match net.pool with
| None -> 0
| Some pool -> P2p_connection_pool.active_connections pool
| Some pool -> P2p_pool.active_connections pool
end
module Point = struct
open P2p_types.Point_info
open P2p_types.Point_state
open P2p_point.Info
open P2p_point.State
let info_of_point_info i =
let open P2p_connection_pool_types in
let state = match Point_info.State.get i with
let state = match P2p_point.Pool_state.get i with
| Requested _ -> Requested
| Accepted { current_peer_id ; _ } -> Accepted current_peer_id
| Running { current_peer_id ; _ } -> Running current_peer_id
| Disconnected -> Disconnected in
Point_info.{
P2p_point.Pool_info.{
trusted = trusted i ;
state ;
greylisted_until = greylisted_until i ;
@ -543,21 +538,19 @@ module RPC = struct
| None -> None
| Some pool ->
Option.map
(P2p_connection_pool.Points.info pool point)
(P2p_pool.Points.info pool point)
~f:info_of_point_info
module Event = P2p_connection_pool_types.Point_info.Event
let events ?(max=max_int) ?(rev=false) net point =
match net.pool with
| None -> []
| Some pool ->
Option.unopt_map
(P2p_connection_pool.Points.info pool point)
(P2p_pool.Points.info pool point)
~default:[]
~f:begin fun pi ->
let evts =
P2p_connection_pool_types.Point_info.fold_events
P2p_point.Pool_event.fold
pi ~init:[] ~f:(fun a e -> e :: a) in
(if rev then List.rev_sub else List.sub) evts max
end
@ -566,15 +559,15 @@ module RPC = struct
match net.pool with
| None -> raise Not_found
| Some pool ->
match P2p_connection_pool.Points.info pool point with
match P2p_pool.Points.info pool point with
| None -> raise Not_found
| Some pi -> P2p_connection_pool_types.Point_info.watch pi
| Some pi -> P2p_point.Pool_event.watch pi
let list ?(restrict=[]) net =
match net.pool with
| None -> []
| Some pool ->
P2p_connection_pool.Points.fold_known
P2p_pool.Points.fold_known
pool ~init:[]
~f:begin fun point i a ->
let info = info_of_point_info i in
@ -588,24 +581,22 @@ module RPC = struct
module Peer_id = struct
open P2p_types.Peer_info
open P2p_types.Peer_state
open P2p_peer.Info
open P2p_peer.State
let info_of_peer_info pool i =
let open P2p_connection_pool in
let open P2p_connection_pool_types in
let state, id_point = match Peer_info.State.get i with
let state, id_point = match P2p_peer.Pool_state.get i with
| Accepted { current_point } -> Accepted, Some current_point
| Running { current_point } -> Running, Some current_point
| Disconnected -> Disconnected, None
in
let peer_id = Peer_info.peer_id i in
let score = Peer_ids.get_score pool peer_id in
let peer_id = P2p_peer.Pool_info.peer_id i in
let score = P2p_pool.Peers.get_score pool peer_id in
let stat =
match P2p_connection_pool.Connection.find_by_peer_id pool peer_id with
| None -> Stat.empty
| Some conn -> P2p_connection_pool.Connection.stat conn
in Peer_info.{
match P2p_pool.Connection.find_by_peer_id pool peer_id with
| None -> P2p_stat.empty
| Some conn -> P2p_pool.Connection.stat conn
in P2p_peer.Pool_info.{
score ;
trusted = trusted i ;
state ;
@ -623,7 +614,7 @@ module RPC = struct
match net.pool with
| None -> None
| Some pool -> begin
match P2p_connection_pool.Peer_ids.info pool peer_id with
match P2p_pool.Peers.info pool peer_id with
| Some info -> Some (info_of_peer_info pool info)
| None -> None
end
@ -633,10 +624,10 @@ module RPC = struct
| None -> []
| Some pool ->
Option.unopt_map
(P2p_connection_pool.Peer_ids.info pool peer_id)
(P2p_pool.Peers.info pool peer_id)
~default:[]
~f:begin fun gi ->
let evts = P2p_connection_pool_types.Peer_info.fold_events gi
let evts = P2p_peer.Pool_event.fold gi
~init:[] ~f:(fun a e -> e :: a) in
(if rev then List.rev_sub else List.sub) evts max
end
@ -645,15 +636,15 @@ module RPC = struct
match net.pool with
| None -> raise Not_found
| Some pool ->
match P2p_connection_pool.Peer_ids.info pool peer_id with
match P2p_pool.Peers.info pool peer_id with
| None -> raise Not_found
| Some gi -> P2p_connection_pool_types.Peer_info.watch gi
| Some gi -> P2p_peer.Pool_event.watch gi
let list ?(restrict=[]) net =
match net.pool with
| None -> []
| Some pool ->
P2p_connection_pool.Peer_ids.fold_known pool
P2p_pool.Peers.fold_known pool
~init:[]
~f:begin fun peer_id i a ->
let info = info_of_peer_info pool i in

98
src/lib_p2p/p2p.mli
View File

@ -9,28 +9,6 @@
(** Tezos Shell Net - Low level API for the Gossip network *)
(** A peer connection address *)
type addr = Ipaddr.V6.t
(** A peer connection port *)
type port = int
(** A p2p protocol version *)
module Version = P2p_types.Version
(** A global identifier for a peer, a.k.a. an identity *)
module Peer_id = P2p_types.Peer_id
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;
@ -47,21 +25,21 @@ type 'msg app_message_encoding = Encoding : {
type 'msg message_config = {
encoding : 'msg app_message_encoding list ;
versions : Version.t list;
versions : P2p_version.t list;
}
(** Network configuration *)
type config = {
listening_port : port option;
listening_port : P2p_addr.port option;
(** Tells if incoming connections accepted, precising the TCP port
on which the peer can be reached *)
listening_addr : addr option;
listening_addr : P2p_addr.t option;
(** When incoming connections are accepted, precising on which
IP adddress the node listen (default: [[::]]). *)
trusted_points : Point.t list ;
trusted_points : P2p_point.Id.t list ;
(** List of hard-coded known peers to bootstrap the network from. *)
peers_file : string ;
@ -72,7 +50,7 @@ type config = {
(** If [true], the only accepted connections are from peers whose
addresses are in [trusted_peers]. *)
identity : Identity.t ;
identity : P2p_identity.t ;
(** Cryptographic identity of the peer. *)
proof_of_work_target : Crypto_box.target ;
@ -148,7 +126,7 @@ val create :
'meta meta_config -> 'msg message_config -> ('msg, 'meta) net tzresult Lwt.t
(** Return one's peer_id *)
val peer_id : ('msg, 'meta) net -> Peer_id.t
val peer_id : ('msg, 'meta) net -> P2p_peer.Id.t
(** A maintenance operation : try and reach the ideal number of peers *)
val maintain : ('msg, 'meta) net -> unit Lwt.t
@ -166,23 +144,23 @@ type ('msg, 'meta) connection
val connections : ('msg, 'meta) net -> ('msg, 'meta) connection list
(** Return the active peer with identity [peer_id] *)
val find_connection : ('msg, 'meta) net -> Peer_id.t -> ('msg, 'meta) connection option
val find_connection : ('msg, 'meta) net -> P2p_peer.Id.t -> ('msg, 'meta) connection option
(** Access the info of an active peer, if available *)
val connection_info :
('msg, 'meta) net -> ('msg, 'meta) connection -> Connection_info.t
('msg, 'meta) net -> ('msg, 'meta) connection -> P2p_connection.Info.t
val connection_stat :
('msg, 'meta) net -> ('msg, 'meta) connection -> Stat.t
('msg, 'meta) net -> ('msg, 'meta) connection -> P2p_stat.t
(** Cleanly closes a connection. *)
val disconnect :
('msg, 'meta) net -> ?wait:bool -> ('msg, 'meta) connection -> unit Lwt.t
val global_stat : ('msg, 'meta) net -> Stat.t
val global_stat : ('msg, 'meta) net -> P2p_stat.t
(** Accessors for meta information about a global identifier *)
val get_metadata : ('msg, 'meta) net -> Peer_id.t -> 'meta
val set_metadata : ('msg, 'meta) net -> Peer_id.t -> 'meta -> unit
val get_metadata : ('msg, 'meta) net -> P2p_peer.Id.t -> 'meta
val set_metadata : ('msg, 'meta) net -> P2p_peer.Id.t -> 'meta -> unit
(** Wait for a message from a given connection. *)
val recv :
@ -207,56 +185,56 @@ val broadcast : ('msg, 'meta) net -> 'msg -> unit
module RPC : sig
val stat : ('msg, 'meta) net -> Stat.t
val stat : ('msg, 'meta) net -> P2p_stat.t
val watch :
('msg, 'meta) net ->
P2p_types.Connection_pool_log_event.t Lwt_stream.t * Lwt_watcher.stopper
val connect : ('msg, 'meta) net -> Point.t -> float -> unit tzresult Lwt.t
P2p_connection.Pool_event.t Lwt_stream.t * Lwt_watcher.stopper
val connect : ('msg, 'meta) net -> P2p_point.Id.t -> float -> unit tzresult Lwt.t
module Connection : sig
val info : ('msg, 'meta) net -> Peer_id.t -> Connection_info.t option
val kick : ('msg, 'meta) net -> Peer_id.t -> bool -> unit Lwt.t
val list : ('msg, 'meta) net -> Connection_info.t list
val info : ('msg, 'meta) net -> P2p_peer.Id.t -> P2p_connection.Info.t option
val kick : ('msg, 'meta) net -> P2p_peer.Id.t -> bool -> unit Lwt.t
val list : ('msg, 'meta) net -> P2p_connection.Info.t list
val count : ('msg, 'meta) net -> int
end
module Point : sig
val info :
('msg, 'meta) net -> Point.t -> P2p_types.Point_info.t option
('msg, 'meta) net -> P2p_point.Id.t -> P2p_point.Info.t option
val list :
?restrict: P2p_types.Point_state.t list ->
('msg, 'meta) net -> (Point.t * P2p_types.Point_info.t) list
?restrict: P2p_point.State.t list ->
('msg, 'meta) net -> (P2p_point.Id.t * P2p_point.Info.t) list
val events :
?max:int -> ?rev:bool -> ('msg, 'meta) net -> Point.t ->
P2p_connection_pool_types.Point_info.Event.t list
?max:int -> ?rev:bool -> ('msg, 'meta) net -> P2p_point.Id.t ->
P2p_point.Pool_event.t list
val watch :
('msg, 'meta) net -> Point.t ->
P2p_connection_pool_types.Point_info.Event.t Lwt_stream.t * Lwt_watcher.stopper
('msg, 'meta) net -> P2p_point.Id.t ->
P2p_point.Pool_event.t Lwt_stream.t * Lwt_watcher.stopper
end
module Peer_id : sig
val info :
('msg, 'meta) net -> Peer_id.t -> P2p_types.Peer_info.t option
('msg, 'meta) net -> P2p_peer.Id.t -> P2p_peer.Info.t option
val list :
?restrict: P2p_types.Peer_state.t list ->
('msg, 'meta) net -> (Peer_id.t * P2p_types.Peer_info.t) list
?restrict: P2p_peer.State.t list ->
('msg, 'meta) net -> (P2p_peer.Id.t * P2p_peer.Info.t) list
val events :
?max: int -> ?rev: bool ->
('msg, 'meta) net -> Peer_id.t ->
P2p_connection_pool_types.Peer_info.Event.t list
('msg, 'meta) net -> P2p_peer.Id.t ->
P2p_peer.Pool_event.t list
val watch :
('msg, 'meta) net -> Peer_id.t ->
P2p_connection_pool_types.Peer_info.Event.t Lwt_stream.t * Lwt_watcher.stopper
('msg, 'meta) net -> P2p_peer.Id.t ->
P2p_peer.Pool_event.t Lwt_stream.t * Lwt_watcher.stopper
end
@ -264,24 +242,24 @@ end
val fold_connections :
('msg, 'meta) net ->
init:'a -> f:(Peer_id.t -> ('msg, 'meta) connection -> 'a -> 'a) -> 'a
init:'a -> f:(P2p_peer.Id.t -> ('msg, 'meta) connection -> 'a -> 'a) -> 'a
val iter_connections :
('msg, 'meta) net ->
(Peer_id.t -> ('msg, 'meta) connection -> unit) -> unit
(P2p_peer.Id.t -> ('msg, 'meta) connection -> unit) -> unit
val on_new_connection :
('msg, 'meta) net ->
(Peer_id.t -> ('msg, 'meta) connection -> unit) -> unit
(P2p_peer.Id.t -> ('msg, 'meta) connection -> unit) -> unit
(**/**)
module Raw : sig
type 'a t =
| Bootstrap
| Advertise of P2p_types.Point.t list
| Swap_request of Point.t * Peer_id.t
| Swap_ack of Point.t * Peer_id.t
| Advertise of P2p_point.Id.t list
| Swap_request of P2p_point.Id.t * P2p_peer.Id.t
| Swap_ack of P2p_point.Id.t * P2p_peer.Id.t
| Message of 'a
| Disconnect
val encoding: 'msg app_message_encoding list -> 'msg t Data_encoding.t

8
src/lib_p2p/p2p_discovery.ml
View File

@ -20,7 +20,7 @@ let inet_addr = Unix.inet_addr_of_string "ff0e::54:455a:3053"
module Message = struct
let encoding =
Data_encoding.(tup3 (Fixed.string 10) Peer_id.encoding int16)
Data_encoding.(tup3 (Fixed.string 10) P2p_peer.Id.encoding int16)
let length = Data_encoding.Binary.fixed_length_exn encoding
@ -40,7 +40,7 @@ let sender sock saddr my_peer_id inco_port cancelation restart =
Lwt.return_unit)
(fun exn ->
lwt_debug "(%a) error broadcasting a discovery request: %a"
Peer_id.pp my_peer_id Error_monad.pp (Exn exn)) >>= fun () ->
P2p_peer.Id.pp my_peer_id Error_monad.pp (Exn exn)) >>= fun () ->
Lwt.pick
[ (Lwt_unix.sleep delay >>= fun () -> Lwt.return (Some (delay, n + 1))) ;
(cancelation () >>= fun () -> Lwt.return_none) ;
@ -100,7 +100,7 @@ module Answerer = struct
Lwt.catch
(fun () ->
Lwt_utils.worker
(Format.asprintf "(%a) discovery answerer" Peer_id.pp my_peer_id)
(Format.asprintf "(%a) discovery answerer" P2p_peer.Id.pp my_peer_id)
(fun () -> answerer fd my_peer_id cancelation callback)
cancel)
(fun exn ->
@ -118,7 +118,7 @@ let discovery_sender =
Discovery.sender fd
saddr my_peer_id inco_port cancelation restart_discovery in
Lwt_utils.worker
(Format.asprintf "(%a) discovery sender" Peer_id.pp my_peer_id)
(Format.asprintf "(%a) discovery sender" P2p_peer.Id.pp my_peer_id)
sender cancel)
(fun exn ->
lwt_log_error "Discovery sender not started: %a"

2
src/lib_p2p/p2p_discovery.mli
View File

@ -8,6 +8,6 @@
(**************************************************************************)
type t
val create : ('msg, 'meta) P2p_connection_pool.pool -> t
val create : ('msg, 'meta) P2p_pool.t -> t
val restart : t -> unit
val shutdown : t -> unit Lwt.t

3
src/lib_p2p/p2p_io_scheduler.ml
View File

@ -17,7 +17,6 @@ let () =
if Sys.os_type <> "Win32" then
Sys.(set_signal sigpipe Signal_ignore)
open P2p_types
include Logging.Make (struct let name = "p2p.io-scheduler" end)
module Inttbl = Hashtbl.Make(struct
@ -457,7 +456,7 @@ let read_full conn ?pos ?len buf =
loop pos len
let convert ~ws ~rs =
{ Stat.total_sent = ws.Moving_average.total ;
{ P2p_stat.total_sent = ws.Moving_average.total ;
total_recv = rs.Moving_average.total ;
current_outflow = ws.average ;
current_inflow = rs.average ;

6
src/lib_p2p/p2p_io_scheduler.mli
View File

@ -23,8 +23,6 @@
num_connections).
*)
open P2p_types
type connection
(** Type of a connection. *)
@ -71,11 +69,11 @@ 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
val stat: connection -> P2p_stat.t
(** [stat conn] is a snapshot of current bandwidth usage for
[conn]. *)
val global_stat: t -> Stat.t
val global_stat: t -> P2p_stat.t
(** [global_stat sched] is a snapshot of [sched]'s bandwidth usage
(sum of [stat conn] for each [conn] in [sched]). *)

35
src/lib_p2p/p2p_maintenance.ml
View File

@ -7,9 +7,6 @@
(* *)
(**************************************************************************)
open P2p_types
open P2p_connection_pool_types
include Logging.Make (struct let name = "p2p.maintenance" end)
type bounds = {
@ -19,7 +16,7 @@ type bounds = {
max_threshold: int ;
}
type 'meta pool = Pool : ('msg, 'meta) P2p_connection_pool.t -> 'meta pool
type 'meta pool = Pool : ('msg, 'meta) P2p_pool.t -> 'meta pool
type 'meta t = {
canceler: Lwt_canceler.t ;
@ -41,7 +38,7 @@ let connectable st start_time expected =
let now = Time.now () in
let module Bounded_point_info =
List.Bounded(struct
type t = (Time.t option * Point.t)
type t = (Time.t option * P2p_point.Id.t)
let compare (t1, _) (t2, _) =
match t1, t2 with
| None, None -> 0
@ -50,13 +47,13 @@ let connectable st start_time expected =
| Some t1, Some t2 -> Time.compare t2 t1
end) in
let acc = Bounded_point_info.create expected in
P2p_connection_pool.Points.fold_known pool ~init:()
P2p_pool.Points.fold_known pool ~init:()
~f:begin fun point pi () ->
match Point_info.State.get pi with
match P2p_point.Pool_state.get pi with
| Disconnected -> begin
match Point_info.last_miss pi with
match P2p_point.Pool_info.last_miss pi with
| Some last when Time.(start_time < last)
|| Point_info.greylisted ~now pi -> ()
|| P2p_point.Pool_info.greylisted ~now pi -> ()
| last ->
Bounded_point_info.insert (last, point) acc
end
@ -83,7 +80,7 @@ let rec try_to_contact
else
List.fold_left
(fun acc point ->
P2p_connection_pool.connect
P2p_pool.connect
~timeout:st.connection_timeout pool point >>= function
| Ok _ -> acc >|= succ
| Error _ -> acc)
@ -96,7 +93,7 @@ let rec try_to_contact
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
let n_connected = P2p_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
@ -121,10 +118,10 @@ and too_few_connections st n_connected =
(* not enough contacts, ask the pals of our pals,
discover the local network and then wait *)
Option.iter ~f:P2p_discovery.restart st.disco ;
P2p_connection_pool.broadcast_bootstrap_msg pool ;
P2p_pool.broadcast_bootstrap_msg pool ;
Lwt_utils.protect ~canceler:st.canceler begin fun () ->
Lwt.pick [
P2p_connection_pool.Pool_event.wait_new_peer pool ;
P2p_pool.Pool_event.wait_new_peer pool ;
Lwt_unix.sleep 5.0 (* TODO exponential back-off ??
or wait for the existence of a
non grey-listed peer ?? *)
@ -138,11 +135,11 @@ and too_many_connections st n_connected =
(* 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.Connection.fold pool
snd @@ P2p_pool.Connection.fold 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))
else (i - 1, t >>= fun () -> P2p_pool.disconnect conn))
>>= fun () ->
maintain st
@ -153,17 +150,17 @@ let rec worker_loop st =
Lwt.pick [
Lwt_unix.sleep 120. ; (* every two minutes *)
Lwt_condition.wait st.please_maintain ; (* when asked *)
P2p_connection_pool.Pool_event.wait_too_few_connections pool ; (* limits *)
P2p_connection_pool.Pool_event.wait_too_many_connections pool
P2p_pool.Pool_event.wait_too_few_connections pool ; (* limits *)
P2p_pool.Pool_event.wait_too_many_connections pool
] >>= fun () ->
return ()
end >>=? fun () ->
let n_connected = P2p_connection_pool.active_connections pool in
let n_connected = P2p_pool.active_connections pool in
if n_connected < st.bounds.min_threshold
|| st.bounds.max_threshold < n_connected then
maintain st
else begin
P2p_connection_pool.send_swap_request pool ;
P2p_pool.send_swap_request pool ;
return ()
end
end >>= function

2
src/lib_p2p/p2p_maintenance.mli
View File

@ -36,7 +36,7 @@ type 'meta t
val run:
connection_timeout:float ->
bounds ->
('msg, 'meta) P2p_connection_pool.t ->
('msg, 'meta) P2p_pool.t ->
P2p_discovery.t option ->
'meta t

377
src/lib_p2p/p2p_connection_pool.ml → src/lib_p2p/p2p_pool.ml
View File

@ -15,9 +15,6 @@
(* TODO allow to track "requested peer_ids" 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 : {
@ -32,9 +29,9 @@ module Message = struct
type 'msg t =
| Bootstrap
| Advertise of Point.t list
| Swap_request of Point.t * Peer_id.t
| Swap_ack of Point.t * Peer_id.t
| Advertise of P2p_point.Id.t list
| Swap_request of P2p_point.Id.t * P2p_peer.Id.t
| Swap_ack of P2p_point.Id.t * P2p_peer.Id.t
| Message of 'msg
| Disconnect
@ -48,15 +45,15 @@ module Message = struct
case (Tag 0x02) null
(function Bootstrap -> Some () | _ -> None)
(fun () -> Bootstrap);
case (Tag 0x03) (Variable.list Point.encoding)
case (Tag 0x03) (Variable.list P2p_point.Id.encoding)
(function Advertise points -> Some points | _ -> None)
(fun points -> Advertise points);
case (Tag 0x04) (tup2 Point.encoding Peer_id.encoding)
case (Tag 0x04) (tup2 P2p_point.Id.encoding P2p_peer.Id.encoding)
(function
| Swap_request (point, peer_id) -> Some (point, peer_id)
| _ -> None)
(fun (point, peer_id) -> Swap_request (point, peer_id)) ;
case (Tag 0x05) (tup2 Point.encoding Peer_id.encoding)
case (Tag 0x05) (tup2 P2p_point.Id.encoding P2p_peer.Id.encoding)
(function
| Swap_ack (point, peer_id) -> Some (point, peer_id)
| _ -> None)
@ -74,16 +71,16 @@ end
module Answerer = struct
type 'msg callback = {
bootstrap: unit -> Point.t list Lwt.t ;
advertise: Point.t list -> unit Lwt.t ;
bootstrap: unit -> P2p_point.Id.t list Lwt.t ;
advertise: P2p_point.Id.t list -> unit Lwt.t ;
message: int -> 'msg -> unit Lwt.t ;
swap_request: Point.t -> Peer_id.t -> unit Lwt.t ;
swap_ack: Point.t -> Peer_id.t -> unit Lwt.t ;
swap_request: P2p_point.Id.t -> P2p_peer.Id.t -> unit Lwt.t ;
swap_ack: P2p_point.Id.t -> P2p_peer.Id.t -> unit Lwt.t ;
}
type 'msg t = {
canceler: Lwt_canceler.t ;
conn: 'msg Message.t P2p_connection.t ;
conn: 'msg Message.t P2p_socket.t ;
callback: 'msg callback ;
mutable worker: unit Lwt.t ;
}
@ -91,14 +88,14 @@ module Answerer = struct
let rec worker_loop st =
Lwt_unix.yield () >>= fun () ->
Lwt_utils.protect ~canceler:st.canceler begin fun () ->
P2p_connection.read st.conn
P2p_socket.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
match P2p_socket.write_now st.conn (Advertise points) with
| Ok _sent ->
(* if not sent then ?? TODO count dropped message ?? *)
worker_loop st
@ -121,7 +118,7 @@ module Answerer = struct
| Ok (_, Disconnect) | Error [P2p_io_scheduler.Connection_closed] ->
Lwt_canceler.cancel st.canceler >>= fun () ->
Lwt.return_unit
| Error [P2p_connection.Decoding_error] ->
| Error [P2p_socket.Decoding_error] ->
(* TODO: Penalize peer... *)
Lwt_canceler.cancel st.canceler >>= fun () ->
Lwt.return_unit
@ -150,18 +147,16 @@ module Answerer = struct
end
module Log_event = Connection_pool_log_event
type config = {
identity : Identity.t ;
identity : P2p_identity.t ;
proof_of_work_target : Crypto_box.target ;
trusted_points : Point.t list ;
trusted_points : P2p_point.Id.t list ;
peers_file : string ;
closed_network : bool ;
listening_port : port option ;
listening_port : P2p_addr.port option ;
min_connections : int ;
max_connections : int ;
max_incoming_connections : int ;
@ -189,27 +184,27 @@ type 'meta meta_config = {
type 'msg message_config = {
encoding : 'msg encoding list ;
versions : P2p_types.Version.t list;
versions : P2p_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 ;
my_id_points : unit P2p_point.Table.t ;
known_peer_ids :
(('msg, 'meta) connection, 'meta) Peer_info.t Peer_id.Table.t ;
(('msg, 'meta) connection, 'meta) P2p_peer.Pool_info.t P2p_peer.Table.t ;
connected_peer_ids :
(('msg, 'meta) connection, 'meta) Peer_info.t Peer_id.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 : Lwt_canceler.t Point.Table.t ;
(('msg, 'meta) connection, 'meta) P2p_peer.Pool_info.t P2p_peer.Table.t ;
known_points : ('msg, 'meta) connection P2p_point.Pool_info.t P2p_point.Table.t ;
connected_points : ('msg, 'meta) connection P2p_point.Pool_info.t P2p_point.Table.t ;
incoming : Lwt_canceler.t P2p_point.Table.t ;
io_sched : P2p_io_scheduler.t ;
encoding : 'msg Message.t Data_encoding.t ;
events : events ;
watcher : Log_event.t Lwt_watcher.input ;
watcher : P2p_connection.Pool_event.t Lwt_watcher.input ;
mutable new_connection_hook :
(Peer_id.t -> ('msg, 'meta) connection -> unit) list ;
(P2p_peer.Id.t -> ('msg, 'meta) connection -> unit) list ;
mutable latest_accepted_swap : Time.t ;
mutable latest_succesfull_swap : Time.t ;
}
@ -224,11 +219,11 @@ and events = {
and ('msg, 'meta) connection = {
canceler : Lwt_canceler.t ;
messages : (int * 'msg) Lwt_pipe.t ;
conn : 'msg Message.t P2p_connection.t ;
peer_info : (('msg, 'meta) connection, 'meta) Peer_info.t ;
point_info : ('msg, 'meta) connection Point_info.t option ;
conn : 'msg Message.t P2p_socket.t ;
peer_info : (('msg, 'meta) connection, 'meta) P2p_peer.Pool_info.t ;
point_info : ('msg, 'meta) connection P2p_point.Pool_info.t option ;
answerer : 'msg Answerer.t Lazy.t ;
mutable last_sent_swap_request : (Time.t * Peer_id.t) option ;
mutable last_sent_swap_request : (Time.t * P2p_peer.Id.t) option ;
mutable wait_close : bool ;
}
@ -248,8 +243,8 @@ end
let watch { watcher } = Lwt_watcher.create_stream watcher
let log { watcher } event = Lwt_watcher.notify watcher event
module GcPointSet = List.Bounded(struct
type t = Time.t * Point.t
module Gc_point_set = List.Bounded(struct
type t = Time.t * P2p_point.Id.t
let compare (x, _) (y, _) = - (Time.compare x y)
end)
@ -258,37 +253,37 @@ let gc_points ({ config = { max_known_points } ; known_points } as pool) =
| None -> ()
| Some (_, target) ->
let now = Time.now () in (* TODO: maybe time of discovery? *)
let table = GcPointSet.create target in
Point.Table.iter (fun p point_info ->
if Point_info.State.is_disconnected point_info then
let table = Gc_point_set.create target in
P2p_point.Table.iter (fun p point_info ->
if P2p_point.Pool_state.is_disconnected point_info then
let time =
match Point_info.last_miss point_info with
match P2p_point.Pool_info.last_miss point_info with
| None -> now
| Some t -> t in
GcPointSet.insert (time, p) table
Gc_point_set.insert (time, p) table
) known_points ;
let to_remove = GcPointSet.get table in
let to_remove = Gc_point_set.get table in
ListLabels.iter to_remove ~f:begin fun (_, p) ->
Point.Table.remove known_points p
P2p_point.Table.remove known_points p
end ;
log pool Gc_points
let register_point pool ?trusted _source_peer_id (addr, port as point) =
match Point.Table.find pool.known_points point with
match P2p_point.Table.find pool.known_points point with
| exception Not_found ->
let point_info = Point_info.create ?trusted addr port in
let point_info = P2p_point.Pool_info.create ?trusted addr port in
Option.iter pool.config.max_known_points ~f:begin fun (max, _) ->
if Point.Table.length pool.known_points >= max then gc_points pool
if P2p_point.Table.length pool.known_points >= max then gc_points pool
end ;
Point.Table.add pool.known_points point point_info ;
P2p_point.Table.add pool.known_points point point_info ;
log pool (New_point point) ;
point_info
| point_info -> point_info
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)
| [P2p_socket.Myself (addr, Some port)] ->
P2p_point.Table.add pool.my_id_points (addr, port) () ;
P2p_point.Table.remove pool.known_points (addr, port)
| _ -> ()
@ -299,8 +294,8 @@ let may_register_my_id_point pool = function
case of a flood attack, the newly added infos will probably belong
to peer_ids with the same (low) score and removing the most recent ones
ensure that older (and probably legit) peer_id infos are kept. *)
module GcPeer_idSet = List.Bounded(struct
type t = float * Time.t * Peer_id.t
module Gc_peer_set = List.Bounded(struct
type t = float * Time.t * P2p_peer.Id.t
let compare (s, t, _) (s', t', _) =
let score_cmp = Pervasives.compare s s' in
if score_cmp = 0 then Time.compare t t' else - score_cmp
@ -312,27 +307,27 @@ let gc_peer_ids ({ meta_config = { score } ;
match max_known_peer_ids with
| None -> ()
| Some (_, target) ->
let table = GcPeer_idSet.create target in
Peer_id.Table.iter (fun peer_id peer_info ->
let created = Peer_info.created peer_info in
let score = score @@ Peer_info.metadata peer_info in
GcPeer_idSet.insert (score, created, peer_id) table
let table = Gc_peer_set.create target in
P2p_peer.Table.iter (fun peer_id peer_info ->
let created = P2p_peer.Pool_info.created peer_info in
let score = score @@ P2p_peer.Pool_info.metadata peer_info in
Gc_peer_set.insert (score, created, peer_id) table
) known_peer_ids ;
let to_remove = GcPeer_idSet.get table in
let to_remove = Gc_peer_set.get table in
ListLabels.iter to_remove ~f:begin fun (_, _, peer_id) ->
Peer_id.Table.remove known_peer_ids peer_id
P2p_peer.Table.remove known_peer_ids peer_id
end ;
log pool Gc_peer_ids
let register_peer pool peer_id =
match Peer_id.Table.find pool.known_peer_ids peer_id with
match P2p_peer.Table.find pool.known_peer_ids peer_id with
| exception Not_found ->
Lwt_condition.broadcast pool.events.new_peer () ;
let peer = Peer_info.create peer_id ~metadata:pool.meta_config.initial in
let peer = P2p_peer.Pool_info.create peer_id ~metadata:pool.meta_config.initial in
Option.iter pool.config.max_known_peer_ids ~f:begin fun (max, _) ->
if Peer_id.Table.length pool.known_peer_ids >= max then gc_peer_ids pool
if P2p_peer.Table.length pool.known_peer_ids >= max then gc_peer_ids pool
end ;
Peer_id.Table.add pool.known_peer_ids peer_id peer ;
P2p_peer.Table.add pool.known_peer_ids peer_id peer ;
log pool (New_peer peer_id) ;
peer
| peer -> peer
@ -344,7 +339,7 @@ let read { messages ; conn } =
Lwt.catch
(fun () -> Lwt_pipe.pop messages >>= fun (s, msg) ->
lwt_debug "%d bytes message popped from queue %a\027[0m"
s Connection_info.pp (P2p_connection.info conn) >>= fun () ->
s P2p_connection.Info.pp (P2p_socket.info conn) >>= fun () ->
return msg)
(fun _ (* Closed *) -> fail P2p_io_scheduler.Connection_closed)
@ -354,111 +349,111 @@ let is_readable { messages } =
(fun _ (* Closed *) -> fail P2p_io_scheduler.Connection_closed)
let write { conn } msg =
P2p_connection.write conn (Message msg)
P2p_socket.write conn (Message msg)
let write_sync { conn } msg =
P2p_connection.write_sync conn (Message msg)
P2p_socket.write_sync conn (Message msg)
let raw_write_sync { conn } buf =
P2p_connection.raw_write_sync conn buf
P2p_socket.raw_write_sync conn buf
let write_now { conn } msg =
P2p_connection.write_now conn (Message msg)
P2p_socket.write_now conn (Message msg)
let write_all pool msg =
Peer_id.Table.iter
P2p_peer.Table.iter
(fun _peer_id peer_info ->
match Peer_info.State.get peer_info with
match P2p_peer.Pool_state.get peer_info with
| Running { data = conn } ->
ignore (write_now conn msg : bool tzresult )
| _ -> ())
pool.connected_peer_ids
let broadcast_bootstrap_msg pool =
Peer_id.Table.iter
P2p_peer.Table.iter
(fun _peer_id peer_info ->
match Peer_info.State.get peer_info with
match P2p_peer.Pool_state.get peer_info with
| Running { data = { conn } } ->
ignore (P2p_connection.write_now conn Bootstrap : bool tzresult )
ignore (P2p_socket.write_now conn Bootstrap : bool tzresult )
| _ -> ())
pool.connected_peer_ids
(***************************************************************************)
module Peer_ids = struct
module Peers = struct
type ('msg, 'meta) info = (('msg, 'meta) connection, 'meta) Peer_info.t
type ('msg, 'meta) info = (('msg, 'meta) connection, 'meta) P2p_peer.Pool_info.t
let info { known_peer_ids } point =
try Some (Peer_id.Table.find known_peer_ids point)
try Some (P2p_peer.Table.find known_peer_ids point)
with Not_found -> None
let get_metadata pool peer_id =
try Peer_info.metadata (Peer_id.Table.find pool.known_peer_ids peer_id)
try P2p_peer.Pool_info.metadata (P2p_peer.Table.find pool.known_peer_ids peer_id)
with Not_found -> pool.meta_config.initial
let get_score pool peer_id =
pool.meta_config.score (get_metadata pool peer_id)
let set_metadata pool peer_id data =
Peer_info.set_metadata (register_peer pool peer_id) data
P2p_peer.Pool_info.set_metadata (register_peer pool peer_id) data
let get_trusted pool peer_id =
try Peer_info.trusted (Peer_id.Table.find pool.known_peer_ids peer_id)
try P2p_peer.Pool_info.trusted (P2p_peer.Table.find pool.known_peer_ids peer_id)
with Not_found -> false
let set_trusted pool peer_id =
try Peer_info.set_trusted (register_peer pool peer_id)
try P2p_peer.Pool_info.set_trusted (register_peer pool peer_id)
with Not_found -> ()
let unset_trusted pool peer_id =
try Peer_info.unset_trusted (Peer_id.Table.find pool.known_peer_ids peer_id)
try P2p_peer.Pool_info.unset_trusted (P2p_peer.Table.find pool.known_peer_ids peer_id)
with Not_found -> ()
let fold_known pool ~init ~f =
Peer_id.Table.fold f pool.known_peer_ids init
P2p_peer.Table.fold f pool.known_peer_ids init
let fold_connected pool ~init ~f =
Peer_id.Table.fold f pool.connected_peer_ids init
P2p_peer.Table.fold f pool.connected_peer_ids init
end
module Points = struct
type ('msg, 'meta) info = ('msg, 'meta) connection Point_info.t
type ('msg, 'meta) info = ('msg, 'meta) connection P2p_point.Pool_info.t
let info { known_points } point =
try Some (Point.Table.find known_points point)
try Some (P2p_point.Table.find known_points point)
with Not_found -> None
let get_trusted pool point =
try Point_info.trusted (Point.Table.find pool.known_points point)
try P2p_point.Pool_info.trusted (P2p_point.Table.find pool.known_points point)
with Not_found -> false
let set_trusted pool point =
try
Point_info.set_trusted
P2p_point.Pool_info.set_trusted
(register_point pool pool.config.identity.peer_id point)
with Not_found -> ()
let unset_trusted pool peer_id =
try Point_info.unset_trusted (Point.Table.find pool.known_points peer_id)
try P2p_point.Pool_info.unset_trusted (P2p_point.Table.find pool.known_points peer_id)
with Not_found -> ()
let fold_known pool ~init ~f =
Point.Table.fold f pool.known_points init
P2p_point.Table.fold f pool.known_points init
let fold_connected pool ~init ~f =
Point.Table.fold f pool.connected_points init
P2p_point.Table.fold f pool.connected_points init
end
module Connection = struct
let fold pool ~init ~f =
Peer_ids.fold_connected pool ~init ~f:begin fun peer_id peer_info acc ->
match Peer_info.State.get peer_info with
Peers.fold_connected pool ~init ~f:begin fun peer_id peer_info acc ->
match P2p_peer.Pool_state.get peer_info with
| Running { data } -> f peer_id data acc
| _ -> acc
end
@ -471,7 +466,7 @@ module Connection = struct
fold pool ~init:[] ~f:begin fun _peer conn acc ->
match different_than with
| Some excluded_conn
when P2p_connection.equal conn.conn excluded_conn.conn -> acc
when P2p_socket.equal conn.conn excluded_conn.conn -> acc
| Some _ | None -> conn :: acc
end in
match candidates with
@ -484,9 +479,9 @@ module Connection = struct
fold pool ~init:[] ~f:begin fun _peer conn acc ->
match different_than with
| Some excluded_conn
when P2p_connection.equal conn.conn excluded_conn.conn -> acc
when P2p_socket.equal conn.conn excluded_conn.conn -> acc
| Some _ | None ->
let ci = P2p_connection.info conn.conn in
let ci = P2p_socket.info conn.conn in
match ci.id_point with
| _, None -> acc
| addr, Some port -> ((addr, port), ci.peer_id, conn) :: acc
@ -497,18 +492,18 @@ module Connection = struct
Some (List.nth candidates (Random.int @@ List.length candidates))
let stat { conn } =
P2p_connection.stat conn
P2p_socket.stat conn
let score { meta_config = { score }} meta = score meta
let info { conn } =
P2p_connection.info conn
P2p_socket.info conn
let find_by_peer_id pool peer_id =
Option.apply
(Peer_ids.info pool peer_id)
(Peers.info pool peer_id)
~f:(fun p ->
match Peer_info.State.get p with
match P2p_peer.Pool_state.get p with
| Running { data } -> Some data
| _ -> None)
@ -516,7 +511,7 @@ module Connection = struct
Option.apply
(Points.info pool point)
~f:(fun p ->
match Point_info.State.get p with
match P2p_point.Pool_state.get p with
| Running { data } -> Some data
| _ -> None)
@ -528,7 +523,7 @@ let pool_stat { io_sched } =
(***************************************************************************)
type error += Rejected of Peer_id.t
type error += Rejected of P2p_peer.Id.t
type error += Pending_connection
type error += Connected
type error += Connection_closed = P2p_io_scheduler.Connection_closed
@ -537,13 +532,13 @@ type error += Closed_network
type error += Too_many_connections
let fail_unless_disconnected_point point_info =
match Point_info.State.get point_info with
match P2p_point.Pool_state.get point_info with
| Disconnected -> return ()
| Requested _ | Accepted _ -> fail Pending_connection
| Running _ -> fail Connected
let fail_unless_disconnected_peer_id peer_info =
match Peer_info.State.get peer_info with
match P2p_peer.Pool_state.get peer_info with
| Disconnected -> return ()
| Accepted _ -> fail Pending_connection
| Running _ -> fail Connected
@ -551,10 +546,10 @@ let fail_unless_disconnected_peer_id peer_info =
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 disconnected1 = P2p_point.Pool_state.is_disconnected p1
and disconnected2 = P2p_point.Pool_state.is_disconnected p2 in
let compare_last_seen p1 p2 =
match Point_info.last_seen p1, Point_info.last_seen p2 with
match P2p_point.Pool_info.last_seen p1, P2p_point.Pool_info.last_seen p2 with
| None, None -> Random.int 2 * 2 - 1 (* HACK... *)
| Some _, None -> 1
| None, Some _ -> -1
@ -576,40 +571,40 @@ let rec connect ~timeout pool point =
Lwt_utils.with_timeout ~canceler timeout begin fun canceler ->
let point_info =
register_point pool pool.config.identity.peer_id point in
let addr, port as point = Point_info.point point_info in
let addr, port as point = P2p_point.Pool_info.point point_info in
fail_unless
(not pool.config.closed_network || Point_info.trusted point_info)
(not pool.config.closed_network || P2p_point.Pool_info.trusted point_info)
Closed_network >>=? fun () ->
fail_unless_disconnected_point point_info >>=? fun () ->
Point_info.State.set_requested point_info canceler ;
P2p_point.Pool_state.set_requested point_info 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_debug "connect: %a" P2p_point.Id.pp point >>= fun () ->
Lwt_utils.protect ~canceler begin fun () ->
log pool (Outgoing_connection point) ;
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 point_info ;
lwt_debug "connect: %a -> disconnect" P2p_point.Id.pp point >>= fun () ->
P2p_point.Pool_state.set_disconnected point_info ;
Lwt_utils.safe_close fd >>= fun () ->
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 () ->
lwt_debug "connect: %a -> authenticate" P2p_point.Id.pp point >>= fun () ->
authenticate pool ~point_info canceler fd point
end
and authenticate pool ?point_info canceler fd point =
let incoming = point_info = None in
lwt_debug "authenticate: %a%s"
Point.pp point
P2p_point.Id.pp point
(if incoming then " incoming" else "") >>= fun () ->
Lwt_utils.protect ~canceler begin fun () ->
P2p_connection.authenticate
P2p_socket.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
@ -620,31 +615,31 @@ and authenticate pool ?point_info canceler fd point =
| [ Lwt_utils.Canceled ] ->
(* Currently only on time out *)
lwt_debug "authenticate: %a%s -> canceled"
Point.pp point
P2p_point.Id.pp point
(if incoming then " incoming" else "")
| err ->
(* Authentication incorrect! *)
lwt_debug "@[authenticate: %a%s -> failed@ %a@]"
Point.pp point
P2p_point.Id.pp point
(if incoming then " incoming" else "")
pp_print_error err
end >>= fun () ->
may_register_my_id_point pool err ;
log pool (Authentication_failed point) ;
if incoming then
Point.Table.remove pool.incoming point
P2p_point.Table.remove pool.incoming point
else
Option.iter ~f:Point_info.State.set_disconnected point_info ;
Option.iter ~f:P2p_point.Pool_state.set_disconnected point_info ;
Lwt.return (Error err)
end >>=? fun (info, auth_fd) ->
(* Authentication correct! *)
lwt_debug "authenticate: %a -> auth %a"
Point.pp point
Connection_info.pp info >>= fun () ->
P2p_point.Id.pp point
P2p_connection.Info.pp info >>= fun () ->
let remote_point_info =
match info.id_point with
| addr, Some port
when not (Point.Table.mem pool.my_id_points (addr, port)) ->
when not (P2p_point.Table.mem pool.my_id_points (addr, port)) ->
Some (register_point pool info.peer_id (addr, port))
| _ -> None in
let connection_point_info =
@ -653,22 +648,22 @@ and authenticate pool ?point_info canceler fd point =
| Some _ as point_info, _ | _, (Some _ as point_info) -> point_info in
let peer_info = register_peer pool info.peer_id in
let acceptable_versions =
Version.common info.versions pool.message_config.versions
P2p_version.common info.versions pool.message_config.versions
in
let acceptable_point =
Option.unopt_map connection_point_info
~default:(not pool.config.closed_network)
~f:begin fun connection_point_info ->
match Point_info.State.get connection_point_info with
match P2p_point.Pool_state.get connection_point_info with
| Requested _ -> not incoming
| Disconnected ->
not pool.config.closed_network
|| Point_info.trusted connection_point_info
|| P2p_point.Pool_info.trusted connection_point_info
| Accepted _ | Running _ -> false
end
in
let acceptable_peer_id =
match Peer_info.State.get peer_info with
match P2p_peer.Pool_state.get peer_info with
| Accepted _ ->
(* TODO: in some circumstances cancel and accept... *)
false
@ -676,41 +671,41 @@ and authenticate pool ?point_info canceler fd point =
| Disconnected -> true
in
if incoming then
Point.Table.remove pool.incoming point ;
P2p_point.Table.remove pool.incoming point ;
match acceptable_versions with
| Some version when acceptable_peer_id && acceptable_point -> begin
log pool (Accepting_request (point, info.id_point, info.peer_id)) ;
Option.iter connection_point_info
~f:(fun point_info ->
Point_info.State.set_accepted point_info info.peer_id canceler) ;
Peer_info.State.set_accepted peer_info info.id_point canceler ;
P2p_point.Pool_state.set_accepted point_info info.peer_id canceler) ;
P2p_peer.Pool_state.set_accepted peer_info info.id_point canceler ;
lwt_debug "authenticate: %a -> accept %a"
Point.pp point
Connection_info.pp info >>= fun () ->
P2p_point.Id.pp point
P2p_connection.Info.pp info >>= fun () ->
Lwt_utils.protect ~canceler begin fun () ->
P2p_connection.accept
P2p_socket.accept
?incoming_message_queue_size:pool.config.incoming_message_queue_size
?outgoing_message_queue_size:pool.config.outgoing_message_queue_size
?binary_chunks_size:pool.config.binary_chunks_size
auth_fd pool.encoding >>= fun conn ->
lwt_debug "authenticate: %a -> Connected %a"
Point.pp point
Connection_info.pp info >>= fun () ->
P2p_point.Id.pp point
P2p_connection.Info.pp info >>= fun () ->
Lwt.return conn
end ~on_error: begin fun err ->
if incoming then
log pool
(Request_rejected (point, Some (info.id_point, info.peer_id))) ;
lwt_debug "authenticate: %a -> rejected %a"
Point.pp point
Connection_info.pp info >>= fun () ->
P2p_point.Id.pp point
P2p_connection.Info.pp info >>= fun () ->
Option.iter connection_point_info
~f:Point_info.State.set_disconnected ;
Peer_info.State.set_disconnected peer_info ;
~f:P2p_point.Pool_state.set_disconnected ;
P2p_peer.Pool_state.set_disconnected peer_info ;
Lwt.return (Error err)
end >>=? fun conn ->
let id_point =
match info.id_point, Option.map ~f:Point_info.point point_info with
match info.id_point, Option.map ~f:P2p_point.Pool_info.point point_info with
| (addr, _), Some (_, port) -> addr, Some port
| id_point, None -> id_point in
return
@ -721,19 +716,19 @@ and authenticate pool ?point_info canceler fd point =
| _ -> begin
log pool (Rejecting_request (point, info.id_point, info.peer_id)) ;
lwt_debug "authenticate: %a -> kick %a point: %B peer_id: %B"
Point.pp point
Connection_info.pp info
P2p_point.Id.pp point
P2p_connection.Info.pp info
acceptable_point acceptable_peer_id >>= fun () ->
P2p_connection.kick auth_fd >>= fun () ->
P2p_socket.kick auth_fd >>= fun () ->
if not incoming then begin
Option.iter ~f:Point_info.State.set_disconnected point_info ;
(* FIXME Peer_info.State.set_disconnected ~requested:true peer_info ; *)
Option.iter ~f:P2p_point.Pool_state.set_disconnected point_info ;
(* FIXME P2p_peer.Pool_state.set_disconnected ~requested:true peer_info ; *)
end ;
fail (Rejected info.peer_id)
end
and create_connection pool p2p_conn id_point point_info peer_info _version =
let peer_id = Peer_info.peer_id peer_info in
let peer_id = P2p_peer.Pool_info.peer_id peer_info in
let canceler = Lwt_canceler.create () in
let size =
Option.map pool.config.incoming_app_message_queue_size
@ -759,30 +754,30 @@ and create_connection pool p2p_conn id_point point_info peer_info _version =
last_sent_swap_request = None } in
ignore (Lazy.force answerer) ;
Option.iter point_info ~f:begin fun point_info ->
let point = Point_info.point point_info in
Point_info.State.set_running point_info peer_id conn ;
Point.Table.add pool.connected_points point point_info ;
let point = P2p_point.Pool_info.point point_info in
P2p_point.Pool_state.set_running point_info peer_id conn ;
P2p_point.Table.add pool.connected_points point point_info ;
end ;
log pool (Connection_established (id_point, peer_id)) ;
Peer_info.State.set_running peer_info id_point conn ;
Peer_id.Table.add pool.connected_peer_ids peer_id peer_info ;
P2p_peer.Pool_state.set_running peer_info id_point conn ;
P2p_peer.Table.add pool.connected_peer_ids peer_id peer_info ;
Lwt_condition.broadcast pool.events.new_connection () ;
Lwt_canceler.on_cancel canceler begin fun () ->
lwt_debug "Disconnect: %a (%a)"
Peer_id.pp peer_id Id_point.pp id_point >>= fun () ->
Option.iter ~f:Point_info.State.set_disconnected point_info ;
P2p_peer.Id.pp peer_id P2p_connection.Id.pp id_point >>= fun () ->
Option.iter ~f:P2p_point.Pool_state.set_disconnected point_info ;
log pool (Disconnection peer_id) ;
Peer_info.State.set_disconnected peer_info ;
P2p_peer.Pool_state.set_disconnected peer_info ;
Option.iter point_info ~f:begin fun point_info ->
Point.Table.remove pool.connected_points (Point_info.point point_info) ;
P2p_point.Table.remove pool.connected_points (P2p_point.Pool_info.point point_info) ;
end ;
Peer_id.Table.remove pool.connected_peer_ids peer_id ;
P2p_peer.Table.remove pool.connected_peer_ids peer_id ;
if pool.config.max_connections <= active_connections pool then begin
Lwt_condition.broadcast pool.events.too_many_connections () ;
log pool Too_many_connections ;
end ;
Lwt_pipe.close messages ;
P2p_connection.close ~wait:conn.wait_close conn.conn
P2p_socket.close ~wait:conn.wait_close conn.conn
end ;
List.iter (fun f -> f peer_id conn) pool.new_connection_hook ;
if active_connections pool < pool.config.min_connections then begin
@ -796,31 +791,31 @@ and disconnect ?(wait = false) conn =
Answerer.shutdown (Lazy.force conn.answerer)
and register_new_points pool conn =
let source_peer_id = Peer_info.peer_id conn.peer_info in
let source_peer_id = P2p_peer.Pool_info.peer_id conn.peer_info in
fun points ->
List.iter (register_new_point pool source_peer_id) points ;
Lwt.return_unit
and register_new_point pool _source_peer_id point =
if not (Point.Table.mem pool.my_id_points point) then
if not (P2p_point.Table.mem pool.my_id_points point) then
ignore (register_point pool _source_peer_id point)
and list_known_points pool _conn () =
let knowns =
Point.Table.fold
P2p_point.Table.fold
(fun _ point_info acc -> point_info :: acc)
pool.known_points [] in
let best_knowns =
List.take_n ~compare:compare_known_point_info 50 knowns in
Lwt.return (List.map Point_info.point best_knowns)
Lwt.return (List.map P2p_point.Pool_info.point best_knowns)
and active_connections pool = Peer_id.Table.length pool.connected_peer_ids
and active_connections pool = P2p_peer.Table.length pool.connected_peer_ids
and swap_request pool conn new_point _new_peer_id =
let source_peer_id = Peer_info.peer_id conn.peer_info in
let source_peer_id = P2p_peer.Pool_info.peer_id conn.peer_info in
log pool (Swap_request_received { source = source_peer_id }) ;
lwt_log_info
"Swap request received from %a" Peer_id.pp source_peer_id >>= fun () ->
"Swap request received from %a" P2p_peer.Id.pp source_peer_id >>= fun () ->
(* Ignore if already connected to peer or already swapped less
than <swap_linger> seconds ago. *)
let now = Time.now () in
@ -830,16 +825,16 @@ and swap_request pool conn new_point _new_peer_id =
(Time.max pool.latest_succesfull_swap pool.latest_accepted_swap) in
let new_point_info = register_point pool source_peer_id new_point in
if span_since_last_swap < int_of_float pool.config.swap_linger
|| not (Point_info.State.is_disconnected new_point_info) then begin
|| not (P2p_point.Pool_state.is_disconnected new_point_info) then begin
log pool (Swap_request_ignored { source = source_peer_id }) ;
lwt_log_info "Ignoring swap request from %a" Peer_id.pp source_peer_id
lwt_log_info "Ignoring swap request from %a" P2p_peer.Id.pp source_peer_id
end else begin
match Connection.random_lowid pool with
| None ->
lwt_log_info
"No swap candidate for %a" Peer_id.pp source_peer_id
"No swap candidate for %a" P2p_peer.Id.pp source_peer_id
| Some (proposed_point, proposed_peer_id, _proposed_conn) ->
match P2p_connection.write_now
match P2p_socket.write_now
conn.conn (Swap_ack (proposed_point, proposed_peer_id)) with
| Ok true ->
log pool (Swap_ack_sent { source = source_peer_id }) ;
@ -854,10 +849,10 @@ and swap_request pool conn new_point _new_peer_id =
end
and swap_ack pool conn new_point _new_peer_id =
let source_peer_id = Peer_info.peer_id conn.peer_info in
let source_peer_id = P2p_peer.Pool_info.peer_id conn.peer_info in
log pool (Swap_ack_received { source = source_peer_id }) ;
lwt_log_info
"Swap ack received from %a" Peer_id.pp source_peer_id >>= fun () ->
"Swap ack received from %a" P2p_peer.Id.pp source_peer_id >>= fun () ->
match conn.last_sent_swap_request with
| None -> Lwt.return_unit (* ignore *)
| Some (_time, proposed_peer_id) ->
@ -869,13 +864,13 @@ and swap_ack pool conn new_point _new_peer_id =
Lwt.return_unit
and swap pool conn current_peer_id new_point =
let source_peer_id = Peer_info.peer_id conn.peer_info in
let source_peer_id = P2p_peer.Pool_info.peer_id conn.peer_info in
pool.latest_accepted_swap <- Time.now () ;
connect ~timeout:10. pool new_point >>= function
| Ok _new_conn -> begin
pool.latest_succesfull_swap <- Time.now () ;
log pool (Swap_success { source = source_peer_id }) ;
lwt_log_info "Swap to %a succeeded" Point.pp new_point >>= fun () ->
lwt_log_info "Swap to %a succeeded" P2p_point.Id.pp new_point >>= fun () ->
match Connection.find_by_peer_id pool current_peer_id with
| None -> Lwt.return_unit
| Some conn ->
@ -888,20 +883,20 @@ and swap pool conn current_peer_id new_point =
match err with
| [ Lwt_utils.Timeout ] ->
lwt_debug "Swap to %a was interupted: %a"
Point.pp new_point pp_print_error err
P2p_point.Id.pp new_point pp_print_error err
| _ ->
lwt_log_error "Swap to %a failed: %a"
Point.pp new_point pp_print_error err
P2p_point.Id.pp new_point pp_print_error err
end
let accept pool fd point =
log pool (Incoming_connection point) ;
if pool.config.max_incoming_connections <= Point.Table.length pool.incoming
if pool.config.max_incoming_connections <= P2p_point.Table.length pool.incoming
|| pool.config.max_connections <= active_connections pool then
Lwt.async (fun () -> Lwt_utils.safe_close fd)
else
let canceler = Lwt_canceler.create () in
Point.Table.add pool.incoming point canceler ;
P2p_point.Table.add pool.incoming point canceler ;
Lwt.async begin fun () ->
Lwt_utils.with_timeout
~canceler pool.config.authentification_timeout
@ -919,7 +914,7 @@ let send_swap_request pool =
log pool (Swap_request_sent { source = recipient_peer_id }) ;
recipient.last_sent_swap_request <-
Some (Time.now (), proposed_peer_id) ;
ignore (P2p_connection.write_now recipient.conn
ignore (P2p_socket.write_now recipient.conn
(Swap_request (proposed_point, proposed_peer_id)))
(***************************************************************************)
@ -933,12 +928,12 @@ let create config meta_config message_config io_sched =
} in
let pool = {
config ; meta_config ; message_config ;
my_id_points = Point.Table.create 7 ;
known_peer_ids = Peer_id.Table.create 53 ;
connected_peer_ids = Peer_id.Table.create 53 ;
known_points = Point.Table.create 53 ;
connected_points = Point.Table.create 53 ;
incoming = Point.Table.create 53 ;
my_id_points = P2p_point.Table.create 7 ;
known_peer_ids = P2p_peer.Table.create 53 ;
connected_peer_ids = P2p_peer.Table.create 53 ;
known_points = P2p_point.Table.create 53 ;
connected_points = P2p_point.Table.create 53 ;
incoming = P2p_point.Table.create 53 ;
io_sched ;
encoding = Message.encoding message_config.encoding ;
events ;
@ -948,12 +943,12 @@ let create config meta_config message_config io_sched =
latest_succesfull_swap = Time.epoch ;
} in
List.iter (Points.set_trusted pool) config.trusted_points ;
Peer_info.File.load config.peers_file meta_config.encoding >>= function
P2p_peer.Pool_info.File.load config.peers_file meta_config.encoding >>= function
| Ok peer_ids ->
List.iter
(fun peer_info ->
let peer_id = Peer_info.peer_id peer_info in
Peer_id.Table.add pool.known_peer_ids peer_id peer_info)
let peer_id = P2p_peer.Pool_info.peer_id peer_info in
P2p_peer.Table.add pool.known_peer_ids peer_id peer_info)
peer_ids ;
Lwt.return pool
| Error err ->
@ -962,23 +957,23 @@ let create config meta_config message_config io_sched =
Lwt.return pool
let destroy pool =
Point.Table.fold (fun _point point_info acc ->
match Point_info.State.get point_info with
P2p_point.Table.fold (fun _point point_info acc ->
match P2p_point.Pool_state.get point_info with
| Requested { cancel } | Accepted { cancel } ->
Lwt_canceler.cancel cancel >>= fun () -> acc
| Running { data = conn } ->
disconnect conn >>= fun () -> acc
| Disconnected -> acc)
pool.known_points @@
Peer_id.Table.fold (fun _peer_id peer_info acc ->
match Peer_info.State.get peer_info with
P2p_peer.Table.fold (fun _peer_id peer_info acc ->
match P2p_peer.Pool_state.get peer_info with
| Accepted { cancel } ->
Lwt_canceler.cancel cancel >>= fun () -> acc
| Running { data = conn } ->
disconnect conn >>= fun () -> acc
| Disconnected -> acc)
pool.known_peer_ids @@
Point.Table.fold (fun _point canceler acc ->
P2p_point.Table.fold (fun _point canceler acc ->
Lwt_canceler.cancel canceler >>= fun () -> acc)
pool.incoming Lwt.return_unit

79
src/lib_p2p/p2p_connection_pool.mli → src/lib_p2p/p2p_pool.mli
View File

@ -22,9 +22,6 @@
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 ;
@ -43,13 +40,13 @@ type ('msg, 'meta) pool = ('msg, 'meta) t
type config = {
identity : Identity.t ;
identity : P2p_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 ;
trusted_points : P2p_point.Id.t list ;
(** List of hard-coded known peers to bootstrap the network from. *)
peers_file : string ;
@ -60,7 +57,7 @@ type config = {
(** If [true], the only accepted connections are from peers whose
addresses are in [trusted_peers]. *)
listening_port : port option ;
listening_port : P2p_addr.port option ;
(** If provided, it will be passed to [P2p_connection.authenticate]
when we authenticate against a new peer. *)
@ -126,7 +123,7 @@ type 'meta meta_config = {
type 'msg message_config = {
encoding : 'msg encoding list ;
versions : P2p_types.Version.t list;
versions : P2p_version.t list;
}
val create:
@ -146,7 +143,7 @@ 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
val pool_stat: ('msg, 'meta) pool -> P2p_stat.t
(** [pool_stat pool] is a snapshot of current bandwidth usage for the
entire [pool]. *)
@ -186,19 +183,19 @@ type ('msg, 'meta) connection
type error += Pending_connection
type error += Connected
type error += Connection_refused
type error += Rejected of Peer_id.t
type error += Rejected of P2p_peer.Id.t
type error += Too_many_connections
type error += Closed_network
val connect:
timeout:float ->
('msg, 'meta) pool -> Point.t ->
('msg, 'meta) pool -> P2p_point.Id.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
('msg, 'meta) pool -> Lwt_unix.file_descr -> P2p_point.Id.t -> unit
(** [accept pool fd point] instructs [pool] to start the process of
accepting a connection from [fd]. Used by [P2p]. *)
@ -209,32 +206,32 @@ val disconnect:
module Connection : sig
val info: ('msg, 'meta) connection -> Connection_info.t
val info: ('msg, 'meta) connection -> P2p_connection.Info.t
val stat: ('msg, 'meta) connection -> Stat.t
val stat: ('msg, 'meta) connection -> P2p_stat.t
(** [stat conn] is a snapshot of current bandwidth usage for
[conn]. *)
val fold:
('msg, 'meta) pool ->
init:'a ->
f:(Peer_id.t -> ('msg, 'meta) connection -> 'a -> 'a) ->
f:(P2p_peer.Id.t -> ('msg, 'meta) connection -> 'a -> 'a) ->
'a
val list:
('msg, 'meta) pool -> (Peer_id.t * ('msg, 'meta) connection) list
('msg, 'meta) pool -> (P2p_peer.Id.t * ('msg, 'meta) connection) list
val find_by_point:
('msg, 'meta) pool -> Point.t -> ('msg, 'meta) connection option
('msg, 'meta) pool -> P2p_point.Id.t -> ('msg, 'meta) connection option
val find_by_peer_id:
('msg, 'meta) pool -> Peer_id.t -> ('msg, 'meta) connection option
('msg, 'meta) pool -> P2p_peer.Id.t -> ('msg, 'meta) connection option
end
val on_new_connection:
('msg, 'meta) pool ->
(Peer_id.t -> ('msg, 'meta) connection -> unit) -> unit
(P2p_peer.Id.t -> ('msg, 'meta) connection -> unit) -> unit
(** {1 I/O on connections} *)
@ -277,31 +274,31 @@ val broadcast_bootstrap_msg: ('msg, 'meta) pool -> unit
(** {1 Functions on [Peer_id]} *)
module Peer_ids : sig
module Peers : sig
type ('msg, 'meta) info = (('msg, 'meta) connection, 'meta) Peer_info.t
type ('msg, 'meta) info = (('msg, 'meta) connection, 'meta) P2p_peer.Pool_info.t
val info:
('msg, 'meta) pool -> Peer_id.t -> ('msg, 'meta) info option
('msg, 'meta) pool -> P2p_peer.Id.t -> ('msg, 'meta) info option
val get_metadata: ('msg, 'meta) pool -> Peer_id.t -> 'meta
val set_metadata: ('msg, 'meta) pool -> Peer_id.t -> 'meta -> unit
val get_score: ('msg, 'meta) pool -> Peer_id.t -> float
val get_metadata: ('msg, 'meta) pool -> P2p_peer.Id.t -> 'meta
val set_metadata: ('msg, 'meta) pool -> P2p_peer.Id.t -> 'meta -> unit
val get_score: ('msg, 'meta) pool -> P2p_peer.Id.t -> float
val get_trusted: ('msg, 'meta) pool -> Peer_id.t -> bool
val set_trusted: ('msg, 'meta) pool -> Peer_id.t -> unit
val unset_trusted: ('msg, 'meta) pool -> Peer_id.t -> unit
val get_trusted: ('msg, 'meta) pool -> P2p_peer.Id.t -> bool
val set_trusted: ('msg, 'meta) pool -> P2p_peer.Id.t -> unit
val unset_trusted: ('msg, 'meta) pool -> P2p_peer.Id.t -> unit
val fold_known:
('msg, 'meta) pool ->
init:'a ->
f:(Peer_id.t -> ('msg, 'meta) info -> 'a -> 'a) ->
f:(P2p_peer.Id.t -> ('msg, 'meta) info -> 'a -> 'a) ->
'a
val fold_connected:
('msg, 'meta) pool ->
init:'a ->
f:(Peer_id.t -> ('msg, 'meta) info -> 'a -> 'a) ->
f:(P2p_peer.Id.t -> ('msg, 'meta) info -> 'a -> 'a) ->
'a
end
@ -310,32 +307,30 @@ end
module Points : sig
type ('msg, 'meta) info = ('msg, 'meta) connection Point_info.t
type ('msg, 'meta) info = ('msg, 'meta) connection P2p_point.Pool_info.t
val info:
('msg, 'meta) pool -> Point.t -> ('msg, 'meta) info option
('msg, 'meta) pool -> P2p_point.Id.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 get_trusted: ('msg, 'meta) pool -> P2p_point.Id.t -> bool
val set_trusted: ('msg, 'meta) pool -> P2p_point.Id.t -> unit
val unset_trusted: ('msg, 'meta) pool -> P2p_point.Id.t -> unit
val fold_known:
('msg, 'meta) pool ->
init:'a ->
f:(Point.t -> ('msg, 'meta) info -> 'a -> 'a) ->
f:(P2p_point.Id.t -> ('msg, 'meta) info -> 'a -> 'a) ->
'a
val fold_connected:
('msg, 'meta) pool ->
init:'a ->
f:(Point.t -> ('msg, 'meta) info -> 'a -> 'a) ->
f:(P2p_point.Id.t -> ('msg, 'meta) info -> 'a -> 'a) ->
'a
end
module Log_event = Connection_pool_log_event
val watch: ('msg, 'meta) pool -> Log_event.t Lwt_stream.t * Lwt_watcher.stopper
val watch: ('msg, 'meta) pool -> P2p_connection.Pool_event.t Lwt_stream.t * Lwt_watcher.stopper
(** [watch pool] is a [stream, close] a [stream] of events and a
[close] function for this stream. *)
@ -345,9 +340,9 @@ module Message : sig
type 'msg t =
| Bootstrap
| Advertise of Point.t list
| Swap_request of Point.t * Peer_id.t
| Swap_ack of Point.t * Peer_id.t
| Advertise of P2p_point.Id.t list
| Swap_request of P2p_point.Id.t * P2p_peer.Id.t
| Swap_ack of P2p_point.Id.t * P2p_peer.Id.t
| Message of 'msg
| Disconnect

48
src/lib_p2p/p2p_connection.ml → src/lib_p2p/p2p_socket.ml
View File

@ -19,8 +19,6 @@
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
@ -28,8 +26,8 @@ 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 Peer_id.t
type error += Myself of P2p_connection.Id.t
type error += Not_enough_proof_of_work of P2p_peer.Id.t
type error += Invalid_auth
type error += Invalid_chunks_size of { value: int ; min: int ; max: int }
@ -94,7 +92,7 @@ module Connection_message = struct
type t = {
port : int option ;
versions : Version.t list ;
versions : P2p_version.t list ;
public_key : Crypto_box.public_key ;
proof_of_work_stamp : Crypto_box.nonce ;
message_nonce : Crypto_box.nonce ;
@ -118,7 +116,7 @@ module Connection_message = struct
(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)))
(req "versions" (Variable.list P2p_version.encoding)))
let write fd message =
let encoded_message_len =
@ -172,7 +170,7 @@ module Ack = struct
end
type authenticated_fd =
P2p_io_scheduler.connection * Connection_info.t * Crypto.data
P2p_io_scheduler.connection * P2p_connection.Info.t * Crypto.data
let kick (fd, _ , cryptobox_data) =
Ack.write fd cryptobox_data Nack >>= fun _ ->
@ -187,9 +185,9 @@ let authenticate
~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 () ->
lwt_debug "Sending authenfication to %a" P2p_point.Id.pp point >>= fun () ->
Connection_message.write fd
{ public_key = identity.Identity.public_key ;
{ public_key = identity.P2p_identity.public_key ;
proof_of_work_stamp = identity.proof_of_work_stamp ;
message_nonce = local_nonce ;
port = listening_port ;
@ -200,16 +198,16 @@ let authenticate
let id_point = remote_addr, remote_listening_port in
let remote_peer_id = Crypto_box.hash msg.public_key in
fail_unless
(remote_peer_id <> identity.Identity.peer_id)
(remote_peer_id <> identity.P2p_identity.peer_id)
(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_peer_id) >>=? fun () ->
let channel_key =
Crypto_box.precompute identity.Identity.secret_key msg.public_key in
Crypto_box.precompute identity.P2p_identity.secret_key msg.public_key in
let info =
{ Connection_info.peer_id = remote_peer_id ;
{ P2p_connection.Info.peer_id = remote_peer_id ;
versions = msg.versions ; incoming ;
id_point ; remote_socket_port ;} in
let cryptobox_data =
@ -219,7 +217,7 @@ let authenticate
type connection = {
id : int ;
info : Connection_info.t ;
info : P2p_connection.Info.t ;
fd : P2p_io_scheduler.connection ;
cryptobox_data : Crypto.data ;
}
@ -254,7 +252,7 @@ module Reader = struct
end >>=? fun buf ->
lwt_debug
"reading %d bytes from %a"
(MBytes.length buf) Connection_info.pp st.conn.info >>= fun () ->
(MBytes.length buf) P2p_connection.Info.pp st.conn.info >>= fun () ->
loop (decode_next_buf buf) in
loop
(Data_encoding.Binary.read_stream_of_bytes ~init:init_mbytes st.encoding)
@ -282,7 +280,7 @@ module Reader = struct
Lwt.return_unit
| Error [Lwt_utils.Canceled | Exn Lwt_pipe.Closed] ->
lwt_debug "connection closed to %a"
Connection_info.pp st.conn.info >>= fun () ->
P2p_connection.Info.pp st.conn.info >>= fun () ->
Lwt.return_unit
| Error _ as err ->
Lwt_pipe.safe_push_now st.messages err ;
@ -335,7 +333,7 @@ module Writer = struct
Crypto.write_chunk st.conn.fd st.conn.cryptobox_data buf
end >>=? fun () ->
lwt_debug "writing %d bytes to %a"
(MBytes.length buf) Connection_info.pp st.conn.info >>= fun () ->
(MBytes.length buf) P2p_connection.Info.pp st.conn.info >>= fun () ->
loop l in
loop buf
@ -350,12 +348,12 @@ module Writer = struct
end >>= function
| Error [Lwt_utils.Canceled | Exn Lwt_pipe.Closed] ->
lwt_debug "connection closed to %a"
Connection_info.pp st.conn.info >>= fun () ->
P2p_connection.Info.pp st.conn.info >>= fun () ->
Lwt.return_unit
| Error err ->
lwt_log_error
"@[<v 2>error writing to %a@ %a@]"
Connection_info.pp st.conn.info pp_print_error err >>= fun () ->
P2p_connection.Info.pp st.conn.info pp_print_error err >>= fun () ->
Lwt_canceler.cancel st.canceler >>= fun () ->
Lwt.return_unit
| Ok (buf, wakener) ->
@ -372,17 +370,17 @@ module Writer = struct
match err with
| [ Lwt_utils.Canceled | Exn Lwt_pipe.Closed ] ->
lwt_debug "connection closed to %a"
Connection_info.pp st.conn.info >>= fun () ->
P2p_connection.Info.pp st.conn.info >>= fun () ->
Lwt.return_unit
| [ P2p_io_scheduler.Connection_closed ] ->
lwt_debug "connection closed to %a"
Connection_info.pp st.conn.info >>= fun () ->
P2p_connection.Info.pp st.conn.info >>= fun () ->
Lwt_canceler.cancel st.canceler >>= fun () ->
Lwt.return_unit
| err ->
lwt_log_error
"@[<v 2>error writing to %a@ %a@]"
Connection_info.pp st.conn.info
P2p_connection.Info.pp st.conn.info
pp_print_error err >>= fun () ->
Lwt_canceler.cancel st.canceler >>= fun () ->
Lwt.return_unit
@ -447,7 +445,7 @@ type 'msg t = {
let equal { conn = { id = id1 } } { conn = { id = id2 } } = id1 = id2
let pp ppf { conn } = Connection_info.pp ppf conn.info
let pp ppf { conn } = P2p_connection.Info.pp ppf conn.info
let info { conn } = conn.info
let accept
@ -497,7 +495,7 @@ let pp_json encoding ppf msg =
let write { writer ; conn } msg =
catch_closed_pipe begin fun () ->
debug "Sending message to %a: %a"
P2p_types.Peer_id.pp_short conn.info.peer_id (pp_json writer.encoding) msg ;
P2p_peer.Id.pp_short conn.info.peer_id (pp_json writer.encoding) msg ;
Lwt.return (Writer.encode_message writer msg) >>=? fun buf ->
Lwt_pipe.push writer.messages (buf, None) >>= return
end
@ -506,7 +504,7 @@ let write_sync { writer ; conn } msg =
catch_closed_pipe begin fun () ->
let waiter, wakener = Lwt.wait () in
debug "Sending message to %a: %a"
P2p_types.Peer_id.pp_short conn.info.peer_id (pp_json writer.encoding) msg ;
P2p_peer.Id.pp_short conn.info.peer_id (pp_json writer.encoding) msg ;
Lwt.return (Writer.encode_message writer msg) >>=? fun buf ->
Lwt_pipe.push writer.messages (buf, Some wakener) >>= fun () ->
waiter
@ -514,7 +512,7 @@ let write_sync { writer ; conn } msg =
let write_now { writer ; conn } msg =
debug "Try sending message to %a: %a"
P2p_types.Peer_id.pp_short conn.info.peer_id (pp_json writer.encoding) msg ;
P2p_peer.Id.pp_short conn.info.peer_id (pp_json writer.encoding) msg ;
Writer.encode_message writer msg >>? fun buf ->
try Ok (Lwt_pipe.push_now writer.messages (buf, None))
with Lwt_pipe.Closed -> Error [P2p_io_scheduler.Connection_closed]

16
src/lib_p2p/p2p_connection.mli → src/lib_p2p/p2p_socket.mli
View File

@ -15,8 +15,6 @@
limited by providing corresponding arguments to [accept].
*)
open P2p_types
(** {1 Types} *)
type error += Decipher_error
@ -24,8 +22,8 @@ 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 Peer_id.t
type error += Myself of P2p_connection.Id.t
type error += Not_enough_proof_of_work of P2p_peer.Id.t
type error += Invalid_auth
type error += Invalid_chunks_size of { value: int ; min: int ; max: int }
@ -40,17 +38,17 @@ type 'msg t
val equal: 'mst t -> 'msg t -> bool
val pp: Format.formatter -> 'msg t -> unit
val info: 'msg t -> Connection_info.t
val info: 'msg t -> P2p_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 ->
P2p_io_scheduler.connection -> P2p_point.Id.t ->
?listening_port: int ->
Identity.t -> Version.t list ->
(Connection_info.t * authenticated_fd) tzresult Lwt.t
P2p_identity.t -> P2p_version.t list ->
(P2p_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
@ -112,7 +110,7 @@ val read_now: 'msg t -> (int * 'msg) tzresult option
is not empty, [None] if it is empty, or fails with a correponding
error otherwise. *)
val stat: 'msg t -> Stat.t
val stat: 'msg t -> P2p_stat.t
(** [stat conn] is a snapshot of current bandwidth usage for
[conn]. *)

4
src/lib_p2p/p2p_welcome.ml
View File

@ -9,7 +9,7 @@
include Logging.Make (struct let name = "p2p.welcome" end)
type pool = Pool : ('msg, 'meta) P2p_connection_pool.t -> pool
type pool = Pool : ('msg, 'meta) P2p_pool.t -> pool
type t = {
socket: Lwt_unix.file_descr ;
@ -30,7 +30,7 @@ let rec worker_loop st =
| 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 ;
P2p_pool.accept pool fd point ;
worker_loop st
| Error [Lwt_utils.Canceled] ->
Lwt.return_unit

6
src/lib_p2p/p2p_welcome.mli
View File

@ -7,8 +7,6 @@
(* *)
(**************************************************************************)
open P2p_types
(** Welcome worker. Accept incoming connections and add them to its
connection pool. *)
@ -18,8 +16,8 @@ type t
val run:
backlog:int ->
('msg, 'meta) P2p_connection_pool.t ->
?addr:addr -> port -> t Lwt.t
('msg, 'meta) P2p_pool.t ->
?addr:P2p_addr.t -> P2p_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]. *)

526
src/lib_p2p_services/p2p_connection_pool_types.ml
View File

@ -1,526 +0,0 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* 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: Lwt_canceler.t }
| Accepted of { current_peer_id: Peer_id.t ;
cancel: Lwt_canceler.t }
| Running of { data: 'data ;
current_peer_id: Peer_id.t }
| Disconnected
module Event = struct
type kind =
| Outgoing_request
| Accepting_request of Peer_id.t
| Rejecting_request of Peer_id.t
| Request_rejected of Peer_id.t option
| Connection_established of Peer_id.t
| Disconnection of Peer_id.t
| External_disconnection of Peer_id.t
let kind_encoding =
let open Data_encoding in
let branch_encoding name obj =
conv (fun x -> (), x) (fun ((), x) -> x)
(merge_objs
(obj1 (req "event_kind" (constant name))) obj) in
union ~tag_size:`Uint8 [
case (Tag 0) (branch_encoding "outgoing_request" empty)
(function Outgoing_request -> Some () | _ -> None)
(fun () -> Outgoing_request) ;
case (Tag 1) (branch_encoding "accepting_request"
(obj1 (req "peer_id" Peer_id.encoding)))
(function Accepting_request peer_id -> Some peer_id | _ -> None)
(fun peer_id -> Accepting_request peer_id) ;
case (Tag 2) (branch_encoding "rejecting_request"
(obj1 (req "peer_id" Peer_id.encoding)))
(function Rejecting_request peer_id -> Some peer_id | _ -> None)
(fun peer_id -> Rejecting_request peer_id) ;
case (Tag 3) (branch_encoding "request_rejected"
(obj1 (opt "peer_id" Peer_id.encoding)))
(function Request_rejected peer_id -> Some peer_id | _ -> None)
(fun peer_id -> Request_rejected peer_id) ;
case (Tag 4) (branch_encoding "rejecting_request"
(obj1 (req "peer_id" Peer_id.encoding)))
(function Connection_established peer_id -> Some peer_id | _ -> None)
(fun peer_id -> Connection_established peer_id) ;
case (Tag 5) (branch_encoding "rejecting_request"
(obj1 (req "peer_id" Peer_id.encoding)))
(function Disconnection peer_id -> Some peer_id | _ -> None)
(fun peer_id -> Disconnection peer_id) ;
case (Tag 6) (branch_encoding "rejecting_request"
(obj1 (req "peer_id" Peer_id.encoding)))
(function External_disconnection peer_id -> Some peer_id | _ -> None)
(fun peer_id -> External_disconnection peer_id) ;
]
type t = {
kind : kind ;
timestamp : Time.t ;
}
let encoding =
let open Data_encoding in
conv
(fun { kind ; timestamp ; } -> (kind, timestamp))
(fun (kind, timestamp) -> { kind ; timestamp ; })
(obj2
(req "kind" kind_encoding)
(req "timestamp" Time.encoding))
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 : (Peer_id.t * Time.t) option ;
mutable last_established_connection : (Peer_id.t * Time.t) option ;
mutable last_disconnection : (Peer_id.t * Time.t) option ;
greylisting : greylisting_config ;
mutable greylisting_delay : float ;
mutable greylisting_end : Time.t ;
events : Event.t Ring.t ;
watchers : Event.t Lwt_watcher.input ;
}
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.epoch ;
watchers = Lwt_watcher.create_input () ;
}
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 greylisted_until s = s.greylisting_end
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,
(Option.map ~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 watch { watchers ; _ } = Lwt_watcher.create_stream watchers
let log { events ; watchers ; _ } ?(timestamp = Time.now ()) kind =
let event = { Event.kind ; timestamp } in
Ring.add events event ;
Lwt_watcher.notify watchers event
let log_incoming_rejection ?timestamp point_info peer_id =
log point_info ?timestamp (Rejecting_request peer_id)
module State = struct
type 'data t = 'data state =
| Requested of { cancel: Lwt_canceler.t }
| Accepted of { current_peer_id: Peer_id.t ;
cancel: Lwt_canceler.t }
| Running of { data: 'data ;
current_peer_id: Peer_id.t }
| Disconnected
type 'data state = 'data t
let pp ppf = function
| Requested _ ->
Format.fprintf ppf "requested"
| Accepted { current_peer_id ; _ } ->
Format.fprintf ppf "accepted %a" Peer_id.pp current_peer_id
| Running { current_peer_id ; _ } ->
Format.fprintf ppf "running %a" Peer_id.pp current_peer_id
| 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_peer_id 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_peer_id ; cancel } ;
log point_info ~timestamp (Accepting_request current_peer_id)
let set_running
?(timestamp = Time.now ())
point_info peer_id data =
assert begin
match point_info.state with
| Disconnected -> true (* request to unknown peer_id. *)
| Running _ -> false
| Accepted { current_peer_id ; _ } -> Peer_id.equal peer_id current_peer_id
| Requested _ -> true
end ;
point_info.state <- Running { data ; current_peer_id = peer_id } ;
point_info.last_established_connection <- Some (peer_id, timestamp) ;
log point_info ~timestamp (Connection_established peer_id)
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_peer_id ; _ } ->
set_greylisted timestamp point_info ;
point_info.last_rejected_connection <-
Some (current_peer_id, timestamp) ;
Request_rejected (Some current_peer_id)
| Running { current_peer_id ; _ } ->
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_peer_id, timestamp) ;
if requested
then Disconnection current_peer_id
else External_disconnection current_peer_id
| Disconnected ->
assert false
in
point_info.state <- Disconnected ;
log point_info ~timestamp event
end
end
module Peer_info = struct
type 'data state =
| Accepted of { current_point: Id_point.t ;
cancel: Lwt_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 =
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, addr, port))
(fun (kind, timestamp, addr, port) ->
{ kind ; timestamp ; point = (addr, port) })
(obj4
(req "kind" kind_encoding)
(req "timestamp" Time.encoding)
(req "addr" P2p_types.addr_encoding)
(opt "port" int16))
end
type ('conn, 'meta) t = {
peer_id : Peer_id.t ;
created : Time.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 ;
watchers : Event.t Lwt_watcher.input ;
}
type ('conn, 'meta) peer_info = ('conn, 'meta) t
let compare gi1 gi2 = Peer_id.compare gi1.peer_id gi2.peer_id
let log_size = 100
let create ?(created = Time.now ()) ?(trusted = false) ~metadata peer_id =
{ peer_id ;
created ;
state = Disconnected ;
metadata ;
trusted ;
last_failed_connection = None ;
last_rejected_connection = None ;
last_established_connection = None ;
last_disconnection = None ;
events = Ring.create log_size ;
watchers = Lwt_watcher.create_input () ;
}
let encoding metadata_encoding =
let open Data_encoding in
conv
(fun { peer_id ; trusted ; metadata ; events ; created ;
last_failed_connection ; last_rejected_connection ;
last_established_connection ; last_disconnection ; _ } ->
(peer_id, created, trusted, metadata, Ring.elements events,
last_failed_connection, last_rejected_connection,
last_established_connection, last_disconnection))
(fun (peer_id, created, trusted, metadata, event_list,
last_failed_connection, last_rejected_connection,
last_established_connection, last_disconnection) ->
let info = create ~trusted ~metadata peer_id in
let events = Ring.create log_size in
Ring.add_list info.events event_list ;
{ state = Disconnected ;
trusted ; peer_id ; metadata ; created ;
last_failed_connection ;
last_rejected_connection ;
last_established_connection ;
last_disconnection ;
events ;
watchers = Lwt_watcher.create_input () ;
})
(obj9
(req "peer_id" Peer_id.encoding)
(req "created" Time.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 peer_id { peer_id ; _ } = peer_id
let created { created ; _ } = created
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 ; watchers ; _ } ?(timestamp = Time.now ()) point kind =
let event = { Event.kind ; timestamp ; point } in
Ring.add events event ;
Lwt_watcher.notify watchers event
let watch { watchers ; _ } = Lwt_watcher.create_stream watchers
let log_incoming_rejection ?timestamp peer_info point =
log peer_info ?timestamp point Rejecting_request
module State = struct
type 'data t = 'data state =
| Accepted of { current_point: Id_point.t ;
cancel: Lwt_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 ())
peer_info current_point cancel =
assert begin
match peer_info.state with
| Accepted _ | Running _ -> false
| Disconnected -> true
end ;
peer_info.state <- Accepted { current_point ; cancel } ;
log peer_info ~timestamp current_point Accepting_request
let set_running
?(timestamp = Time.now ())
peer_info point data =
assert begin
match peer_info.state with
| Disconnected -> true (* request to unknown peer_id. *)
| Running _ -> false
| Accepted { current_point ; _ } ->
Id_point.equal point current_point
end ;
peer_info.state <- Running { data ; current_point = point } ;
peer_info.last_established_connection <- Some (point, timestamp) ;
log peer_info ~timestamp point Connection_established
let set_disconnected
?(timestamp = Time.now ()) ?(requested = false) peer_info =
let current_point, (event : Event.kind) =
match peer_info.state with
| Accepted { current_point ; _ } ->
peer_info.last_rejected_connection <-
Some (current_point, timestamp) ;
current_point, Request_rejected
| Running { current_point ; _ } ->
peer_info.last_disconnection <-
Some (current_point, timestamp) ;
current_point,
if requested then Disconnection else External_disconnection
| Disconnected -> assert false
in
peer_info.state <- Disconnected ;
log peer_info ~timestamp current_point event
end
module File = struct
let load path metadata_encoding =
let enc = Data_encoding.list (encoding metadata_encoding) in
if path <> "/dev/null" && Sys.file_exists path then
Data_encoding_ezjsonm.read_file path >>=? fun json ->
return (Data_encoding.Json.destruct enc json)
else
return []
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

284
src/lib_p2p_services/p2p_connection_pool_types.mli
View File

@ -1,284 +0,0 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* 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 -> (Peer_id.t * Time.t) option
val last_established_connection :
'conn point_info -> (Peer_id.t * Time.t) option
val last_disconnection :
'conn point_info -> (Peer_id.t * Time.t) option
val last_seen :
'conn point_info -> (Peer_id.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
(** [last_miss pi] is the most recent of:
* last failed connection
* last rejected connection
* last disconnection
*)
val greylisted :
?now:Time.t -> 'conn point_info -> bool
val greylisted_until : 'conn point_info -> Time.t
val point : 'conn point_info -> Point.t
module State : sig
type 'conn t =
| Requested of { cancel: Lwt_canceler.t }
(** We initiated a connection. *)
| Accepted of { current_peer_id: Peer_id.t ;
cancel: Lwt_canceler.t }
(** We accepted a incoming connection. *)
| Running of { data: 'conn ;
current_peer_id: Peer_id.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 -> Lwt_canceler.t -> unit
val set_accepted :
?timestamp:Time.t ->
'conn point_info -> Peer_id.t -> Lwt_canceler.t -> unit
val set_running :
?timestamp:Time.t -> 'conn point_info -> Peer_id.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 Peer_id.t
(** We accepted a connection after authentifying the remote peer. *)
| Rejecting_request of Peer_id.t
(** We rejected a connection after authentifying the remote peer. *)
| Request_rejected of Peer_id.t option
(** The remote peer rejected our connection. *)
| Connection_established of Peer_id.t
(** We succesfully established a authentified connection. *)
| Disconnection of Peer_id.t
(** We decided to close the connection. *)
| External_disconnection of Peer_id.t
(** The connection was closed for external reason. *)
type t = {
kind : kind ;
timestamp : Time.t ;
}
val encoding : t Data_encoding.t
end
val fold_events :
'conn point_info -> init:'a -> f:('a -> Event.t -> 'a) -> 'a
val watch :
'conn point_info -> Event.t Lwt_stream.t * Lwt_watcher.stopper
val log_incoming_rejection :
?timestamp:Time.t -> 'conn point_info -> Peer_id.t -> unit
end
(** Peer_id info: current and historical information about a peer_id *)
module Peer_info : sig
type ('conn, 'meta) t
type ('conn, 'meta) peer_info = ('conn, 'meta) t
val compare : ('conn, 'meta) t -> ('conn, 'meta) t -> int
val create :
?created:Time.t ->
?trusted:bool ->
metadata:'meta ->
Peer_id.t -> ('conn, 'meta) peer_info
(** [create ~trusted ~meta peer_id] is a freshly minted peer_id info for
[peer_id]. *)
val peer_id : ('conn, 'meta) peer_info -> Peer_id.t
val created : ('conn, 'meta) peer_info -> Time.t
val metadata : ('conn, 'meta) peer_info -> 'meta
val set_metadata : ('conn, 'meta) peer_info -> 'meta -> unit
val trusted : ('conn, 'meta) peer_info -> bool
val set_trusted : ('conn, 'meta) peer_info -> unit
val unset_trusted : ('conn, 'meta) peer_info -> unit
val last_failed_connection :
('conn, 'meta) peer_info -> (Id_point.t * Time.t) option
val last_rejected_connection :
('conn, 'meta) peer_info -> (Id_point.t * Time.t) option
val last_established_connection :
('conn, 'meta) peer_info -> (Id_point.t * Time.t) option
val last_disconnection :
('conn, 'meta) peer_info -> (Id_point.t * Time.t) option
val last_seen :
('conn, 'meta) peer_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) peer_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: Lwt_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) peer_info -> 'conn state
val is_disconnected : ('conn, 'meta) peer_info -> bool
val set_accepted :
?timestamp:Time.t ->
('conn, 'meta) peer_info -> Id_point.t -> Lwt_canceler.t -> unit
val set_running :
?timestamp:Time.t ->
('conn, 'meta) peer_info -> Id_point.t -> 'conn -> unit
val set_disconnected :
?timestamp:Time.t ->
?requested:bool ->
('conn, 'meta) peer_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 ;
}
val encoding : t Data_encoding.t
end
val fold_events :
('conn, 'meta) peer_info -> init:'a -> f:('a -> Event.t -> 'a) -> 'a
val watch :
('conn, 'meta) peer_info -> Event.t Lwt_stream.t * Lwt_watcher.stopper
val log_incoming_rejection :
?timestamp:Time.t ->
('conn, 'meta) peer_info -> Id_point.t -> unit
module File : sig
val load :
string -> 'meta Data_encoding.t ->
('conn, 'meta) peer_info list tzresult Lwt.t
val save :
string -> 'meta Data_encoding.t ->
('conn, 'meta) peer_info list -> unit tzresult Lwt.t
end
end

38
src/lib_p2p_services/p2p_services.ml
View File

@ -7,17 +7,15 @@
(* *)
(**************************************************************************)
open P2p_types
let (peer_id_arg : P2p_types.Peer_id.t RPC_arg.arg) =
let (peer_id_arg : P2p_peer.Id.t RPC_arg.arg) =
Crypto_box.Public_key_hash.rpc_arg
let point_arg =
RPC_arg.make
~name:"point"
~descr:"A network point (ipv4:port or [ipv6]:port)."
~destruct:Point.of_string
~construct:Point.to_string
~destruct:P2p_point.Id.of_string
~construct:P2p_point.Id.to_string
()
let versions =
@ -25,7 +23,7 @@ let versions =
~description:"Supported network layer versions."
~query: RPC_query.empty
~input: Data_encoding.empty
~output: (Data_encoding.list P2p_types.Version.encoding)
~output: (Data_encoding.list P2p_version.encoding)
~error: Data_encoding.empty
RPC_path.(root / "network" / "versions")
@ -34,7 +32,7 @@ let stat =
~description:"Global network bandwidth statistics in B/s."
~query: RPC_query.empty
~input: Data_encoding.empty
~output: P2p_types.Stat.encoding
~output: P2p_stat.encoding
~error: Data_encoding.empty
RPC_path.(root / "network" / "stat")
@ -43,7 +41,7 @@ let events =
~description:"Stream of all network events"
~query: RPC_query.empty
~input: Data_encoding.empty
~output: P2p_types.Connection_pool_log_event.encoding
~output: P2p_connection.Pool_event.encoding
~error: Data_encoding.empty
RPC_path.(root / "network" / "log")
@ -65,7 +63,7 @@ module Connection = struct
~description:"List the running P2P connection."
~query: RPC_query.empty
~input: Data_encoding.empty
~output: (Data_encoding.list P2p_types.Connection_info.encoding)
~output: (Data_encoding.list P2p_connection.Info.encoding)
~error: Data_encoding.empty
RPC_path.(root / "network" / "connection")
@ -73,7 +71,7 @@ module Connection = struct
RPC_service.post_service
~query: RPC_query.empty
~input: Data_encoding.empty
~output: (Data_encoding.option P2p_types.Connection_info.encoding)
~output: (Data_encoding.option P2p_connection.Info.encoding)
~error: Data_encoding.empty
~description:"Details about the current P2P connection to the given peer."
RPC_path.(root / "network" / "connection" /: peer_id_arg)
@ -95,7 +93,7 @@ module Point = struct
RPC_service.post_service
~query: RPC_query.empty
~input: Data_encoding.empty
~output: (Data_encoding.option P2p_types.Point_info.encoding)
~output: (Data_encoding.option P2p_point.Info.encoding)
~error: Data_encoding.empty
~description: "Details about a given `IP:addr`."
RPC_path.(root / "network" / "point" /: point_arg)
@ -105,7 +103,7 @@ module Point = struct
~query: RPC_query.empty
~input: monitor_encoding
~output: (Data_encoding.list
P2p_connection_pool_types.Point_info.Event.encoding)
P2p_point.Pool_event.encoding)
~error: Data_encoding.empty
~description: "Monitor network events related to an `IP:addr`."
RPC_path.(root / "network" / "point" /: point_arg / "log")
@ -113,14 +111,14 @@ module Point = struct
let list =
let filter =
let open Data_encoding in
obj1 (dft "filter" (list P2p_types.Point_state.encoding) []) in
obj1 (dft "filter" (list P2p_point.State.encoding) []) in
RPC_service.post_service
~query: RPC_query.empty
~input: filter
~output:
Data_encoding.(list (tup2
P2p_types.Point.encoding
P2p_types.Point_info.encoding))
P2p_point.Id.encoding
P2p_point.Info.encoding))
~error: Data_encoding.empty
~description:"List the pool of known `IP:port` \
used for establishing P2P connections ."
@ -134,7 +132,7 @@ module Peer_id = struct
RPC_service.post_service
~query: RPC_query.empty
~input: Data_encoding.empty
~output: (Data_encoding.option P2p_types.Peer_info.encoding)
~output: (Data_encoding.option P2p_peer.Info.encoding)
~error: Data_encoding.empty
~description:"Details about a given peer."
RPC_path.(root / "network" / "peer_id" /: peer_id_arg)
@ -144,7 +142,7 @@ module Peer_id = struct
~query: RPC_query.empty
~input: monitor_encoding
~output: (Data_encoding.list
P2p_connection_pool_types.Peer_info.Event.encoding)
P2p_peer.Pool_event.encoding)
~error: Data_encoding.empty
~description:"Monitor network events related to a given peer."
RPC_path.(root / "network" / "peer_id" /: peer_id_arg / "log")
@ -152,14 +150,14 @@ module Peer_id = struct
let list =
let filter =
let open Data_encoding in
obj1 (dft "filter" (list P2p_types.Peer_state.encoding) []) in
obj1 (dft "filter" (list P2p_peer.State.encoding) []) in
RPC_service.post_service
~query: RPC_query.empty
~input: filter
~output:
Data_encoding.(list (tup2
P2p_types.Peer_id.encoding
P2p_types.Peer_info.encoding))
P2p_peer.Id.encoding
P2p_peer.Info.encoding))
~error: Data_encoding.empty
~description:"List the peers the node ever met."
RPC_path.(root / "network" / "peer_id")

42
src/lib_p2p_services/p2p_services.mli
View File

@ -7,26 +7,24 @@
(* *)
(**************************************************************************)
open P2p_types
val stat :
([ `POST ], unit,
unit, unit, unit,
Stat.t, unit) RPC_service.t
P2p_stat.t, unit) RPC_service.t
val versions :
([ `POST ], unit,
unit, unit, unit,
Version.t list, unit) RPC_service.t
P2p_version.t list, unit) RPC_service.t
val events :
([ `POST ], unit,
unit, unit, unit,
Connection_pool_log_event.t, unit) RPC_service.t
P2p_connection.Pool_event.t, unit) RPC_service.t
val connect :
([ `POST ], unit,
unit * Point.t, unit, float,
unit * P2p_point.Id.t, unit, float,
unit tzresult, unit) RPC_service.t
module Connection : sig
@ -34,16 +32,16 @@ module Connection : sig
val list :
([ `POST ], unit,
unit, unit, unit,
Connection_info.t list, unit) RPC_service.t
P2p_connection.Info.t list, unit) RPC_service.t
val info :
([ `POST ], unit,
unit * Peer_id.t, unit, unit,
Connection_info.t option, unit) RPC_service.t
unit * P2p_peer.Id.t, unit, unit,
P2p_connection.Info.t option, unit) RPC_service.t
val kick :
([ `POST ], unit,
unit * Peer_id.t, unit, bool,
unit * P2p_peer.Id.t, unit, bool,
unit, unit) RPC_service.t
end
@ -51,33 +49,33 @@ end
module Point : sig
val list :
([ `POST ], unit,
unit, unit, Point_state.t list,
(Point.t * Point_info.t) list, unit) RPC_service.t
unit, unit, P2p_point.State.t list,
(P2p_point.Id.t * P2p_point.Info.t) list, unit) RPC_service.t
val info :
([ `POST ], unit,
unit * Point.t, unit, unit,
Point_info.t option, unit) RPC_service.t
unit * P2p_point.Id.t, unit, unit,
P2p_point.Info.t option, unit) RPC_service.t
val events :
([ `POST ], unit,
unit * Point.t, unit, bool,
P2p_connection_pool_types.Point_info.Event.t list, unit) RPC_service.t
unit * P2p_point.Id.t, unit, bool,
P2p_point.Pool_event.t list, unit) RPC_service.t
end
module Peer_id : sig
val list :
([ `POST ], unit,
unit, unit, Peer_state.t list,
(Peer_id.t * Peer_info.t) list, unit) RPC_service.t
unit, unit, P2p_peer.State.t list,
(P2p_peer.Id.t * P2p_peer.Info.t) list, unit) RPC_service.t
val info :
([ `POST ], unit,
unit * Peer_id.t, unit, unit,
Peer_info.t option, unit) RPC_service.t
unit * P2p_peer.Id.t, unit, unit,
P2p_peer.Info.t option, unit) RPC_service.t
val events :
([ `POST ], unit,
unit * Peer_id.t, unit, bool,
P2p_connection_pool_types.Peer_info.Event.t list, unit) RPC_service.t
unit * P2p_peer.Id.t, unit, bool,
P2p_peer.Pool_event.t list, unit) RPC_service.t
end

717
src/lib_p2p_services/p2p_types.ml
View File

@ -1,717 +0,0 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
module Version = struct
type t = {
name : string ;
major : int ;
minor : int ;
}
let pp ppf { name ; major ; minor } =
Format.fprintf ppf "%s.%d.%d" name major minor
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 : int64 ;
total_recv : int64 ;
current_inflow : int ;
current_outflow : int ;
}
let empty = {
total_sent = 0L ;
total_recv = 0L ;
current_inflow = 0 ;
current_outflow = 0 ;
}
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 print_size64 ppf sz =
let open Int64 in
let ratio n = (to_float sz /. float_of_int (1 lsl n)) in
if sz < shift_left 1L 10 then
Format.fprintf ppf "%Ld B" sz
else if sz < shift_left 1L 20 then
Format.fprintf ppf "%.2f kiB" (ratio 10)
else if sz < shift_left 1L 30 then
Format.fprintf ppf "%.2f MiB" (ratio 20)
else if sz < shift_left 1L 40 then
Format.fprintf ppf "%.2f GiB" (ratio 30)
else
Format.fprintf ppf "%.2f TiB" (ratio 40)
let pp ppf stat =
Format.fprintf ppf
"↗ %a (%a/s) ↘ %a (%a/s)"
print_size64 stat.total_sent print_size stat.current_outflow
print_size64 stat.total_recv print_size stat.current_inflow
let encoding =
let open Data_encoding in
conv
(fun { total_sent ; total_recv ; current_inflow ; current_outflow } ->
(total_sent, total_recv, current_inflow, current_outflow))
(fun (total_sent, total_recv, current_inflow, current_outflow) ->
{ total_sent ; total_recv ; current_inflow ; current_outflow })
(obj4
(req "total_sent" int64)
(req "total_recv" int64)
(req "current_inflow" int31)
(req "current_outflow" int31))
end
(* public types *)
type addr = Ipaddr.V6.t
let addr_encoding =
let open Data_encoding in
splitted
~json:begin
conv
Ipaddr.V6.to_string
Ipaddr.V6.of_string_exn
string
end
~binary:begin
conv
Ipaddr.V6.to_bytes
Ipaddr.V6.of_bytes_exn
string
end
type port = int
module Id_point = struct
module T = struct
(* A net point (address x port). *)
type t = addr * port option
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 to_string t = Format.asprintf "%a" pp t
let is_local (addr, _) = Ipaddr.V6.is_private addr
let is_global (addr, _) = not @@ Ipaddr.V6.is_private addr
let of_point (addr, port) = addr, Some port
let to_point = function
| _, None -> None
| addr, Some port -> Some (addr, port)
let to_point_exn = function
| _, None -> invalid_arg "to_point_exn"
| addr, Some port -> addr, port
let encoding =
let open Data_encoding in
(obj2
(req "addr" addr_encoding)
(opt "port" uint16))
end
include T
module Map = Map.Make (T)
module Set = Set.Make (T)
module Table = Hashtbl.Make (T)
end
module Peer_id = Crypto_box.Public_key_hash
module Peer_state = struct
type t =
| Accepted
| Running
| Disconnected
let pp_digram ppf = function
| Accepted -> Format.fprintf ppf "⚎"
| Running -> Format.fprintf ppf "⚌"
| Disconnected -> Format.fprintf ppf "⚏"
let encoding =
let open Data_encoding in
string_enum [
"accepted", Accepted ;
"running", Running ;
"disconnected", Disconnected ;
]
end
module Peer_info = struct
type t = {
score : float ;
trusted : bool ;
state : Peer_state.t ;
id_point : Id_point.t option ;
stat : Stat.t ;
last_failed_connection : (Id_point.t * Time.t) option ;
last_rejected_connection : (Id_point.t * Time.t) option ;
last_established_connection : (Id_point.t * Time.t) option ;
last_disconnection : (Id_point.t * Time.t) option ;
last_seen : (Id_point.t * Time.t) option ;
last_miss : (Id_point.t * Time.t) option ;
}
let encoding =
let open Data_encoding in
conv
(fun (
{ score ; trusted ; state ; id_point ; stat ;
last_failed_connection ; last_rejected_connection ;
last_established_connection ; last_disconnection ;
last_seen ; last_miss }) ->
((score, trusted, state, id_point, stat),
(last_failed_connection, last_rejected_connection,
last_established_connection, last_disconnection,
last_seen, last_miss)))
(fun ((score, trusted, state, id_point, stat),
(last_failed_connection, last_rejected_connection,
last_established_connection, last_disconnection,
last_seen, last_miss)) ->
{ score ; trusted ; state ; id_point ; stat ;
last_failed_connection ; last_rejected_connection ;
last_established_connection ; last_disconnection ;
last_seen ; last_miss })
(merge_objs
(obj5
(req "score" float)
(req "trusted" bool)
(req "state" Peer_state.encoding)
(opt "reachable_at" Id_point.encoding)
(req "stat" Stat.encoding))
(obj6
(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))
(opt "last_seen" (tup2 Id_point.encoding Time.encoding))
(opt "last_miss" (tup2 Id_point.encoding Time.encoding))))
end
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) =
match Ipaddr.v4_of_v6 addr with
| Some addr ->
Format.fprintf ppf "%a:%d" Ipaddr.V4.pp_hum addr port
| None ->
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 check_port port =
if TzString.mem_char port '[' ||
TzString.mem_char port ']' ||
TzString.mem_char port ':' then
invalid_arg "Utils.parse_addr_port (invalid character in port)"
let parse_addr_port s =
let len = String.length s in
if len = 0 then
("", "")
else if s.[0] = '[' then begin (* inline IPv6 *)
match String.rindex s ']' with
| exception Not_found ->
invalid_arg "Utils.parse_addr_port (missing ']')"
| pos ->
let addr = String.sub s 1 (pos - 1) in
let port =
if pos = len - 1 then
""
else if s.[pos+1] <> ':' then
invalid_arg "Utils.parse_addr_port (unexpected char after ']')"
else
String.sub s (pos + 2) (len - pos - 2) in
check_port port ;
addr, port
end else begin
match String.rindex s ']' with
| _pos ->
invalid_arg "Utils.parse_addr_port (unexpected char ']')"
| exception Not_found ->
match String.index s ':' with
| exception _ -> s, ""
| pos ->
match String.index_from s (pos+1) ':' with
| exception _ ->
let addr = String.sub s 0 pos in
let port = String.sub s (pos + 1) (len - pos - 1) in
check_port port ;
addr, port
| _pos ->
invalid_arg "Utils.parse_addr_port: IPv6 addresses must be bracketed"
end
let of_string_exn str =
let addr, port = parse_addr_port str in
let port = int_of_string port in
if port < 0 && port > 1 lsl 16 - 1 then
invalid_arg "port must be between 0 and 65535" ;
match Ipaddr.of_string_exn addr with
| V4 addr -> Ipaddr.v6_of_v4 addr, port
| V6 addr -> addr, port
let of_string str =
try Ok (of_string_exn str) with
| Invalid_argument s -> Error s
| Failure s -> Error s
| _ -> Error "Point.of_string"
let to_string saddr = Format.asprintf "%a" pp saddr
let encoding =
Data_encoding.conv to_string of_string_exn Data_encoding.string
end
include T
module Map = Map.Make (T)
module Set = Set.Make (T)
module Table = Hashtbl.Make (T)
end
module Point_state = struct
type t =
| Requested
| Accepted of Peer_id.t
| Running of Peer_id.t
| Disconnected
let of_peer_id = function
| Requested -> None
| Accepted pi -> Some pi
| Running pi -> Some pi
| Disconnected -> None
let of_peerid_state state pi =
match state, pi with
| Requested, _ -> Requested
| Accepted _, Some pi -> Accepted pi
| Running _, Some pi -> Running pi
| Disconnected, _ -> Disconnected
| _ -> invalid_arg "state_of_state_peerid"
let pp_digram ppf = function
| Requested -> Format.fprintf ppf "⚎"
| Accepted _ -> Format.fprintf ppf "⚍"
| Running _ -> Format.fprintf ppf "⚌"
| Disconnected -> Format.fprintf ppf "⚏"
let encoding =
let open Data_encoding in
let branch_encoding name obj =
conv (fun x -> (), x) (fun ((), x) -> x)
(merge_objs
(obj1 (req "event_kind" (constant name))) obj) in
union ~tag_size:`Uint8 [
case (Tag 0) (branch_encoding "requested" empty)
(function Requested -> Some () | _ -> None)
(fun () -> Requested) ;
case (Tag 1) (branch_encoding "accepted"
(obj1 (req "peer_id" Peer_id.encoding)))
(function Accepted peer_id -> Some peer_id | _ -> None)
(fun peer_id -> Accepted peer_id) ;
case (Tag 2) (branch_encoding "running"
(obj1 (req "peer_id" Peer_id.encoding)))
(function Running peer_id -> Some peer_id | _ -> None)
(fun peer_id -> Running peer_id) ;
case (Tag 3) (branch_encoding "disconnected" empty)
(function Disconnected -> Some () | _ -> None)
(fun () -> Disconnected) ;
]
end
module Point_info = struct
type t = {
trusted : bool ;
greylisted_until : Time.t ;
state : Point_state.t ;
last_failed_connection : Time.t option ;
last_rejected_connection : (Peer_id.t * Time.t) option ;
last_established_connection : (Peer_id.t * Time.t) option ;
last_disconnection : (Peer_id.t * Time.t) option ;
last_seen : (Peer_id.t * Time.t) option ;
last_miss : Time.t option ;
}
let encoding =
let open Data_encoding in
conv
(fun { trusted ; greylisted_until ; state ;
last_failed_connection ; last_rejected_connection ;
last_established_connection ; last_disconnection ;
last_seen ; last_miss } ->
let peer_id = Point_state.of_peer_id state in
(trusted, greylisted_until, state, peer_id,
last_failed_connection, last_rejected_connection,
last_established_connection, last_disconnection,
last_seen, last_miss))
(fun (trusted, greylisted_until, state, peer_id,
last_failed_connection, last_rejected_connection,
last_established_connection, last_disconnection,
last_seen, last_miss) ->
let state = Point_state.of_peerid_state state peer_id in
{ trusted ; greylisted_until ; state ;
last_failed_connection ; last_rejected_connection ;
last_established_connection ; last_disconnection ;
last_seen ; last_miss })
(obj10
(req "trusted" bool)
(dft "greylisted_until" Time.encoding Time.epoch)
(req "state" Point_state.encoding)
(opt "peer_id" Peer_id.encoding)
(opt "last_failed_connection" Time.encoding)
(opt "last_rejected_connection" (tup2 Peer_id.encoding Time.encoding))
(opt "last_established_connection" (tup2 Peer_id.encoding Time.encoding))
(opt "last_disconnection" (tup2 Peer_id.encoding Time.encoding))
(opt "last_seen" (tup2 Peer_id.encoding Time.encoding))
(opt "last_miss" Time.encoding))
end
module Identity = struct
type t = {
peer_id : Peer_id.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 peer_id = Crypto_box.hash public_key in
{ peer_id ; 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 ?max target =
let secret_key, public_key, peer_id = Crypto_box.random_keypair () in
let proof_of_work_stamp =
Crypto_box.generate_proof_of_work ?max public_key target in
{ peer_id ; public_key ; secret_key ; proof_of_work_stamp }
let animation = [|
"|.....|" ;
"|o....|" ;
"|oo...|" ;
"|ooo..|" ;
"|.ooo.|" ;
"|..ooo|" ;
"|...oo|" ;
"|....o|" ;
"|.....|" ;
"|.....|" ;
"|.....|" ;
"|.....|" ;
|]
let init = String.make (String.length animation.(0)) '\ '
let clean = String.make (String.length animation.(0)) '\b'
let animation = Array.map (fun x -> clean ^ x) animation
let animation_size = Array.length animation
let duration = 1200 / animation_size
let generate_with_animation ppf target =
Format.fprintf ppf "%s%!" init ;
let count = ref 10000 in
let rec loop n =
let start = Mtime_clock.counter () in
Format.fprintf ppf "%s%!" animation.(n mod animation_size);
try generate ~max:!count target
with Not_found ->
let time = Mtime.Span.to_ms (Mtime_clock.count start) in
count :=
if time <= 0. then
!count * 10
else
!count * duration / int_of_float time ;
loop (n+1)
in
let id = loop 0 in
Format.fprintf ppf "%s%s\n%!" clean init ;
id
let generate target = generate target
end
module Connection_info = struct
type t = {
incoming : bool;
peer_id : Peer_id.t;
id_point : Id_point.t;
remote_socket_port : port;
versions : Version.t list ;
}
let encoding =
let open Data_encoding in
conv
(fun { incoming ; peer_id ; id_point ; remote_socket_port ; versions } ->
(incoming, peer_id, id_point, remote_socket_port, versions))
(fun (incoming, peer_id, id_point, remote_socket_port, versions) ->
{ incoming ; peer_id ; id_point ; remote_socket_port ; versions })
(obj5
(req "incoming" bool)
(req "peer_id" Peer_id.encoding)
(req "id_point" Id_point.encoding)
(req "remote_socket_port" uint16)
(req "versions" (list Version.encoding)))
let pp ppf
{ incoming ; id_point = (remote_addr, remote_port) ;
remote_socket_port ; peer_id ; versions } =
let version = List.hd versions in
let point = match remote_port with
| None -> remote_addr, remote_socket_port
| Some port -> remote_addr, port in
Format.fprintf ppf "%s %a %a (%a)"
(if incoming then "↘" else "↗")
Peer_id.pp peer_id
Point.pp point
Version.pp version
end
module Connection_pool_log_event = struct
type t =
| Too_few_connections
| Too_many_connections
| New_point of Point.t
| New_peer of Peer_id.t
| Gc_points
| Gc_peer_ids
| Incoming_connection of Point.t
| Outgoing_connection of Point.t
| Authentication_failed of Point.t
| Accepting_request of Point.t * Id_point.t * Peer_id.t
| Rejecting_request of Point.t * Id_point.t * Peer_id.t
| Request_rejected of Point.t * (Id_point.t * Peer_id.t) option
| Connection_established of Id_point.t * Peer_id.t
| Swap_request_received of { source : Peer_id.t }
| Swap_ack_received of { source : Peer_id.t }
| Swap_request_sent of { source : Peer_id.t }
| Swap_ack_sent of { source : Peer_id.t }
| Swap_request_ignored of { source : Peer_id.t }
| Swap_success of { source : Peer_id.t }
| Swap_failure of { source : Peer_id.t }
| Disconnection of Peer_id.t
| External_disconnection of Peer_id.t
let encoding =
let open Data_encoding in
let branch_encoding name obj =
conv (fun x -> (), x) (fun ((), x) -> x)
(merge_objs
(obj1 (req "event" (constant name))) obj) in
union ~tag_size:`Uint8 [
case (Tag 0) (branch_encoding "too_few_connections" empty)
(function Too_few_connections -> Some () | _ -> None)
(fun () -> Too_few_connections) ;
case (Tag 1) (branch_encoding "too_many_connections" empty)
(function Too_many_connections -> Some () | _ -> None)
(fun () -> Too_many_connections) ;
case (Tag 2) (branch_encoding "new_point"
(obj1 (req "point" Point.encoding)))
(function New_point p -> Some p | _ -> None)
(fun p -> New_point p) ;
case (Tag 3) (branch_encoding "new_peer"
(obj1 (req "peer_id" Peer_id.encoding)))
(function New_peer p -> Some p | _ -> None)
(fun p -> New_peer p) ;
case (Tag 4) (branch_encoding "incoming_connection"
(obj1 (req "point" Point.encoding)))
(function Incoming_connection p -> Some p | _ -> None)
(fun p -> Incoming_connection p) ;
case (Tag 5) (branch_encoding "outgoing_connection"
(obj1 (req "point" Point.encoding)))
(function Outgoing_connection p -> Some p | _ -> None)
(fun p -> Outgoing_connection p) ;
case (Tag 6) (branch_encoding "authentication_failed"
(obj1 (req "point" Point.encoding)))
(function Authentication_failed p -> Some p | _ -> None)
(fun p -> Authentication_failed p) ;
case (Tag 7) (branch_encoding "accepting_request"
(obj3
(req "point" Point.encoding)
(req "id_point" Id_point.encoding)
(req "peer_id" Peer_id.encoding)))
(function Accepting_request (p, id_p, g) ->
Some (p, id_p, g) | _ -> None)
(fun (p, id_p, g) -> Accepting_request (p, id_p, g)) ;
case (Tag 8) (branch_encoding "rejecting_request"
(obj3
(req "point" Point.encoding)
(req "id_point" Id_point.encoding)
(req "peer_id" Peer_id.encoding)))
(function Rejecting_request (p, id_p, g) ->
Some (p, id_p, g) | _ -> None)
(fun (p, id_p, g) -> Rejecting_request (p, id_p, g)) ;
case (Tag 9) (branch_encoding "request_rejected"
(obj2
(req "point" Point.encoding)
(opt "identity"
(tup2 Id_point.encoding Peer_id.encoding))))
(function Request_rejected (p, id) -> Some (p, id) | _ -> None)
(fun (p, id) -> Request_rejected (p, id)) ;
case (Tag 10) (branch_encoding "connection_established"
(obj2
(req "id_point" Id_point.encoding)
(req "peer_id" Peer_id.encoding)))
(function Connection_established (id_p, g) ->
Some (id_p, g) | _ -> None)
(fun (id_p, g) -> Connection_established (id_p, g)) ;
case (Tag 11) (branch_encoding "disconnection"
(obj1 (req "peer_id" Peer_id.encoding)))
(function Disconnection g -> Some g | _ -> None)
(fun g -> Disconnection g) ;
case (Tag 12) (branch_encoding "external_disconnection"
(obj1 (req "peer_id" Peer_id.encoding)))
(function External_disconnection g -> Some g | _ -> None)
(fun g -> External_disconnection g) ;
case (Tag 13) (branch_encoding "gc_points" empty)
(function Gc_points -> Some () | _ -> None)
(fun () -> Gc_points) ;
case (Tag 14) (branch_encoding "gc_peer_ids" empty)
(function Gc_peer_ids -> Some () | _ -> None)
(fun () -> Gc_peer_ids) ;
case (Tag 15) (branch_encoding "swap_request_received"
(obj1 (req "source" Peer_id.encoding)))
(function
| Swap_request_received { source } -> Some source
| _ -> None)
(fun source -> Swap_request_received { source }) ;
case (Tag 16) (branch_encoding "swap_ack_received"
(obj1 (req "source" Peer_id.encoding)))
(function
| Swap_ack_received { source } -> Some source
| _ -> None)
(fun source -> Swap_ack_received { source }) ;
case (Tag 17) (branch_encoding "swap_request_sent"
(obj1 (req "source" Peer_id.encoding)))
(function
| Swap_request_sent { source } -> Some source
| _ -> None)
(fun source -> Swap_request_sent { source }) ;
case (Tag 18) (branch_encoding "swap_ack_sent"
(obj1 (req "source" Peer_id.encoding)))
(function
| Swap_ack_sent { source } -> Some source
| _ -> None)
(fun source -> Swap_ack_sent { source }) ;
case (Tag 19) (branch_encoding "swap_request_ignored"
(obj1 (req "source" Peer_id.encoding)))
(function
| Swap_request_ignored { source } -> Some source
| _ -> None)
(fun source -> Swap_request_ignored { source }) ;
case (Tag 20) (branch_encoding "swap_success"
(obj1 (req "source" Peer_id.encoding)))
(function
| Swap_success { source } -> Some source
| _ -> None)
(fun source -> Swap_success { source }) ;
case (Tag 21) (branch_encoding "swap_failure"
(obj1 (req "source" Peer_id.encoding)))
(function
| Swap_failure { source } -> Some source
| _ -> None)
(fun source -> Swap_failure { source }) ;
]
end

263
src/lib_p2p_services/p2p_types.mli
View File

@ -1,263 +0,0 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
(** Protocol version *)
module Version : sig
type t = {
name : string ;
major : int ;
minor : int ;
}
(** Type of a protocol version. *)
val pp : Format.formatter -> t -> unit
val encoding : t Data_encoding.t
val common : t list -> t list -> t option
end
(** Peer_id, i.e. persistent peer identifier *)
module Peer_id : Tezos_crypto.S.INTERNAL_HASH
with type t = Crypto_box.Public_key_hash.t
type addr = Ipaddr.V6.t
type port = int
val addr_encoding : addr Data_encoding.t
(** 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 of_string_exn : string -> t
val of_string : string -> (t, string) result
val to_string : t -> string
val encoding : t Data_encoding.t
val is_local : t -> bool
val is_global : t -> bool
val parse_addr_port : string -> string * string
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 to_string : t -> string
val encoding : t Data_encoding.t
val is_local : t -> bool
val is_global : t -> bool
val of_point : Point.t -> t
val to_point : t -> Point.t option
val to_point_exn : t -> Point.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
(** Identity *)
module Identity : sig
type t = {
peer_id : Peer_id.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 peer_id, 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]. *)
val generate_with_animation :
Format.formatter -> Crypto_box.target -> t
(** [generate_with_animation ppf target] is a freshly minted identity
whose proof of work stamp difficulty is at least equal to [target]. *)
end
(** Bandwidth usage statistics *)
module Stat : sig
type t = {
total_sent : int64 ;
total_recv : int64 ;
current_inflow : int ;
current_outflow : int ;
}
val empty : t
val pp : Format.formatter -> t -> unit
val encoding : t Data_encoding.t
end
(** Information about a connection *)
module Connection_info : sig
type t = {
incoming : bool;
peer_id : Peer_id.t;
id_point : Id_point.t;
remote_socket_port : port;
versions : Version.t list ;
}
val pp : Format.formatter -> t -> unit
val encoding : t Data_encoding.t
end
(** Pool-level events *)
module Connection_pool_log_event : sig
type t =
| Too_few_connections
| Too_many_connections
| New_point of Point.t
| New_peer of Peer_id.t
| Gc_points
(** Garbage collection of known point table has been triggered. *)
| Gc_peer_ids
(** Garbage collection of known peer_ids table has been triggered. *)
(* Connection-level events *)
| Incoming_connection of Point.t
(** We accept(2)-ed an incoming connection *)
| Outgoing_connection of Point.t
(** We connect(2)-ed to a remote endpoint *)
| Authentication_failed of Point.t
(** Remote point failed authentication *)
| Accepting_request of Point.t * Id_point.t * Peer_id.t
(** We accepted a connection after authentifying the remote peer. *)
| Rejecting_request of Point.t * Id_point.t * Peer_id.t
(** We rejected a connection after authentifying the remote peer. *)
| Request_rejected of Point.t * (Id_point.t * Peer_id.t) option
(** The remote peer rejected our connection. *)
| Connection_established of Id_point.t * Peer_id.t
(** We succesfully established a authentified connection. *)
| Swap_request_received of { source : Peer_id.t }
(** A swap request has been received. *)
| Swap_ack_received of { source : Peer_id.t }
(** A swap ack has been received *)
| Swap_request_sent of { source : Peer_id.t }
(** A swap request has been sent *)
| Swap_ack_sent of { source : Peer_id.t }
(** A swap ack has been sent *)
| Swap_request_ignored of { source : Peer_id.t }
(** A swap request has been ignored *)
| Swap_success of { source : Peer_id.t }
(** A swap operation has succeeded *)
| Swap_failure of { source : Peer_id.t }
(** A swap operation has failed *)
| Disconnection of Peer_id.t
(** We decided to close the connection. *)
| External_disconnection of Peer_id.t
(** The connection was closed for external reason. *)
val encoding : t Data_encoding.t
end
module Point_state : sig
type t =
| Requested
| Accepted of Peer_id.t
| Running of Peer_id.t
| Disconnected
val pp_digram : Format.formatter -> t -> unit
val encoding : t Data_encoding.t
end
module Point_info : sig
type t = {
trusted : bool ;
greylisted_until : Time.t ;
state : Point_state.t ;
last_failed_connection : Time.t option ;
last_rejected_connection : (Peer_id.t * Time.t) option ;
last_established_connection : (Peer_id.t * Time.t) option ;
last_disconnection : (Peer_id.t * Time.t) option ;
last_seen : (Peer_id.t * Time.t) option ;
last_miss : Time.t option ;
}
val encoding : t Data_encoding.t
end
module Peer_state : sig
type t =
| Accepted
| Running
| Disconnected
val pp_digram : Format.formatter -> t -> unit
val encoding : t Data_encoding.t
end
module Peer_info : sig
type t = {
score : float ;
trusted : bool ;
state : Peer_state.t ;
id_point : Id_point.t option ;
stat : Stat.t ;
last_failed_connection : (Id_point.t * Time.t) option ;
last_rejected_connection : (Id_point.t * Time.t) option ;
last_established_connection : (Id_point.t * Time.t) option ;
last_disconnection : (Id_point.t * Time.t) option ;
last_seen : (Id_point.t * Time.t) option ;
last_miss : (Id_point.t * Time.t) option ;
}
val encoding : t Data_encoding.t
end

2
src/lib_shell/block_validator.ml
View File

@ -40,7 +40,7 @@ module Request = struct
net_db: Distributed_db.net_db ;
notify_new_block: State.Block.t -> unit ;
canceler: Lwt_canceler.t option ;
peer: P2p.Peer_id.t option ;
peer: P2p_peer.Id.t option ;
hash: Block_hash.t ;
header: Block_header.t ;
operations: Operation.t list list ;

4
src/lib_shell/block_validator.mli
View File

@ -22,7 +22,7 @@ val create:
val validate:
t ->
?canceler:Lwt_canceler.t ->
?peer:P2p.Peer_id.t ->
?peer:P2p_peer.Id.t ->
?notify_new_block:(State.Block.t -> unit) ->
Distributed_db.net_db ->
Block_hash.t -> Block_header.t -> Operation.t list list ->
@ -30,7 +30,7 @@ val validate:
val fetch_and_compile_protocol:
t ->
?peer:P2p.Peer_id.t ->
?peer:P2p_peer.Id.t ->
?timeout:float ->
Protocol_hash.t -> State.Registred_protocol.t tzresult Lwt.t

34
src/lib_shell/bootstrap_pipeline.ml
View File

@ -9,7 +9,7 @@
include Logging.Make(struct let name = "node.validator.bootstrap_pipeline" end)
type error += Invalid_locator of P2p.Peer_id.t * Block_locator.t
type error += Invalid_locator of P2p_peer.Id.t * Block_locator.t
type t = {
canceler: Lwt_canceler.t ;
@ -18,7 +18,7 @@ type t = {
mutable headers_fetch_worker: unit Lwt.t ;
mutable operations_fetch_worker: unit Lwt.t ;
mutable validation_worker: unit Lwt.t ;
peer_id: P2p.Peer_id.t ;
peer_id: P2p_peer.Id.t ;
net_db: Distributed_db.net_db ;
locator: Block_locator.t ;
block_validator: Block_validator.t ;
@ -37,24 +37,24 @@ let fetch_step pipeline (step : Block_locator_iterator.step) =
Block_hash.pp_short step.predecessor
step.step
(if step.strict_step then "" else " max")
P2p.Peer_id.pp_short pipeline.peer_id >>= fun () ->
P2p_peer.Id.pp_short pipeline.peer_id >>= fun () ->
let rec fetch_loop acc hash cpt =
Lwt_unix.yield () >>= fun () ->
if cpt < 0 then
lwt_log_info "invalid step from peer %a (too long)."
P2p.Peer_id.pp_short pipeline.peer_id >>= fun () ->
P2p_peer.Id.pp_short pipeline.peer_id >>= fun () ->
fail (Invalid_locator (pipeline.peer_id, pipeline.locator))
else if Block_hash.equal hash step.predecessor then
if step.strict_step && cpt <> 0 then
lwt_log_info "invalid step from peer %a (too short)."
P2p.Peer_id.pp_short pipeline.peer_id >>= fun () ->
P2p_peer.Id.pp_short pipeline.peer_id >>= fun () ->
fail (Invalid_locator (pipeline.peer_id, pipeline.locator))
else
return acc
else
lwt_debug "fetching block header %a from peer %a."
Block_hash.pp_short hash
P2p.Peer_id.pp_short pipeline.peer_id >>= fun () ->
P2p_peer.Id.pp_short pipeline.peer_id >>= fun () ->
Lwt_utils.protect ~canceler:pipeline.canceler begin fun () ->
Distributed_db.Block_header.fetch
~timeout:pipeline.block_header_timeout
@ -63,7 +63,7 @@ let fetch_step pipeline (step : Block_locator_iterator.step) =
end >>=? fun header ->
lwt_debug "fetched block header %a from peer %a."
Block_hash.pp_short hash
P2p.Peer_id.pp_short pipeline.peer_id >>= fun () ->
P2p_peer.Id.pp_short pipeline.peer_id >>= fun () ->
fetch_loop ((hash, header) :: acc) header.shell.predecessor (cpt - 1)
in
fetch_loop [] step.block step.step >>=? fun headers ->
@ -84,7 +84,7 @@ let headers_fetch_worker_loop pipeline =
end >>= function
| Ok () ->
lwt_log_info "fetched all step from peer %a."
P2p.Peer_id.pp_short pipeline.peer_id >>= fun () ->
P2p_peer.Id.pp_short pipeline.peer_id >>= fun () ->
Lwt_pipe.close pipeline.fetched_headers ;
Lwt.return_unit
| Error [Exn Lwt.Canceled | Lwt_utils.Canceled | Exn Lwt_pipe.Closed] ->
@ -92,7 +92,7 @@ let headers_fetch_worker_loop pipeline =
| Error [ Distributed_db.Block_header.Timeout bh ] ->
lwt_log_info "request for header %a from peer %a timed out."
Block_hash.pp_short bh
P2p.Peer_id.pp_short pipeline.peer_id >>= fun () ->
P2p_peer.Id.pp_short pipeline.peer_id >>= fun () ->
Lwt_canceler.cancel pipeline.canceler >>= fun () ->
Lwt.return_unit
| Error err ->
@ -110,7 +110,7 @@ let rec operations_fetch_worker_loop pipeline =
end >>=? fun (hash, header) ->
lwt_log_info "fetching operations of block %a from peer %a."
Block_hash.pp_short hash
P2p.Peer_id.pp_short pipeline.peer_id >>= fun () ->
P2p_peer.Id.pp_short pipeline.peer_id >>= fun () ->
map_p
(fun i ->
Lwt_utils.protect ~canceler:pipeline.canceler begin fun () ->
@ -122,7 +122,7 @@ let rec operations_fetch_worker_loop pipeline =
(0 -- (header.shell.validation_passes - 1)) >>=? fun operations ->
lwt_log_info "fetched operations of block %a from peer %a."
Block_hash.pp_short hash
P2p.Peer_id.pp_short pipeline.peer_id >>= fun () ->
P2p_peer.Id.pp_short pipeline.peer_id >>= fun () ->
Lwt_utils.protect ~canceler:pipeline.canceler begin fun () ->
Lwt_pipe.push pipeline.fetched_blocks
(hash, header, operations) >>= return
@ -136,7 +136,7 @@ let rec operations_fetch_worker_loop pipeline =
| Error [ Distributed_db.Operations.Timeout (bh, n) ] ->
lwt_log_info "request for operations %a:%d from peer %a timed out."
Block_hash.pp_short bh n
P2p.Peer_id.pp_short pipeline.peer_id >>= fun () ->
P2p_peer.Id.pp_short pipeline.peer_id >>= fun () ->
Lwt_canceler.cancel pipeline.canceler >>= fun () ->
Lwt.return_unit
| Error err ->
@ -154,7 +154,7 @@ let rec validation_worker_loop pipeline =
end >>=? fun (hash, header, operations) ->
lwt_log_info "requesting validation for block %a from peer %a."
Block_hash.pp_short hash
P2p.Peer_id.pp_short pipeline.peer_id >>= fun () ->
P2p_peer.Id.pp_short pipeline.peer_id >>= fun () ->
Lwt_utils.protect ~canceler:pipeline.canceler begin fun () ->
Block_validator.validate
~canceler:pipeline.canceler
@ -164,7 +164,7 @@ let rec validation_worker_loop pipeline =
end >>=? fun _block ->
lwt_log_info "validated block %a from peer %a."
Block_hash.pp_short hash
P2p.Peer_id.pp_short pipeline.peer_id >>= fun () ->
P2p_peer.Id.pp_short pipeline.peer_id >>= fun () ->
return ()
end >>= function
| Ok () -> validation_worker_loop pipeline
@ -214,19 +214,19 @@ let create
pipeline.headers_fetch_worker <-
Lwt_utils.worker
(Format.asprintf "bootstrap_pipeline-headers_fetch.%a.%a"
P2p.Peer_id.pp_short peer_id Block_hash.pp_short hash)
P2p_peer.Id.pp_short peer_id Block_hash.pp_short hash)
~run:(fun () -> headers_fetch_worker_loop pipeline)
~cancel:(fun () -> Lwt_canceler.cancel pipeline.canceler) ;
pipeline.operations_fetch_worker <-
Lwt_utils.worker
(Format.asprintf "bootstrap_pipeline-operations_fetch.%a.%a"
P2p.Peer_id.pp_short peer_id Block_hash.pp_short hash)
P2p_peer.Id.pp_short peer_id Block_hash.pp_short hash)
~run:(fun () -> operations_fetch_worker_loop pipeline)
~cancel:(fun () -> Lwt_canceler.cancel pipeline.canceler) ;
pipeline.validation_worker <-
Lwt_utils.worker
(Format.asprintf "bootstrap_pipeline-validation.%a.%a"
P2p.Peer_id.pp_short peer_id Block_hash.pp_short hash)
P2p_peer.Id.pp_short peer_id Block_hash.pp_short hash)
~run:(fun () -> validation_worker_loop pipeline)
~cancel:(fun () -> Lwt_canceler.cancel pipeline.canceler) ;
pipeline

4
src/lib_shell/bootstrap_pipeline.mli
View File

@ -9,14 +9,14 @@
type t
type error += Invalid_locator of P2p.Peer_id.t * Block_locator.t
type error += Invalid_locator of P2p_peer.Id.t * Block_locator.t
val create:
?notify_new_block: (State.Block.t -> unit) ->
block_header_timeout:float ->
block_operations_timeout: float ->
Block_validator.t ->
P2p.Peer_id.t -> Distributed_db.net_db ->
P2p_peer.Id.t -> Distributed_db.net_db ->
Block_locator.t -> t
val wait: t -> unit tzresult Lwt.t

58
src/lib_shell/distributed_db.ml
View File

@ -15,8 +15,8 @@ type connection = (Message.t, Metadata.t) P2p.connection
type 'a request_param = {
data: 'a ;
active: unit -> P2p.Peer_id.Set.t ;
send: P2p.Peer_id.t -> Message.t -> unit ;
active: unit -> P2p_peer.Set.t ;
send: P2p_peer.Id.t -> Message.t -> unit ;
}
module Make_raw
@ -292,15 +292,15 @@ module Raw_protocol =
type callback = {
notify_branch:
P2p.Peer_id.t -> Block_locator.t -> unit ;
P2p_peer.Id.t -> Block_locator.t -> unit ;
notify_head:
P2p.Peer_id.t -> Block_header.t -> Mempool.t -> unit ;
disconnection: P2p.Peer_id.t -> unit ;
P2p_peer.Id.t -> Block_header.t -> Mempool.t -> unit ;
disconnection: P2p_peer.Id.t -> unit ;
}
type db = {
p2p: p2p ;
p2p_readers: p2p_reader P2p.Peer_id.Table.t ;
p2p_readers: p2p_reader P2p_peer.Table.t ;
disk: State.t ;
active_nets: net_db Net_id.Table.t ;
protocol_db: Raw_protocol.t ;
@ -316,12 +316,12 @@ and net_db = {
operation_hashes_db: Raw_operation_hashes.t ;
operations_db: Raw_operations.t ;
mutable callback: callback ;
active_peers: P2p.Peer_id.Set.t ref ;
active_connections: p2p_reader P2p.Peer_id.Table.t ;
active_peers: P2p_peer.Set.t ref ;
active_connections: p2p_reader P2p_peer.Table.t ;
}
and p2p_reader = {
gid: P2p.Peer_id.t ;
gid: P2p_peer.Id.t ;
conn: connection ;
peer_active_nets: net_db Net_id.Table.t ;
canceler: Lwt_canceler.t ;
@ -418,8 +418,8 @@ module P2p_reader = struct
match Net_id.Table.find global_db.active_nets net_id with
| net_db ->
net_db.active_peers :=
P2p.Peer_id.Set.add state.gid !(net_db.active_peers) ;
P2p.Peer_id.Table.add net_db.active_connections
P2p_peer.Set.add state.gid !(net_db.active_peers) ;
P2p_peer.Table.add net_db.active_connections
state.gid state ;
Net_id.Table.add state.peer_active_nets net_id net_db ;
f net_db
@ -430,8 +430,8 @@ module P2p_reader = struct
let deactivate state net_db =
net_db.callback.disconnection state.gid ;
net_db.active_peers :=
P2p.Peer_id.Set.remove state.gid !(net_db.active_peers) ;
P2p.Peer_id.Table.remove net_db.active_connections state.gid
P2p_peer.Set.remove state.gid !(net_db.active_peers) ;
P2p_peer.Table.remove net_db.active_connections state.gid
let may_handle state net_id f =
match Net_id.Table.find state.peer_active_nets net_id with
@ -456,7 +456,7 @@ module P2p_reader = struct
let open Logging in
lwt_debug "Read message from %a: %a"
P2p.Peer_id.pp_short state.gid Message.pp_json msg >>= fun () ->
P2p_peer.Id.pp_short state.gid Message.pp_json msg >>= fun () ->
match msg with
@ -639,7 +639,7 @@ module P2p_reader = struct
Net_id.Table.iter
(fun _ -> deactivate state)
state.peer_active_nets ;
P2p.Peer_id.Table.remove global_db.p2p_readers state.gid ;
P2p_peer.Table.remove global_db.p2p_readers state.gid ;
Lwt.return_unit
let run db gid conn =
@ -657,10 +657,10 @@ module P2p_reader = struct
state.worker <-
Lwt_utils.worker
(Format.asprintf "db_network_reader.%a"
P2p.Peer_id.pp_short gid)
P2p_peer.Id.pp_short gid)
~run:(fun () -> worker_loop db state)
~cancel:(fun () -> Lwt_canceler.cancel canceler) ;
P2p.Peer_id.Table.add db.p2p_readers gid state
P2p_peer.Table.add db.p2p_readers gid state
let shutdown s =
Lwt_canceler.cancel s.canceler >>= fun () ->
@ -671,9 +671,9 @@ end
let active_peer_ids p2p () =
List.fold_left
(fun acc conn ->
let { P2p.Connection_info.peer_id } = P2p.connection_info p2p conn in
P2p.Peer_id.Set.add peer_id acc)
P2p.Peer_id.Set.empty
let { P2p_connection.Info.peer_id } = P2p.connection_info p2p conn in
P2p_peer.Set.add peer_id acc)
P2p_peer.Set.empty
(P2p.connections p2p)
let raw_try_send p2p peer_id msg =
@ -689,7 +689,7 @@ let create disk p2p =
} in
let protocol_db = Raw_protocol.create global_request disk in
let active_nets = Net_id.Table.create 17 in
let p2p_readers = P2p.Peer_id.Table.create 17 in
let p2p_readers = P2p_peer.Table.create 17 in
let block_input = Lwt_watcher.create_input () in
let operation_input = Lwt_watcher.create_input () in
let db =
@ -704,7 +704,7 @@ let activate ({ p2p ; active_nets } as global_db) net_state =
let net_id = State.Net.id net_state in
match Net_id.Table.find active_nets net_id with
| exception Not_found ->
let active_peers = ref P2p.Peer_id.Set.empty in
let active_peers = ref P2p_peer.Set.empty in
let p2p_request =
{ data = () ;
active = (fun () -> !active_peers) ;
@ -724,7 +724,7 @@ let activate ({ p2p ; active_nets } as global_db) net_state =
global_db ; operation_db ; block_header_db ;
operation_hashes_db ; operations_db ;
net_state ; callback = noop_callback ; active_peers ;
active_connections = P2p.Peer_id.Table.create 53 ;
active_connections = P2p_peer.Table.create 53 ;
} in
P2p.iter_connections p2p (fun _peer_id conn ->
Lwt.async begin fun () ->
@ -742,7 +742,7 @@ let deactivate net_db =
let { active_nets ; p2p } = net_db.global_db in
let net_id = State.Net.id net_db.net_state in
Net_id.Table.remove active_nets net_id ;
P2p.Peer_id.Table.iter
P2p_peer.Table.iter
(fun _peer_id reader ->
P2p_reader.deactivate reader net_db ;
Lwt.async begin fun () ->
@ -764,7 +764,7 @@ let disconnect { global_db = { p2p } } peer_id =
| Some conn -> P2p.disconnect p2p conn
let shutdown { p2p ; p2p_readers ; active_nets } =
P2p.Peer_id.Table.fold
P2p_peer.Table.fold
(fun _peer_id reader acc ->
P2p_reader.shutdown reader >>= fun () -> acc)
p2p_readers
@ -829,12 +829,12 @@ module type DISTRIBUTED_DB = sig
type error += Timeout of key
val fetch:
t ->
?peer:P2p.Peer_id.t ->
?peer:P2p_peer.Id.t ->
?timeout:float ->
key -> param -> value tzresult Lwt.t
val prefetch:
t ->
?peer:P2p.Peer_id.t ->
?peer:P2p_peer.Id.t ->
?timeout:float ->
key -> param -> unit
type error += Canceled of key
@ -913,14 +913,14 @@ end
let broadcast net_db msg =
P2p.Peer_id.Table.iter
P2p_peer.Table.iter
(fun _peer_id state ->
ignore (P2p.try_send net_db.global_db.p2p state.conn msg))
net_db.active_connections
let try_send net_db peer_id msg =
try
let conn = P2p.Peer_id.Table.find net_db.active_connections peer_id in
let conn = P2p_peer.Table.find net_db.active_connections peer_id in
ignore (P2p.try_send net_db.global_db.p2p conn.conn msg : bool)
with Not_found -> ()

22
src/lib_shell/distributed_db.mli
View File

@ -40,9 +40,9 @@ val get_net: t -> Net_id.t -> net_db option
val deactivate: net_db -> unit Lwt.t
type callback = {
notify_branch: P2p.Peer_id.t -> Block_locator.t -> unit ;
notify_head: P2p.Peer_id.t -> Block_header.t -> Mempool.t -> unit ;
disconnection: P2p.Peer_id.t -> unit ;
notify_branch: P2p_peer.Id.t -> Block_locator.t -> unit ;
notify_head: P2p_peer.Id.t -> Block_header.t -> Mempool.t -> unit ;
disconnection: P2p_peer.Id.t -> unit ;
}
(** Register all the possible callback from the distributed DB to the
@ -50,7 +50,7 @@ type callback = {
val set_callback: net_db -> callback -> unit
(** Kick a given peer. *)
val disconnect: net_db -> P2p.Peer_id.t -> unit Lwt.t
val disconnect: net_db -> P2p_peer.Id.t -> unit Lwt.t
(** Various accessors. *)
val net_state: net_db -> State.Net.t
@ -63,12 +63,12 @@ module Request : sig
(** Send to a given peer, or to all known active peers for the
network, a friendly request "Hey, what's your current branch
?". The expected answer is a `Block_locator.t.`. *)
val current_branch: net_db -> ?peer:P2p.Peer_id.t -> unit -> unit
val current_branch: net_db -> ?peer:P2p_peer.Id.t -> unit -> unit
(** Send to a given peer, or to all known active peers for the
given network, a friendly request "Hey, what's your current
branch ?". The expected answer is a `Block_locator.t.`. *)
val current_head: net_db -> ?peer:P2p.Peer_id.t -> unit -> unit
val current_head: net_db -> ?peer:P2p_peer.Id.t -> unit -> unit
end
@ -77,13 +77,13 @@ module Advertise : sig
(** Notify a given peer, or all known active peers for the
network, of a new head and possibly of new operations. *)
val current_head:
net_db -> ?peer:P2p.Peer_id.t ->
net_db -> ?peer:P2p_peer.Id.t ->
?mempool:Mempool.t -> State.Block.t -> unit
(** Notify a given peer, or all known active peers for the
network, of a new head and its sparse history. *)
val current_branch:
net_db -> ?peer:P2p.Peer_id.t ->
net_db -> ?peer:P2p_peer.Id.t ->
Block_locator.t -> unit Lwt.t
end
@ -145,7 +145,7 @@ module type DISTRIBUTED_DB = sig
peer (at each retry). *)
val fetch:
t ->
?peer:P2p.Peer_id.t ->
?peer:P2p_peer.Id.t ->
?timeout:float ->
key -> param -> value tzresult Lwt.t
@ -153,7 +153,7 @@ module type DISTRIBUTED_DB = sig
stored in the local index when received. *)
val prefetch:
t ->
?peer:P2p.Peer_id.t ->
?peer:P2p_peer.Id.t ->
?timeout:float ->
key -> param -> unit
@ -257,6 +257,6 @@ val commit_protocol:
module Raw : sig
val encoding: Message.t P2p.Raw.t Data_encoding.t
val supported_versions: P2p_types.Version.t list
val supported_versions: P2p_version.t list
end

78
src/lib_shell/distributed_db_functors.ml
View File

@ -26,13 +26,13 @@ module type DISTRIBUTED_DB = sig
val prefetch:
t ->
?peer:P2p.Peer_id.t ->
?peer:P2p_peer.Id.t ->
?timeout:float ->
key -> param -> unit
val fetch:
t ->
?peer:P2p.Peer_id.t ->
?peer:P2p_peer.Id.t ->
?timeout:float ->
key -> param -> value tzresult Lwt.t
@ -68,12 +68,12 @@ end
module type SCHEDULER_EVENTS = sig
type t
type key
val request: t -> P2p.Peer_id.t option -> key -> unit
val notify: t -> P2p.Peer_id.t -> key -> unit
val request: t -> P2p_peer.Id.t option -> key -> unit
val notify: t -> P2p_peer.Id.t -> key -> unit
val notify_cancelation: t -> key -> unit
val notify_unrequested: t -> P2p.Peer_id.t -> key -> unit
val notify_duplicate: t -> P2p.Peer_id.t -> key -> unit
val notify_invalid: t -> P2p.Peer_id.t -> key -> unit
val notify_unrequested: t -> P2p_peer.Id.t -> key -> unit
val notify_duplicate: t -> P2p_peer.Id.t -> key -> unit
val notify_invalid: t -> P2p_peer.Id.t -> key -> unit
end
module type PRECHECK = sig
@ -103,7 +103,7 @@ module Make_table
val create:
?global_input:(key * value) Lwt_watcher.input ->
Scheduler.t -> Disk_table.store -> t
val notify: t -> P2p.Peer_id.t -> key -> Precheck.notified_value -> unit Lwt.t
val notify: t -> P2p_peer.Id.t -> key -> Precheck.notified_value -> unit Lwt.t
end = struct
@ -306,8 +306,8 @@ end
module type REQUEST = sig
type key
type param
val active : param -> P2p.Peer_id.Set.t
val send : param -> P2p.Peer_id.t -> key list -> unit
val active : param -> P2p_peer.Set.t
val send : param -> P2p_peer.Id.t -> key list -> unit
end
module Make_request_scheduler
@ -343,24 +343,24 @@ end = struct
}
and status = {
peers: P2p.Peer_id.Set.t ;
peers: P2p_peer.Set.t ;
next_request: float ;
delay: float ;
}
and event =
| Request of P2p.Peer_id.t option * key
| Notify of P2p.Peer_id.t * key
| Request of P2p_peer.Id.t option * key
| Notify of P2p_peer.Id.t * key
| Notify_cancelation of key
| Notify_invalid of P2p.Peer_id.t * key
| Notify_duplicate of P2p.Peer_id.t * key
| Notify_unrequested of P2p.Peer_id.t * key
| Notify_invalid of P2p_peer.Id.t * key
| Notify_duplicate of P2p_peer.Id.t * key
| Notify_unrequested of P2p_peer.Id.t * key
let request t p k =
assert (Lwt_pipe.push_now t.queue (Request (p, k)))
let notify t p k =
debug "push received %a from %a"
Hash.pp k P2p.Peer_id.pp_short p ;
Hash.pp k P2p_peer.Id.pp_short p ;
assert (Lwt_pipe.push_now t.queue (Notify (p, k)))
let notify_cancelation t k =
debug "push cancelation %a"
@ -368,15 +368,15 @@ end = struct
assert (Lwt_pipe.push_now t.queue (Notify_cancelation k))
let notify_invalid t p k =
debug "push received invalid %a from %a"
Hash.pp k P2p.Peer_id.pp_short p ;
Hash.pp k P2p_peer.Id.pp_short p ;
assert (Lwt_pipe.push_now t.queue (Notify_invalid (p, k)))
let notify_duplicate t p k =
debug "push received duplicate %a from %a"
Hash.pp k P2p.Peer_id.pp_short p ;
Hash.pp k P2p_peer.Id.pp_short p ;
assert (Lwt_pipe.push_now t.queue (Notify_duplicate (p, k)))
let notify_unrequested t p k =
debug "push received unrequested %a from %a"
Hash.pp k P2p.Peer_id.pp_short p ;
Hash.pp k P2p_peer.Id.pp_short p ;
assert (Lwt_pipe.push_now t.queue (Notify_unrequested (p, k)))
let compute_timeout state =
@ -399,7 +399,7 @@ end = struct
let may_pp_peer ppf = function
| None -> ()
| Some peer -> P2p.Peer_id.pp_short ppf peer
| Some peer -> P2p_peer.Id.pp_short ppf peer
(* TODO should depend on the ressource kind... *)
let initial_delay = 0.1
@ -413,7 +413,7 @@ end = struct
let peers =
match peer with
| None -> data.peers
| Some peer -> P2p.Peer_id.Set.add peer data.peers in
| Some peer -> P2p_peer.Set.add peer data.peers in
Table.replace state.pending key {
delay = initial_delay ;
next_request = min data.next_request (now +. initial_delay) ;
@ -425,8 +425,8 @@ end = struct
with Not_found ->
let peers =
match peer with
| None -> P2p.Peer_id.Set.empty
| Some peer -> P2p.Peer_id.Set.singleton peer in
| None -> P2p_peer.Set.empty
| Some peer -> P2p_peer.Set.singleton peer in
Table.add state.pending key {
peers ;
next_request = now ;
@ -439,7 +439,7 @@ end = struct
| Notify (peer, key) ->
Table.remove state.pending key ;
lwt_debug "received %a from %a"
Hash.pp key P2p.Peer_id.pp_short peer >>= fun () ->
Hash.pp key P2p_peer.Id.pp_short peer >>= fun () ->
Lwt.return_unit
| Notify_cancelation key ->
Table.remove state.pending key ;
@ -448,17 +448,17 @@ end = struct
Lwt.return_unit
| Notify_invalid (peer, key) ->
lwt_debug "received invalid %a from %a"
Hash.pp key P2p.Peer_id.pp_short peer >>= fun () ->
Hash.pp key P2p_peer.Id.pp_short peer >>= fun () ->
(* TODO *)
Lwt.return_unit
| Notify_unrequested (peer, key) ->
lwt_debug "received unrequested %a from %a"
Hash.pp key P2p.Peer_id.pp_short peer >>= fun () ->
Hash.pp key P2p_peer.Id.pp_short peer >>= fun () ->
(* TODO *)
Lwt.return_unit
| Notify_duplicate (peer, key) ->
lwt_debug "received duplicate %a from %a"
Hash.pp key P2p.Peer_id.pp_short peer >>= fun () ->
Hash.pp key P2p_peer.Id.pp_short peer >>= fun () ->
(* TODO *)
Lwt.return_unit
@ -487,14 +487,14 @@ end = struct
acc
else
let remaining_peers =
P2p.Peer_id.Set.inter peers active_peers in
if P2p.Peer_id.Set.is_empty remaining_peers &&
not (P2p.Peer_id.Set.is_empty peers) then
P2p_peer.Set.inter peers active_peers in
if P2p_peer.Set.is_empty remaining_peers &&
not (P2p_peer.Set.is_empty peers) then
( Table.remove state.pending key ; acc )
else
let requested_peer =
P2p.Peer_id.random_set_elt
(if P2p.Peer_id.Set.is_empty remaining_peers
P2p_peer.Id.random_set_elt
(if P2p_peer.Set.is_empty remaining_peers
then active_peers
else remaining_peers) in
let next = { peers = remaining_peers ;
@ -502,16 +502,16 @@ end = struct
delay = delay *. 1.2 } in
Table.replace state.pending key next ;
let requests =
try key :: P2p_types.Peer_id.Map.find requested_peer acc
try key :: P2p_peer.Map.find requested_peer acc
with Not_found -> [key] in
P2p_types.Peer_id.Map.add requested_peer requests acc)
state.pending P2p_types.Peer_id.Map.empty in
P2p_types.Peer_id.Map.iter (Request.send state.param) requests ;
P2p_types.Peer_id.Map.fold begin fun peer request acc ->
P2p_peer.Map.add requested_peer requests acc)
state.pending P2p_peer.Map.empty in
P2p_peer.Map.iter (Request.send state.param) requests ;
P2p_peer.Map.fold begin fun peer request acc ->
acc >>= fun () ->
Lwt_list.iter_s (fun key ->
lwt_debug "requested %a from %a"
Hash.pp key P2p.Peer_id.pp_short peer)
Hash.pp key P2p_peer.Id.pp_short peer)
request
end requests Lwt.return_unit >>= fun () ->
worker_loop state

20
src/lib_shell/distributed_db_functors.mli
View File

@ -29,13 +29,13 @@ module type DISTRIBUTED_DB = sig
val prefetch:
t ->
?peer:P2p.Peer_id.t ->
?peer:P2p_peer.Id.t ->
?timeout:float ->
key -> param -> unit
val fetch:
t ->
?peer:P2p.Peer_id.t ->
?peer:P2p_peer.Id.t ->
?timeout:float ->
key -> param -> value tzresult Lwt.t
@ -72,12 +72,12 @@ end
module type SCHEDULER_EVENTS = sig
type t
type key
val request: t -> P2p.Peer_id.t option -> key -> unit
val notify: t -> P2p.Peer_id.t -> key -> unit
val request: t -> P2p_peer.Id.t option -> key -> unit
val notify: t -> P2p_peer.Id.t -> key -> unit
val notify_cancelation: t -> key -> unit
val notify_unrequested: t -> P2p.Peer_id.t -> key -> unit
val notify_duplicate: t -> P2p.Peer_id.t -> key -> unit
val notify_invalid: t -> P2p.Peer_id.t -> key -> unit
val notify_unrequested: t -> P2p_peer.Id.t -> key -> unit
val notify_duplicate: t -> P2p_peer.Id.t -> key -> unit
val notify_invalid: t -> P2p_peer.Id.t -> key -> unit
end
module type PRECHECK = sig
@ -107,15 +107,15 @@ module Make_table
val create:
?global_input:(key * value) Lwt_watcher.input ->
Scheduler.t -> Disk_table.store -> t
val notify: t -> P2p.Peer_id.t -> key -> Precheck.notified_value -> unit Lwt.t
val notify: t -> P2p_peer.Id.t -> key -> Precheck.notified_value -> unit Lwt.t
end
module type REQUEST = sig
type key
type param
val active : param -> P2p.Peer_id.Set.t
val send : param -> P2p.Peer_id.t -> key list -> unit
val active : param -> P2p_peer.Set.t
val send : param -> P2p_peer.Id.t -> key list -> unit
end
module Make_request_scheduler

2
src/lib_shell/distributed_db_message.ml
View File

@ -169,7 +169,7 @@ let encoding =
]
let versions =
let open P2p.Version in
let open P2p_version in
[ { name = "TEZOS" ;
major = 0 ;
minor = 27 ;

26
src/lib_shell/net_validator.ml
View File

@ -57,17 +57,17 @@ module Types = struct
mutable child:
(state * (unit -> unit Lwt.t (* shutdown *))) option ;
prevalidator: Prevalidator.t ;
active_peers: Peer_validator.t Lwt.t P2p.Peer_id.Table.t ;
bootstrapped_peers: unit P2p.Peer_id.Table.t ;
active_peers: Peer_validator.t Lwt.t P2p_peer.Table.t ;
bootstrapped_peers: unit P2p_peer.Table.t ;
}
let view (state : state) _ : view =
let { bootstrapped ; active_peers ; bootstrapped_peers } = state in
{ bootstrapped ;
active_peers =
P2p.Peer_id.Table.fold (fun id _ l -> id :: l) active_peers [] ;
P2p_peer.Table.fold (fun id _ l -> id :: l) active_peers [] ;
bootstrapped_peers =
P2p.Peer_id.Table.fold (fun id _ l -> id :: l) bootstrapped_peers [] }
P2p_peer.Table.fold (fun id _ l -> id :: l) bootstrapped_peers [] }
end
module Worker = Worker.Make (Name) (Event) (Request) (Types)
@ -99,7 +99,7 @@ let notify_new_block w block =
let may_toggle_bootstrapped_network w =
let nv = Worker.state w in
if not nv.bootstrapped &&
P2p.Peer_id.Table.length nv.bootstrapped_peers >= nv.parameters.limits.bootstrap_threshold
P2p_peer.Table.length nv.bootstrapped_peers >= nv.parameters.limits.bootstrap_threshold
then begin
nv.bootstrapped <- true ;
Lwt.wakeup_later nv.bootstrapped_wakener () ;
@ -107,24 +107,24 @@ let may_toggle_bootstrapped_network w =
let may_activate_peer_validator w peer_id =
let nv = Worker.state w in
try P2p.Peer_id.Table.find nv.active_peers peer_id
try P2p_peer.Table.find nv.active_peers peer_id
with Not_found ->
let pv =
Peer_validator.create
~notify_new_block:(notify_new_block w)
~notify_bootstrapped: begin fun () ->
P2p.Peer_id.Table.add nv.bootstrapped_peers peer_id () ;
P2p_peer.Table.add nv.bootstrapped_peers peer_id () ;
may_toggle_bootstrapped_network w
end
~notify_termination: begin fun _pv ->
P2p.Peer_id.Table.remove nv.active_peers peer_id ;
P2p.Peer_id.Table.remove nv.bootstrapped_peers peer_id ;
P2p_peer.Table.remove nv.active_peers peer_id ;
P2p_peer.Table.remove nv.bootstrapped_peers peer_id ;
end
nv.parameters.peer_validator_limits
nv.parameters.block_validator
nv.parameters.net_db
peer_id in
P2p.Peer_id.Table.add nv.active_peers peer_id pv ;
P2p_peer.Table.add nv.active_peers peer_id pv ;
pv
let may_switch_test_network w spawn_child block =
@ -260,7 +260,7 @@ let on_close w =
Lwt.join
(Prevalidator.shutdown nv.prevalidator ::
Lwt_utils.may ~f:(fun (_, shutdown) -> shutdown ()) nv.child ::
P2p.Peer_id.Table.fold
P2p_peer.Table.fold
(fun _ pv acc -> (pv >>= Peer_validator.shutdown) :: acc)
nv.active_peers []) >>= fun () ->
Lwt.return_unit
@ -280,9 +280,9 @@ let on_launch w _ parameters =
bootstrapped_waiter ;
bootstrapped = (parameters.limits.bootstrap_threshold <= 0) ;
active_peers =
P2p.Peer_id.Table.create 50 ; (* TODO use `2 * max_connection` *)
P2p_peer.Table.create 50 ; (* TODO use `2 * max_connection` *)
bootstrapped_peers =
P2p.Peer_id.Table.create 50 ; (* TODO use `2 * max_connection` *)
P2p_peer.Table.create 50 ; (* TODO use `2 * max_connection` *)
child = None ;
prevalidator } in
if nv.bootstrapped then Lwt.wakeup_later bootstrapped_wakener () ;

42
src/lib_shell/node.mli
View File

@ -129,58 +129,56 @@ module RPC : sig
module Network : sig
open P2p_types
val stat : t -> Stat.t
val stat : t -> P2p_stat.t
val watch :
t ->
P2p_types.Connection_pool_log_event.t Lwt_stream.t * Lwt_watcher.stopper
val connect : t -> Point.t -> float -> unit tzresult Lwt.t
P2p_connection.Pool_event.t Lwt_stream.t * Lwt_watcher.stopper
val connect : t -> P2p_point.Id.t -> float -> unit tzresult Lwt.t
module Connection : sig
val info : t -> Peer_id.t -> Connection_info.t option
val kick : t -> Peer_id.t -> bool -> unit Lwt.t
val list : t -> Connection_info.t list
val info : t -> P2p_peer.Id.t -> P2p_connection.Info.t option
val kick : t -> P2p_peer.Id.t -> bool -> unit Lwt.t
val list : t -> P2p_connection.Info.t list
val count : t -> int
end
module Point : sig
val info :
t -> Point.t -> P2p_types.Point_info.t option
t -> P2p_point.Id.t -> P2p_point.Info.t option
val list :
?restrict: P2p_types.Point_state.t list ->
t -> (Point.t * P2p_types.Point_info.t) list
?restrict: P2p_point.State.t list ->
t -> (P2p_point.Id.t * P2p_point.Info.t) list
val events :
?max:int -> ?rev:bool -> t -> Point.t ->
P2p_connection_pool_types.Point_info.Event.t list
?max:int -> ?rev:bool -> t -> P2p_point.Id.t ->
P2p_point.Pool_event.t list
val watch :
t -> Point.t ->
P2p_connection_pool_types.Point_info.Event.t Lwt_stream.t * Lwt_watcher.stopper
t -> P2p_point.Id.t ->
P2p_point.Pool_event.t Lwt_stream.t * Lwt_watcher.stopper
end
module Peer_id : sig
val info :
t -> Peer_id.t -> P2p_types.Peer_info.t option
t -> P2p_peer.Id.t -> P2p_peer.Info.t option
val list :
?restrict: P2p_types.Peer_state.t list ->
t -> (Peer_id.t * P2p_types.Peer_info.t) list
?restrict: P2p_peer.State.t list ->
t -> (P2p_peer.Id.t * P2p_peer.Info.t) list
val events :
?max: int -> ?rev: bool ->
t -> Peer_id.t ->
P2p_connection_pool_types.Peer_info.Event.t list
t -> P2p_peer.Id.t ->
P2p_peer.Pool_event.t list
val watch :
t -> Peer_id.t ->
P2p_connection_pool_types.Peer_info.Event.t Lwt_stream.t * Lwt_watcher.stopper
t -> P2p_peer.Id.t ->
P2p_peer.Pool_event.t Lwt_stream.t * Lwt_watcher.stopper
end

38
src/lib_shell/peer_validator.ml
View File

@ -12,13 +12,13 @@
open Peer_validator_worker_state
module Name = struct
type t = Net_id.t * P2p.Peer_id.t
type t = Net_id.t * P2p_peer.Id.t
let encoding =
Data_encoding.tup2 Net_id.encoding P2p.Peer_id.encoding
Data_encoding.tup2 Net_id.encoding P2p_peer.Id.encoding
let base = [ "peer_validator" ]
let pp ppf (net, peer) =
Format.fprintf ppf "%a:%a"
Net_id.pp_short net P2p.Peer_id.pp_short peer
Net_id.pp_short net P2p_peer.Id.pp_short peer
end
module Request = struct
@ -57,7 +57,7 @@ module Types = struct
}
type state = {
peer_id: P2p.Peer_id.t ;
peer_id: P2p_peer.Id.t ;
parameters : parameters ;
mutable bootstrapped: bool ;
mutable last_validated_head: Block_header.t ;
@ -96,7 +96,7 @@ let bootstrap_new_branch w _ancestor _head unknown_prefix =
let len = Block_locator_iterator.estimated_length unknown_prefix in
debug w
"validating new branch from peer %a (approx. %d blocks)"
P2p.Peer_id.pp_short pv.peer_id len ;
P2p_peer.Id.pp_short pv.peer_id len ;
let pipeline =
Bootstrap_pipeline.create
~notify_new_block:pv.parameters.notify_new_block
@ -116,7 +116,7 @@ let bootstrap_new_branch w _ancestor _head unknown_prefix =
set_bootstrapped pv ;
debug w
"done validating new branch from peer %a."
P2p.Peer_id.pp_short pv.peer_id ;
P2p_peer.Id.pp_short pv.peer_id ;
return ()
let validate_new_head w hash (header : Block_header.t) =
@ -127,14 +127,14 @@ let validate_new_head w hash (header : Block_header.t) =
debug w
"missing predecessor for new head %a from peer %a"
Block_hash.pp_short hash
P2p.Peer_id.pp_short pv.peer_id ;
P2p_peer.Id.pp_short pv.peer_id ;
Distributed_db.Request.current_branch pv.parameters.net_db ~peer:pv.peer_id () ;
return ()
| true ->
debug w
"fetching operations for new head %a from peer %a"
Block_hash.pp_short hash
P2p.Peer_id.pp_short pv.peer_id ;
P2p_peer.Id.pp_short pv.peer_id ;
map_p
(fun i ->
Worker.protect w begin fun () ->
@ -147,7 +147,7 @@ let validate_new_head w hash (header : Block_header.t) =
debug w
"requesting validation for new head %a from peer %a"
Block_hash.pp_short hash
P2p.Peer_id.pp_short pv.peer_id ;
P2p_peer.Id.pp_short pv.peer_id ;
Block_validator.validate
~notify_new_block:pv.parameters.notify_new_block
pv.parameters.block_validator pv.parameters.net_db
@ -155,7 +155,7 @@ let validate_new_head w hash (header : Block_header.t) =
debug w
"end of validation for new head %a from peer %a"
Block_hash.pp_short hash
P2p.Peer_id.pp_short pv.peer_id ;
P2p_peer.Id.pp_short pv.peer_id ;
set_bootstrapped pv ;
return ()
@ -170,7 +170,7 @@ let only_if_fitness_increases w distant_header cont =
debug w
"ignoring head %a with non increasing fitness from peer: %a."
Block_hash.pp_short (Block_header.hash distant_header)
P2p.Peer_id.pp_short pv.peer_id ;
P2p_peer.Id.pp_short pv.peer_id ;
(* Don't download a branch that cannot beat the current head. *)
return ()
end else cont ()
@ -185,7 +185,7 @@ let may_validate_new_head w hash header =
debug w
"ignoring previously validated block %a from peer %a"
Block_hash.pp_short hash
P2p.Peer_id.pp_short pv.peer_id ;
P2p_peer.Id.pp_short pv.peer_id ;
set_bootstrapped pv ;
pv.last_validated_head <- header ;
return ()
@ -193,7 +193,7 @@ let may_validate_new_head w hash header =
debug w
"ignoring known invalid block %a from peer %a"
Block_hash.pp_short hash
P2p.Peer_id.pp_short pv.peer_id ;
P2p_peer.Id.pp_short pv.peer_id ;
fail Known_invalid
end
| false ->
@ -210,7 +210,7 @@ let may_validate_new_branch w distant_hash locator =
debug w
"ignoring branch %a without common ancestor from peer: %a."
Block_hash.pp_short distant_hash
P2p.Peer_id.pp_short pv.peer_id ;
P2p_peer.Id.pp_short pv.peer_id ;
fail Unknown_ancestor
| Some (ancestor, unknown_prefix) ->
bootstrap_new_branch w ancestor distant_header unknown_prefix
@ -218,7 +218,7 @@ let may_validate_new_branch w distant_hash locator =
let on_no_request w =
let pv = Worker.state w in
debug w "no new head from peer %a for %g seconds."
P2p.Peer_id.pp_short pv.peer_id
P2p_peer.Id.pp_short pv.peer_id
pv.parameters.limits.new_head_request_timeout ;
Distributed_db.Request.current_head pv.parameters.net_db ~peer:pv.peer_id () ;
return ()
@ -230,13 +230,13 @@ let on_request (type a) w (req : a Request.t) : a tzresult Lwt.t =
debug w
"processing new head %a from peer %a."
Block_hash.pp_short hash
P2p.Peer_id.pp_short pv.peer_id ;
P2p_peer.Id.pp_short pv.peer_id ;
may_validate_new_head w hash header
| Request.New_branch (hash, locator) ->
(* TODO penalize empty locator... ?? *)
debug w "processing new branch %a from peer %a."
Block_hash.pp_short hash
P2p.Peer_id.pp_short pv.peer_id ;
P2p_peer.Id.pp_short pv.peer_id ;
may_validate_new_branch w hash locator
let on_completion w r _ st =
@ -252,7 +252,7 @@ let on_error w r st errs =
(* TODO ban the peer_id... *)
debug w
"Terminating the validation worker for peer %a (kickban)."
P2p.Peer_id.pp_short pv.peer_id ;
P2p_peer.Id.pp_short pv.peer_id ;
debug w "%a" Error_monad.pp_print_error errors ;
Worker.trigger_shutdown w ;
Worker.record_event w (Event.Request (r, st, Some errs)) ;
@ -269,7 +269,7 @@ let on_error w r st errs =
debug w
"Terminating the validation worker for peer %a \
(missing protocol %a)."
P2p.Peer_id.pp_short pv.peer_id
P2p_peer.Id.pp_short pv.peer_id
Protocol_hash.pp_short protocol ;
Worker.record_event w (Event.Request (r, st, Some errs)) ;
Lwt.return (Error errs)

6
src/lib_shell/peer_validator.mli
View File

@ -17,7 +17,7 @@ type limits = {
worker_limits: Worker_types.limits
}
val peer_id: t -> P2p.Peer_id.t
val peer_id: t -> P2p_peer.Id.t
val bootstrapped: t -> bool
val current_head: t -> Block_header.t
@ -27,13 +27,13 @@ val create:
?notify_termination: (unit -> unit) ->
limits ->
Block_validator.t ->
Distributed_db.net_db -> P2p.Peer_id.t -> t Lwt.t
Distributed_db.net_db -> P2p_peer.Id.t -> t Lwt.t
val shutdown: t -> unit Lwt.t
val notify_branch: t -> Block_locator.t -> unit
val notify_head: t -> Block_header.t -> unit
val running_workers: unit -> ((Net_id.t * P2p.Peer_id.t) * t) list
val running_workers: unit -> ((Net_id.t * P2p_peer.Id.t) * t) list
val status: t -> Worker_types.worker_status
val current_request : t -> (Time.t * Time.t * Peer_validator_worker_state.Request.view) option

2
src/lib_shell/prevalidator.mli
View File

@ -40,7 +40,7 @@ type error += Closed of Net_id.t
val create: limits -> Distributed_db.net_db -> t Lwt.t
val shutdown: t -> unit Lwt.t
val notify_operations: t -> P2p.Peer_id.t -> Mempool.t -> unit
val notify_operations: t -> P2p_peer.Id.t -> Mempool.t -> unit
val inject_operation: t -> Operation.t -> unit tzresult Lwt.t
val flush: t -> Block_hash.t -> unit tzresult Lwt.t
val timestamp: t -> Time.t

6
src/lib_shell/protocol_validator.mli
View File

@ -28,19 +28,19 @@ val shutdown: t -> unit Lwt.t
val fetch_and_compile_protocol:
t ->
?peer:P2p.Peer_id.t ->
?peer:P2p_peer.Id.t ->
?timeout:float ->
Protocol_hash.t -> State.Registred_protocol.t tzresult Lwt.t
val fetch_and_compile_protocols:
t ->
?peer:P2p.Peer_id.t ->
?peer:P2p_peer.Id.t ->
?timeout:float ->
State.Block.t -> unit tzresult Lwt.t
val prefetch_and_compile_protocols:
t ->
?peer:P2p.Peer_id.t ->
?peer:P2p_peer.Id.t ->
?timeout:float ->
State.Block.t -> unit

6
src/lib_shell_services/block_validator_worker_state.ml
View File

@ -11,7 +11,7 @@ module Request = struct
type view = {
net_id : Net_id.t ;
block : Block_hash.t ;
peer : P2p_types.Peer_id.t option ;
peer : P2p_peer.Id.t option ;
}
let encoding =
let open Data_encoding in
@ -21,7 +21,7 @@ module Request = struct
(obj3
(req "block" Block_hash.encoding)
(req "net_id" Net_id.encoding)
(opt "peer" P2p_types.Peer_id.encoding))
(opt "peer" P2p_peer.Id.encoding))
let pp ppf { net_id ; block ; peer } =
Format.fprintf ppf "Validation of %a (net: %a)"
@ -31,7 +31,7 @@ module Request = struct
| None -> ()
| Some peer ->
Format.fprintf ppf "from peer %a"
P2p_types.Peer_id.pp_short peer
P2p_peer.Id.pp_short peer
end
module Event = struct

2
src/lib_shell_services/block_validator_worker_state.mli
View File

@ -11,7 +11,7 @@ module Request : sig
type view = {
net_id : Net_id.t ;
block : Block_hash.t ;
peer: P2p_types.Peer_id.t option ;
peer: P2p_peer.Id.t option ;
}
val encoding : view Data_encoding.encoding
val pp : Format.formatter -> view -> unit

12
src/lib_shell_services/net_validator_worker_state.ml
View File

@ -89,8 +89,8 @@ end
module Worker_state = struct
type view =
{ active_peers : P2p_types.Peer_id.t list ;
bootstrapped_peers : P2p_types.Peer_id.t list ;
{ active_peers : P2p_peer.Id.t list ;
bootstrapped_peers : P2p_peer.Id.t list ;
bootstrapped : bool }
let encoding =
let open Data_encoding in
@ -101,8 +101,8 @@ module Worker_state = struct
{ bootstrapped ; bootstrapped_peers ; active_peers })
(obj3
(req "bootstrapped" bool)
(req "bootstrapped_peers" (list P2p_types.Peer_id.encoding))
(req "active_peers" (list P2p_types.Peer_id.encoding)))
(req "bootstrapped_peers" (list P2p_peer.Id.encoding))
(req "active_peers" (list P2p_peer.Id.encoding)))
let pp ppf { bootstrapped ; bootstrapped_peers ; active_peers } =
Format.fprintf ppf
@ -110,8 +110,8 @@ module Worker_state = struct
@[<v 2>Active peers:%a@]@,\
@[<v 2>Bootstrapped peers:%a@]@]"
(if bootstrapped then "" else " not yet")
(fun ppf -> List.iter (Format.fprintf ppf "@,- %a" P2p_types.Peer_id.pp))
(fun ppf -> List.iter (Format.fprintf ppf "@,- %a" P2p_peer.Id.pp))
active_peers
(fun ppf -> List.iter (Format.fprintf ppf "@,- %a" P2p_types.Peer_id.pp))
(fun ppf -> List.iter (Format.fprintf ppf "@,- %a" P2p_peer.Id.pp))
bootstrapped_peers
end

4
src/lib_shell_services/net_validator_worker_state.mli
View File

@ -32,8 +32,8 @@ end
module Worker_state : sig
type view =
{ active_peers : P2p_types.Peer_id.t list ;
bootstrapped_peers : P2p_types.Peer_id.t list ;
{ active_peers : P2p_peer.Id.t list ;
bootstrapped_peers : P2p_peer.Id.t list ;
bootstrapped : bool }
val encoding : view Data_encoding.encoding
val pp : Format.formatter -> view -> unit

6
src/lib_shell_services/prevalidator_worker_state.ml
View File

@ -10,7 +10,7 @@
module Request = struct
type 'a t =
| Flush : Block_hash.t -> unit t
| Notify : P2p_types.Peer_id.t * Mempool.t -> unit t
| Notify : P2p_peer.Id.t * Mempool.t -> unit t
| Inject : Operation.t -> unit tzresult t
| Arrived : Operation_hash.t * Operation.t -> unit t
| Advertise : unit t
@ -30,7 +30,7 @@ module Request = struct
case (Tag 1)
(obj3
(req "request" (constant "notify"))
(req "peer" P2p_types.Peer_id.encoding)
(req "peer" P2p_peer.Id.encoding)
(req "mempool" Mempool.encoding))
(function View (Notify (peer, mempool)) -> Some ((), peer, mempool) | _ -> None)
(fun ((), peer, mempool) -> View (Notify (peer, mempool))) ;
@ -58,7 +58,7 @@ module Request = struct
Block_hash.pp hash
| Notify (id, { Mempool.known_valid ; pending }) ->
Format.fprintf ppf "@[<v 2>notified by %a of operations"
P2p_types.Peer_id.pp id ;
P2p_peer.Id.pp id ;
List.iter
(fun oph ->
Format.fprintf ppf "@,%a (applied)"

2
src/lib_shell_services/prevalidator_worker_state.mli
View File

@ -10,7 +10,7 @@
module Request : sig
type 'a t =
| Flush : Block_hash.t -> unit t
| Notify : P2p_types.Peer_id.t * Mempool.t -> unit t
| Notify : P2p_peer.Id.t * Mempool.t -> unit t
| Inject : Operation.t -> unit tzresult t
| Arrived : Operation_hash.t * Operation.t -> unit t
| Advertise : unit t

8
src/lib_shell_services/shell_services.ml
View File

@ -558,14 +558,14 @@ module Workers = struct
~construct:Net_id.to_b58check
()
let (peer_id_arg : P2p_types.Peer_id.t RPC_arg.t) =
let (peer_id_arg : P2p_peer.Id.t RPC_arg.t) =
RPC_arg.make
~name:"peer_id"
~descr:"The peer identifier of whom the prevalidator is responsible."
~destruct:(fun s -> try
Ok (P2p_types.Peer_id.of_b58check_exn s)
Ok (P2p_peer.Id.of_b58check_exn s)
with Failure msg -> Error msg)
~construct:P2p_types.Peer_id.to_b58check
~construct:P2p_peer.Id.to_b58check
()
let list =
@ -577,7 +577,7 @@ module Workers = struct
~output:
(list
(obj2
(req "peer_id" P2p_types.Peer_id.encoding)
(req "peer_id" P2p_peer.Id.encoding)
(req "status" (Worker_types.worker_status_encoding RPC_error.encoding))))
RPC_path.(root / "workers" / "peer_validators" /: net_id_arg)

4
src/lib_shell_services/shell_services.mli
View File

@ -201,11 +201,11 @@ module Workers : sig
val list :
([ `POST ], unit,
unit * Net_id.t, unit, unit,
(P2p_types.Peer_id.t * Worker_types.worker_status) list, unit) RPC_service.t
(P2p_peer.Id.t * Worker_types.worker_status) list, unit) RPC_service.t
val state :
([ `POST ], unit,
(unit * Net_id.t) * P2p_types.Peer_id.t, unit, unit,
(unit * Net_id.t) * P2p_peer.Id.t, unit, unit,
(Request.view, Event.t) Worker_types.full_status, unit)
RPC_service.t

20
test/p2p/jbuild
View File

@ -1,8 +1,8 @@
(jbuild_version 1)
(executables
((names (test_p2p_connection
test_p2p_connection_pool
((names (test_p2p_socket
test_p2p_pool
test_p2p_io_scheduler))
(libraries (tezos-base
tezos-p2p-services
@ -18,17 +18,17 @@
(alias
((name buildtest)
(deps (test_p2p_connection.exe
test_p2p_connection_pool.exe
(deps (test_p2p_socket.exe
test_p2p_pool.exe
test_p2p_io_scheduler.exe))))
(alias
((name runtest_p2p_connection)
(action (run ${exe:test_p2p_connection.exe} -v))))
((name runtest_p2p_socket)
(action (run ${exe:test_p2p_socket.exe} -v))))
(alias
((name runtest_p2p_connection_pool)
(action (run ${exe:test_p2p_connection_pool.exe} --clients 10 --repeat 5 -v))))
((name runtest_p2p_pool)
(action (run ${exe:test_p2p_pool.exe} --clients 10 --repeat 5 -v))))
(alias
((name runtest_p2p_io_scheduler)
@ -40,8 +40,8 @@
(alias
((name runtest)
(deps ((alias runtest_p2p_connection)
(alias runtest_p2p_connection_pool)
(deps ((alias runtest_p2p_socket)
(alias runtest_p2p_pool)
(alias runtest_p2p_io_scheduler)))))
(alias

9
test/p2p/test_p2p_io_scheduler.ml
View File

@ -7,7 +7,6 @@
(* *)
(**************************************************************************)
open P2p_types
include Logging.Make (struct let name = "test-p2p-io-scheduler" end)
exception Error of error list
@ -89,18 +88,18 @@ let server
~read_buffer_size
() in
Moving_average.on_update begin fun () ->
log_notice "Stat: %a" Stat.pp (P2p_io_scheduler.global_stat sched) ;
log_notice "Stat: %a" P2p_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)) ;
log_notice " client(%d) %a" id P2p_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) ;
log_notice "OK %a" P2p_stat.pp (P2p_io_scheduler.global_stat sched) ;
return ()
let max_size ?max_upload_speed () =
@ -131,7 +130,7 @@ let client ?max_upload_speed ?write_queue_size addr port time _n =
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 () ->
lwt_log_notice "Client OK %a" P2p_stat.pp stat >>= fun () ->
return ()
let run

61
test/p2p/test_p2p_connection_pool.ml → test/p2p/test_p2p_pool.ml
View File

@ -7,16 +7,15 @@
(* *)
(**************************************************************************)
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 = {
let msg_config : message P2p_pool.message_config = {
encoding = [
P2p_connection_pool.Encoding {
P2p_pool.Encoding {
tag = 0x10 ;
encoding = Data_encoding.empty ;
wrap = (function () -> Ping) ;
@ -24,12 +23,12 @@ let msg_config : message P2p_connection_pool.message_config = {
max_length = None ;
} ;
] ;
versions = Version.[ { name = "TEST" ; major = 0 ; minor = 0 } ] ;
versions = P2p_version.[ { name = "TEST" ; major = 0 ; minor = 0 } ] ;
}
type metadata = unit
let meta_config : metadata P2p_connection_pool.meta_config = {
let meta_config : metadata P2p_pool.meta_config = {
encoding = Data_encoding.empty ;
initial = () ;
score = fun () -> 0. ;
@ -59,9 +58,9 @@ let sync_nodes nodes =
let detach_node f points n =
let (addr, port), points = List.select n points in
let proof_of_work_target = Crypto_box.make_target 0. in
let identity = Identity.generate proof_of_work_target in
let identity = P2p_identity.generate proof_of_work_target in
let nb_points = List.length points in
let config = P2p_connection_pool.{
let config = P2p_pool.{
identity ;
proof_of_work_target ;
trusted_points = points ;
@ -83,10 +82,10 @@ let detach_node f points n =
binary_chunks_size = None
} in
Process.detach
~prefix:(Format.asprintf "%a: " Peer_id.pp_short identity.peer_id)
~prefix:(Format.asprintf "%a: " P2p_peer.Id.pp_short identity.peer_id)
begin fun channel ->
let sched = P2p_io_scheduler.create ~read_buffer_size:(1 lsl 12) () in
P2p_connection_pool.create
P2p_pool.create
config meta_config msg_config sched >>= fun pool ->
P2p_welcome.run ~backlog:10 pool ~addr port >>= fun welcome ->
lwt_log_info "Node ready (port: %d)" port >>= fun () ->
@ -94,7 +93,7 @@ let detach_node f points n =
f channel pool points >>=? fun () ->
lwt_log_info "Shutting down..." >>= fun () ->
P2p_welcome.shutdown welcome >>= fun () ->
P2p_connection_pool.destroy pool >>= fun () ->
P2p_pool.destroy pool >>= fun () ->
P2p_io_scheduler.shutdown sched >>= fun () ->
lwt_log_info "Bye." >>= fun () ->
return ()
@ -112,34 +111,34 @@ type error += Connect | Write | Read
module Simple = struct
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.Connection.find_by_point pool point with
lwt_log_info "Connect to %a" P2p_point.Id.pp point >>= fun () ->
P2p_pool.connect pool point ~timeout >>= function
| Error [P2p_pool.Connected] -> begin
match P2p_pool.Connection.find_by_point 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
| Error ([ P2p_pool.Connection_refused
| P2p_pool.Pending_connection
| P2p_socket.Rejected
| Lwt_utils.Canceled
| Lwt_utils.Timeout
| P2p_connection_pool.Rejected _ as err ]) ->
| P2p_pool.Rejected _ as err ]) ->
lwt_log_info "Connection to %a failed (%a)"
Point.pp point
P2p_point.Id.pp point
(fun ppf err -> match err with
| P2p_connection_pool.Connection_refused ->
| P2p_pool.Connection_refused ->
Format.fprintf ppf "connection refused"
| P2p_connection_pool.Pending_connection ->
| P2p_pool.Pending_connection ->
Format.fprintf ppf "pending connection"
| P2p_connection.Rejected ->
| P2p_socket.Rejected ->
Format.fprintf ppf "rejected"
| Lwt_utils.Canceled ->
Format.fprintf ppf "canceled"
| Lwt_utils.Timeout ->
Format.fprintf ppf "timeout"
| P2p_connection_pool.Rejected peer ->
Format.fprintf ppf "rejected (%a)" Peer_id.pp peer
| P2p_pool.Rejected peer ->
Format.fprintf ppf "rejected (%a)" P2p_peer.Id.pp peer
| _ -> assert false) err >>= fun () ->
Lwt_unix.sleep (0.5 +. Random.float 2.) >>= fun () ->
connect ~timeout pool point
@ -151,18 +150,18 @@ module Simple = struct
let write_all conns msg =
iter_p
(fun conn ->
trace Write @@ P2p_connection_pool.write_sync conn msg)
trace Write @@ P2p_pool.write_sync conn msg)
conns
let read_all conns =
iter_p
(fun conn ->
trace Read @@ P2p_connection_pool.read conn >>=? fun Ping ->
trace Read @@ P2p_pool.read conn >>=? fun Ping ->
return ())
conns
let close_all conns =
Lwt_list.iter_p P2p_connection_pool.disconnect conns
Lwt_list.iter_p P2p_pool.disconnect conns
let node channel pool points =
connect_all ~timeout:2. pool points >>=? fun conns ->
@ -187,10 +186,10 @@ module Random_connections = struct
let rec connect_random pool total rem point n =
Lwt_unix.sleep (0.2 +. Random.float 1.0) >>= fun () ->
(trace Connect @@ Simple.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 ->
(trace Write @@ P2p_pool.write conn Ping) >>= fun _ ->
(trace Read @@ P2p_pool.read conn) >>=? fun Ping ->
Lwt_unix.sleep (0.2 +. Random.float 1.0) >>= fun () ->
P2p_connection_pool.disconnect conn >>= fun () ->
P2p_pool.disconnect conn >>= fun () ->
begin
decr rem ;
if !rem mod total = 0 then
@ -231,7 +230,7 @@ module Garbled = struct
let bad_msg = MBytes.of_string (String.make 16 '\000') in
iter_p
(fun conn ->
trace Write @@ P2p_connection_pool.raw_write_sync conn bad_msg)
trace Write @@ P2p_pool.raw_write_sync conn bad_msg)
conns
let node ch pool points =

111
test/p2p/test_p2p_connection.ml → test/p2p/test_p2p_socket.ml
View File

@ -10,20 +10,19 @@
(* TODO Use Kaputt on the client side and remove `assert` from the
server. *)
open P2p_types
include Logging.Make (struct let name = "test.p2p.connection" end)
let default_addr = Ipaddr.V6.localhost
let proof_of_work_target = Crypto_box.make_target 16.
let id1 = Identity.generate proof_of_work_target
let id2 = Identity.generate proof_of_work_target
let id1 = P2p_identity.generate proof_of_work_target
let id2 = P2p_identity.generate proof_of_work_target
let id0 =
(* Luckilly, this will be an insuficient proof of work! *)
Identity.generate (Crypto_box.make_target 0.)
P2p_identity.generate (Crypto_box.make_target 0.)
let versions = Version.[{ name = "TEST" ; minor = 0 ; major = 0 }]
let versions = P2p_version.[{ name = "TEST" ; minor = 0 ; major = 0 }]
let random_bytes len =
let msg = MBytes.create len in
@ -104,7 +103,7 @@ let raw_accept sched main_socket =
let accept sched main_socket =
raw_accept sched main_socket >>= fun (fd, point) ->
P2p_connection.authenticate
P2p_socket.authenticate
~proof_of_work_target
~incoming:true fd point id1 versions
@ -118,11 +117,11 @@ let raw_connect sched addr port =
let connect sched addr port id =
raw_connect sched addr port >>= fun fd ->
P2p_connection.authenticate
P2p_socket.authenticate
~proof_of_work_target
~incoming:false fd (addr, port) id versions >>=? fun (info, auth_fd) ->
_assert (not info.incoming) __LOC__ "" >>=? fun () ->
_assert (Peer_id.compare info.peer_id id1.peer_id = 0)
_assert (P2p_peer.Id.compare info.peer_id id1.peer_id = 0)
__LOC__ "" >>=? fun () ->
return auth_fd
@ -134,7 +133,7 @@ let is_connection_closed = function
false
let is_decoding_error = function
| Error [P2p_connection.Decoding_error] -> true
| Error [P2p_socket.Decoding_error] -> true
| Ok _ -> false
| Error err ->
log_notice "Error: %a" pp_print_error err ;
@ -167,7 +166,7 @@ module Kick = struct
let encoding = Data_encoding.bytes
let is_rejected = function
| Error [P2p_connection.Rejected] -> true
| Error [P2p_socket.Rejected] -> true
| Ok _ -> false
| Error err ->
log_notice "Error: %a" pp_print_error err ;
@ -176,14 +175,14 @@ module Kick = struct
let server _ch sched socket =
accept sched socket >>=? fun (info, auth_fd) ->
_assert (info.incoming) __LOC__ "" >>=? fun () ->
_assert (Peer_id.compare info.peer_id id2.peer_id = 0)
_assert (P2p_peer.Id.compare info.peer_id id2.peer_id = 0)
__LOC__ "" >>=? fun () ->
P2p_connection.kick auth_fd >>= fun () ->
P2p_socket.kick auth_fd >>= fun () ->
return ()
let client _ch sched addr port =
connect sched addr port id2 >>=? fun auth_fd ->
P2p_connection.accept auth_fd encoding >>= fun conn ->
P2p_socket.accept auth_fd encoding >>= fun conn ->
_assert (is_rejected conn) __LOC__ "" >>=? fun () ->
return ()
@ -197,13 +196,13 @@ module Kicked = struct
let server _ch sched socket =
accept sched socket >>=? fun (_info, auth_fd) ->
P2p_connection.accept auth_fd encoding >>= fun conn ->
P2p_socket.accept auth_fd encoding >>= fun conn ->
_assert (Kick.is_rejected conn) __LOC__ "" >>=? fun () ->
return ()
let client _ch sched addr port =
connect sched addr port id2 >>=? fun auth_fd ->
P2p_connection.kick auth_fd >>= fun () ->
P2p_socket.kick auth_fd >>= fun () ->
return ()
let run _dir = run_nodes client server
@ -219,22 +218,22 @@ module Simple_message = struct
let server ch sched socket =
accept sched socket >>=? fun (_info, auth_fd) ->
P2p_connection.accept auth_fd encoding >>=? fun conn ->
P2p_connection.write_sync conn simple_msg >>=? fun () ->
P2p_connection.read conn >>=? fun (_msg_size, msg) ->
P2p_socket.accept auth_fd encoding >>=? fun conn ->
P2p_socket.write_sync conn simple_msg >>=? fun () ->
P2p_socket.read conn >>=? fun (_msg_size, msg) ->
_assert (MBytes.compare simple_msg2 msg = 0) __LOC__ "" >>=? fun () ->
sync ch >>=? fun () ->
P2p_connection.close conn >>= fun _stat ->
P2p_socket.close conn >>= fun _stat ->
return ()
let client ch sched addr port =
connect sched addr port id2 >>=? fun auth_fd ->
P2p_connection.accept auth_fd encoding >>=? fun conn ->
P2p_connection.write_sync conn simple_msg2 >>=? fun () ->
P2p_connection.read conn >>=? fun (_msg_size, msg) ->
P2p_socket.accept auth_fd encoding >>=? fun conn ->
P2p_socket.write_sync conn simple_msg2 >>=? fun () ->
P2p_socket.read conn >>=? fun (_msg_size, msg) ->
_assert (MBytes.compare simple_msg msg = 0) __LOC__ "" >>=? fun () ->
sync ch >>=? fun () ->
P2p_connection.close conn >>= fun _stat ->
P2p_socket.close conn >>= fun _stat ->
return ()
let run _dir = run_nodes client server
@ -250,24 +249,24 @@ module Chunked_message = struct
let server ch sched socket =
accept sched socket >>=? fun (_info, auth_fd) ->
P2p_connection.accept
P2p_socket.accept
~binary_chunks_size:21 auth_fd encoding >>=? fun conn ->
P2p_connection.write_sync conn simple_msg >>=? fun () ->
P2p_connection.read conn >>=? fun (_msg_size, msg) ->
P2p_socket.write_sync conn simple_msg >>=? fun () ->
P2p_socket.read conn >>=? fun (_msg_size, msg) ->
_assert (MBytes.compare simple_msg2 msg = 0) __LOC__ "" >>=? fun () ->
sync ch >>=? fun () ->
P2p_connection.close conn >>= fun _stat ->
P2p_socket.close conn >>= fun _stat ->
return ()
let client ch sched addr port =
connect sched addr port id2 >>=? fun auth_fd ->
P2p_connection.accept
P2p_socket.accept
~binary_chunks_size:21 auth_fd encoding >>=? fun conn ->
P2p_connection.write_sync conn simple_msg2 >>=? fun () ->
P2p_connection.read conn >>=? fun (_msg_size, msg) ->
P2p_socket.write_sync conn simple_msg2 >>=? fun () ->
P2p_socket.read conn >>=? fun (_msg_size, msg) ->
_assert (MBytes.compare simple_msg msg = 0) __LOC__ "" >>=? fun () ->
sync ch >>=? fun () ->
P2p_connection.close conn >>= fun _stat ->
P2p_socket.close conn >>= fun _stat ->
return ()
let run _dir = run_nodes client server
@ -283,22 +282,22 @@ module Oversized_message = struct
let server ch sched socket =
accept sched socket >>=? fun (_info, auth_fd) ->
P2p_connection.accept auth_fd encoding >>=? fun conn ->
P2p_connection.write_sync conn simple_msg >>=? fun () ->
P2p_connection.read conn >>=? fun (_msg_size, msg) ->
P2p_socket.accept auth_fd encoding >>=? fun conn ->
P2p_socket.write_sync conn simple_msg >>=? fun () ->
P2p_socket.read conn >>=? fun (_msg_size, msg) ->
_assert (MBytes.compare simple_msg2 msg = 0) __LOC__ "" >>=? fun () ->
sync ch >>=? fun () ->
P2p_connection.close conn >>= fun _stat ->
P2p_socket.close conn >>= fun _stat ->
return ()
let client ch sched addr port =
connect sched addr port id2 >>=? fun auth_fd ->
P2p_connection.accept auth_fd encoding >>=? fun conn ->
P2p_connection.write_sync conn simple_msg2 >>=? fun () ->
P2p_connection.read conn >>=? fun (_msg_size, msg) ->
P2p_socket.accept auth_fd encoding >>=? fun conn ->
P2p_socket.write_sync conn simple_msg2 >>=? fun () ->
P2p_socket.read conn >>=? fun (_msg_size, msg) ->
_assert (MBytes.compare simple_msg msg = 0) __LOC__ "" >>=? fun () ->
sync ch >>=? fun () ->
P2p_connection.close conn >>= fun _stat ->
P2p_socket.close conn >>= fun _stat ->
return ()
let run _dir = run_nodes client server
@ -313,18 +312,18 @@ module Close_on_read = struct
let server ch sched socket =
accept sched socket >>=? fun (_info, auth_fd) ->
P2p_connection.accept auth_fd encoding >>=? fun conn ->
P2p_socket.accept auth_fd encoding >>=? fun conn ->
sync ch >>=? fun () ->
P2p_connection.close conn >>= fun _stat ->
P2p_socket.close conn >>= fun _stat ->
return ()
let client ch sched addr port =
connect sched addr port id2 >>=? fun auth_fd ->
P2p_connection.accept auth_fd encoding >>=? fun conn ->
P2p_socket.accept auth_fd encoding >>=? fun conn ->
sync ch >>=? fun () ->
P2p_connection.read conn >>= fun err ->
P2p_socket.read conn >>= fun err ->
_assert (is_connection_closed err) __LOC__ "" >>=? fun () ->
P2p_connection.close conn >>= fun _stat ->
P2p_socket.close conn >>= fun _stat ->
return ()
let run _dir = run_nodes client server
@ -339,19 +338,19 @@ module Close_on_write = struct
let server ch sched socket =
accept sched socket >>=? fun (_info, auth_fd) ->
P2p_connection.accept auth_fd encoding >>=? fun conn ->
P2p_connection.close conn >>= fun _stat ->
P2p_socket.accept auth_fd encoding >>=? fun conn ->
P2p_socket.close conn >>= fun _stat ->
sync ch >>=? fun ()->
return ()
let client ch sched addr port =
connect sched addr port id2 >>=? fun auth_fd ->
P2p_connection.accept auth_fd encoding >>=? fun conn ->
P2p_socket.accept auth_fd encoding >>=? fun conn ->
sync ch >>=? fun ()->
Lwt_unix.sleep 0.1 >>= fun () ->
P2p_connection.write_sync conn simple_msg >>= fun err ->
P2p_socket.write_sync conn simple_msg >>= fun err ->
_assert (is_connection_closed err) __LOC__ "" >>=? fun () ->
P2p_connection.close conn >>= fun _stat ->
P2p_socket.close conn >>= fun _stat ->
return ()
let run _dir = run_nodes client server
@ -376,19 +375,19 @@ module Garbled_data = struct
let server _ch sched socket =
accept sched socket >>=? fun (_info, auth_fd) ->
P2p_connection.accept auth_fd encoding >>=? fun conn ->
P2p_connection.raw_write_sync conn garbled_msg >>=? fun () ->
P2p_connection.read conn >>= fun err ->
P2p_socket.accept auth_fd encoding >>=? fun conn ->
P2p_socket.raw_write_sync conn garbled_msg >>=? fun () ->
P2p_socket.read conn >>= fun err ->
_assert (is_connection_closed err) __LOC__ "" >>=? fun () ->
P2p_connection.close conn >>= fun _stat ->
P2p_socket.close conn >>= fun _stat ->
return ()
let client _ch sched addr port =
connect sched addr port id2 >>=? fun auth_fd ->
P2p_connection.accept auth_fd encoding >>=? fun conn ->
P2p_connection.read conn >>= fun err ->
P2p_socket.accept auth_fd encoding >>=? fun conn ->
P2p_socket.read conn >>= fun err ->
_assert (is_decoding_error err) __LOC__ "" >>=? fun () ->
P2p_connection.close conn >>= fun _stat ->
P2p_socket.close conn >>= fun _stat ->
return ()
let run _dir = run_nodes client server