ligo/src/lib_base/p2p_connection.ml

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

type peer_id = Crypto_box.Public_key_hash.t
let peer_id_encoding = Crypto_box.Public_key_hash.encoding
let peer_id_pp = Crypto_box.Public_key_hash.pp

module Id = struct

  (* A net point (address x port). *)
  type t = P2p_addr.t * P2p_addr.port option
  let compare (a1, p1) (a2, p2) =
    match Ipaddr.V6.compare a1 a2 with
    | 0 -> Pervasives.compare p1 p2
    | x -> x
  let equal p1 p2 = compare p1 p2 = 0
  let hash = Hashtbl.hash
  let pp ppf (addr, port) =
    match port with
    | None ->
        Format.fprintf ppf "[%a]:??" Ipaddr.V6.pp_hum addr
    | Some port ->
        Format.fprintf ppf "[%a]:%d" Ipaddr.V6.pp_hum addr port
  let pp_opt ppf = function
    | None -> Format.pp_print_string ppf "none"
    | Some point -> pp ppf point
  let to_string t = Format.asprintf "%a" pp t

  let is_local (addr, _) = Ipaddr.V6.is_private addr
  let is_global (addr, _) = not @@ Ipaddr.V6.is_private addr

  let of_point (addr, port) = addr, Some port
  let to_point = function
    | _, None -> None
    | addr, Some port -> Some (addr, port)
  let to_point_exn = function
    | _, None -> invalid_arg "to_point_exn"
    | addr, Some port -> addr, port

  let encoding =
    let open Data_encoding in
    (obj2
       (req "addr" P2p_addr.encoding)
       (opt "port" uint16))

end

module Map = Map.Make (Id)
module Set = Set.Make (Id)
module Table = Hashtbl.Make (Id)

module Info = struct

  type t = {
    incoming : bool;
    peer_id : peer_id;
    id_point : Id.t;
    remote_socket_port : P2p_addr.port;
    versions : P2p_version.t list ;
  }

  let encoding =
    let open Data_encoding in
    conv
      (fun { incoming ; peer_id ; id_point ; remote_socket_port ; versions } ->
         (incoming, peer_id, id_point, remote_socket_port, versions))
      (fun (incoming, peer_id, id_point, remote_socket_port, versions) ->
         { incoming ; peer_id ; id_point ; remote_socket_port ; versions })
      (obj5
         (req "incoming" bool)
         (req "peer_id" peer_id_encoding)
         (req "id_point" Id.encoding)
         (req "remote_socket_port" uint16)
         (req "versions" (list P2p_version.encoding)))

  let pp ppf
      { incoming ; id_point = (remote_addr, remote_port) ;
        remote_socket_port ; peer_id ; versions } =
    let version = List.hd versions in
    let point = match remote_port with
      | None -> remote_addr, remote_socket_port
      | Some port -> remote_addr, port in
    Format.fprintf ppf "%s %a %a (%a)"
      (if incoming then "↘" else "↗")
      peer_id_pp peer_id
      P2p_point.Id.pp point
      P2p_version.pp version

end

module Pool_event = struct

  (** Pool-level events *)

  type t =

    | Too_few_connections
    | Too_many_connections

    | New_point of P2p_point.Id.t
    | New_peer of peer_id

    | Gc_points
    | Gc_peer_ids

    | Incoming_connection of P2p_point.Id.t
    | Outgoing_connection of P2p_point.Id.t
    | Authentication_failed of P2p_point.Id.t
    | Accepting_request of P2p_point.Id.t * Id.t * peer_id
    | Rejecting_request of P2p_point.Id.t * Id.t * peer_id
    | Request_rejected of P2p_point.Id.t * (Id.t * peer_id) option
    | Connection_established of Id.t * peer_id

    | Swap_request_received of { source : peer_id }
    | Swap_ack_received of { source : peer_id }
    | Swap_request_sent of { source : peer_id }
    | Swap_ack_sent of { source : peer_id }
    | Swap_request_ignored of { source : peer_id }
    | Swap_success of { source : peer_id }
    | Swap_failure of { source : peer_id }

    | Disconnection of peer_id
    | External_disconnection of peer_id

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

end