Jbuilder: split lib_node_net

- `lib_node_p2p_base`: Base datatypes for the P2P layers
- `lib_node_services`: RPC service definitions (depends on `node_p2p_base`)
- `lib_node_http`: RPC http server
- `lib_node_p2p`: the P2P workers

bin_node/jbuild

@@ -5,7 +5,9 @@
   (public_name tezos-node)
   (libraries (tezos-base
               tezos-node-updater
-              tezos-node-net
+              tezos-node-p2p-base
+              tezos-node-p2p
+              tezos-node-http
               tezos-node-shell
               tezos-embedded-protocol-genesis
               tezos-embedded-protocol-demo
@@ -15,7 +17,9 @@
                     -safe-string
                     -open Tezos_base__TzPervasives
                     -open Tezos_node_updater
-                    -open Tezos_node_net
+                    -open Tezos_node_p2p_base
+                    -open Tezos_node_p2p
+                    -open Tezos_node_http
                     -open Tezos_node_shell
                     -linkall))))
 

lib_base/jbuild

@@ -13,8 +13,9 @@
               tezos-crypto
               tezos-data-encoding
               tezos-error-monad
+              calendar
               ezjsonm
-              calendar))))
+              mtime.clock.os))))
 
 (alias
  ((name runtest_indent)

lib_base/preapply_result.ml

@@ -0,0 +1,76 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2017.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+type 'error t = {
+  applied: (Operation_hash.t * Operation.t) list;
+  refused: (Operation.t * 'error list) Operation_hash.Map.t;
+  branch_refused: (Operation.t * 'error list) Operation_hash.Map.t;
+  branch_delayed: (Operation.t * 'error list) Operation_hash.Map.t;
+}
+
+let empty = {
+  applied = [] ;
+  refused = Operation_hash.Map.empty ;
+  branch_refused = Operation_hash.Map.empty ;
+  branch_delayed = Operation_hash.Map.empty ;
+}
+
+let map f r = {
+  applied = r.applied;
+  refused = Operation_hash.Map.map f r.refused ;
+  branch_refused = Operation_hash.Map.map f r.branch_refused ;
+  branch_delayed = Operation_hash.Map.map f r.branch_delayed ;
+}
+
+let encoding error_encoding =
+  let open Data_encoding in
+  let operation_encoding =
+    merge_objs
+      (obj1 (req "hash" Operation_hash.encoding))
+      (dynamic_size Operation.encoding) in
+  let refused_encoding =
+    merge_objs
+      (obj1 (req "hash" Operation_hash.encoding))
+      (merge_objs
+         (dynamic_size Operation.encoding)
+         (obj1 (req "error" error_encoding))) in
+  let build_list map = Operation_hash.Map.bindings map in
+  let build_map list =
+    List.fold_right
+      (fun (k, e) m -> Operation_hash.Map.add k e m)
+      list Operation_hash.Map.empty in
+  conv
+    (fun { applied ; refused ; branch_refused ; branch_delayed } ->
+       (applied, build_list refused,
+        build_list branch_refused, build_list branch_delayed))
+    (fun (applied, refused, branch_refused, branch_delayed) ->
+       let refused = build_map refused in
+       let branch_refused = build_map branch_refused in
+       let branch_delayed = build_map branch_delayed in
+       { applied ; refused ; branch_refused ; branch_delayed })
+    (obj4
+       (req "applied" (list operation_encoding))
+       (req "refused" (list refused_encoding))
+       (req "branch_refused" (list refused_encoding))
+       (req "branch_delayed" (list refused_encoding)))
+
+let operations t =
+  let ops =
+    List.fold_left
+      (fun acc (h, op) -> Operation_hash.Map.add h op acc)
+      Operation_hash.Map.empty t.applied in
+  let ops =
+    Operation_hash.Map.fold
+      (fun h (op, _err) acc -> Operation_hash.Map.add h op acc)
+      t.branch_delayed ops in
+  let ops =
+    Operation_hash.Map.fold
+      (fun h (op, _err) acc -> Operation_hash.Map.add h op acc)
+      t.branch_refused ops in
+  ops

lib_base/preapply_result.mli

@@ -0,0 +1,30 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2017.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+type 'error t = {
+  applied: (Operation_hash.t * Operation.t) list;
+  refused: (Operation.t * 'error list) Operation_hash.Map.t;
+  (* e.g. invalid signature *)
+  branch_refused: (Operation.t * 'error list) Operation_hash.Map.t;
+  (* e.g. insufficent balance *)
+  branch_delayed: (Operation.t * 'error list) Operation_hash.Map.t;
+  (* e.g. timestamp in the future *)
+}
+
+val empty : 'error t
+
+val map :
+  (Operation.t * 'a list -> Operation.t * 'b list) -> 'a t -> 'b t
+
+val operations :
+  'error t -> Operation.t Operation_hash.Map.t
+
+val encoding :
+  'error list Data_encoding.t ->
+  'error t Data_encoding.t

lib_base/test_network_status.ml

@@ -0,0 +1,74 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2017.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+type t =
+  | Not_running
+  | Forking of {
+      protocol: Protocol_hash.t ;
+      expiration: Time.t ;
+    }
+  | Running of {
+      net_id: Net_id.t ;
+      genesis: Block_hash.t ;
+      protocol: Protocol_hash.t ;
+      expiration: Time.t ;
+    }
+
+let encoding =
+  let open Data_encoding in
+  union [
+    case ~tag:0
+      (obj1 (req "status" (constant "not_running")))
+      (function Not_running -> Some () | _ -> None)
+      (fun () -> Not_running) ;
+    case ~tag:1
+      (obj3
+         (req "status" (constant "forking"))
+         (req "protocol" Protocol_hash.encoding)
+         (req "expiration" Time.encoding))
+      (function
+        | Forking { protocol ; expiration } ->
+            Some ((), protocol, expiration)
+        | _ -> None)
+      (fun ((), protocol, expiration) ->
+         Forking { protocol ; expiration }) ;
+    case ~tag:2
+      (obj5
+         (req "status" (constant "running"))
+         (req "net_id" Net_id.encoding)
+         (req "genesis" Block_hash.encoding)
+         (req "protocol" Protocol_hash.encoding)
+         (req "expiration" Time.encoding))
+      (function
+        | Running { net_id ; genesis ; protocol ; expiration } ->
+            Some ((), net_id, genesis, protocol, expiration)
+        | _ -> None)
+      (fun ((), net_id, genesis, protocol, expiration) ->
+         Running { net_id ; genesis ; protocol ; expiration }) ;
+  ]
+
+let pp ppf = function
+  | Not_running -> Format.fprintf ppf "@[<v 2>Not running@]"
+  | Forking { protocol ; expiration } ->
+      Format.fprintf ppf
+        "@[<v 2>Forking %a (expires %a)@]"
+        Protocol_hash.pp
+        protocol
+        Time.pp_hum
+        expiration
+  | Running { net_id ; genesis ; protocol ; expiration } ->
+      Format.fprintf ppf
+        "@[<v 2>Running %a\
+         @ Genesis: %a\
+         @ Net id: %a\
+         @ Expiration: %a@]"
+        Protocol_hash.pp protocol
+        Block_hash.pp genesis
+        Net_id.pp net_id
+        Time.pp_hum expiration

lib_base/test_network_status.mli

@@ -0,0 +1,25 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2017.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+type t =
+  | Not_running
+  | Forking of {
+      protocol: Protocol_hash.t ;
+      expiration: Time.t ;
+    }
+  | Running of {
+      net_id: Net_id.t ;
+      genesis: Block_hash.t ;
+      protocol: Protocol_hash.t ;
+      expiration: Time.t ;
+    }
+
+val encoding: t Data_encoding.t
+
+val pp : Format.formatter -> t -> unit

lib_base/tzPervasives.ml

@@ -29,5 +29,8 @@ module Block_header = Block_header
 module Operation = Operation
 module Protocol = Protocol
 
+module Test_network_status = Test_network_status
+module Preapply_result = Preapply_result
+
 include Utils.Infix
 include Error_monad

lib_base/tzPervasives.mli

@@ -28,6 +28,8 @@ module Fitness = Fitness
 module Block_header = Block_header
 module Operation = Operation
 module Protocol = Protocol
+module Test_network_status = Test_network_status
+module Preapply_result = Preapply_result
 
 include (module type of (struct include Utils.Infix end))
 include (module type of (struct include Error_monad end))

lib_client_base/client_debug.ml

@@ -28,7 +28,7 @@ let pp_block ppf
      @ Operations: @[<v>%a@]\
      @ Data (hex encoded): \"%s\"@]"
     Block_hash.pp hash
-    Context.pp_test_network test_network
+    Test_network_status.pp test_network
     level
     proto_level
     Block_hash.pp predecessor

lib_client_base/client_network.ml

@@ -8,6 +8,7 @@
 (**************************************************************************)
 
 open Client_commands
+open P2p_types
 
 let group =
   { Cli_entries.name = "network" ;
@@ -23,32 +24,31 @@ let commands () = [
     Client_node_rpcs.Network.peers cctxt.rpc_config >>=? fun peers ->
     Client_node_rpcs.Network.points cctxt.rpc_config >>=? fun points ->
     cctxt.message "GLOBAL STATS" >>= fun () ->
-    cctxt.message "  %a" P2p_types.Stat.pp stat >>= fun () ->
+    cctxt.message "  %a" Stat.pp stat >>= fun () ->
     cctxt.message "CONNECTIONS" >>= fun () ->
     let incoming, outgoing =
-      List.partition (fun c -> c.P2p_types.Connection_info.incoming) conns in
+      List.partition (fun c -> c.Connection_info.incoming) conns in
     Lwt_list.iter_s begin fun conn ->
-      cctxt.message "  %a" P2p_types.Connection_info.pp conn
+      cctxt.message "  %a" Connection_info.pp conn
     end incoming >>= fun () ->
     Lwt_list.iter_s begin fun conn ->
-      cctxt.message "  %a" P2p_types.Connection_info.pp conn
+      cctxt.message "  %a" Connection_info.pp conn
     end outgoing >>= fun () ->
     cctxt.message "KNOWN PEERS" >>= fun () ->
     Lwt_list.iter_s begin fun (p, pi) ->
-      let open P2p.RPC.Peer_id in
       cctxt.message "  %a  %.0f %a %a %s"
-        pp_state_digram pi.state
+        Peer_state.pp_digram pi.Peer_info.state
         pi.score
-        pp p P2p_types.Stat.pp pi.stat
+        Peer_id.pp p
+        Stat.pp pi.stat
         (if pi.trusted then "★" else " ")
     end peers >>= fun () ->
     cctxt.message "KNOWN POINTS" >>= fun () ->
     Lwt_list.iter_s begin fun (p, pi) ->
-      let open P2p.RPC in
+      match pi.Point_info.state with
-      match pi.Point.state with
       | Running peer_id ->
           cctxt.message "  %a  %a %a %s"
-            Point.pp_state_digram pi.state
+            Point_state.pp_digram pi.state
             Point.pp p
             Peer_id.pp peer_id
             (if pi.trusted then "★" else " ")
@@ -56,14 +56,14 @@ let commands () = [
           match pi.last_seen with
           | Some (peer_id, ts) ->
               cctxt.message "  %a  %a (last seen: %a %a) %s"
-                Point.pp_state_digram pi.state
+                Point_state.pp_digram pi.state
                 Point.pp p
                 Peer_id.pp peer_id
                 Time.pp_hum ts
                 (if pi.trusted then "★" else " ")
           | None ->
               cctxt.message "  %a  %a %s"
-                Point.pp_state_digram pi.state
+                Point_state.pp_digram pi.state
                 Point.pp p
                 (if pi.trusted then "★" else " ")
     end points >>= fun () ->

lib_client_base/client_node_rpcs.ml

@@ -71,7 +71,7 @@ module Blocks = struct
     data: MBytes.t ;
     operations: (Operation_hash.t * Operation.t) list list option ;
     protocol: Protocol_hash.t ;
-    test_network: Context.test_network;
+    test_network: Test_network_status.t;
   }
   type preapply_param = Services.Blocks.preapply_param = {
     timestamp: Time.t ;
@@ -81,7 +81,7 @@ module Blocks = struct
   }
   type preapply_result = Services.Blocks.preapply_result = {
     shell_header: Block_header.shell_header ;
-    operations: error Prevalidation.preapply_result ;
+    operations: error Preapply_result.t ;
   }
   let net_id cctxt h =
     call_service1 cctxt Services.Blocks.net_id h ()

lib_client_base/client_node_rpcs.mli

@@ -74,12 +74,12 @@ module Blocks : sig
     block -> Protocol_hash.t tzresult Lwt.t
   val test_network:
     config ->
-    block -> Context.test_network tzresult Lwt.t
+    block -> Test_network_status.t tzresult Lwt.t
 
   val pending_operations:
     config ->
     block ->
-    (error Prevalidation.preapply_result * Operation.t Operation_hash.Map.t) tzresult Lwt.t
+    (error Preapply_result.t * Operation.t Operation_hash.Map.t) tzresult Lwt.t
 
   type block_info = {
     hash: Block_hash.t ;
@@ -94,7 +94,7 @@ module Blocks : sig
     data: MBytes.t ;
     operations: (Operation_hash.t * Operation.t) list list option ;
     protocol: Protocol_hash.t ;
-    test_network: Context.test_network;
+    test_network: Test_network_status.t ;
   }
 
   val info:
@@ -115,7 +115,7 @@ module Blocks : sig
 
   type preapply_result = {
     shell_header: Block_header.shell_header ;
-    operations: error Prevalidation.preapply_result ;
+    operations: error Preapply_result.t ;
   }
 
   val preapply:
@@ -156,17 +156,19 @@ val bootstrapped:
 
 module Network : sig
 
+  open P2p_types
+
   val stat:
-    config -> P2p_types.Stat.t tzresult Lwt.t
+    config -> Stat.t tzresult Lwt.t
 
   val connections:
-    config -> P2p_types.Connection_info.t list tzresult Lwt.t
+    config -> Connection_info.t list tzresult Lwt.t
 
   val peers:
-    config -> (P2p.Peer_id.t * P2p.RPC.Peer_id.info) list tzresult Lwt.t
+    config -> (Peer_id.t * P2p_types.Peer_info.t) list tzresult Lwt.t
 
   val points:
-    config -> (P2p.Point.t * P2p.RPC.Point.info) list tzresult Lwt.t
+    config -> (Point.t * P2p_types.Point_info.t) list tzresult Lwt.t
 
 end
 

lib_client_base/jbuild

@@ -5,17 +5,17 @@
   (public_name tezos-client-base)
   (libraries (tezos-base
               tezos-storage
-              tezos-node-shell
+              tezos-node-p2p-base
-              tezos-node-net
+              tezos-node-services
               tezos-node-updater
               tezos-protocol-compiler))
   (flags (:standard -w -9+27-30-32-40@8
                     -safe-string
                     -open Tezos_base__TzPervasives
                     -open Tezos_storage
-                    -open Tezos_node_net
+                    -open Tezos_node_p2p_base
-                    -open Tezos_node_updater
+                    -open Tezos_node_services
-                    -open Tezos_node_shell))))
+                    -open Tezos_node_updater))))
 
 (alias
  ((name runtest_indent)

lib_embedded_client_alpha/client_baking_forge.ml

@@ -110,7 +110,7 @@ let forge_block cctxt block
           Operation_hash.Map.bindings @@
           Operation_hash.Map.fold
             Operation_hash.Map.add
-            (Prevalidation.preapply_result_operations ops)
+            (Preapply_result.operations ops)
             pendings in
         return ops
     | Some operations -> return operations
@@ -465,7 +465,7 @@ let bake cctxt state =
          List.map snd @@
          Operation_hash.Map.bindings @@
          Operation_hash.Map.(fold add)
-           ops (Prevalidation.preapply_result_operations res) in
+           ops (Preapply_result.operations res) in
        let request = List.length operations in
        let proto_header =
          forge_faked_proto_header ~priority ~seed_nonce_hash in

lib_embedded_client_alpha/jbuild

@@ -6,7 +6,7 @@
   (libraries (tezos-base
               tezos-embedded-protocol-alpha
               tezos-embedded-protocol-alpha.raw
-              tezos-node-shell
+              tezos-node-services
               tezos-client-base))
   (library_flags (:standard -linkall))
   (flags (:standard -w -9+27-30-32-40@8
@@ -14,7 +14,7 @@
                     -open Tezos_base__TzPervasives
                     -open Tezos_embedded_protocol_environment_alpha
                     -open Tezos_embedded_raw_protocol_alpha
-                    -open Tezos_node_shell
+                    -open Tezos_node_services
                     -open Tezos_client_base
                     -open Tezos_context))))
 

lib_embedded_client_genesis/jbuild

@@ -8,7 +8,7 @@
               tezos-embedded-protocol-genesis.raw
               tezos-embedded-protocol-alpha.environment
               tezos-embedded-protocol-alpha.raw
-              tezos-node-shell
+              tezos-node-services
               tezos-client-base))
   (library_flags (:standard -linkall))
   (flags (:standard -w -9+27-30-32-40@8
@@ -16,7 +16,7 @@
                     -open Tezos_base__TzPervasives
                     -open Tezos_embedded_protocol_environment_genesis
                     -open Tezos_embedded_raw_protocol_genesis
-                    -open Tezos_node_shell
+                    -open Tezos_node_services
                     -open Tezos_client_base))))
 
 (alias

lib_node_http/RPC_server.ml

@@ -12,6 +12,9 @@ type cors = RestoCohttp.cors = {
   allowed_origins : string list ;
 }
 
+include RestoDirectory
+module Directory = RestoDirectory.MakeDirectory(RPC.Data)
+
 include RestoCohttp.Make(RPC.Data)(Logging.RPC)
 
 let json  = {
@@ -44,3 +47,21 @@ let octet_stream = {
     | Some data -> Ok data
   end ;
 }
+
+(* Compatibility layer, to be removed ASAP. *)
+
+type 'a directory = 'a Directory.t
+
+let empty = Directory.empty
+let register d s f = Directory.register d s (fun p () i -> f p i)
+
+open Directory.Curry
+let register0 root s f = register root s (curry Z f)
+let register1 root s f = register root s (curry (S Z) f)
+let register2 root s f = register root s (curry (S (S Z)) f)
+(* let register3 root s f = register root s (curry (S (S (S Z))) f) *)
+(* let register4 root s f = register root s (curry (S (S (S (S Z)))) f) *)
+(* let register5 root s f = register root s (curry (S (S (S (S (S Z))))) f) *)
+
+let register_dynamic_directory1 =
+  Directory.register_dynamic_directory1

lib_node_http/RPC_server.mli

@@ -7,6 +7,11 @@
 (*                                                                        *)
 (**************************************************************************)
 
+
+module Directory :
+  (module type of struct include RestoDirectory.MakeDirectory(RPC.Data) end)
+include (module type of struct include RestoDirectory end)
+
 (** Typed RPC services: server implementation. *)
 
 type cors = {
@@ -32,8 +37,45 @@ val launch :
   ?cors:cors ->
   media_types:media_type list ->
   Conduit_lwt_unix.server ->
-  unit RPC.Directory.t ->
+  unit Directory.t ->
   server Lwt.t
 
 (** Kill an RPC server. *)
 val shutdown : server -> unit Lwt.t
+
+
+(** Compatibility layer, to be removed ASAP. *)
+
+type 'a directory = 'a Directory.t
+val empty: 'a directory
+val register:
+  'prefix directory ->
+  ('prefix, 'params, 'input, 'output) RPC.service ->
+  ('params -> 'input -> [< ('output, unit) RestoDirectory.Answer.t ] Lwt.t) ->
+  'prefix directory
+
+val register0:
+  unit directory ->
+  (unit, unit, 'i, 'o) RPC.service ->
+  ('i -> [< ('o, unit) Answer.t ] Lwt.t) ->
+  unit directory
+
+val register1:
+  'prefix directory ->
+  ('prefix, unit * 'a, 'i, 'o) RPC.service ->
+  ('a -> 'i -> [< ('o, unit) Answer.t ] Lwt.t) ->
+  'prefix directory
+
+val register2:
+  'prefix directory ->
+  ('prefix, (unit * 'a) * 'b, 'i, 'o) RPC.service ->
+  ('a -> 'b -> 'i -> [< ('o, unit) Answer.t ] Lwt.t) ->
+  'prefix directory
+
+val register_dynamic_directory1:
+  ?descr:string ->
+  'prefix directory ->
+  ('prefix, unit * 'a) RPC.Path.path ->
+  ('a -> (unit * 'a) directory Lwt.t) ->
+  'prefix directory
+

lib_node_http/jbuild

@@ -0,0 +1,18 @@
+(jbuild_version 1)
+
+(library
+ ((name tezos_node_http)
+  (public_name tezos-node-http)
+  (libraries (tezos-base
+              tezos-node-services
+              ocplib-resto-directory
+              ocplib-resto-cohttp))
+  (flags (:standard -w -9+27-30-32-40@8
+                    -safe-string
+                    -open Tezos_base__TzPervasives
+                    -open Tezos_node_services))))
+
+(alias
+ ((name runtest_indent)
+  (deps ((glob_files *.ml) (glob_files *.mli)))
+  (action (run bash ${libexec:tezos-stdlib:test-ocp-indent.sh} ${<}))))

lib_node_net/p2p_types.ml

@@ -1,384 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*    Copyright (c) 2014 - 2017.                                          *)
-(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
-(*                                                                        *)
-(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
-(*                                                                        *)
-(**************************************************************************)
-
-module Version = struct
-  type t = {
-    name : string ;
-    major : int ;
-    minor : int ;
-  }
-
-  let pp ppf { name ; major ; minor } =
-    Format.fprintf ppf "%s.%d.%d" name major minor
-
-  let encoding =
-    let open Data_encoding in
-    conv
-      (fun { name; major; minor } -> (name, major, minor))
-      (fun (name, major, minor) -> { name; major; minor })
-      (obj3
-         (req "name" string)
-         (req "major" int8)
-         (req "minor" int8))
-
-  (* the common version for a pair of peers, if any, is the maximum one,
-     in lexicographic order *)
-  let common la lb =
-    let la = List.sort (fun l r -> compare r l) la in
-    let lb = List.sort (fun l r -> compare r l) lb in
-    let rec find = function
-      | [], _ | _, [] -> None
-      | ((a :: ta) as la), ((b :: tb) as lb) ->
-          if a = b then Some a
-          else if a < b then find (ta, lb)
-          else find (la, tb)
-    in find (la, lb)
-end
-
-module Stat = struct
-
-  type t = {
-    total_sent : int64 ;
-    total_recv : int64 ;
-    current_inflow : int ;
-    current_outflow : int ;
-  }
-
-  let empty = {
-    total_sent = 0L ;
-    total_recv = 0L ;
-    current_inflow = 0 ;
-    current_outflow = 0 ;
-  }
-
-  let print_size ppf sz =
-    let ratio n = (float_of_int sz /. float_of_int (1 lsl n)) in
-    if sz < 1 lsl 10 then
-      Format.fprintf ppf "%d B" sz
-    else if sz < 1 lsl 20 then
-      Format.fprintf ppf "%.2f kiB" (ratio 10)
-    else
-      Format.fprintf ppf "%.2f MiB" (ratio 20)
-
-  let print_size64 ppf sz =
-    let open Int64 in
-    let ratio n = (to_float sz /. float_of_int (1 lsl n)) in
-    if sz < shift_left 1L 10 then
-      Format.fprintf ppf "%Ld B" sz
-    else if sz < shift_left 1L 20 then
-      Format.fprintf ppf "%.2f kiB" (ratio 10)
-    else if sz < shift_left 1L 30 then
-      Format.fprintf ppf "%.2f MiB" (ratio 20)
-    else if sz < shift_left 1L 40 then
-      Format.fprintf ppf "%.2f GiB" (ratio 30)
-    else
-      Format.fprintf ppf "%.2f TiB" (ratio 40)
-
-  let pp ppf stat =
-    Format.fprintf ppf
-      "↗ %a (%a/s) ↘ %a (%a/s)"
-      print_size64 stat.total_sent print_size stat.current_outflow
-      print_size64 stat.total_recv print_size stat.current_inflow
-
-  let encoding =
-    let open Data_encoding in
-    conv
-      (fun { total_sent ; total_recv ; current_inflow ; current_outflow } ->
-         (total_sent, total_recv, current_inflow, current_outflow))
-      (fun (total_sent, total_recv, current_inflow, current_outflow) ->
-         { total_sent ; total_recv ; current_inflow ; current_outflow })
-      (obj4
-         (req "total_sent" int64)
-         (req "total_recv" int64)
-         (req "current_inflow" int31)
-         (req "current_outflow" int31))
-end
-
-module Peer_id = Crypto_box.Public_key_hash
-
-(* public types *)
-type addr = Ipaddr.V6.t
-
-let addr_encoding =
-  let open Data_encoding in
-  splitted
-    ~json:begin
-      conv
-        Ipaddr.V6.to_string
-        Ipaddr.V6.of_string_exn
-        string
-    end
-    ~binary:begin
-      conv
-        Ipaddr.V6.to_bytes
-        Ipaddr.V6.of_bytes_exn
-        string
-    end
-
-type port = int
-
-module Point = struct
-
-  module T = struct
-
-    (* A net point (address x port). *)
-    type t = addr * port
-    let compare (a1, p1) (a2, p2) =
-      match Ipaddr.V6.compare a1 a2 with
-      | 0 -> p1 - p2
-      | x -> x
-    let equal p1 p2 = compare p1 p2 = 0
-    let hash = Hashtbl.hash
-    let pp ppf (addr, port) =
-      match Ipaddr.v4_of_v6 addr with
-      | Some addr ->
-          Format.fprintf ppf "%a:%d" Ipaddr.V4.pp_hum addr port
-      | None ->
-          Format.fprintf ppf "[%a]:%d" Ipaddr.V6.pp_hum addr port
-    let pp_opt ppf = function
-      | None -> Format.pp_print_string ppf "none"
-      | Some point -> pp ppf point
-
-    let is_local (addr, _) = Ipaddr.V6.is_private addr
-    let is_global (addr, _) = not @@ Ipaddr.V6.is_private addr
-
-    let check_port port =
-      if String.mem_char port '[' ||
-         String.mem_char port ']' ||
-         String.mem_char port ':' then
-        invalid_arg "Utils.parse_addr_port (invalid character in port)"
-
-    let parse_addr_port s =
-      let len = String.length s in
-      if len = 0 then
-        ("", "")
-      else if s.[0] = '[' then begin (* inline IPv6 *)
-        match String.rindex s ']' with
-        | exception Not_found ->
-            invalid_arg "Utils.parse_addr_port (missing ']')"
-        | pos ->
-            let addr = String.sub s 1 (pos - 1) in
-            let port =
-              if pos = len - 1 then
-                ""
-              else if s.[pos+1] <> ':' then
-                invalid_arg "Utils.parse_addr_port (unexpected char after ']')"
-              else
-                String.sub s (pos + 2) (len - pos - 2) in
-            check_port port ;
-            addr, port
-      end else begin
-        match String.rindex s ']' with
-        | _pos ->
-            invalid_arg "Utils.parse_addr_port (unexpected char ']')"
-        | exception Not_found ->
-            match String.index s ':' with
-            | exception _ -> s, ""
-            | pos ->
-                match String.index_from s (pos+1) ':'  with
-                | exception _ ->
-                    let addr = String.sub s 0 pos in
-                    let port = String.sub s (pos + 1) (len - pos - 1) in
-                    check_port port ;
-                    addr, port
-                | _pos ->
-                    invalid_arg "Utils.parse_addr_port: IPv6 addresses must be bracketed"
-      end
-
-    let of_string_exn str =
-      let addr, port = parse_addr_port str in
-      let port = int_of_string port in
-      if port < 0 && port > 1 lsl 16 - 1 then
-        invalid_arg "port must be between 0 and 65535" ;
-      match Ipaddr.of_string_exn addr with
-      | V4 addr -> Ipaddr.v6_of_v4 addr, port
-      | V6 addr -> addr, port
-
-    let of_string str =
-      try Ok (of_string_exn str) with
-      | Invalid_argument s -> Error s
-      | Failure s -> Error s
-      | _ -> Error "Point.of_string"
-
-    let to_string saddr = Format.asprintf "%a" pp saddr
-
-    let encoding =
-      Data_encoding.conv to_string of_string_exn Data_encoding.string
-
-  end
-
-  include T
-
-  module Map = Map.Make (T)
-  module Set = Set.Make (T)
-  module Table = Hashtbl.Make (T)
-
-end
-
-module 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 to_string t = Format.asprintf "%a" pp t
-
-    let is_local (addr, _) = Ipaddr.V6.is_private addr
-    let is_global (addr, _) = not @@ Ipaddr.V6.is_private addr
-
-    let of_point (addr, port) = addr, Some port
-    let to_point = function
-      | _, None -> None
-      | addr, Some port -> Some (addr, port)
-    let to_point_exn = function
-      | _, None -> invalid_arg "to_point_exn"
-      | addr, Some port -> addr, port
-
-    let encoding =
-      let open Data_encoding in
-      (obj2
-         (req "addr" addr_encoding)
-         (opt "port" uint16))
-
-  end
-
-  include T
-
-  module Map = Map.Make (T)
-  module Set = Set.Make (T)
-  module Table = Hashtbl.Make (T)
-
-end
-
-module Identity = struct
-
-  type t = {
-    peer_id : Peer_id.t ;
-    public_key : Crypto_box.public_key ;
-    secret_key : Crypto_box.secret_key ;
-    proof_of_work_stamp : Crypto_box.nonce ;
-  }
-
-  let encoding =
-    let open Data_encoding in
-    conv
-      (fun { public_key ; secret_key ; proof_of_work_stamp } ->
-         (public_key, secret_key, proof_of_work_stamp))
-      (fun (public_key, secret_key, proof_of_work_stamp) ->
-         let peer_id = Crypto_box.hash public_key in
-         { peer_id ; public_key ; secret_key ; proof_of_work_stamp })
-      (obj3
-         (req "public_key" Crypto_box.public_key_encoding)
-         (req "secret_key" Crypto_box.secret_key_encoding)
-         (req "proof_of_work_stamp" Crypto_box.nonce_encoding))
-
-  let generate ?max target =
-    let secret_key, public_key, peer_id = Crypto_box.random_keypair () in
-    let proof_of_work_stamp =
-      Crypto_box.generate_proof_of_work ?max public_key target in
-    { peer_id ; public_key ; secret_key ; proof_of_work_stamp }
-
-  let animation = [|
-    "|.....|" ;
-    "|o....|" ;
-    "|oo...|" ;
-    "|ooo..|" ;
-    "|.ooo.|" ;
-    "|..ooo|" ;
-    "|...oo|" ;
-    "|....o|" ;
-    "|.....|" ;
-    "|.....|" ;
-    "|.....|" ;
-    "|.....|" ;
-  |]
-
-  let init = String.make (String.length animation.(0)) '\ '
-  let clean = String.make (String.length animation.(0)) '\b'
-  let animation = Array.map (fun x -> clean ^ x) animation
-  let animation_size = Array.length animation
-  let duration = 1200 / animation_size
-
-  let generate_with_animation ppf target =
-    Format.fprintf ppf "%s%!" init ;
-    let count = ref 10000 in
-    let rec loop n =
-      let start = Mtime_clock.counter () in
-      Format.fprintf ppf "%s%!" animation.(n mod animation_size);
-      try generate ~max:!count target
-      with Not_found ->
-        let time = Mtime.Span.to_ms (Mtime_clock.count start) in
-        count :=
-          if time <= 0. then
-            !count * 10
-          else
-            !count * duration / int_of_float time ;
-        loop (n+1)
-    in
-    let id = loop 0 in
-    Format.fprintf ppf "%s%s\n%!" clean init ;
-    id
-
-  let generate target = generate target
-
-end
-
-module Connection_info = struct
-
-  type t = {
-    incoming : bool;
-    peer_id : Peer_id.t;
-    id_point : Id_point.t;
-    remote_socket_port : port;
-    versions : Version.t list ;
-  }
-
-  let encoding =
-    let open Data_encoding in
-    conv
-      (fun { incoming ; peer_id ; id_point ; remote_socket_port ; versions } ->
-         (incoming, peer_id, id_point, remote_socket_port, versions))
-      (fun (incoming, peer_id, id_point, remote_socket_port, versions) ->
-         { incoming ; peer_id ; id_point ; remote_socket_port ; versions })
-      (obj5
-         (req "incoming" bool)
-         (req "peer_id" Peer_id.encoding)
-         (req "id_point" Id_point.encoding)
-         (req "remote_socket_port" uint16)
-         (req "versions" (list Version.encoding)))
-
-  let pp ppf
-      { incoming ; id_point = (remote_addr, remote_port) ;
-        remote_socket_port ; peer_id ; versions } =
-    let version = List.hd versions in
-    let point = match remote_port with
-      | None -> remote_addr, remote_socket_port
-      | Some port -> remote_addr, port in
-    Format.fprintf ppf "%s %a %a (%a)"
-      (if incoming then "↘" else "↗")
-      Peer_id.pp peer_id
-      Point.pp point
-      Version.pp version
-end

lib_node_p2p/jbuild

@@ -1,14 +1,14 @@
 (jbuild_version 1)
 
 (library
- ((name tezos_node_net)
+ ((name tezos_node_p2p)
-  (public_name tezos-node-net)
+  (public_name tezos-node-p2p)
   (libraries (tezos-base
-              mtime.clock.os
+              tezos-node-p2p-base))
-              ocplib-resto-cohttp))
   (flags (:standard -w -9+27-30-32-40@8
                     -safe-string
-                    -open Tezos_base__TzPervasives))))
+                    -open Tezos_base__TzPervasives
+                    -open Tezos_node_p2p_base))))
 
 (alias
  ((name runtest_indent)

lib_node_p2p/p2p.ml

@@ -515,107 +515,16 @@ module RPC = struct
   end
 
   module Point = struct
-    include Point
 
-    type state =
+    open P2p_types.Point_info
-      | Requested
+    open P2p_types.Point_state
-      | Accepted of Peer_id.t
-      | Running of Peer_id.t
-      | Disconnected
-
-    let peer_id_of_state = function
-      | Requested -> None
-      | Accepted pi -> Some pi
-      | Running pi -> Some pi
-      | Disconnected -> None
-
-    let state_of_state_peerid state pi = match state, pi with
-      | Requested, _ -> Requested
-      | Accepted _, Some pi -> Accepted pi
-      | Running _, Some pi -> Running pi
-      | Disconnected, _ -> Disconnected
-      | _ -> invalid_arg "state_of_state_peerid"
-
-    let pp_state_digram ppf = function
-      | Requested -> Format.fprintf ppf "⚎"
-      | Accepted _ -> Format.fprintf ppf "⚍"
-      | Running _ -> Format.fprintf ppf "⚌"
-      | Disconnected -> Format.fprintf ppf "⚏"
-
-    let state_encoding =
-      let open Data_encoding in
-      let branch_encoding name obj =
-        conv (fun x -> (), x) (fun ((), x) -> x)
-          (merge_objs
-             (obj1 (req "event_kind" (constant name))) obj) in
-      union ~tag_size:`Uint8 [
-        case ~tag:0 (branch_encoding "requested" empty)
-          (function Requested -> Some () | _ -> None)
-          (fun () -> Requested) ;
-        case ~tag:1 (branch_encoding "accepted"
-                       (obj1 (req "peer_id" Peer_id.encoding)))
-          (function Accepted peer_id -> Some peer_id | _ -> None)
-          (fun peer_id -> Accepted peer_id) ;
-        case ~tag:2 (branch_encoding "running"
-                       (obj1 (req "peer_id" Peer_id.encoding)))
-          (function Running peer_id -> Some peer_id | _ -> None)
-          (fun peer_id -> Running peer_id) ;
-        case ~tag:3 (branch_encoding "disconnected" empty)
-          (function Disconnected -> Some () | _ -> None)
-          (fun () -> Disconnected) ;
-      ]
-
-    type info = {
-      trusted : bool ;
-      greylisted_until : Time.t ;
-      state : state ;
-      last_failed_connection : Time.t option ;
-      last_rejected_connection : (Peer_id.t * Time.t) option ;
-      last_established_connection : (Peer_id.t * Time.t) option ;
-      last_disconnection : (Peer_id.t * Time.t) option ;
-      last_seen : (Peer_id.t * Time.t) option ;
-      last_miss : Time.t option ;
-    }
-
-    let info_encoding =
-      let open Data_encoding in
-      conv
-        (fun { trusted ; greylisted_until ; state ;
-               last_failed_connection ; last_rejected_connection ;
-               last_established_connection ; last_disconnection ;
-               last_seen ; last_miss } ->
-          let peer_id = peer_id_of_state state in
-          (trusted, greylisted_until, state, peer_id,
-           last_failed_connection, last_rejected_connection,
-           last_established_connection, last_disconnection,
-           last_seen, last_miss))
-        (fun (trusted, greylisted_until, state, peer_id,
-              last_failed_connection, last_rejected_connection,
-              last_established_connection, last_disconnection,
-              last_seen, last_miss) ->
-          let state = state_of_state_peerid state peer_id in
-          { trusted ; greylisted_until ; state ;
-            last_failed_connection ; last_rejected_connection ;
-            last_established_connection ; last_disconnection ;
-            last_seen ; last_miss })
-        (obj10
-           (req "trusted" bool)
-           (dft "greylisted_until" Time.encoding Time.epoch)
-           (req "state" state_encoding)
-           (opt "peer_id" Peer_id.encoding)
-           (opt "last_failed_connection" Time.encoding)
-           (opt "last_rejected_connection" (tup2 Peer_id.encoding Time.encoding))
-           (opt "last_established_connection" (tup2 Peer_id.encoding Time.encoding))
-           (opt "last_disconnection" (tup2 Peer_id.encoding Time.encoding))
-           (opt "last_seen" (tup2 Peer_id.encoding Time.encoding))
-           (opt "last_miss" Time.encoding))
 
     let info_of_point_info i =
       let open P2p_connection_pool_types in
       let state = match Point_info.State.get i with
         | Requested _ -> Requested
-        | Accepted { current_peer_id } -> Accepted current_peer_id
+        | Accepted { current_peer_id ; _ } -> Accepted current_peer_id
-        | Running { current_peer_id } -> Running current_peer_id
+        | Running { current_peer_id ; _ } -> Running current_peer_id
         | Disconnected -> Disconnected in
       Point_info.{
         trusted = trusted i ;
@@ -677,74 +586,9 @@ module RPC = struct
   end
 
   module Peer_id = struct
-    include Peer_id
 
-    type state =
+    open P2p_types.Peer_info
-      | Accepted
+    open P2p_types.Peer_state
-      | Running
-      | Disconnected
-
-    let pp_state_digram ppf = function
-      | Accepted -> Format.fprintf ppf "⚎"
-      | Running -> Format.fprintf ppf "⚌"
-      | Disconnected -> Format.fprintf ppf "⚏"
-
-    let state_encoding =
-      let open Data_encoding in
-      string_enum [
-        "accepted", Accepted ;
-        "running", Running ;
-        "disconnected", Disconnected ;
-      ]
-
-    type info = {
-      score : float ;
-      trusted : bool ;
-      state : state ;
-      id_point : Id_point.t option ;
-      stat : Stat.t ;
-      last_failed_connection : (Id_point.t * Time.t) option ;
-      last_rejected_connection : (Id_point.t * Time.t) option ;
-      last_established_connection : (Id_point.t * Time.t) option ;
-      last_disconnection : (Id_point.t * Time.t) option ;
-      last_seen : (Id_point.t * Time.t) option ;
-      last_miss : (Id_point.t * Time.t) option ;
-    }
-
-    let info_encoding =
-      let open Data_encoding in
-      conv
-        (fun (
-           { score ; trusted ; state ; id_point ; stat ;
-             last_failed_connection ; last_rejected_connection ;
-             last_established_connection ; last_disconnection ;
-             last_seen ; last_miss }) ->
-           ((score, trusted, state, id_point, stat),
-            (last_failed_connection, last_rejected_connection,
-             last_established_connection, last_disconnection,
-             last_seen, last_miss)))
-        (fun ((score, trusted, state, id_point, stat),
-              (last_failed_connection, last_rejected_connection,
-               last_established_connection, last_disconnection,
-               last_seen, last_miss)) ->
-          { score ; trusted ; state ; id_point ; stat ;
-            last_failed_connection ; last_rejected_connection ;
-            last_established_connection ; last_disconnection ;
-            last_seen ; last_miss })
-        (merge_objs
-           (obj5
-              (req "score" float)
-              (req "trusted" bool)
-              (req "state" state_encoding)
-              (opt "reachable_at" Id_point.encoding)
-              (req "stat" Stat.encoding))
-           (obj6
-              (opt "last_failed_connection" (tup2 Id_point.encoding Time.encoding))
-              (opt "last_rejected_connection" (tup2 Id_point.encoding Time.encoding))
-              (opt "last_established_connection" (tup2 Id_point.encoding Time.encoding))
-              (opt "last_disconnection" (tup2 Id_point.encoding Time.encoding))
-              (opt "last_seen" (tup2 Id_point.encoding Time.encoding))
-              (opt "last_miss" (tup2 Id_point.encoding Time.encoding))))
 
     let info_of_peer_info pool i =
       let open P2p_connection_pool in
@@ -783,8 +627,6 @@ module RPC = struct
           | None -> None
         end
 
-    module Event = P2p_connection_pool_types.Peer_info.Event
-
     let events ?(max=max_int) ?(rev=false) net peer_id =
       match net.pool with
       | None -> []

lib_node_p2p/p2p.mli

@@ -209,9 +209,9 @@ module RPC : sig
 
   val stat : ('msg, 'meta) net -> Stat.t
 
-  module Event = P2p_connection_pool.Log_event
+  val watch :
-
+    ('msg, 'meta) net ->
-  val watch : ('msg, 'meta) net -> Event.t Lwt_stream.t * Lwt_watcher.stopper
+    P2p_types.Connection_pool_log_event.t Lwt_stream.t * Lwt_watcher.stopper
   val connect : ('msg, 'meta) net -> Point.t -> float -> unit tzresult Lwt.t
 
   module Connection : sig
@@ -222,79 +222,41 @@ module RPC : sig
   end
 
   module Point : sig
-    include module type of Point
-
-    type state =
-      | Requested
-      | Accepted of Peer_id.t
-      | Running of Peer_id.t
-      | Disconnected
-
-    val pp_state_digram : Format.formatter -> state -> unit
-    val state_encoding : state Data_encoding.t
-
-    type info = {
-      trusted : bool ;
-      greylisted_until : Time.t ;
-      state : state ;
-      last_failed_connection : Time.t option ;
-      last_rejected_connection : (Peer_id.t * Time.t) option ;
-      last_established_connection : (Peer_id.t * Time.t) option ;
-      last_disconnection : (Peer_id.t * Time.t) option ;
-      last_seen : (Peer_id.t * Time.t) option ;
-      last_miss : Time.t option ;
-    }
-
-    val info_encoding : info Data_encoding.t
-
-    module Event = P2p_connection_pool_types.Point_info.Event
 
     val info :
-      ('msg, 'meta) net -> Point.t -> info option
+      ('msg, 'meta) net -> Point.t -> P2p_types.Point_info.t option
+
     val list :
-      ?restrict:state list -> ('msg, 'meta) net -> (Point.t * info) list
+      ?restrict: P2p_types.Point_state.t list ->
+      ('msg, 'meta) net -> (Point.t * P2p_types.Point_info.t) list
+
     val events :
-      ?max:int -> ?rev:bool -> ('msg, 'meta) net -> Point.t -> Event.t list
+      ?max:int -> ?rev:bool -> ('msg, 'meta) net -> Point.t ->
+      P2p_connection_pool_types.Point_info.Event.t list
+
     val watch :
-      ('msg, 'meta) net -> Point.t -> Event.t Lwt_stream.t * Lwt_watcher.stopper
+      ('msg, 'meta) net -> Point.t ->
+      P2p_connection_pool_types.Point_info.Event.t Lwt_stream.t * Lwt_watcher.stopper
+
   end
 
   module Peer_id : sig
-    include module type of Peer_id
-
-    type state =
-      | Accepted
-      | Running
-      | Disconnected
-
-    val pp_state_digram : Format.formatter -> state -> unit
-    val state_encoding : state Data_encoding.t
-
-    type info = {
-      score : float ;
-      trusted : bool ;
-      state : state ;
-      id_point : Id_point.t option ;
-      stat : Stat.t ;
-      last_failed_connection : (Id_point.t * Time.t) option ;
-      last_rejected_connection : (Id_point.t * Time.t) option ;
-      last_established_connection : (Id_point.t * Time.t) option ;
-      last_disconnection : (Id_point.t * Time.t) option ;
-      last_seen : (Id_point.t * Time.t) option ;
-      last_miss : (Id_point.t * Time.t) option ;
-    }
-    val info_encoding : info Data_encoding.t
-
-    module Event = P2p_connection_pool_types.Peer_info.Event
 
     val info :
-      ('msg, 'meta) net -> Peer_id.t -> info option
+      ('msg, 'meta) net -> Peer_id.t -> P2p_types.Peer_info.t option
+
     val list :
-      ?restrict:state list -> ('msg, 'meta) net -> (Peer_id.t * info) list
+      ?restrict: P2p_types.Peer_state.t list ->
+      ('msg, 'meta) net -> (Peer_id.t * P2p_types.Peer_info.t) list
+
     val events :
-      ?max:int -> ?rev:bool -> ('msg, 'meta) net -> Peer_id.t -> Event.t list
+      ?max: int -> ?rev: bool ->
+      ('msg, 'meta) net -> Peer_id.t ->
+      P2p_connection_pool_types.Peer_info.Event.t list
+
     val watch :
-      ('msg, 'meta) net -> Peer_id.t -> Event.t Lwt_stream.t * Lwt_watcher.stopper
+      ('msg, 'meta) net -> Peer_id.t ->
+      P2p_connection_pool_types.Peer_info.Event.t Lwt_stream.t * Lwt_watcher.stopper
 
   end
 
@@ -313,6 +275,7 @@ val on_new_connection :
   (Peer_id.t -> ('msg, 'meta) connection -> unit) -> unit
 
 (**/**)
+
 module Raw : sig
   type 'a t =
     | Bootstrap

lib_node_p2p/p2p_connection_pool.ml

@@ -150,160 +150,7 @@ module Answerer = struct
 
 end
 
-module Log_event = struct
+module Log_event = Connection_pool_log_event
-
-  type t =
-
-    | Too_few_connections
-    | Too_many_connections
-
-    | New_point of Point.t
-    | New_peer of Peer_id.t
-
-    | Gc_points
-    | Gc_peer_ids
-
-    | Incoming_connection of Point.t
-    | Outgoing_connection of Point.t
-    | Authentication_failed of Point.t
-    | Accepting_request of Point.t * Id_point.t * Peer_id.t
-    | Rejecting_request of Point.t * Id_point.t * Peer_id.t
-    | Request_rejected of Point.t * (Id_point.t * Peer_id.t) option
-    | Connection_established of Id_point.t * Peer_id.t
-
-    | Swap_request_received of { source : Peer_id.t }
-    | Swap_ack_received of { source : Peer_id.t }
-    | Swap_request_sent of { source : Peer_id.t }
-    | Swap_ack_sent of { source : Peer_id.t }
-    | Swap_request_ignored of { source : Peer_id.t }
-    | Swap_success of { source : Peer_id.t }
-    | Swap_failure of { source : Peer_id.t }
-
-    | Disconnection of Peer_id.t
-    | External_disconnection of Peer_id.t
-
-  let encoding =
-    let open Data_encoding in
-    let branch_encoding name obj =
-      conv (fun x -> (), x) (fun ((), x) -> x)
-        (merge_objs
-           (obj1 (req "event" (constant name))) obj) in
-    union ~tag_size:`Uint8 [
-      case ~tag:0 (branch_encoding "too_few_connections" empty)
-        (function Too_few_connections -> Some () | _ -> None)
-        (fun () -> Too_few_connections) ;
-      case ~tag:1 (branch_encoding "too_many_connections" empty)
-        (function Too_many_connections -> Some () | _ -> None)
-        (fun () -> Too_many_connections) ;
-      case ~tag:2 (branch_encoding "new_point"
-                     (obj1 (req "point" Point.encoding)))
-        (function New_point p -> Some p | _ -> None)
-        (fun p -> New_point p) ;
-      case ~tag:3 (branch_encoding "new_peer"
-                     (obj1 (req "peer_id" Peer_id.encoding)))
-        (function New_peer p -> Some p | _ -> None)
-        (fun p -> New_peer p) ;
-      case ~tag:4 (branch_encoding "incoming_connection"
-                     (obj1 (req "point" Point.encoding)))
-        (function Incoming_connection p -> Some p | _ -> None)
-        (fun p -> Incoming_connection p) ;
-      case ~tag:5 (branch_encoding "outgoing_connection"
-                     (obj1 (req "point" Point.encoding)))
-        (function Outgoing_connection p -> Some p | _ -> None)
-        (fun p -> Outgoing_connection p) ;
-      case ~tag:6 (branch_encoding "authentication_failed"
-                     (obj1 (req "point" Point.encoding)))
-        (function Authentication_failed p -> Some p | _ -> None)
-        (fun p -> Authentication_failed p) ;
-      case ~tag:7 (branch_encoding "accepting_request"
-                     (obj3
-                        (req "point" Point.encoding)
-                        (req "id_point" Id_point.encoding)
-                        (req "peer_id" Peer_id.encoding)))
-        (function Accepting_request (p, id_p, g) ->
-           Some (p, id_p, g) | _ -> None)
-        (fun (p, id_p, g) -> Accepting_request (p, id_p, g)) ;
-      case ~tag:8 (branch_encoding "rejecting_request"
-                     (obj3
-                        (req "point" Point.encoding)
-                        (req "id_point" Id_point.encoding)
-                        (req "peer_id" Peer_id.encoding)))
-        (function Rejecting_request (p, id_p, g) ->
-           Some (p, id_p, g) | _ -> None)
-        (fun (p, id_p, g) -> Rejecting_request (p, id_p, g)) ;
-      case ~tag:9 (branch_encoding "request_rejected"
-                     (obj2
-                        (req "point" Point.encoding)
-                        (opt "identity"
-                           (tup2 Id_point.encoding Peer_id.encoding))))
-        (function Request_rejected (p, id) -> Some (p, id) | _ -> None)
-        (fun (p, id) -> Request_rejected (p, id)) ;
-      case ~tag:10 (branch_encoding "connection_established"
-                      (obj2
-                         (req "id_point" Id_point.encoding)
-                         (req "peer_id" Peer_id.encoding)))
-        (function Connection_established (id_p, g) ->
-           Some (id_p, g) | _ -> None)
-        (fun (id_p, g) -> Connection_established (id_p, g)) ;
-      case ~tag:11 (branch_encoding "disconnection"
-                      (obj1 (req "peer_id" Peer_id.encoding)))
-        (function Disconnection g -> Some g | _ -> None)
-        (fun g -> Disconnection g) ;
-      case ~tag:12 (branch_encoding "external_disconnection"
-                      (obj1 (req "peer_id" Peer_id.encoding)))
-        (function External_disconnection g -> Some g | _ -> None)
-        (fun g -> External_disconnection g) ;
-      case ~tag:13 (branch_encoding "gc_points" empty)
-        (function Gc_points -> Some () | _ -> None)
-        (fun () -> Gc_points) ;
-      case ~tag:14 (branch_encoding "gc_peer_ids" empty)
-        (function Gc_peer_ids -> Some () | _ -> None)
-        (fun () -> Gc_peer_ids) ;
-      case ~tag:15 (branch_encoding "swap_request_received"
-                      (obj1 (req "source" Peer_id.encoding)))
-        (function
-          | Swap_request_received { source } -> Some source
-          | _ -> None)
-        (fun source -> Swap_request_received { source }) ;
-      case ~tag:16 (branch_encoding "swap_ack_received"
-                      (obj1 (req "source" Peer_id.encoding)))
-        (function
-          | Swap_ack_received { source } -> Some source
-          | _ -> None)
-        (fun source -> Swap_ack_received { source }) ;
-      case ~tag:17 (branch_encoding "swap_request_sent"
-                      (obj1 (req "source" Peer_id.encoding)))
-        (function
-          | Swap_request_sent { source } -> Some source
-          | _ -> None)
-        (fun source -> Swap_request_sent { source }) ;
-      case ~tag:18 (branch_encoding "swap_ack_sent"
-                      (obj1 (req "source" Peer_id.encoding)))
-        (function
-          | Swap_ack_sent { source } -> Some source
-          | _ -> None)
-        (fun source -> Swap_ack_sent { source }) ;
-      case ~tag:19 (branch_encoding "swap_request_ignored"
-                      (obj1 (req "source" Peer_id.encoding)))
-        (function
-          | Swap_request_ignored { source } -> Some source
-          | _ -> None)
-        (fun source -> Swap_request_ignored { source }) ;
-      case ~tag:20 (branch_encoding "swap_success"
-                      (obj1 (req "source" Peer_id.encoding)))
-        (function
-          | Swap_success { source } -> Some source
-          | _ -> None)
-        (fun source -> Swap_success { source }) ;
-      case ~tag:21 (branch_encoding "swap_failure"
-                      (obj1 (req "source" Peer_id.encoding)))
-        (function
-          | Swap_failure { source } -> Some source
-          | _ -> None)
-        (fun source -> Swap_failure { source }) ;
-    ]
-
-end
 
 type config = {
 

lib_node_p2p/p2p_connection_pool.mli

@@ -333,66 +333,7 @@ module Points : sig
 
 end
 
-module Log_event : sig
+module Log_event = Connection_pool_log_event
-
-  type t =
-
-    (* Pool-level events *)
-
-    | Too_few_connections
-    | Too_many_connections
-
-    | New_point of Point.t
-    | New_peer of Peer_id.t
-
-    | Gc_points
-    (** Garbage collection of known point table has been triggered. *)
-
-    | Gc_peer_ids
-    (** Garbage collection of known peer_ids table has been triggered. *)
-
-    (* Connection-level events *)
-
-    | Incoming_connection of Point.t
-    (** We accept(2)-ed an incoming connection *)
-    | Outgoing_connection of Point.t
-    (** We connect(2)-ed to a remote endpoint *)
-    | Authentication_failed of Point.t
-    (** Remote point failed authentication *)
-
-    | Accepting_request of Point.t * Id_point.t * Peer_id.t
-    (** We accepted a connection after authentifying the remote peer. *)
-    | Rejecting_request of Point.t * Id_point.t * Peer_id.t
-    (** We rejected a connection after authentifying the remote peer. *)
-    | Request_rejected of Point.t * (Id_point.t * Peer_id.t) option
-    (** The remote peer rejected our connection. *)
-
-    | Connection_established of Id_point.t * Peer_id.t
-    (** We succesfully established a authentified connection. *)
-
-    | Swap_request_received of { source : Peer_id.t }
-    (** A swap request has been received. *)
-    | Swap_ack_received of { source : Peer_id.t }
-    (** A swap ack has been received *)
-    | Swap_request_sent of { source : Peer_id.t }
-    (** A swap request has been sent *)
-    | Swap_ack_sent of { source : Peer_id.t }
-    (** A swap ack has been sent *)
-    | Swap_request_ignored of { source : Peer_id.t }
-    (** A swap request has been ignored *)
-    | Swap_success of { source : Peer_id.t }
-    (** A swap operation has succeeded *)
-    | Swap_failure of { source : Peer_id.t }
-    (** A swap operation has failed *)
-
-    | Disconnection of Peer_id.t
-    (** We decided to close the connection. *)
-    | External_disconnection of Peer_id.t
-    (** The connection was closed for external reason. *)
-
-  val encoding : t Data_encoding.t
-
-end
 
 val watch: ('msg, 'meta) pool -> Log_event.t Lwt_stream.t * Lwt_watcher.stopper
 (** [watch pool] is a [stream, close] a [stream] of events and a

lib_node_p2p/tezos-node-p2p.opam

@@ -0,0 +1,21 @@
+opam-version: "1.2"
+version: "dev"
+maintainer: "contact@tezos.com"
+authors: [ "Tezos devteam" ]
+homepage: "https://www.tezos.com/"
+bug-reports: "https://gitlab.com/tezos/tezos/issues"
+dev-repo: "https://gitlab.com/tezos/tezos.git"
+license: "unreleased"
+depends: [
+  "ocamlfind" { build }
+  "jbuilder" { build & >= "1.0+beta15" }
+  "base-bigarray"
+  "mtime.clock.os"
+  "ocplib-resto-cohttp"
+]
+build: [
+  [ "jbuilder" "build" "-p" name "-j" jobs ]
+]
+build-test: [
+  [ "jbuilder" "runtest" "-p" name "-j" jobs ]
+]

lib_node_p2p_base/jbuild

@@ -0,0 +1,12 @@
+(jbuild_version 1)
+
+(library
+ ((name tezos_node_p2p_base)
+  (public_name tezos-node-p2p-base)
+  (libraries (tezos-base))
+  (flags (:standard -open Tezos_base__TzPervasives))))
+
+(alias
+ ((name runtest_indent)
+  (deps ((glob_files *.ml) (glob_files *.mli)))
+  (action (run bash ${libexec:tezos-stdlib:test-ocp-indent.sh} ${<}))))

lib_node_p2p_base/p2p_connection_pool_types.ml

@@ -163,11 +163,11 @@ module Point_info = struct
     | (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 fold_events { events ; _ } ~init ~f = Ring.fold events ~init ~f
 
-  let watch { watchers } = Lwt_watcher.create_stream watchers
+  let watch { watchers ; _ } = Lwt_watcher.create_stream watchers
 
-  let log { events ; watchers } ?(timestamp = Time.now ()) kind =
+  let log { events ; watchers ; _ } ?(timestamp = Time.now ()) kind =
     let event = { Event.kind ; timestamp } in
     Ring.add events event ;
     Lwt_watcher.notify watchers event
@@ -189,16 +189,16 @@ module Point_info = struct
     let pp ppf = function
       | Requested _ ->
           Format.fprintf ppf "requested"
-      | Accepted { current_peer_id } ->
+      | Accepted { current_peer_id ; _ } ->
           Format.fprintf ppf "accepted %a" Peer_id.pp current_peer_id
-      | Running { current_peer_id } ->
+      | Running { current_peer_id ; _ } ->
           Format.fprintf ppf "running %a" Peer_id.pp current_peer_id
       | Disconnected ->
           Format.fprintf ppf "disconnected"
 
-    let get { state } = state
+    let get { state ; _ } = state
 
-    let is_disconnected { state } =
+    let is_disconnected { state ; _ } =
       match state with
       | Disconnected -> true
       | Requested _ | Accepted _ | Running _ -> false
@@ -232,7 +232,7 @@ module Point_info = struct
         match point_info.state with
         | Disconnected -> true (* request to unknown peer_id. *)
         | Running _ -> false
-        | Accepted { current_peer_id } -> Peer_id.equal peer_id current_peer_id
+        | Accepted { current_peer_id ; _ } -> Peer_id.equal peer_id current_peer_id
         | Requested _ -> true
       end ;
       point_info.state <- Running { data ; current_peer_id = peer_id } ;
@@ -255,12 +255,12 @@ module Point_info = struct
             set_greylisted timestamp point_info ;
             point_info.last_failed_connection <- Some timestamp ;
             Request_rejected None
-        | Accepted { current_peer_id } ->
+        | Accepted { current_peer_id ; _ } ->
             set_greylisted timestamp point_info ;
             point_info.last_rejected_connection <-
               Some (current_peer_id, timestamp) ;
             Request_rejected (Some current_peer_id)
-        | Running { current_peer_id } ->
+        | Running { current_peer_id ; _ } ->
             point_info.greylisting_delay <-
               float_of_int point_info.greylisting.initial_delay ;
             point_info.greylisting_end <-
@@ -368,7 +368,7 @@ module Peer_info = struct
     conv
       (fun { peer_id ; trusted ; metadata ; events ; created ;
              last_failed_connection ; last_rejected_connection ;
-             last_established_connection ; last_disconnection } ->
+             last_established_connection ; last_disconnection ; _ } ->
         (peer_id, created, trusted, metadata, Ring.elements events,
          last_failed_connection, last_rejected_connection,
          last_established_connection, last_disconnection))
@@ -402,14 +402,14 @@ module Peer_info = struct
          (opt "last_disconnection"
             (tup2 Id_point.encoding Time.encoding)))
 
-  let peer_id { peer_id } = peer_id
+  let peer_id { peer_id ; _ } = peer_id
-  let created { created } = created
+  let created { created ; _ } = created
-  let metadata { metadata } = metadata
+  let metadata { metadata ; _ } = metadata
   let set_metadata gi metadata = gi.metadata <- metadata
-  let trusted { trusted } = trusted
+  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 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
@@ -426,12 +426,12 @@ module Peer_info = struct
       s.last_failed_connection
       (recent s.last_rejected_connection s.last_disconnection)
 
-  let log { events ; watchers } ?(timestamp = Time.now ()) point kind =
+  let log { events ; watchers ; _ } ?(timestamp = Time.now ()) point kind =
     let event = { Event.kind ; timestamp ; point } in
     Ring.add events event ;
     Lwt_watcher.notify watchers event
 
-  let watch { watchers } = Lwt_watcher.create_stream watchers
+  let watch { watchers ; _ } = Lwt_watcher.create_stream watchers
 
   let log_incoming_rejection ?timestamp peer_info point =
     log peer_info ?timestamp point Rejecting_request
@@ -447,16 +447,16 @@ module Peer_info = struct
     type 'data state = 'data t
 
     let pp ppf = function
-      | Accepted { current_point } ->
+      | Accepted { current_point ; _ } ->
           Format.fprintf ppf "accepted %a" Id_point.pp current_point
-      | Running { 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 get { state ; _ } = state
 
-    let is_disconnected { state } =
+    let is_disconnected { state ; _ } =
       match state with
       | Disconnected -> true
       | Accepted _ | Running _ -> false
@@ -479,7 +479,7 @@ module Peer_info = struct
         match peer_info.state with
         | Disconnected -> true (* request to unknown peer_id. *)
         | Running _ -> false
-        | Accepted { current_point } ->
+        | Accepted { current_point ; _ } ->
             Id_point.equal point current_point
       end ;
       peer_info.state <- Running { data ; current_point = point } ;
@@ -490,11 +490,11 @@ module Peer_info = struct
         ?(timestamp = Time.now ()) ?(requested = false) peer_info =
       let current_point, (event : Event.kind) =
         match peer_info.state with
-        | Accepted { current_point } ->
+        | Accepted { current_point ; _ } ->
             peer_info.last_rejected_connection <-
               Some (current_point, timestamp) ;
             current_point, Request_rejected
-        | Running { current_point } ->
+        | Running { current_point ; _ } ->
             peer_info.last_disconnection <-
               Some (current_point, timestamp) ;
             current_point,

lib_node_p2p_base/p2p_types.ml

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

lib_node_p2p_base/p2p_types.mli

@@ -19,7 +19,7 @@ module Version : sig
 
   val pp : Format.formatter -> t -> unit
   val encoding : t Data_encoding.t
-  val common: t list -> t list -> t option
+  val common : t list -> t list -> t option
 end
 
 
@@ -36,10 +36,13 @@ val addr_encoding : addr Data_encoding.t
 (** Point, i.e. socket address *)
 
 module Point : sig
+
   type t = addr * port
   val compare : t -> t -> int
+
   val pp : Format.formatter -> t -> unit
   val pp_opt : Format.formatter -> t option -> unit
+
   val of_string_exn : string -> t
   val of_string : string -> (t, string) result
   val to_string : t -> string
@@ -47,9 +50,11 @@ module Point : sig
   val is_local : t -> bool
   val is_global : t -> bool
   val parse_addr_port : string -> string * string
+
   module Map : Map.S with type key = t
   module Set : Set.S with type elt = t
   module Table : Hashtbl.S with type key = t
+
 end
 
 (** Point representing a reachable socket address *)
@@ -112,7 +117,7 @@ module Stat : sig
   }
 
   val empty : t
-  val pp: Format.formatter -> t -> unit
+  val pp : Format.formatter -> t -> unit
   val encoding : t Data_encoding.t
 end
 
@@ -128,7 +133,131 @@ module Connection_info : sig
     versions : Version.t list ;
   }
 
-  val pp: Format.formatter -> t -> unit
+  val pp : Format.formatter -> t -> unit
   val encoding : t Data_encoding.t
 
 end
+
+(** Pool-level events *)
+
+module Connection_pool_log_event : sig
+
+  type t =
+
+    | Too_few_connections
+    | Too_many_connections
+
+    | New_point of Point.t
+    | New_peer of Peer_id.t
+
+    | Gc_points
+    (** Garbage collection of known point table has been triggered. *)
+
+    | Gc_peer_ids
+    (** Garbage collection of known peer_ids table has been triggered. *)
+
+    (* Connection-level events *)
+
+    | Incoming_connection of Point.t
+    (** We accept(2)-ed an incoming connection *)
+    | Outgoing_connection of Point.t
+    (** We connect(2)-ed to a remote endpoint *)
+    | Authentication_failed of Point.t
+    (** Remote point failed authentication *)
+
+    | Accepting_request of Point.t * Id_point.t * Peer_id.t
+    (** We accepted a connection after authentifying the remote peer. *)
+    | Rejecting_request of Point.t * Id_point.t * Peer_id.t
+    (** We rejected a connection after authentifying the remote peer. *)
+    | Request_rejected of Point.t * (Id_point.t * Peer_id.t) option
+    (** The remote peer rejected our connection. *)
+
+    | Connection_established of Id_point.t * Peer_id.t
+    (** We succesfully established a authentified connection. *)
+
+    | Swap_request_received of { source : Peer_id.t }
+    (** A swap request has been received. *)
+    | Swap_ack_received of { source : Peer_id.t }
+    (** A swap ack has been received *)
+    | Swap_request_sent of { source : Peer_id.t }
+    (** A swap request has been sent *)
+    | Swap_ack_sent of { source : Peer_id.t }
+    (** A swap ack has been sent *)
+    | Swap_request_ignored of { source : Peer_id.t }
+    (** A swap request has been ignored *)
+    | Swap_success of { source : Peer_id.t }
+    (** A swap operation has succeeded *)
+    | Swap_failure of { source : Peer_id.t }
+    (** A swap operation has failed *)
+
+    | Disconnection of Peer_id.t
+    (** We decided to close the connection. *)
+    | External_disconnection of Peer_id.t
+    (** The connection was closed for external reason. *)
+
+  val encoding : t Data_encoding.t
+
+end
+
+module Point_state : sig
+
+  type t =
+    | Requested
+    | Accepted of Peer_id.t
+    | Running of Peer_id.t
+    | Disconnected
+
+  val pp_digram : Format.formatter -> t -> unit
+  val encoding : t Data_encoding.t
+
+end
+
+module Point_info : sig
+
+  type t = {
+    trusted : bool ;
+    greylisted_until : Time.t ;
+    state : Point_state.t ;
+    last_failed_connection : Time.t option ;
+    last_rejected_connection : (Peer_id.t * Time.t) option ;
+    last_established_connection : (Peer_id.t * Time.t) option ;
+    last_disconnection : (Peer_id.t * Time.t) option ;
+    last_seen : (Peer_id.t * Time.t) option ;
+    last_miss : Time.t option ;
+  }
+
+  val encoding : t Data_encoding.t
+
+end
+
+module Peer_state : sig
+
+  type t =
+    | Accepted
+    | Running
+    | Disconnected
+
+  val pp_digram : Format.formatter -> t -> unit
+  val encoding : t Data_encoding.t
+
+end
+
+module Peer_info : sig
+
+  type t = {
+    score : float ;
+    trusted : bool ;
+    state : Peer_state.t ;
+    id_point : Id_point.t option ;
+    stat : Stat.t ;
+    last_failed_connection : (Id_point.t * Time.t) option ;
+    last_rejected_connection : (Id_point.t * Time.t) option ;
+    last_established_connection : (Id_point.t * Time.t) option ;
+    last_disconnection : (Id_point.t * Time.t) option ;
+    last_seen : (Id_point.t * Time.t) option ;
+    last_miss : (Id_point.t * Time.t) option ;
+  }
+  val encoding : t Data_encoding.t
+
+end
+

lib_node_p2p_base/tezos-node-p2p-base.opam

@@ -0,0 +1,21 @@
+opam-version: "1.2"
+version: "dev"
+maintainer: "contact@tezos.com"
+authors: [ "Tezos devteam" ]
+homepage: "https://www.tezos.com/"
+bug-reports: "https://gitlab.com/tezos/tezos/issues"
+dev-repo: "https://gitlab.com/tezos/tezos.git"
+license: "unreleased"
+depends: [
+  "ocamlfind" { build }
+  "jbuilder" { build & >= "1.0+beta15" }
+  "base-bigarray"
+  "mtime.clock.os"
+  "ocplib-resto-cohttp"
+]
+build: [
+  [ "jbuilder" "build" "-p" name "-j" jobs ]
+]
+build-test: [
+  [ "jbuilder" "runtest" "-p" name "-j" jobs ]
+]

lib_node_services/RPC.ml

@@ -135,14 +135,10 @@ module Data = struct
 end
 
 include Resto
-include RestoDirectory
+module Service = Resto.MakeService(Data)
-module Directory = RestoDirectory.MakeDirectory(Data)
-module Service = Directory.Service
-
 
 (* Compatibility layer, to be removed ASAP. *)
 
-type 'a directory = 'a Directory.t
 type ('prefix, 'params, 'input, 'output) service =
   ([ `POST ], 'prefix, 'params, unit, 'input, 'output, unit) Service.t
 
@@ -157,20 +153,6 @@ let service ?description ~input ~output path =
 
 type directory_descr = Data_encoding.json_schema Description.directory
 
-let empty = Directory.empty
-let register d s f = Directory.register d s (fun p () i -> f p i)
-
-open Directory.Curry
-let register0 root s f = register root s (curry Z f)
-let register1 root s f = register root s (curry (S Z) f)
-let register2 root s f = register root s (curry (S (S Z)) f)
-(* let register3 root s f = register root s (curry (S (S (S Z))) f) *)
-(* let register4 root s f = register root s (curry (S (S (S (S Z)))) f) *)
-(* let register5 root s f = register root s (curry (S (S (S (S (S Z))))) f) *)
-
-let register_dynamic_directory1 =
-  Directory.register_dynamic_directory1
-
 let forge_request (type i) (service: (_,_,_,_,i,_,_) Service.t) params body =
   let { Service.meth ; path } =
     Service.forge_request service params () in

lib_node_services/RPC.mli

@@ -13,13 +13,10 @@ module Data : Resto.ENCODING with type 'a t = 'a Data_encoding.t
                               and type schema = Data_encoding.json_schema
 
 include (module type of struct include Resto end)
-include (module type of struct include RestoDirectory end)
+module Service : (module type of struct include Resto.MakeService(Data) end)
-module Directory : (module type of struct include RestoDirectory.MakeDirectory(Data) end)
-module Service : (module type of struct include Directory.Service end)
 
 (** Compatibility layer, to be removed ASAP. *)
 
-type 'a directory = 'a Directory.t
 type ('prefix, 'params, 'input, 'output) service =
   ([ `POST ], 'prefix, 'params, unit, 'input, 'output, unit) Service.t
 
@@ -32,38 +29,6 @@ val service:
 
 type directory_descr = Data_encoding.json_schema Description.directory
 
-val empty: 'a directory
-val register:
-  'prefix directory ->
-  ('prefix, 'params, 'input, 'output) service ->
-  ('params -> 'input -> [< ('output, unit) RestoDirectory.Answer.t ] Lwt.t) ->
-  'prefix directory
-
-val register0:
-  unit directory ->
-  (unit, unit, 'i, 'o) service ->
-  ('i -> [< ('o, unit) Answer.t ] Lwt.t) ->
-  unit directory
-
-val register1:
-  'prefix directory ->
-  ('prefix, unit * 'a, 'i, 'o) service ->
-  ('a -> 'i -> [< ('o, unit) Answer.t ] Lwt.t) ->
-  'prefix directory
-
-val register2:
-  'prefix directory ->
-  ('prefix, (unit * 'a) * 'b, 'i, 'o) service ->
-  ('a -> 'b -> 'i -> [< ('o, unit) Answer.t ] Lwt.t) ->
-  'prefix directory
-
-val register_dynamic_directory1:
-  ?descr:string ->
-  'prefix directory ->
-  ('prefix, unit * 'a) Path.path ->
-  ('a -> (unit * 'a) directory Lwt.t) ->
-  'prefix directory
-
 val forge_request:
   (unit, 'params, 'input, _) service ->
   'params -> 'input -> MethMap.key * string list * Data_encoding.json

lib_node_services/jbuild

@@ -0,0 +1,17 @@
+(jbuild_version 1)
+
+(library
+ ((name tezos_node_services)
+  (public_name tezos-node-services)
+  (libraries (tezos-base
+              tezos-node-p2p-base
+              ocplib-resto))
+  (flags (:standard -w -9+27-30-32-40@8
+                    -safe-string
+                    -open Tezos_base__TzPervasives
+                    -open Tezos_node_p2p_base))))
+
+(alias
+ ((name runtest_indent)
+  (deps ((glob_files *.ml) (glob_files *.mli)))
+  (action (run bash ${libexec:tezos-stdlib:test-ocp-indent.sh} ${<}))))

lib_node_services/node_rpc_services.ml

@@ -69,7 +69,7 @@ module Blocks = struct
     data: MBytes.t ;
     operations: (Operation_hash.t * Operation.t) list list option ;
     protocol: Protocol_hash.t ;
-    test_network: Context.test_network;
+    test_network: Test_network_status.t ;
   }
 
   let block_info_encoding =
@@ -104,7 +104,7 @@ module Blocks = struct
                (opt "operations" (dynamic_size (list (dynamic_size (list (dynamic_size operation_encoding))))))
                (req "protocol" Protocol_hash.encoding)
                (dft "test_network"
-                  Context.test_network_encoding Context.Not_running))
+                  Test_network_status.encoding Not_running))
             Block_header.encoding))
 
   let parse_block s =
@@ -243,7 +243,7 @@ module Blocks = struct
     RPC.service
       ~description:"Returns the status of the associated test network."
       ~input: empty
-      ~output: Context.test_network_encoding
+      ~output: Test_network_status.encoding
       RPC.Path.(block_path / "test_network")
 
   let pending_operations =
@@ -259,7 +259,8 @@ module Blocks = struct
       ~output:
         (conv
            (fun (preapplied, unprocessed) ->
-              ({ preapplied with Prevalidation.refused = Operation_hash.Map.empty },
+              ({ preapplied with
+                 Preapply_result.refused = Operation_hash.Map.empty },
                Operation_hash.Map.bindings unprocessed))
            (fun (preapplied, unprocessed) ->
               (preapplied,
@@ -268,7 +269,7 @@ module Blocks = struct
                  unprocessed Operation_hash.Map.empty))
            (merge_objs
               (dynamic_size
-                 (Prevalidation.preapply_result_encoding Error.encoding))
+                 (Preapply_result.encoding Error.encoding))
               (obj1 (req "unprocessed" (list (dynamic_size operation_encoding))))))
       RPC.Path.(block_path / "pending_operations")
 
@@ -296,7 +297,7 @@ module Blocks = struct
 
   type preapply_result = {
     shell_header: Block_header.shell_header ;
-    operations: error Prevalidation.preapply_result ;
+    operations: error Preapply_result.t ;
   }
 
   let preapply_result_encoding =
@@ -308,7 +309,7 @@ module Blocks = struct
        (obj2
           (req "shell_header" Block_header.shell_header_encoding)
           (req "operations"
-             (Prevalidation.preapply_result_encoding Error.encoding))))
+             (Preapply_result.encoding Error.encoding))))
 
   let preapply =
     RPC.service
@@ -498,21 +499,21 @@ module Network = struct
     RPC.service
       ~description:"Supported network layer versions."
       ~input: empty
-      ~output: (list P2p.Version.encoding)
+      ~output: (list P2p_types.Version.encoding)
       RPC.Path.(root / "network" / "versions")
 
   let stat =
     RPC.service
       ~description:"Global network bandwidth statistics in B/s."
       ~input: empty
-      ~output: P2p.Stat.encoding
+      ~output: P2p_types.Stat.encoding
       RPC.Path.(root / "network" / "stat")
 
   let events =
     RPC.service
       ~description:"Stream of all network events"
       ~input: empty
-      ~output: P2p.RPC.Event.encoding
+      ~output: P2p_types.Connection_pool_log_event.encoding
       RPC.Path.(root / "network" / "log")
 
   let connect =
@@ -530,13 +531,13 @@ module Network = struct
       RPC.service
         ~description:"List the running P2P connection."
         ~input: empty
-        ~output: (list P2p.Connection_info.encoding)
+        ~output: (list P2p_types.Connection_info.encoding)
         RPC.Path.(root / "network" / "connection")
 
     let info =
       RPC.service
         ~input: empty
-        ~output: (option P2p.Connection_info.encoding)
+        ~output: (option P2p_types.Connection_info.encoding)
         ~description:"Details about the current P2P connection to the given peer."
         RPC.Path.(root / "network" / "connection" /: peer_id_arg)
 
@@ -554,23 +555,26 @@ module Network = struct
     let info =
       RPC.service
         ~input: empty
-        ~output: (option P2p.RPC.Point.info_encoding)
+        ~output: (option P2p_types.Point_info.encoding)
         ~description: "Details about a given `IP:addr`."
         RPC.Path.(root / "network" / "point" /: point_arg)
 
     let events =
       RPC.service
         ~input: monitor_encoding
-        ~output: (list P2p.RPC.Point.Event.encoding)
+        ~output: (list P2p_connection_pool_types.Point_info.Event.encoding)
         ~description: "Monitor network events related to an `IP:addr`."
         RPC.Path.(root / "network" / "point" /: point_arg / "log")
 
     let list =
       let filter =
-        obj1 (dft "filter" (list P2p.RPC.Point.state_encoding) []) in
+        obj1 (dft "filter" (list P2p_types.Point_state.encoding) []) in
       RPC.service
         ~input: filter
-        ~output: (list (tup2 P2p.Point.encoding P2p.RPC.Point.info_encoding))
+        ~output:
+          (list (tup2
+                   P2p_types.Point.encoding
+                   P2p_types.Point_info.encoding))
         ~description:"List the pool of known `IP:port` \
                       used for establishing P2P connections ."
         RPC.Path.(root / "network" / "point")
@@ -582,23 +586,26 @@ module Network = struct
     let info =
       RPC.service
         ~input: empty
-        ~output: (option P2p.RPC.Peer_id.info_encoding)
+        ~output: (option P2p_types.Peer_info.encoding)
         ~description:"Details about a given peer."
         RPC.Path.(root / "network" / "peer_id" /: peer_id_arg)
 
     let events =
       RPC.service
         ~input: monitor_encoding
-        ~output: (list P2p.RPC.Peer_id.Event.encoding)
+        ~output: (list P2p_connection_pool_types.Peer_info.Event.encoding)
         ~description:"Monitor network events related to a given peer."
         RPC.Path.(root / "network" / "peer_id" /: peer_id_arg / "log")
 
     let list =
       let filter =
-        obj1 (dft "filter" (list P2p.RPC.Peer_id.state_encoding) []) in
+        obj1 (dft "filter" (list P2p_types.Peer_state.encoding) []) in
       RPC.service
         ~input: filter
-        ~output: (list (tup2 P2p.Peer_id.encoding P2p.RPC.Peer_id.info_encoding))
+        ~output:
+          (list (tup2
+                   P2p_types.Peer_id.encoding
+                   P2p_types.Peer_info.encoding))
         ~description:"List the peers the node ever met."
         RPC.Path.(root / "network" / "peer_id")
 

lib_node_services/node_rpc_services.mli

@@ -39,7 +39,7 @@ module Blocks : sig
     data: MBytes.t ;
     operations: (Operation_hash.t * Operation.t) list list option ;
     protocol: Protocol_hash.t ;
-    test_network: Context.test_network;
+    test_network: Test_network_status.t ;
   }
 
   val info:
@@ -70,10 +70,10 @@ module Blocks : sig
   val protocol:
     (unit, unit * block, unit, Protocol_hash.t) RPC.service
   val test_network:
-    (unit, unit * block, unit, Context.test_network) RPC.service
+    (unit, unit * block, unit, Test_network_status.t) RPC.service
   val pending_operations:
     (unit, unit * block, unit,
-     error Prevalidation.preapply_result * Operation.t Operation_hash.Map.t) RPC.service
+     error Preapply_result.t * Operation.t Operation_hash.Map.t) RPC.service
 
   type list_param = {
     include_ops: bool ;
@@ -99,7 +99,7 @@ module Blocks : sig
 
   type preapply_result = {
     shell_header: Block_header.shell_header ;
-    operations: error Prevalidation.preapply_result ;
+    operations: error Preapply_result.t ;
   }
   val preapply:
     (unit, unit * block, preapply_param, preapply_result tzresult) RPC.service
@@ -131,44 +131,56 @@ end
 module Network : sig
 
   val stat :
-    (unit, unit, unit, P2p.Stat.t) RPC.service
+    (unit, unit, unit, P2p_types.Stat.t) RPC.service
 
   val versions :
-    (unit, unit, unit, P2p.Version.t list) RPC.service
+    (unit, unit, unit, P2p_types.Version.t list) RPC.service
 
   val events :
-    (unit, unit, unit, P2p.RPC.Event.t) RPC.service
+    (unit, unit, unit, P2p_types.Connection_pool_log_event.t) RPC.service
 
   val connect :
-    (unit, unit * P2p.Point.t, float, unit tzresult) RPC.service
+    (unit, unit * P2p_types.Point.t, float, unit tzresult) RPC.service
 
   module Connection : sig
+
     val list :
-      (unit, unit, unit, P2p.Connection_info.t list) RPC.service
+      (unit, unit, unit, P2p_types.Connection_info.t list) RPC.service
+
     val info :
-      (unit, unit * P2p.Peer_id.t, unit, P2p.Connection_info.t option) RPC.service
+      (unit, unit * P2p_types.Peer_id.t, unit,
+       P2p_types.Connection_info.t option) RPC.service
+
     val kick :
-      (unit, unit * P2p.Peer_id.t, bool, unit) RPC.service
+      (unit, unit * P2p_types.Peer_id.t, bool, unit) RPC.service
+
   end
 
   module Point : sig
     val list :
-      (unit, unit, P2p.RPC.Point.state list,
+      (unit, unit, P2p_types.Point_state.t list,
-       (P2p.Point.t * P2p.RPC.Point.info) list) RPC.service
+       (P2p_types.Point.t * P2p_types.Point_info.t) list) RPC.service
     val info :
-      (unit, unit * P2p.Point.t, unit, P2p.RPC.Point.info option) RPC.service
+      (unit, unit * P2p_types.Point.t, unit, P2p_types.Point_info.t option) RPC.service
     val events :
-      (unit, unit * P2p.Point.t, bool, P2p.RPC.Point.Event.t list) RPC.service
+      (unit, unit * P2p_types.Point.t, bool,
+       P2p_connection_pool_types.Point_info.Event.t list) RPC.service
   end
 
   module Peer_id : sig
+
     val list :
-      (unit, unit, P2p.RPC.Peer_id.state list,
+      (unit, unit, P2p_types.Peer_state.t list,
-       (P2p.Peer_id.t * P2p.RPC.Peer_id.info) list) RPC.service
+       (P2p_types.Peer_id.t * P2p_types.Peer_info.t) list) RPC.service
+
     val info :
-      (unit, unit * P2p.Peer_id.t, unit, P2p.RPC.Peer_id.info option) RPC.service
+      (unit, unit * P2p_types.Peer_id.t, unit,
+       P2p_types.Peer_info.t option) RPC.service
+
     val events :
-      (unit, unit * P2p.Peer_id.t, bool, P2p.RPC.Peer_id.Event.t list) RPC.service
+      (unit, unit * P2p_types.Peer_id.t, bool,
+       P2p_connection_pool_types.Peer_info.Event.t list) RPC.service
+
   end
 
 end

lib_node_services/tezos-node-services.opam

@@ -0,0 +1,21 @@
+opam-version: "1.2"
+version: "dev"
+maintainer: "contact@tezos.com"
+authors: [ "Tezos devteam" ]
+homepage: "https://www.tezos.com/"
+bug-reports: "https://gitlab.com/tezos/tezos/issues"
+dev-repo: "https://gitlab.com/tezos/tezos.git"
+license: "unreleased"
+depends: [
+  "ocamlfind" { build }
+  "jbuilder" { build & >= "1.0+beta15" }
+  "base-bigarray"
+  "mtime.clock.os"
+  "ocplib-resto-cohttp"
+]
+build: [
+  [ "jbuilder" "build" "-p" name "-j" jobs ]
+]
+build-test: [
+  [ "jbuilder" "runtest" "-p" name "-j" jobs ]
+]

lib_node_shell/jbuild

@@ -5,13 +5,18 @@
   (public_name tezos-node-shell)
   (libraries (tezos-base
               tezos-storage
-              tezos-node-net
+              tezos-node-services
+              tezos-node-p2p-base
+              tezos-node-p2p
               tezos-node-updater))
   (flags (:standard -w -9+27-30-32-40@8
                     -safe-string
                     -open Tezos_base__TzPervasives
                     -open Tezos_storage
-                    -open Tezos_node_net
+                    -open Tezos_node_services
+                    -open Tezos_node_http
+                    -open Tezos_node_p2p_base
+                    -open Tezos_node_p2p
                     -open Tezos_node_updater))))
 
 (alias

lib_node_shell/node.ml

@@ -152,7 +152,7 @@ module RPC = struct
     data: MBytes.t ;
     operations: (Operation_hash.t * Operation.t) list list option ;
     protocol: Protocol_hash.t ;
-    test_network: Context.test_network;
+    test_network: Test_network_status.t ;
   }
 
   let convert (block: State.Block.t) =
@@ -377,7 +377,7 @@ module RPC = struct
     | (`Prevalidation | `Test_prevalidation) as block ->
         let validator = get_validator node block in
         let pv = Net_validator.prevalidator validator in
-        let { Prevalidation.applied }, _ = Prevalidator.operations pv in
+        let { Preapply_result.applied }, _ = Prevalidator.operations pv in
         Lwt.return [List.map fst applied]
     | `Hash hash ->
         read_valid_block node hash >>= function
@@ -398,7 +398,7 @@ module RPC = struct
     | (`Prevalidation | `Test_prevalidation) as block ->
         let validator = get_validator node block in
         let pv = Net_validator.prevalidator validator in
-        let { Prevalidation.applied }, _ = Prevalidator.operations pv in
+        let { Preapply_result.applied }, _ = Prevalidator.operations pv in
         Lwt.return [List.map snd applied]
     | `Hash hash ->
         read_valid_block node hash >>= function
@@ -421,24 +421,24 @@ module RPC = struct
         Chain.head net_state >>= fun head ->
         predecessor net_db n head >>= fun b ->
         Prevalidator.pending ~block:b prevalidator >|= fun ops ->
-        Prevalidation.empty_result, ops
+        Preapply_result.empty, ops
     | `Genesis ->
         let net_state = Net_validator.net_state node.mainnet_validator in
         let prevalidator =
           Net_validator.prevalidator node.mainnet_validator in
         Chain.genesis net_state >>= fun b ->
         Prevalidator.pending ~block:b prevalidator >|= fun ops ->
-        Prevalidation.empty_result, ops
+        Preapply_result.empty, ops
     | `Hash h -> begin
         get_validator_per_hash node h >>= function
         | None ->
-            Lwt.return (Prevalidation.empty_result, Operation_hash.Map.empty)
+            Lwt.return (Preapply_result.empty, Operation_hash.Map.empty)
         | Some validator ->
             let net_state = Net_validator.net_state validator in
             let prevalidator = Net_validator.prevalidator validator in
             State.Block.read_exn net_state h >>= fun block ->
             Prevalidator.pending ~block prevalidator >|= fun ops ->
-            Prevalidation.empty_result, ops
+            Preapply_result.empty, ops
       end
 
   let protocols { state } =
@@ -522,8 +522,8 @@ module RPC = struct
     | Some rpc_context ->
         Context.get_protocol rpc_context.context >>= fun protocol_hash ->
         let (module Proto) = State.Registred_protocol.get_exn protocol_hash in
-        let dir = RPC.Directory.map (fun () -> rpc_context) Proto.rpc_services in
+        let dir = RPC_server.Directory.map (fun () -> rpc_context) Proto.rpc_services in
-        Lwt.return (Some (RPC.Directory.map (fun _ -> ()) dir))
+        Lwt.return (Some (RPC_server.Directory.map (fun _ -> ()) dir))
 
   let heads node =
     let net_state = Net_validator.net_state node.mainnet_validator in
@@ -627,7 +627,7 @@ module RPC = struct
         ]
       end in
     let shutdown () = Lwt_watcher.shutdown stopper in
-    RPC.Answer.{ next ; shutdown }
+    RPC_server.Answer.{ next ; shutdown }
 
   module Network = struct
 
@@ -661,11 +661,11 @@ module RPC = struct
       let info (node : t) =
         P2p.RPC.Point.info node.p2p
 
-      let list (node : t) restrict =
+      let list ?restrict (node : t) =
-        P2p.RPC.Point.list ~restrict node.p2p
+        P2p.RPC.Point.list ?restrict node.p2p
 
-      let events (node : t) =
+      let events ?max ?rev (node : t) =
-        P2p.RPC.Point.events node.p2p
+        P2p.RPC.Point.events node.p2p ?max ?rev
 
       let watch (node : t) =
         P2p.RPC.Point.watch node.p2p
@@ -677,11 +677,11 @@ module RPC = struct
       let info (node : t) =
         P2p.RPC.Peer_id.info node.p2p
 
-      let list (node : t) restrict =
+      let list ?restrict (node : t) =
-        P2p.RPC.Peer_id.list ~restrict node.p2p
+        P2p.RPC.Peer_id.list ?restrict node.p2p
 
-      let events (node : t) =
+      let events ?max ?rev (node : t) =
-        P2p.RPC.Peer_id.events node.p2p
+        P2p.RPC.Peer_id.events node.p2p ?max ?rev
 
       let watch (node : t) =
         P2p.RPC.Peer_id.watch node.p2p

lib_node_shell/node.mli

@@ -78,7 +78,8 @@ module RPC : sig
     t -> (Operation_hash.t * Operation.t) Lwt_stream.t * Lwt_watcher.stopper
 
   val pending_operations:
-    t -> block -> (error Prevalidation.preapply_result * Operation.t Operation_hash.Map.t) Lwt.t
+    t -> block ->
+    (error Preapply_result.t * Operation.t Operation_hash.Map.t) Lwt.t
 
   val protocols:
     t -> Protocol_hash.t list Lwt.t
@@ -88,52 +89,78 @@ module RPC : sig
     t -> (Protocol_hash.t * Protocol.t) Lwt_stream.t * Lwt_watcher.stopper
 
   val context_dir:
-    t -> block -> 'a RPC.directory option Lwt.t
+    t -> block -> 'a RPC_server.directory option Lwt.t
 
   val preapply:
     t -> block ->
     timestamp:Time.t -> proto_header:MBytes.t ->
     sort_operations:bool -> Operation.t list ->
-    (Block_header.shell_header * error Prevalidation.preapply_result) tzresult Lwt.t
+    (Block_header.shell_header * error Preapply_result.t) tzresult Lwt.t
 
   val context_dir:
-    t -> block -> 'a RPC.directory option Lwt.t
+    t -> block -> 'a RPC_server.directory option Lwt.t
 
   val complete:
     t -> ?block:block -> string -> string list Lwt.t
 
   val bootstrapped:
-    t -> (Block_hash.t * Time.t) RPC.Answer.stream
+    t -> (Block_hash.t * Time.t) RPC_server.Answer.stream
 
   module Network : sig
 
-    val stat : t -> P2p.Stat.t
+    open P2p_types
-    val watch : t -> P2p.RPC.Event.t Lwt_stream.t * Lwt_watcher.stopper
+
-    val connect : t -> P2p.Point.t -> float -> unit tzresult Lwt.t
+    val stat : t -> Stat.t
+
+    val watch :
+      t ->
+      P2p_types.Connection_pool_log_event.t Lwt_stream.t * Lwt_watcher.stopper
+    val connect : t -> Point.t -> float -> unit tzresult Lwt.t
 
     module Connection : sig
-      val info : t -> P2p.Peer_id.t -> P2p.Connection_info.t option
+      val info : t -> Peer_id.t -> Connection_info.t option
-      val kick : t -> P2p.Peer_id.t -> bool -> unit Lwt.t
+      val kick : t -> Peer_id.t -> bool -> unit Lwt.t
-      val list : t -> P2p.Connection_info.t list
+      val list : t -> Connection_info.t list
       val count : t -> int
     end
 
-    module Peer_id : sig
+    module Point : sig
-      val list : t ->
+
-        P2p.RPC.Peer_id.state list -> (P2p.Peer_id.t * P2p.RPC.Peer_id.info) list
+      val info :
-      val info : t -> P2p.Peer_id.t -> P2p.RPC.Peer_id.info option
+        t -> Point.t -> P2p_types.Point_info.t option
-      val events : t -> P2p.Peer_id.t -> P2p.RPC.Peer_id.Event.t list
+
-      val watch : t -> P2p.Peer_id.t ->
+      val list :
-        P2p.RPC.Peer_id.Event.t Lwt_stream.t * Lwt_watcher.stopper
+        ?restrict: P2p_types.Point_state.t list ->
+        t -> (Point.t * P2p_types.Point_info.t) list
+
+      val events :
+        ?max:int -> ?rev:bool -> t -> Point.t ->
+        P2p_connection_pool_types.Point_info.Event.t list
+
+      val watch :
+        t -> Point.t ->
+        P2p_connection_pool_types.Point_info.Event.t Lwt_stream.t * Lwt_watcher.stopper
+
     end
 
-    module Point : sig
+    module Peer_id : sig
-      val list : t ->
+
-        P2p.RPC.Point.state list -> (P2p.Point.t * P2p.RPC.Point.info) list
+      val info :
-      val info : t -> P2p.Point.t -> P2p.RPC.Point.info option
+        t -> Peer_id.t -> P2p_types.Peer_info.t option
-      val events : t -> P2p.Point.t -> P2p.RPC.Point.Event.t list
+
-      val watch : t -> P2p.Point.t ->
+      val list :
-        P2p.RPC.Point.Event.t Lwt_stream.t * Lwt_watcher.stopper
+        ?restrict: P2p_types.Peer_state.t list ->
+        t -> (Peer_id.t * P2p_types.Peer_info.t) list
+
+      val events :
+        ?max: int -> ?rev: bool ->
+        t -> Peer_id.t ->
+        P2p_connection_pool_types.Peer_info.Event.t list
+
+      val watch :
+        t -> Peer_id.t ->
+        P2p_connection_pool_types.Peer_info.Event.t Lwt_stream.t * Lwt_watcher.stopper
+
     end
 
   end

lib_node_shell/node_rpc.ml

@@ -36,70 +36,70 @@ let monitor_operations node contents =
         Lwt.return_some @@
         List.map (List.map (fun h -> h, None)) hashes
     end in
-  RPC.Answer.return_stream { next ; shutdown }
+  RPC_server.Answer.return_stream { next ; shutdown }
 
 let register_bi_dir node dir =
   let dir =
     let implementation b include_ops =
       Node.RPC.block_info node b >>= fun bi ->
-      RPC.Answer.return (filter_bi include_ops bi) in
+      RPC_server.Answer.return (filter_bi include_ops bi) in
-    RPC.register1 dir
+    RPC_server.register1 dir
       Services.Blocks.info implementation in
   let dir =
     let implementation b () =
       Node.RPC.block_info node b >>= fun bi ->
-      RPC.Answer.return bi.hash in
+      RPC_server.Answer.return bi.hash in
-    RPC.register1 dir
+    RPC_server.register1 dir
       Services.Blocks.hash
       implementation in
   let dir =
     let implementation b () =
       Node.RPC.block_info node b >>= fun bi ->
-      RPC.Answer.return bi.net_id in
+      RPC_server.Answer.return bi.net_id in
-    RPC.register1 dir
+    RPC_server.register1 dir
       Services.Blocks.net_id implementation in
   let dir =
     let implementation b () =
       Node.RPC.block_info node b >>= fun bi ->
-      RPC.Answer.return bi.level in
+      RPC_server.Answer.return bi.level in
-    RPC.register1 dir
+    RPC_server.register1 dir
       Services.Blocks.level implementation in
   let dir =
     let implementation b () =
       Node.RPC.block_info node b >>= fun bi ->
-      RPC.Answer.return bi.predecessor in
+      RPC_server.Answer.return bi.predecessor in
-    RPC.register1 dir
+    RPC_server.register1 dir
       Services.Blocks.predecessor implementation in
   let dir =
     let implementation b len =
       Node.RPC.block_info node b >>= fun bi ->
       Node.RPC.predecessors node len bi.hash >>= fun hashes ->
-      RPC.Answer.return hashes in
+      RPC_server.Answer.return hashes in
-    RPC.register1 dir
+    RPC_server.register1 dir
       Services.Blocks.predecessors implementation in
   let dir =
     let implementation b () =
       Node.RPC.block_info node b >>= fun bi ->
-      RPC.Answer.return bi.fitness in
+      RPC_server.Answer.return bi.fitness in
-    RPC.register1 dir
+    RPC_server.register1 dir
       Services.Blocks.fitness implementation in
   let dir =
     let implementation b () =
       Node.RPC.block_info node b >>= fun bi ->
-      RPC.Answer.return bi.timestamp in
+      RPC_server.Answer.return bi.timestamp in
-    RPC.register1 dir
+    RPC_server.register1 dir
       Services.Blocks.timestamp implementation in
   let dir =
     let implementation b () =
       Node.RPC.block_info node b >>= fun bi ->
-      RPC.Answer.return bi.protocol in
+      RPC_server.Answer.return bi.protocol in
-    RPC.register1 dir
+    RPC_server.register1 dir
       Services.Blocks.protocol implementation in
   let dir =
     let implementation b () =
       Node.RPC.block_info node b >>= fun bi ->
-      RPC.Answer.return bi.test_network in
+      RPC_server.Answer.return bi.test_network in
-    RPC.register1 dir
+    RPC_server.register1 dir
       Services.Blocks.test_network implementation in
   let dir =
     let implementation b { Node_rpc_services.Blocks.contents ; monitor } =
@@ -110,19 +110,19 @@ let register_bi_dir node dir =
           Node.RPC.operation_hashes node b >>= fun hashes ->
           if contents then
             Node.RPC.operations node b >>= fun ops ->
-            RPC.Answer.return @@
+            RPC_server.Answer.return @@
             List.map2 (List.map2 (fun h op -> h, Some op)) hashes ops
           else
-            RPC.Answer.return @@
+            RPC_server.Answer.return @@
             List.map (List.map (fun h -> h, None)) hashes
     in
-    RPC.register1 dir
+    RPC_server.register1 dir
       Services.Blocks.operations implementation in
   let dir =
     let implementation b () =
       Node.RPC.pending_operations node b >>= fun res ->
-      RPC.Answer.return res in
+      RPC_server.Answer.return res in
-    RPC.register1 dir
+    RPC_server.register1 dir
       Services.Blocks.pending_operations
       implementation in
   let dir =
@@ -132,15 +132,15 @@ let register_bi_dir node dir =
       Node.RPC.preapply node b
         ~timestamp ~proto_header ~sort_operations operations >>= function
       | Ok (shell_header, operations) ->
-          RPC.Answer.return
+          RPC_server.Answer.return
             (Ok { Services.Blocks.shell_header ; operations })
-      | Error _ as err -> RPC.Answer.return err in
+      | Error _ as err -> RPC_server.Answer.return err in
-    RPC.register1 dir
+    RPC_server.register1 dir
       Services.Blocks.preapply implementation in
   dir
 
 let ops_dir _node =
-  let ops_dir = RPC.empty in
+  let ops_dir = RPC_server.empty in
   ops_dir
 
 let rec insert_future_block (bi: Services.Blocks.block_info) = function
@@ -303,7 +303,7 @@ let list_blocks
       List.map
         (List.map (filter_bi include_ops))
         requested_blocks in
-    RPC.Answer.return infos
+    RPC_server.Answer.return infos
   else begin
     let (bi_stream, stopper) = Node.RPC.block_watcher node in
     let stream =
@@ -325,12 +325,12 @@ let list_blocks
           List.map (List.map (filter_bi include_ops)) requested_blocks in
         Lwt.return (Some infos)
       end in
-    RPC.Answer.return_stream { next ; shutdown }
+    RPC_server.Answer.return_stream { next ; shutdown }
   end
 
 let list_invalid node () =
   Node.RPC.list_invalid node >>= fun l ->
-  RPC.Answer.return l
+  RPC_server.Answer.return l
 
 let list_protocols node {Services.Protocols.monitor; contents} =
   let monitor = match monitor with None -> false | Some x -> x in
@@ -346,7 +346,7 @@ let list_protocols node {Services.Protocols.monitor; contents} =
          Lwt.return (hash, None))
     protocols >>= fun protocols ->
   if not monitor then
-    RPC.Answer.return protocols
+    RPC_server.Answer.return protocols
   else
     let stream, stopper = Node.RPC.protocol_watcher node in
     let shutdown () = Lwt_watcher.shutdown stopper in
@@ -361,19 +361,19 @@ let list_protocols node {Services.Protocols.monitor; contents} =
         first_request := false ;
         Lwt.return (Some protocols)
       end in
-    RPC.Answer.return_stream { next ; shutdown }
+    RPC_server.Answer.return_stream { next ; shutdown }
 
 let get_protocols node hash () =
   Node.RPC.protocol_content node hash >>= function
-  | Ok bytes -> RPC.Answer.return bytes
+  | Ok bytes -> RPC_server.Answer.return bytes
   | Error _ -> raise Not_found
 
 let build_rpc_directory node =
-  let dir = RPC.empty in
+  let dir = RPC_server.empty in
   let dir =
-    RPC.register0 dir Services.Blocks.list (list_blocks node) in
+    RPC_server.register0 dir Services.Blocks.list (list_blocks node) in
   let dir =
-    RPC.register0 dir Services.Blocks.list_invalid (list_invalid node) in
+    RPC_server.register0 dir Services.Blocks.list_invalid (list_invalid node) in
   let dir = register_bi_dir node dir in
   let dir =
     let implementation block =
@@ -381,21 +381,21 @@ let build_rpc_directory node =
           Node.RPC.context_dir node block >>= function
           | None -> Lwt.fail Not_found
           | Some context_dir -> Lwt.return context_dir)
-        (fun _ -> Lwt.return RPC.empty) in
+        (fun _ -> Lwt.return RPC_server.empty) in
-    RPC.register_dynamic_directory1
+    RPC_server.register_dynamic_directory1
       ~descr:
         "All the RPCs which are specific to the protocol version."
       dir Services.Blocks.proto_path implementation in
   let dir =
-    RPC.register0 dir Services.Protocols.list (list_protocols node) in
+    RPC_server.register0 dir Services.Protocols.list (list_protocols node) in
   let dir =
-    RPC.register1 dir Services.Protocols.contents (get_protocols node) in
+    RPC_server.register1 dir Services.Protocols.contents (get_protocols node) in
   let dir =
     let implementation header =
       let res =
         Data_encoding.Binary.to_bytes Block_header.encoding header in
-      RPC.Answer.return res in
+      RPC_server.Answer.return res in
-    RPC.register0 dir Services.forge_block_header implementation in
+    RPC_server.register0 dir Services.forge_block_header implementation in
   let dir =
     let implementation
         { Node_rpc_services.raw ; blocking ; force ; operations } =
@@ -404,88 +404,88 @@ let build_rpc_directory node =
           node ~force
           raw operations >>=? fun (hash, wait) ->
         (if blocking then wait else return ()) >>=? fun () -> return hash
-      end >>= RPC.Answer.return in
+      end >>= RPC_server.Answer.return in
-    RPC.register0 dir Services.inject_block implementation in
+    RPC_server.register0 dir Services.inject_block implementation in
   let dir =
     let implementation (contents, blocking, net_id, force) =
       Node.RPC.inject_operation
         node ?force ?net_id contents >>= fun (hash, wait) ->
       begin
         (if blocking then wait else return ()) >>=? fun () -> return hash
-      end >>= RPC.Answer.return in
+      end >>= RPC_server.Answer.return in
-    RPC.register0 dir Services.inject_operation implementation in
+    RPC_server.register0 dir Services.inject_operation implementation in
   let dir =
     let implementation (proto, blocking, force) =
       Node.RPC.inject_protocol ?force node proto >>= fun (hash, wait) ->
       begin
         (if blocking then wait else return ()) >>=? fun () -> return hash
-      end >>= RPC.Answer.return in
+      end >>= RPC_server.Answer.return in
-    RPC.register0 dir Services.inject_protocol implementation in
+    RPC_server.register0 dir Services.inject_protocol implementation in
   let dir =
     let implementation () =
-      RPC.Answer.return_stream (Node.RPC.bootstrapped node) in
+      RPC_server.Answer.return_stream (Node.RPC.bootstrapped node) in
-    RPC.register0 dir Services.bootstrapped implementation in
+    RPC_server.register0 dir Services.bootstrapped implementation in
   let dir =
     let implementation () =
-      RPC.Answer.return
+      RPC_server.Answer.return
         Data_encoding.Json.(schema Error_monad.error_encoding) in
-    RPC.register0 dir Services.Error.service implementation in
+    RPC_server.register0 dir Services.Error.service implementation in
   let dir =
-    RPC.register1 dir Services.complete
+    RPC_server.register1 dir Services.complete
       (fun s () ->
-         Node.RPC.complete node s >>= RPC.Answer.return) in
+         Node.RPC.complete node s >>= RPC_server.Answer.return) in
   let dir =
-    RPC.register2 dir Services.Blocks.complete
+    RPC_server.register2 dir Services.Blocks.complete
       (fun block s () ->
-         Node.RPC.complete node ~block s >>= RPC.Answer.return) in
+         Node.RPC.complete node ~block s >>= RPC_server.Answer.return) in
 
   (* Network : Global *)
 
   let dir =
     let implementation () =
-      Node.RPC.Network.stat node |> RPC.Answer.return in
+      Node.RPC.Network.stat node |> RPC_server.Answer.return in
-    RPC.register0 dir Services.Network.stat implementation in
+    RPC_server.register0 dir Services.Network.stat implementation in
   let dir =
     let implementation () =
-      RPC.Answer.return Distributed_db.Raw.supported_versions in
+      RPC_server.Answer.return Distributed_db.Raw.supported_versions in
-    RPC.register0 dir Services.Network.versions implementation in
+    RPC_server.register0 dir Services.Network.versions implementation in
   let dir =
     let implementation () =
       let stream, stopper = Node.RPC.Network.watch node in
       let shutdown () = Lwt_watcher.shutdown stopper in
       let next () = Lwt_stream.get stream in
-      RPC.Answer.return_stream { next ; shutdown } in
+      RPC_server.Answer.return_stream { next ; shutdown } in
-    RPC.register0 dir Services.Network.events implementation in
+    RPC_server.register0 dir Services.Network.events implementation in
   let dir =
     let implementation point timeout =
-      Node.RPC.Network.connect node point timeout >>= RPC.Answer.return in
+      Node.RPC.Network.connect node point timeout >>= RPC_server.Answer.return in
-    RPC.register1 dir Services.Network.connect implementation in
+    RPC_server.register1 dir Services.Network.connect implementation in
 
   (* Network : Connection *)
 
   let dir =
     let implementation peer_id () =
-      Node.RPC.Network.Connection.info node peer_id |> RPC.Answer.return in
+      Node.RPC.Network.Connection.info node peer_id |> RPC_server.Answer.return in
-    RPC.register1 dir Services.Network.Connection.info implementation in
+    RPC_server.register1 dir Services.Network.Connection.info implementation in
   let dir =
     let implementation peer_id wait =
-      Node.RPC.Network.Connection.kick node peer_id wait >>= RPC.Answer.return in
+      Node.RPC.Network.Connection.kick node peer_id wait >>= RPC_server.Answer.return in
-    RPC.register1 dir Services.Network.Connection.kick implementation in
+    RPC_server.register1 dir Services.Network.Connection.kick implementation in
   let dir =
     let implementation () =
-      Node.RPC.Network.Connection.list node |> RPC.Answer.return in
+      Node.RPC.Network.Connection.list node |> RPC_server.Answer.return in
-    RPC.register0 dir Services.Network.Connection.list implementation in
+    RPC_server.register0 dir Services.Network.Connection.list implementation in
 
   (* Network : Peer_id *)
 
   let dir =
     let implementation state =
-      Node.RPC.Network.Peer_id.list node state |> RPC.Answer.return in
+      Node.RPC.Network.Peer_id.list node ~restrict:state |> RPC_server.Answer.return in
-    RPC.register0 dir Services.Network.Peer_id.list implementation in
+    RPC_server.register0 dir Services.Network.Peer_id.list implementation in
   let dir =
     let implementation peer_id () =
-      Node.RPC.Network.Peer_id.info node peer_id |> RPC.Answer.return in
+      Node.RPC.Network.Peer_id.info node peer_id |> RPC_server.Answer.return in
-    RPC.register1 dir Services.Network.Peer_id.info implementation in
+    RPC_server.register1 dir Services.Network.Peer_id.info implementation in
   let dir =
     let implementation peer_id monitor =
       if monitor then
@@ -499,21 +499,21 @@ let build_rpc_directory node =
             first_request := false ;
             Lwt.return_some @@ Node.RPC.Network.Peer_id.events node peer_id
           end in
-        RPC.Answer.return_stream { next ; shutdown }
+        RPC_server.Answer.return_stream { next ; shutdown }
       else
-        Node.RPC.Network.Peer_id.events node peer_id |> RPC.Answer.return in
+        Node.RPC.Network.Peer_id.events node peer_id |> RPC_server.Answer.return in
-    RPC.register1 dir Services.Network.Peer_id.events implementation in
+    RPC_server.register1 dir Services.Network.Peer_id.events implementation in
 
   (* Network : Point *)
 
   let dir =
     let implementation state =
-      Node.RPC.Network.Point.list node state |> RPC.Answer.return in
+      Node.RPC.Network.Point.list node ~restrict:state |> RPC_server.Answer.return in
-    RPC.register0 dir Services.Network.Point.list implementation in
+    RPC_server.register0 dir Services.Network.Point.list implementation in
   let dir =
     let implementation point () =
-      Node.RPC.Network.Point.info node point |> RPC.Answer.return in
+      Node.RPC.Network.Point.info node point |> RPC_server.Answer.return in
-    RPC.register1 dir Services.Network.Point.info implementation in
+    RPC_server.register1 dir Services.Network.Point.info implementation in
   let dir =
     let implementation point monitor =
       if monitor then
@@ -527,10 +527,10 @@ let build_rpc_directory node =
             first_request := false ;
             Lwt.return_some @@ Node.RPC.Network.Point.events node point
           end in
-        RPC.Answer.return_stream { next ; shutdown }
+        RPC_server.Answer.return_stream { next ; shutdown }
       else
-        Node.RPC.Network.Point.events node point |> RPC.Answer.return in
+        Node.RPC.Network.Point.events node point |> RPC_server.Answer.return in
-    RPC.register1 dir Services.Network.Point.events implementation in
+    RPC_server.register1 dir Services.Network.Point.events implementation in
   let dir =
-    RPC.Directory.register_describe_directory_service dir Services.describe in
+    RPC_server.Directory.register_describe_directory_service dir Services.describe in
   dir

lib_node_shell/node_rpc.mli

@@ -7,4 +7,4 @@
 (*                                                                        *)
 (**************************************************************************)
 
-val build_rpc_directory: Node.t -> unit RPC.directory
+val build_rpc_directory: Node.t -> unit RPC_server.directory

lib_node_shell/prevalidation.ml

@@ -7,80 +7,7 @@
 (*                                                                        *)
 (**************************************************************************)
 
-
+open Preapply_result
-type 'error preapply_result = {
-  applied: (Operation_hash.t * Operation.t) list;
-  refused: (Operation.t * 'error list) Operation_hash.Map.t;
-  branch_refused: (Operation.t * 'error list) Operation_hash.Map.t;
-  branch_delayed: (Operation.t * 'error list) Operation_hash.Map.t;
-}
-
-let empty_result = {
-  applied = [] ;
-  refused = Operation_hash.Map.empty ;
-  branch_refused = Operation_hash.Map.empty ;
-  branch_delayed = Operation_hash.Map.empty ;
-}
-
-let map_result f r = {
-  applied = r.applied;
-  refused = Operation_hash.Map.map f r.refused ;
-  branch_refused = Operation_hash.Map.map f r.branch_refused ;
-  branch_delayed = Operation_hash.Map.map f r.branch_delayed ;
-}
-
-let preapply_result_encoding error_encoding =
-  let open Data_encoding in
-  let operation_encoding =
-    merge_objs
-      (obj1 (req "hash" Operation_hash.encoding))
-      (dynamic_size Operation.encoding) in
-  let refused_encoding =
-    merge_objs
-      (obj1 (req "hash" Operation_hash.encoding))
-      (merge_objs
-         (dynamic_size Operation.encoding)
-         (obj1 (req "error" error_encoding))) in
-  let build_list map = Operation_hash.Map.bindings map in
-  let build_map list =
-    List.fold_right
-      (fun (k, e) m -> Operation_hash.Map.add k e m)
-      list Operation_hash.Map.empty in
-  conv
-    (fun { applied ; refused ; branch_refused ; branch_delayed } ->
-       (applied, build_list refused,
-        build_list branch_refused, build_list branch_delayed))
-    (fun (applied, refused, branch_refused, branch_delayed) ->
-       let refused = build_map refused in
-       let branch_refused = build_map branch_refused in
-       let branch_delayed = build_map branch_delayed in
-       { applied ; refused ; branch_refused ; branch_delayed })
-    (obj4
-       (req "applied" (list operation_encoding))
-       (req "refused" (list refused_encoding))
-       (req "branch_refused" (list refused_encoding))
-       (req "branch_delayed" (list refused_encoding)))
-
-let preapply_result_operations t =
-  let ops =
-    List.fold_left
-      (fun acc (h, op) -> Operation_hash.Map.add h op acc)
-      Operation_hash.Map.empty t.applied in
-  let ops =
-    Operation_hash.Map.fold
-      (fun h (op, _err) acc -> Operation_hash.Map.add h op acc)
-      t.branch_delayed ops in
-  let ops =
-    Operation_hash.Map.fold
-      (fun h (op, _err) acc -> Operation_hash.Map.add h op acc)
-      t.branch_refused ops in
-  ops
-
-let empty_result =
-  { applied = [] ;
-    refused = Operation_hash.Map.empty ;
-    branch_refused = Operation_hash.Map.empty ;
-    branch_delayed = Operation_hash.Map.empty }
 
 let rec apply_operations apply_operation state r max_ops ~sort ops =
   Lwt_list.fold_left_s
@@ -235,7 +162,7 @@ let prevalidate
       Proto.apply_operation state parse_op in
   apply_operations
     apply_operation
-    state empty_result max_number_of_operations
+    state Preapply_result.empty max_number_of_operations
     ~sort sorted_ops >>= fun (state, max_number_of_operations, r) ->
   let r =
     { r with

lib_node_shell/prevalidation.mli

@@ -7,25 +7,6 @@
 (*                                                                        *)
 (**************************************************************************)
 
-type 'error preapply_result = {
-  applied: (Operation_hash.t * Operation.t) list;
-  refused: (Operation.t * 'error list) Operation_hash.Map.t;
-  (* e.g. invalid signature *)
-  branch_refused: (Operation.t * 'error list) Operation_hash.Map.t;
-  (* e.g. insufficent balance *)
-  branch_delayed: (Operation.t * 'error list) Operation_hash.Map.t;
-  (* e.g. timestamp in the future *)
-}
-
-val empty_result : 'error preapply_result
-
-val preapply_result_operations :
-  'error preapply_result -> Operation.t Operation_hash.Map.t
-
-val preapply_result_encoding :
-  'error list Data_encoding.t ->
-  'error preapply_result Data_encoding.t
-
 type prevalidation_state
 
 val start_prevalidation :
@@ -38,7 +19,7 @@ val start_prevalidation :
 val prevalidate :
   prevalidation_state -> sort:bool ->
   (Operation_hash.t * Operation.t) list ->
-  (prevalidation_state * error preapply_result) Lwt.t
+  (prevalidation_state * error Preapply_result.t) Lwt.t
 
 val end_prevalidation :
   prevalidation_state -> Updater.validation_result tzresult Lwt.t

lib_node_shell/prevalidator.ml

@@ -8,6 +8,7 @@
 (**************************************************************************)
 
 open Logging.Node.Prevalidator
+open Preapply_result
 
 let list_pendings ?maintain_net_db  ~from_block ~to_block old_mempool =
   let rec pop_blocks ancestor block mempool =
@@ -59,8 +60,8 @@ type t = {
   notify_operations: P2p.Peer_id.t -> Mempool.t -> unit ;
   prevalidate_operations:
     bool -> Operation.t list ->
-    (Operation_hash.t list * error preapply_result) tzresult Lwt.t ;
+    (Operation_hash.t list * error Preapply_result.t) tzresult Lwt.t ;
-  operations: unit -> error preapply_result * Operation.t Operation_hash.Map.t ;
+  operations: unit -> error Preapply_result.t * Operation.t Operation_hash.Map.t ;
   pending: ?block:State.Block.t -> unit -> Operation.t Operation_hash.Map.t Lwt.t ;
   timestamp: unit -> Time.t ;
   context: unit -> Updater.validation_result tzresult Lwt.t ;
@@ -95,7 +96,7 @@ let create
   let pending = Operation_hash.Table.create 53 in
   let head = ref head in
   let mempool = ref Mempool.empty in
-  let operations = ref empty_result in
+  let operations = ref Preapply_result.empty in
   let operation_count = ref 0 in (* unprocessed + operations/mempool *)
   Chain_traversal.live_blocks
     !head
@@ -171,7 +172,7 @@ let create
               Lwt.return (Ok state, r)
           | Error err ->
               let r =
-                { empty_result with
+                { Preapply_result.empty with
                   branch_delayed =
                     List.fold_left
                       (fun m (h, op) -> Operation_hash.Map.add h (op, err) m)
@@ -354,7 +355,7 @@ let create
                   list_pendings
                     ~maintain_net_db:net_db
                     ~from_block:!head ~to_block:new_head
-                    (preapply_result_operations !operations) >>= fun new_mempool ->
+                    (Preapply_result.operations !operations) >>= fun new_mempool ->
                   Chain_traversal.live_blocks
                     new_head
                     (State.Block.max_operations_ttl new_head)
@@ -365,7 +366,7 @@ let create
                   (* Reset the pre-validation context *)
                   head := new_head ;
                   mempool := Mempool.empty ;
-                  operations := empty_result ;
+                  operations := Preapply_result.empty ;
                   broadcast_unprocessed := false ;
                   unprocessed := new_mempool ;
                   operation_count := Operation_hash.Map.cardinal new_mempool ;
@@ -410,7 +411,7 @@ let create
     cancel () >>= fun () ->
     prevalidation_worker in
   let pending ?block () =
-    let ops = preapply_result_operations !operations in
+    let ops = Preapply_result.operations !operations in
     match block with
     | None -> Lwt.return ops
     | Some to_block -> list_pendings ~from_block:!head ~to_block ops in

lib_node_shell/prevalidator.mli

@@ -47,7 +47,7 @@ val inject_operation: t -> ?force:bool -> Operation.t -> unit tzresult Lwt.t
 
 val flush: t -> State.Block.t -> unit
 val timestamp: t -> Time.t
-val operations: t -> error Prevalidation.preapply_result * Operation.t Operation_hash.Map.t
+val operations: t -> error Preapply_result.t * Operation.t Operation_hash.Map.t
 val context: t -> Updater.validation_result tzresult Lwt.t
 
 val pending: ?block:State.Block.t -> t -> Operation.t Operation_hash.Map.t Lwt.t

lib_node_shell/state.mli

@@ -139,7 +139,7 @@ module Block : sig
 
   val context: t -> Context.t Lwt.t
   val protocol_hash: t -> Protocol_hash.t Lwt.t
-  val test_network: t -> Context.test_network Lwt.t
+  val test_network: t -> Test_network_status.t Lwt.t
 
   val operation_hashes:
     t -> int ->

lib_node_updater/jbuild

@@ -7,7 +7,9 @@
               tezos-micheline
               tezos-protocol-compiler
               tezos-storage
-              tezos-node-net
+              tezos-node-services
+              tezos-node-p2p-base
+              tezos-node-http
               dynlink))
   (flags (:standard -w -9+27-30-32-40@8
                     -safe-string
@@ -15,7 +17,9 @@
                     -open Tezos_micheline
                     -open Tezos_protocol_compiler
                     -open Tezos_storage
-                    -open Tezos_node_net))))
+                    -open Tezos_node_services
+                    -open Tezos_node_http
+                    -open Tezos_node_p2p_base))))
 
 (alias
  ((name runtest_indent)

lib_node_updater/tezos_protocol_environment.ml

@@ -56,7 +56,10 @@ module Make(Param : sig val name: string end)() = struct
     module Block_header = Block_header
     module Protocol = Protocol
   end
-  module RPC = RPC
+  module RPC = struct
+    include RPC
+    include RPC_server
+  end
   module Micheline = Tezos_micheline.Micheline
   module Fitness = Fitness
   module Error_monad = struct

lib_node_updater/updater.ml

@@ -137,7 +137,7 @@ module Node_protocol_environment_sigs = struct
        and type Tezos_data.Operation.t = Operation.t
        and type Tezos_data.Block_header.shell_header = Block_header.shell_header
        and type Tezos_data.Block_header.t = Block_header.t
-       and type 'a RPC.Directory.t = 'a RPC.Directory.t
+       and type 'a RPC.Directory.t = 'a RPC_server.Directory.t
        and type Updater.validation_result = validation_result
        and type Updater.rpc_context = rpc_context
 
@@ -182,7 +182,7 @@ module type RAW_PROTOCOL = sig
     validation_state -> operation -> validation_state tzresult Lwt.t
   val finalize_block:
     validation_state -> validation_result tzresult Lwt.t
-  val rpc_services: rpc_context RPC.directory
+  val rpc_services: rpc_context RPC_server.directory
   val configure_sandbox:
     Context.t -> Data_encoding.json option -> Context.t tzresult Lwt.t
 end

lib_node_updater/updater.mli

@@ -68,7 +68,7 @@ module type RAW_PROTOCOL = sig
     validation_state -> operation -> validation_state tzresult Lwt.t
   val finalize_block:
     validation_state -> validation_result tzresult Lwt.t
-  val rpc_services: rpc_context RPC.directory
+  val rpc_services: rpc_context RPC_server.directory
   val configure_sandbox:
     Context.t -> Data_encoding.json option -> Context.t tzresult Lwt.t
 end
@@ -99,7 +99,7 @@ module Node_protocol_environment_sigs : sig
        and type Tezos_data.Operation.t = Operation.t
        and type Tezos_data.Block_header.shell_header = Block_header.shell_header
        and type Tezos_data.Block_header.t = Block_header.t
-       and type 'a RPC.Directory.t = 'a RPC.Directory.t
+       and type 'a RPC.Directory.t = 'a RPC_server.Directory.t
        and type Updater.validation_result = validation_result
        and type Updater.rpc_context = rpc_context
 

lib_storage/context.ml

@@ -177,83 +177,17 @@ let get_protocol v =
 let set_protocol v key =
   raw_set v current_protocol_key (Protocol_hash.to_bytes key)
 
-type test_network =
-  | Not_running
-  | Forking of {
-      protocol: Protocol_hash.t ;
-      expiration: Time.t ;
-    }
-  | Running of {
-      net_id: Net_id.t ;
-      genesis: Block_hash.t ;
-      protocol: Protocol_hash.t ;
-      expiration: Time.t ;
-    }
-
-let pp_test_network ppf = function
-  | Not_running -> Format.fprintf ppf "@[<v 2>Not running@]"
-  | Forking { protocol ; expiration } ->
-      Format.fprintf ppf
-        "@[<v 2>Forking %a (expires %a)@]"
-        Protocol_hash.pp
-        protocol
-        Time.pp_hum
-        expiration
-  | Running { net_id ; genesis ; protocol ; expiration } ->
-      Format.fprintf ppf
-        "@[<v 2>Running %a\
-         @ Genesis: %a\
-         @ Net id: %a\
-         @ Expiration: %a@]"
-        Protocol_hash.pp protocol
-        Block_hash.pp genesis
-        Net_id.pp net_id
-        Time.pp_hum expiration
-
-let test_network_encoding =
-  let open Data_encoding in
-  union [
-    case ~tag:0
-      (obj1 (req "status" (constant "not_running")))
-      (function Not_running -> Some () | _ -> None)
-      (fun () -> Not_running) ;
-    case ~tag:1
-      (obj3
-         (req "status" (constant "forking"))
-         (req "protocol" Protocol_hash.encoding)
-         (req "expiration" Time.encoding))
-      (function
-        | Forking { protocol ; expiration } ->
-            Some ((), protocol, expiration)
-        | _ -> None)
-      (fun ((), protocol, expiration) ->
-         Forking { protocol ; expiration }) ;
-    case ~tag:2
-      (obj5
-         (req "status" (constant "running"))
-         (req "net_id" Net_id.encoding)
-         (req "genesis" Block_hash.encoding)
-         (req "protocol" Protocol_hash.encoding)
-         (req "expiration" Time.encoding))
-      (function
-        | Running { net_id ; genesis ; protocol ; expiration } ->
-            Some ((), net_id, genesis, protocol, expiration)
-        | _ -> None)
-      (fun ((), net_id, genesis, protocol, expiration) ->
-         Running { net_id ; genesis ; protocol ; expiration }) ;
-  ]
-
 let get_test_network v =
   raw_get v current_test_network_key >>= function
   | None -> Lwt.fail (Failure "Unexpected error (Context.get_test_network)")
   | Some data ->
-      match Data_encoding.Binary.of_bytes test_network_encoding data with
+      match Data_encoding.Binary.of_bytes Test_network_status.encoding data with
       | None -> Lwt.fail (Failure "Unexpected error (Context.get_test_network)")
       | Some r -> Lwt.return r
 
 let set_test_network v id =
   raw_set v current_test_network_key
-    (Data_encoding.Binary.to_bytes test_network_encoding id)
+    (Data_encoding.Binary.to_bytes Test_network_status.encoding id)
 let del_test_network v  = raw_del v current_test_network_key
 
 let fork_test_network v ~protocol ~expiration =

lib_storage/context.mli

@@ -77,25 +77,9 @@ val set_master: index -> commit -> unit Lwt.t
 val get_protocol: context -> Protocol_hash.t Lwt.t
 val set_protocol: context -> Protocol_hash.t -> context Lwt.t
 
-type test_network =
+val get_test_network: context -> Test_network_status.t Lwt.t
-  | Not_running
+val set_test_network: context -> Test_network_status.t -> context Lwt.t
-  | Forking of {
-      protocol: Protocol_hash.t ;
-      expiration: Time.t ;
-    }
-  | Running of {
-      net_id: Net_id.t ;
-      genesis: Block_hash.t ;
-      protocol: Protocol_hash.t ;
-      expiration: Time.t ;
-    }
 
-val pp_test_network : Format.formatter -> test_network -> unit
-
-val test_network_encoding: test_network Data_encoding.t
-
-val get_test_network: context -> test_network Lwt.t
-val set_test_network: context -> test_network -> context Lwt.t
 val del_test_network: context -> context Lwt.t
 
 val reset_test_network: context -> Block_hash.t -> Time.t -> context Lwt.t

test/p2p/jbuild

@@ -5,13 +5,16 @@
           test_p2p_connection_pool
           test_p2p_io_scheduler))
   (libraries (tezos-base
-              tezos-node-net
+              tezos-node-p2p-base
+              tezos-node-p2p
+              lwt.unix
               test_lib))
   (flags (:standard -w -9-32
                     -linkall
                     -safe-string
                     -open Tezos_base__TzPervasives
-                    -open Tezos_node_net))))
+                    -open Tezos_node_p2p_base
+                    -open Tezos_node_p2p))))
 
 (alias
  ((name buildtest)