Merge branch 'p2p' into 'master'

Split the p2p layer in multiple files

See merge request !132

.gitignore

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

.gitlab-ci.yml

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

scripts/create_docker_builder.sh

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

scripts/install_build_deps.sh

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

src/.merlin

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

src/Makefile

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

src/attacker/attacker_minimal.ml

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

src/client/embedded/bootstrap/mining/client_mining_forge.ml

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

src/client/embedded/bootstrap/mining/client_mining_operations.ml

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

src/client/embedded/bootstrap/webclient/webclient_proto_service_directory.ml

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

src/minutils/data_encoding.ml

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

src/minutils/data_encoding.mli

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

src/minutils/utils.ml

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

src/minutils/utils.mli

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

src/node/net/p2p.mli

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

src/node/net/p2p_connection.ml

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

src/node/net/p2p_connection.mli

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

src/node/net/p2p_connection_pool.ml

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

src/node/net/p2p_connection_pool.mli

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

src/node/net/p2p_connection_pool_types.ml

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

src/node/net/p2p_connection_pool_types.mli

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

src/node/net/p2p_discovery.ml

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

src/node/net/p2p_discovery.mli

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

src/node/net/p2p_io_scheduler.ml

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

src/node/net/p2p_io_scheduler.mli

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

src/node/net/p2p_maintenance.ml

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

src/node/net/p2p_maintenance.mli

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

src/node/net/p2p_types.ml

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

src/node/net/p2p_types.mli

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

src/node/net/p2p_welcome.ml

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

src/node/net/p2p_welcome.mli

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

src/node/shell/tezos_p2p.ml

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

src/node/shell/tezos_p2p.mli

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

src/node_main.ml

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

src/tezos-deps.opam

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

src/utils/base48.ml

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

src/utils/base48.mli

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

src/utils/crypto_box.ml

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

src/utils/crypto_box.mli

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

src/utils/error_monad.ml

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

src/utils/error_monad.mli

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

src/utils/error_monad_sig.ml

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

src/utils/hash.ml

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

src/utils/hash.mli

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

src/utils/logging.ml

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

src/utils/logging.mli

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

src/utils/lwt_exit.ml

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

src/utils/lwt_pipe.ml

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

src/utils/lwt_pipe.mli

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

src/utils/lwt_utils.ml

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

src/utils/lwt_utils.mli

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

src/utils/moving_average.ml

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

src/utils/moving_average.mli

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

src/utils/ring.ml

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

src/utils/ring.mli

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

src/utils/time.ml

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

src/utils/time.mli

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

test/Makefile

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

test/lib/process.ml

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

test/lib/process.mli

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

test/test_lwt_pipe.ml

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

test/test_p2p.ml

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

test/test_p2p_connection.ml

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

test/test_p2p_connection_pool.ml

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

test/test_p2p_io_scheduler.ml

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