P2p: refactor the mli

src/Makefile

@@ -231,7 +231,6 @@ NODE_LIB_INTFS := \
   node/shell/prevalidator.mli \
   node/shell/validator.mli \
   \
-  node/shell/messages.mli \
   node/shell/discoverer.mli \
   node/shell/node_rpc_services.mli \
   node/shell/node.mli \
@@ -257,9 +256,10 @@ NODE_LIB_IMPLS := \
   node/updater/proto_environment.ml \
   node/updater/register.ml \
   \
+  node/shell/messages.ml \
+  node/shell/netparams.ml \
   node/shell/state.ml \
   \
-  node/shell/messages.ml \
   node/shell/prevalidator.ml \
   node/shell/validator.ml \
   \

src/node/net/p2p.mli

@@ -7,35 +7,27 @@
 (*                                                                        *)
 (**************************************************************************)
 
-(** A P2P network *)
-type net
-
-(** A faked p2p layer, which do not initiate any connection
-    nor open any listening socket. *)
-val faked_network : net
-
 (** A peer connection address *)
 type addr = Ipaddr.t
 
 (** A peer connection port *)
 type port = int
 
-(** A protocol version tag: (name, major, minor) *)
+(** A p2p protocol version *)
-type version = string * int * int
+type version = {
+  name : string ;
+  major : int ;
+  minor : int ;
+}
 
 (** Network configuration *)
 type config = {
   (** Tells if incoming connections accepted, precising the TCP port
-  on which the peer can be reached *)
+      on which the peer can be reached *)
   incoming_port : port option ;
   (** Tells if peers should be discovered automatically on the local
-  network, precising the UDP port to use *)
+      network, precising the UDP port to use *)
   discovery_port : port option ;
-  (** High level protocol(s) talked by the peer. When two peers
-      initiate a connection, they exchange their list of supported
-      versions. The chosen one, if any, is the maximum common one (in
-      lexicographic order) *)
-  supported_versions : version list ;
   (** List of hard-coded known peers to bootstrap the network from *)
   known_peers : (addr * port) list ;
   (** The path to the JSON file where the peer cache is loaded / stored *)
@@ -47,7 +39,7 @@ type config = {
 
 (** Network capacities *)
 type limits = {
-  (** Maximum length in bytes of network frames *)
+  (** Maximum length in bytes of network messages' payload *)
   max_packet_size : int ;
   (** Delay after which a non responding peer is considered dead *)
   peer_answer_timeout : float ;
@@ -61,42 +53,94 @@ type limits = {
   blacklist_time : float ;
 }
 
-(** Main network initialisation function *)
+type 'msg msg_encoding = Encoding : {
-val bootstrap : config -> limits -> net Lwt.t
+    tag: int ;
+    encoding: 'a Data_encoding.t ;
+    wrap: 'a -> 'msg ;
+    unwrap: 'msg -> 'a option ;
+    max_length: int option ;
+  } -> 'msg msg_encoding
 
-(** A maintenance operation : try and reach the ideal number of peers *)
+module type NET_PARAMS = sig
-val maintain : net -> unit Lwt.t
+  type meta (** Type of metadata associated to an identity *)
+  type msg (** Type of message used by higher layers *)
 
-(** Voluntarily drop some peers and replace them by new buddies *)
+  val msg_encodings : msg msg_encoding list
-val roll : net -> unit Lwt.t
 
-(** Close all connections properly *)
+  val init_meta : meta
-val shutdown : net -> unit Lwt.t
+  val score_enc : meta Data_encoding.t
+  val score: meta -> float
 
-(** A connection to a peer *)
+  (** High level protocol(s) talked by the peer. When two peers
-type peer
+      initiate a connection, they exchange their list of supported
+      versions. The chosen one, if any, is the maximum common one (in
+      lexicographic order) *)
+  val supported_versions : version list
+end
 
-(** Access the domain of active peers *)
+module Make (P : NET_PARAMS) : sig
-val peers : net -> peer list
+  type net
 
-(** Access the info of an active peer, if available *)
+  (** A faked p2p layer, which do not initiate any connection
-val peer_info : peer -> net -> addr * port * version
+      nor open any listening socket. *)
+  val faked_network : net
 
-(** Wait for a Netbits.frame from any peer in the network *)
+  (** Main network initialisation function *)
-val recv : net -> (peer * Netbits.frame) Lwt.t
+  val bootstrap : config:config -> limits:limits -> net Lwt.t
 
-(** Send a Netbits.frame to a peer and wait for it to be in the tube *)
+  (** A maintenance operation : try and reach the ideal number of peers *)
-val send : peer * Netbits.frame -> net -> unit Lwt.t
+  val maintain : net -> unit Lwt.t
 
-(** Send a Netbits.frame to a peer asynchronously *)
+  (** Voluntarily drop some peers and replace them by new buddies *)
-val push : peer * Netbits.frame -> net -> unit
+  val roll : net -> unit Lwt.t
 
-(** Send a Netbits.frame to all peers *)
+  (** Close all connections properly *)
-val broadcast : Netbits.frame -> net -> unit
+  val shutdown : net -> unit Lwt.t
 
-(** Shutdown the connection to all peers at this address and stop the
+  (** A connection to a peer *)
-    communications with this machine for [duration] seconds *)
+  type peer
-val blacklist : ?duration:float -> addr -> net -> unit
 
-(** Keep a connection to this pair as often as possible *)
+  (** A global identifier for a peer, a.k.a. an identity *)
-val whitelist : peer -> net -> unit
+  type gid
+
+  (** Access the domain of active peers *)
+  val peers : net -> peer list
+
+  (** Return the active peer with identity [gid] *)
+  val find_peer : net -> gid -> peer option
+
+  type peer_info = {
+    gid : gid;
+    addr : addr;
+    port : port;
+    version : version;
+  }
+
+  (** Access the info of an active peer, if available *)
+  val peer_info : net -> peer -> peer_info
+
+  (** Accessors for meta information about a peer *)
+  val get_meta : net -> gid -> P.meta option
+  val set_meta : net -> gid -> P.meta -> unit
+
+  (** Wait for a payload from any peer in the network *)
+  val recv : net -> (peer * P.msg) Lwt.t
+
+  (** Send a payload to a peer and wait for it to be in the tube *)
+  val send : net -> peer -> P.msg -> unit Lwt.t
+
+  (** Send a payload to a peer without waiting for the result. Return
+      [true] if the message can be enqueued in the peer's output queue
+      or [false] otherwise. *)
+  val try_send : net -> peer -> P.msg -> bool
+
+  (** Send a payload to all peers *)
+  val broadcast : net -> P.msg -> unit
+
+  (** Shutdown the connection to all peers at this address and stop the
+      communications with this machine for [duration] seconds *)
+  val blacklist : net -> gid -> unit
+
+  (** Keep a connection to this pair as often as possible *)
+  val whitelist : net -> gid -> unit
+end

src/node/shell/discoverer.ml

@@ -7,6 +7,8 @@
 (*                                                                        *)
 (**************************************************************************)
 
+module P2p = Netparams
+
 type worker = {
   shutdown: unit -> unit Lwt.t;
 }
@@ -15,7 +17,7 @@ let create_worker p2p state =
 
   let cancelation, cancel, _on_cancel = Lwt_utils.canceler () in
 
-  let broadcast m = P2p.broadcast (Messages.to_frame m) p2p in
+  let broadcast m = P2p.broadcast p2p m in
 
   let discovery_worker =
     let rec worker_loop () =

src/node/shell/discoverer.mli

@@ -9,6 +9,6 @@
 
 type worker
 
-val create_worker: P2p.net -> State.t -> worker
+val create_worker: Netparams.net -> State.t -> worker
 
 val shutdown: worker -> unit Lwt.t

src/node/shell/messages.ml

@@ -7,11 +7,9 @@
 (*                                                                        *)
 (**************************************************************************)
 
-open Netbits
-
 type net_id = Store.net_id
 
-type message =
+type t =
 
   | Discover_blocks of net_id * Block_hash.t list (* Block locator *)
   | Block_inventory of net_id * Block_hash.t list
@@ -28,65 +26,53 @@ type message =
   | Get_protocols of Protocol_hash.t list
   | Protocol of MBytes.t
 
+let encoding =
+  let open Data_encoding in
+  let case ?max_length ~tag encoding unwrap wrap =
+    P2p.Encoding { tag; encoding; wrap; unwrap; max_length }
+  in [
+    case ~tag:0x10 (tup2 Block_hash.encoding (list Block_hash.encoding))
+      (function
+        | Discover_blocks (Net genesis_bh, bhs) -> Some (genesis_bh, bhs)
+        | _ -> None)
+      (fun (genesis_bh, bhs) -> Discover_blocks (Net genesis_bh, bhs));
+    case ~tag:0x11 (tup2 Block_hash.encoding (list Block_hash.encoding))
+      (function
+        | Block_inventory (Net genesis_bh, bhs) -> Some (genesis_bh, bhs)
+        | _ -> None)
+      (fun (genesis_bh, bhs) -> Block_inventory (Net genesis_bh, bhs));
 
-let to_frame msg =
+    case ~tag:0x12 (list Block_hash.encoding)
+      (function
+        | Get_blocks bhs -> Some bhs
+        | _ -> None)
+      (fun bhs -> Get_blocks bhs);
+    case ~tag:0x13 Data_encoding.bytes
+      (function Block b -> Some b  | _ -> None)
+      (fun b -> Block b);
 
-  let bh h = B (Block_hash.to_bytes h) in
+    case ~tag:0x20 Block_hash.encoding
-  let oph h = B (Operation_hash.to_bytes h) in
+      (function Current_operations (Net genesis_bh) -> Some genesis_bh | _ -> None)
-  let ph h = B (Protocol_hash.to_bytes h) in
+      (fun genesis_bh -> Current_operations (Net genesis_bh));
-  match msg with
+    case ~tag:0x21 (tup2 Block_hash.encoding (list Operation_hash.encoding))
+      (function Operation_inventory ((Net genesis_bh), ops) -> Some (genesis_bh, ops) | _ -> None)
+      (fun (genesis_bh, ops) -> Operation_inventory (Net genesis_bh, ops));
 
-  | Discover_blocks (Net netid, blocks) ->
+    case ~tag:0x22 (list Operation_hash.encoding)
-      [ S 2100 ; bh netid ; F (List.map bh blocks) ]
+      (function
-  | Block_inventory (Net netid, blocks) ->
+        | Get_operations ops -> Some ops
-      [ S 2101 ; bh netid ; F (List.map bh blocks) ]
+        | _ -> None)
-  | Get_blocks blocks ->
+      (fun ops -> Get_operations ops);
-      [ S 2102 ; F (List.map bh blocks) ]
+    case ~tag:0x23 Data_encoding.bytes
-  | Block b ->
+      (function Operation o -> Some o  | _ -> None)
-      [ S 2103 ; B b ]
+      (fun o -> Operation o);
-
-  | Current_operations (Net net_id) ->
-      [ S 2700 ; bh net_id ]
-  | Operation_inventory (Net net_id, ops) ->
-      [ S 2701 ; bh net_id ; F (List.map oph ops) ]
-  | Get_operations ops ->
-      [ S 2702 ; F (List.map oph ops) ]
-  | Operation b ->
-      [ S 2703 ; B b ]
-
-  | Get_protocols protos ->
-      [ S 2800 ; F (List.map ph protos) ]
-  | Protocol p ->
-      [ S 2801 ; B p ]
-
-let from_frame msg =
-
-  let bh = function B s -> (Block_hash.of_bytes s) | _ -> invalid_arg "bh" in
-  let oph = function B s -> (Operation_hash.of_bytes s) | _ -> invalid_arg "oph" in
-  let ph = function B s -> (Protocol_hash.of_bytes s) | _ -> invalid_arg "ph" in
-  let net = function netid -> Store.Net (Block_hash.of_bytes netid) in
-  try match msg with
-
-    | [ S 2100 ; B netid ; F blocks ] ->
-        Some (Discover_blocks (net netid, List.map bh blocks))
-    | [ S 2101 ; B netid ; F blocks ] ->
-        Some (Block_inventory (net netid, List.map bh blocks))
-    | [ S 2102 ; F blocks ] ->
-        Some (Get_blocks (List.map bh blocks))
-    | [ S 2103 ; B bh ] -> Some (Block bh)
-    | [ S 2700 ; B netid ] ->
-        Some (Current_operations (net netid))
-    | [ S 2701 ; B netid ; F ops ] ->
-        Some (Operation_inventory (net netid, List.map oph ops))
-    | [ S 2702 ; F ops ] ->
-        Some (Get_operations (List.map oph ops))
-    | [ S 2703 ; B contents ] -> Some (Operation contents)
-
-    | [ S 2800 ; F protos ] -> Some (Get_protocols (List.map ph protos))
-
-    | [ S 2801 ; B contents ] -> Some (Protocol contents)
-
-    | _ -> None
-
-  with Invalid_argument _ -> None
 
+    case ~tag:0x32 (list Protocol_hash.encoding)
+      (function
+        | Get_protocols protos -> Some protos
+        | _ -> None)
+      (fun protos -> Get_protocols protos);
+    case ~tag:0x33 Data_encoding.bytes
+      (function Protocol proto -> Some proto  | _ -> None)
+      (fun proto -> Protocol proto);
+]

src/node/shell/messages.mli

@@ -8,7 +8,7 @@
 (**************************************************************************)
 
 (** High level messages *)
-type message =
+type t =
 
   | Discover_blocks of Store.net_id * Block_hash.t list (* Block locator *)
   | Block_inventory of Store.net_id * Block_hash.t list
@@ -25,9 +25,4 @@ type message =
   | Get_protocols of Protocol_hash.t list
   | Protocol of MBytes.t
 
-
+val encoding : t P2p.msg_encoding list
-(** Converts a high level message to a network frame *)
-val to_frame: message -> Netbits.frame
-
-(** Tries and convert a network frame to a high level message *)
-val from_frame: Netbits.frame -> message option

src/node/shell/node.ml

@@ -7,12 +7,12 @@
 (*                                                                        *)
 (**************************************************************************)
 
+module P2p = Netparams
+
 open Logging.Node.Worker
 
 let (>|=) = Lwt.(>|=)
 
-let supported_versions = ["TEZOS", 0, 0]
-
 let inject_operation validator ?force bytes =
   let t =
     match Store.Operation.of_bytes bytes with
@@ -194,18 +194,17 @@ type t = {
 let request_operations net _net_id operations =
   (* TODO improve the lookup strategy.
           For now simply broadcast the request to all our neighbours. *)
-  P2p.broadcast
+  P2p.broadcast net (Get_operations operations)
-    (Messages.(to_frame (Get_operations operations))) net
 
 let request_blocks net _net_id blocks =
   (* TODO improve the lookup strategy.
           For now simply broadcast the request to all our neighbours. *)
-  P2p.broadcast (Messages.(to_frame (Get_blocks blocks))) net
+  P2p.broadcast net (Get_blocks blocks)
 
 let request_protocols net protocols =
   (* TODO improve the lookup strategy.
           For now simply broadcast the request to all our neighbours. *)
-  P2p.broadcast (Messages.(to_frame (Get_protocols protocols))) net
+  P2p.broadcast net (Get_protocols protocols)
 
 let init_p2p net_params =
   match net_params with
@@ -244,21 +243,12 @@ let create
 
   lwt_log_info "starting worker..." >>= fun () ->
   let worker =
-    let handle_msg peer frame =
+    let handle_msg peer msg =
-      lwt_log_info "received message" >>= fun () ->
+      process state validator msg >>= fun msgs ->
-      match Messages.from_frame frame with
+      List.iter
-      | None ->
+        (fun msg -> ignore @@ P2p.try_send p2p peer msg)
-          lwt_warn "can't parse message" >>= fun () ->
+        msgs;
-          (* FIXME 60 second ? parameter... and Log_notice *)
+      Lwt.return_unit
-          let addr, _, _ = P2p.peer_info peer p2p in
-          P2p.blacklist ~duration:60. addr p2p ;
-          Lwt.return_unit
-      | Some msg ->
-          process state validator msg >>= fun msgs ->
-          List.iter
-            (fun msg -> P2p.push (peer, Messages.to_frame msg) p2p)
-            msgs;
-          Lwt.return_unit
     in
     let rec worker_loop () =
       P2p.recv p2p >>= fun (peer, msg) ->

src/node/shell/node.mli

@@ -9,8 +9,6 @@
 
 type t
 
-val supported_versions: P2p.version list
-
 val create:
   genesis:Store.genesis ->
   store_root:string ->

src/node/shell/prevalidator.ml

@@ -7,6 +7,8 @@
 (*                                                                        *)
 (**************************************************************************)
 
+module P2p = Netparams
+
 open Logging.Node.Prevalidator
 
 let preapply
@@ -95,9 +97,7 @@ let create p2p net =
     Lwt.return_unit in
 
   let broadcast_operation ops =
-    P2p.broadcast
+    P2p.broadcast p2p (Operation_inventory (State.Net.id net, ops)) in
-      Messages.(to_frame @@ Operation_inventory (State.Net.id net, ops))
-      p2p in
 
   let handle_unprocessed () =
     if Operation_hash_set.is_empty !unprocessed then

src/node/shell/prevalidator.mli

@@ -26,6 +26,8 @@
 
 *)
 
+module P2p = Netparams
+
 type t
 
 (** Creation and destruction of a "prevalidation" worker. *)

src/node/shell/validator.ml

@@ -7,6 +7,8 @@
 (*                                                                        *)
 (**************************************************************************)
 
+module P2p = Netparams
+
 open Logging.Node.Validator
 
 type worker = {
@@ -43,7 +45,7 @@ let test_validator w = w.test_validator ()
 let fetch_block v = v.fetch_block
 let prevalidator v = v.prevalidator
 
-let broadcast w m = P2p.broadcast (Messages.to_frame m) w.p2p
+let broadcast w m = P2p.broadcast w.p2p m
 
 (** Current block computation *)
 

src/node/shell/validator.mli

@@ -9,6 +9,8 @@
 
 type worker
 
+module P2p = Netparams
+
 val create_worker: P2p.net -> State.t -> worker
 val shutdown: worker -> unit Lwt.t
 

src/node_main.ml

@@ -288,7 +288,6 @@ let init_node () =
           { incoming_port = Globals.incoming_port#get ;
             discovery_port =
               if Globals.discovery_port#get then Some 7732 else None ;
-            supported_versions = Node.supported_versions ;
             known_peers = Globals.bootstrap_peers#get ;
             peers_file = Globals.peers_file#get ;
             closed_network = Globals.closed_network#get }