Merge pull request #463 from hannesm/no-mirage-protocols

move Mirage_protocols and Mirage_stack into tcpip directly

CHANGES.md

@@ -1,3 +1,14 @@
+### v7.0.0 (2021-12-10)
+
+* Fix memory leak in processing RST packets (#460 @balrajsingh, reported in
+  #456 by @dinosaure)
+* Move module types (IP, UDP, TCP, STACK, ICMP) into tcpip core library
+  (#463 @hannesm)
+* API breakage: Tcpip_checksum is now part of tcpip.checksum (used to be
+  part of tcpip #463 @hannesm)
+* API breakage: tcpip.unix has been removed (#463 @hannesm)
+* Use Lwt.pause instead of deprecated Lwt_{unix,main}.yield (#461 @dinosaure)
+
 ### v6.4.0 (2021-11-11)
 
 * Adapt to mirage-protocols 6.0.0 API (#457 @hannesm)

src/core/dune

@@ -0,0 +1,6 @@
+(library
+ (name tcpip)
+ (public_name tcpip)
+ (instrumentation
+  (backend bisect_ppx))
+ (libraries cstruct lwt fmt ipaddr mirage-flow duration))

src/core/ip.ml

@@ -0,0 +1,34 @@
+type error = [
+  | `No_route of string (** can't send a message to that destination *)
+  | `Would_fragment
+]
+let pp_error ppf = function
+  | `No_route s -> Fmt.pf ppf "no route to destination: %s" s
+  | `Would_fragment -> Fmt.string ppf "would fragment"
+
+type proto = [ `TCP | `UDP | `ICMP ]
+let pp_proto ppf = function
+  | `TCP -> Fmt.string ppf "TCP"
+  | `UDP -> Fmt.string ppf "UDP"
+  | `ICMP -> Fmt.string ppf "ICMP"
+
+module type S = sig
+  type nonrec error = private [> error]
+  val pp_error: error Fmt.t
+  type ipaddr
+  val pp_ipaddr : ipaddr Fmt.t
+  type t
+  val disconnect : t -> unit Lwt.t
+  type callback = src:ipaddr -> dst:ipaddr -> Cstruct.t -> unit Lwt.t
+  val input:
+    t ->
+    tcp:callback -> udp:callback -> default:(proto:int -> callback) ->
+    Cstruct.t -> unit Lwt.t
+  val write: t -> ?fragment:bool -> ?ttl:int ->
+    ?src:ipaddr -> ipaddr -> proto -> ?size:int -> (Cstruct.t -> int) ->
+    Cstruct.t list -> (unit, error) result Lwt.t
+  val pseudoheader : t -> ?src:ipaddr -> ipaddr -> proto -> int -> Cstruct.t
+  val src: t -> dst:ipaddr -> ipaddr
+  val get_ip: t -> ipaddr list
+  val mtu: t -> dst:ipaddr -> int
+end

src/core/ip.mli

@@ -0,0 +1,86 @@
+(** {2 IP layer} *)
+
+(** IP errors and protocols. *)
+type error = [
+  | `No_route of string (** can't send a message to that destination *)
+  | `Would_fragment (** would need to fragment, but fragmentation is disabled *)
+]
+
+val pp_error : error Fmt.t
+
+type proto = [ `TCP | `UDP | `ICMP ]
+val pp_proto: proto Fmt.t
+
+(** An Internet Protocol (IP) layer reassembles IP fragments into packets,
+   removes the IP header, and on the sending side fragments overlong payload
+   and inserts IP headers. *)
+module type S = sig
+
+  type nonrec error = private [> error]
+  (** The type for IP errors. *)
+
+  val pp_error: error Fmt.t
+  (** [pp_error] is the pretty-printer for errors. *)
+
+  type ipaddr
+  (** The type for IP addresses. *)
+
+  val pp_ipaddr : ipaddr Fmt.t
+  (** [pp_ipaddr] is the pretty-printer for IP addresses. *)
+
+  type t
+  (** The type representing the internal state of the IP layer. *)
+
+  val disconnect: t -> unit Lwt.t
+  (** Disconnect from the IP layer. While this might take some time to
+      complete, it can never result in an error. *)
+
+  type callback = src:ipaddr -> dst:ipaddr -> Cstruct.t -> unit Lwt.t
+  (** An input continuation used by the parsing functions to pass on
+      an input packet down the stack.
+
+      [callback ~src ~dst buf] will be called with [src] and [dst]
+      containing the source and destination IP address respectively,
+      and [buf] will be a buffer pointing at the start of the IP
+      payload. *)
+
+  val input:
+    t ->
+    tcp:callback -> udp:callback -> default:(proto:int -> callback) ->
+    Cstruct.t -> unit Lwt.t
+  (** [input ~tcp ~udp ~default ip buf] demultiplexes an incoming
+      [buffer] that contains an IP frame. It examines the protocol
+      header and passes the result onto either the [tcp] or [udp]
+      function, or the [default] function for unknown IP protocols. *)
+
+  val write: t -> ?fragment:bool -> ?ttl:int ->
+    ?src:ipaddr -> ipaddr -> proto -> ?size:int -> (Cstruct.t -> int) ->
+    Cstruct.t list -> (unit, error) result Lwt.t
+  (** [write t ~fragment ~ttl ~src dst proto ~size headerf payload] allocates a
+     buffer, writes the IP header, and calls the headerf function. This may
+     write to the provided buffer of [size] (default 0). If [size + ip header]
+     exceeds the maximum transfer unit, an error is returned. The [payload] is
+     appended. The optional [fragment] argument defaults to [true], in which
+     case multiple IP-fragmented frames are sent if the payload is too big for a
+     single frame. When it is [false], the don't fragment bit is set and if the
+     payload and header would exceed the maximum transfer unit, an error is
+     returned. *)
+
+  val pseudoheader : t -> ?src:ipaddr -> ipaddr -> proto -> int -> Cstruct.t
+  (** [pseudoheader t ~src dst proto len] gives a pseudoheader suitable for use in
+      TCP or UDP checksum calculation based on [t]. *)
+
+  val src: t -> dst:ipaddr -> ipaddr
+  (** [src ip ~dst] is the source address to be used to send a
+      packet to [dst].  In the case of IPv4, this will always return
+      the same IP, which is the only one set. *)
+
+  val get_ip: t -> ipaddr list
+  (** Get the IP addresses associated with this interface. For IPv4, only
+      one IP address can be set at a time, so the list will always be of
+      length 1 (and may be the default value, 0.0.0.0). *)
+
+  val mtu: t -> dst:ipaddr -> int
+  (** [mtu ~dst ip] is the Maximum Transmission Unit of the [ip] i.e. the
+      maximum size of the payload, not including the IP header. *)
+end

src/core/stack.ml

@@ -0,0 +1,156 @@
+module type V4 = sig
+
+  type t
+  (** The type representing the internal state of the IPv4 stack. *)
+
+  val disconnect: t -> unit Lwt.t
+  (** Disconnect from the IPv4 stack. While this might take some time to
+      complete, it can never result in an error. *)
+
+  module UDPV4: Udp.S with type ipaddr = Ipaddr.V4.t
+
+  module TCPV4: Tcp.S with type ipaddr = Ipaddr.V4.t
+
+  module IPV4: Ip.S with type ipaddr = Ipaddr.V4.t
+
+  val udpv4: t -> UDPV4.t
+  (** [udpv4 t] obtains a descriptor for use with the [UDPV4] module,
+      usually to transmit traffic. *)
+
+  val tcpv4: t -> TCPV4.t
+  (** [tcpv4 t] obtains a descriptor for use with the [TCPV4] module,
+      usually to initiate outgoing connections. *)
+
+  val ipv4: t -> IPV4.t
+  (** [ipv4 t] obtains a descriptor for use with the [IPV4] module,
+      which can handle raw IPv4 frames, or manipulate IP address
+      configuration on the stack interface. *)
+
+  val listen_udpv4: t -> port:int -> UDPV4.callback -> unit
+  [@@ocaml.deprecated "use UDPV4.listen instead (since mirage-protocols 6.0.0)."]
+  (** [listen_udpv4 t ~port cb] registers the [cb] callback on the
+      UDPv4 [port] and immediately return.  If [port] is invalid (not
+      between 0 and 65535 inclusive), it raises [Invalid_argument].
+      Multiple bindings to the same port will overwrite previous
+      bindings, so callbacks will not chain if ports clash. *)
+
+  val listen_tcpv4: ?keepalive:Tcp.Keepalive.t
+    -> t -> port:int -> (TCPV4.flow -> unit Lwt.t) -> unit
+  [@@ocaml.deprecated "use TCPV4.listen instead (since mirage-protocols 6.0.0)."]
+  (** [listen_tcpv4 ~keepalive t ~port cb] registers the [cb] callback
+      on the TCPv4 [port] and immediately return.  If [port] is invalid (not
+      between 0 and 65535 inclusive), it raises [Invalid_argument].
+      Multiple bindings to the same port will overwrite previous
+      bindings, so callbacks will not chain if ports clash.
+      If [~keepalive] is provided then these keepalive settings will be
+      applied to the accepted connections before the callback is called. *)
+
+  val listen: t -> unit Lwt.t
+  (** [listen t] requests that the stack listen for traffic on the
+      network interface associated with the stack, and demultiplex
+      traffic to the appropriate callbacks. *)
+end
+
+module type V6 = sig
+  type t
+  (** The type representing the internal state of the IPv6 stack. *)
+
+  val disconnect: t -> unit Lwt.t
+  (** Disconnect from the IPv6 stack. While this might take some time to
+      complete, it can never result in an error. *)
+
+  module UDP: Udp.S with type ipaddr = Ipaddr.V6.t
+
+  module TCP: Tcp.S with type ipaddr = Ipaddr.V6.t
+
+  module IP: Ip.S with type ipaddr = Ipaddr.V6.t
+
+  val udp: t -> UDP.t
+  (** [udp t] obtains a descriptor for use with the [UDPV6] module,
+      usually to transmit traffic. *)
+
+  val tcp: t -> TCP.t
+  (** [tcp t] obtains a descriptor for use with the [TCPV6] module,
+      usually to initiate outgoing connections. *)
+
+  val ip: t -> IP.t
+  (** [ip t] obtains a descriptor for use with the [IPV6] module,
+      which can handle raw IPv6 frames, or manipulate IP address
+      configuration on the stack interface. *)
+
+  val listen_udp: t -> port:int -> UDP.callback -> unit
+  [@@ocaml.deprecated "use UDP.listen instead (since mirage-protocols 6.0.0)."]
+  (** [listen_udp t ~port cb] registers the [cb] callback on the
+      UDPv6 [port] and immediately return.  If [port] is invalid (not
+      between 0 and 65535 inclusive), it raises [Invalid_argument].
+      Multiple bindings to the same port will overwrite previous
+      bindings, so callbacks will not chain if ports clash. *)
+
+  val listen_tcp: ?keepalive:Tcp.Keepalive.t
+    -> t -> port:int -> (TCP.flow -> unit Lwt.t) -> unit
+  [@@ocaml.deprecated "use TCP.listen instead (since mirage-protocols 6.0.0)."]
+  (** [listen_tcp ~keepalive t ~port cb] registers the [cb] callback
+      on the TCPv6 [port] and immediately return.  If [port] is invalid (not
+      between 0 and 65535 inclusive), it raises [Invalid_argument].
+      Multiple bindings to the same port will overwrite previous
+      bindings, so callbacks will not chain if ports clash.
+      If [~keepalive] is provided then these keepalive settings will be
+      applied to the accepted connections before the callback is called. *)
+
+  val listen: t -> unit Lwt.t
+  (** [listen t] requests that the stack listen for traffic on the
+      network interface associated with the stack, and demultiplex
+      traffic to the appropriate callbacks. *)
+end
+
+module type V4V6 = sig
+  type t
+  (** The type representing the internal state of the dual IPv4 and IPv6 stack. *)
+
+  val disconnect: t -> unit Lwt.t
+  (** Disconnect from the dual IPv4 and IPv6 stack. While this might take some
+      time to complete, it can never result in an error. *)
+
+  module UDP: Udp.S with type ipaddr = Ipaddr.t
+
+  module TCP: Tcp.S with type ipaddr = Ipaddr.t
+
+  module IP: Ip.S with type ipaddr = Ipaddr.t
+
+  val udp: t -> UDP.t
+  (** [udp t] obtains a descriptor for use with the [UDP] module,
+      usually to transmit traffic. *)
+
+  val tcp: t -> TCP.t
+  (** [tcp t] obtains a descriptor for use with the [TCP] module,
+      usually to initiate outgoing connections. *)
+
+  val ip: t -> IP.t
+  (** [ip t] obtains a descriptor for use with the [IP] module,
+      which can handle raw IPv4 and IPv6 frames, or manipulate IP address
+      configuration on the stack interface. *)
+
+  val listen_udp: t -> port:int -> UDP.callback -> unit
+  [@@ocaml.deprecated "use UDP.listen instead (since mirage-protocols 6.0.0)."]
+  (** [listen_udp t ~port cb] registers the [cb] callback on the
+      UDP [port] and immediately return.  If [port] is invalid (not
+      between 0 and 65535 inclusive), it raises [Invalid_argument].
+      Multiple bindings to the same port will overwrite previous
+      bindings, so callbacks will not chain if ports clash. *)
+
+  val listen_tcp: ?keepalive:Tcp.Keepalive.t
+    -> t -> port:int -> (TCP.flow -> unit Lwt.t) -> unit
+  [@@ocaml.deprecated "use TCP.listen instead (since mirage-protocols 6.0.0)."]
+  (** [listen_tcp ~keepalive t ~port cb] registers the [cb] callback
+      on the TCP [port] and immediately return.  If [port] is invalid (not
+      between 0 and 65535 inclusive), it raises [Invalid_argument].
+      Multiple bindings to the same port will overwrite previous
+      bindings, so callbacks will not chain if ports clash.
+      If [~keepalive] is provided then these keepalive settings will be
+      applied to the accepted connections before the callback is called. *)
+
+  val listen: t -> unit Lwt.t
+  (** [listen t] requests that the stack listen for traffic on the
+      network interface associated with the stack, and demultiplex
+      traffic to the appropriate callbacks. *)
+end

src/core/tcp.ml

@@ -0,0 +1,39 @@
+type error = [ `Timeout | `Refused]
+type write_error = [ error | Mirage_flow.write_error]
+
+let pp_error ppf = function
+  | `Timeout -> Fmt.string ppf "connection attempt timed out"
+  | `Refused -> Fmt.string ppf "connection attempt was refused"
+
+let pp_write_error ppf = function
+  | #Mirage_flow.write_error as e -> Mirage_flow.pp_write_error ppf e
+  | #error as e                   -> pp_error ppf e
+
+module Keepalive = struct
+  type t = {
+    after: Duration.t;
+    interval: Duration.t;
+    probes: int;
+  }
+end
+
+module type S = sig
+  type nonrec error = private [> error]
+  type nonrec write_error = private [> write_error]
+  type ipaddr
+  type flow
+  type t
+  val disconnect : t -> unit Lwt.t
+  include Mirage_flow.S with
+      type flow   := flow
+  and type error  := error
+  and type write_error := write_error
+
+  val dst: flow -> ipaddr * int
+  val write_nodelay: flow -> Cstruct.t -> (unit, write_error) result Lwt.t
+  val writev_nodelay: flow -> Cstruct.t list -> (unit, write_error) result Lwt.t
+  val create_connection: ?keepalive:Keepalive.t -> t -> ipaddr * int -> (flow, error) result Lwt.t
+  val listen : t -> port:int -> ?keepalive:Keepalive.t -> (flow -> unit Lwt.t) -> unit
+  val unlisten : t -> port:int -> unit
+  val input: t -> src:ipaddr -> dst:ipaddr -> Cstruct.t -> unit Lwt.t
+end