unikernel/duniverse/ethernet/.gitignore

@@ -0,0 +1,4 @@
+_build/
+.merlin
+*.install
+.*.swp

unikernel/duniverse/ethernet/CHANGES.md

@@ -0,0 +1,42 @@
+### v3.2.0 (2023-03-12)
+
+* Remove mirage-profile dependency (#11 @hannesm)
+
+### v3.1.0 (2023-03-09)
+
+* Remove ppx_cstruct usage, include Ethernet_wire in Ethernet_packet (#10 @hannesm)
+
+### v3.0.0 (2021-12-09)
+
+* Include Mirage_protocols.ETHERNET module type in ethernet directly, remove
+  dependency on mirage-protocols (#8 @hannesm)
+* The ethernet library is now wrapped, this means a lot of API breakage.
+  The most used binding, Ethernet_wire.sizeof_ethernet is now known as
+  Ethernet.Packet.sizeof_ethernet. (#8 @hannesm)
+
+### v2.2.1 (2021-10-21)
+
+* Remove rresult dependency (#7 @hannesm)
+* Avoid deprecated Cstruct.len, use Cstruct.length (#7 @hannesm)
+
+### v2.2.0 (2019-10-30)
+
+* Adapt to mirage-net 3.0.0 and mirage-protocols 4.0.0 changes (#6 @hannesm)
+
+### v2.1.0 (2019-07-15)
+
+* Use ipaddr.4.0.0 interfaces (#5 @avsm)
+
+### v2.0.0 (2019-02-24)
+
+* Adjust to mirage-protocols 2.0.0 and mirage-net 2.0.0 changes
+* Ethernet is now responsible for prefixing the Ethernet header
+* MTU is required from the underlying network interface instead of as argument
+  to connect
+* Ethif/ETHIF are now Ethernet/ETHERNET
+
+### v1.0.0 (2019-02-01)
+
+* Minor ocamldoc improvements (@avsm).
+* Initial import from mirage-tcpip (@hannesm).
+  Based on source code from mirage-tcpip.3.6.0.

unikernel/duniverse/ethernet/LICENSE.md

@@ -0,0 +1,34 @@
+Copyright (c) Anil Madhavapeddy <anil@recoil.org>
+Copyright (c) Balraj Singh <balrajsingh@ieee.org>
+Copyright (c) Citrix Inc
+Copyright (c) David Scott <dave@recoil.org>
+Copyright (c) Docker Inc
+Copyright (c) Drup <drupyog@zoho.com>
+Copyright (c) Gabor Pali <pali.gabor@gmail.com>
+Copyright (c) Hannes Mehnert <hannes@mehnert.org>
+Copyright (c) Haris Rotsos <cr409@cam.ac.uk>
+Copyright (c) Kia <sadieperkins@riseup.net>
+Copyright (c) Luke Dunstan <LukeDunstan81@gmail.com>
+Copyright (c) Magnus Skjegstad <magnus@skjegstad.com>
+Copyright (c) Mindy Preston <meetup@yomimono.org>
+Copyright (c) Nicolas Ojeda Bar <n.oje.bar@gmail.com>
+Copyright (c) Pablo Polvorin <ppolvorin@process-one.net>
+Copyright (c) Richard Mortier <mort@cantab.net>
+Copyright (c) Thomas Gazagnaire <thomas@gazagnaire.org>
+Copyright (c) Thomas Leonard <talex5@gmail.com>
+Copyright (c) Tim Cuthbertson <tim@gfxmonk.net>
+Copyright (c) Vincent Bernardoff <vb@luminar.eu.org>
+Copyright (c) lnmx <len@lnmx.org>
+Copyright (c) pqwy <david@numm.org> 
+
+Permission to use, copy, modify, and distribute this software for any
+purpose with or without fee is hereby granted, provided that the above
+copyright notice and this permission notice appear in all copies.
+
+THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+WITH REGARD TO THIS l SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

unikernel/duniverse/ethernet/Makefile

@@ -0,0 +1,9 @@
+.PHONY : clean all doc
+all:
+	dune build
+
+doc:
+	dune build @doc
+
+clean:
+	dune clean

unikernel/duniverse/ethernet/README.md

@@ -0,0 +1,5 @@
+# Ethernet - an OCaml Ethernet (IEEE 802.3) layer
+
+`ethernet` provides an [Ethernet](https://en.wikipedia.org/wiki/Ethernet)
+(specified by IEEE 802.3) layer implementation for the
+[Mirage operating system](https://mirage.io).

unikernel/duniverse/ethernet/dune-project

@@ -0,0 +1,3 @@
+(lang dune 1.0)
+(name ethernet)
+(version v3.2.0)

unikernel/duniverse/ethernet/ethernet.opam

@@ -0,0 +1,36 @@
+version: "3.2.0"
+opam-version: "2.0"
+maintainer:   "mirageos-devel@lists.xenproject.org"
+homepage:     "https://github.com/mirage/ethernet"
+dev-repo:     "git+https://github.com/mirage/ethernet.git"
+bug-reports:  "https://github.com/mirage/ethernet/issues"
+doc:          "https://mirage.github.io/ethernet/"
+authors: [
+  "Anil Madhavapeddy" "Balraj Singh" "Richard Mortier" "Nicolas Ojeda Bar"
+  "Thomas Gazagnaire" "Vincent Bernardoff" "Magnus Skjegstad" "Mindy Preston"
+  "Thomas Leonard" "David Scott" "Gabor Pali" "Hannes Mehnert" "Haris Rotsos"
+  "Kia" "Luke Dunstan" "Pablo Polvorin" "Tim Cuthbertson" "lnmx" "pqwy" ]
+license: "ISC"
+tags: ["org:mirage"]
+
+build: [
+  ["dune" "subst"] {dev}
+  ["dune" "build" "-p" name "-j" jobs]
+]
+
+depends: [
+  "dune"
+  "ocaml" {>= "4.08.0"}
+  "cstruct" {>= "6.0.0"}
+  "mirage-net" {>= "3.0.0"}
+  "macaddr" {>= "4.0.0"}
+  "lwt" {>= "3.0.0"}
+  "logs" {>= "0.6.0"}
+]
+conflicts: [ "result" {< "1.5"} ]
+synopsis: "OCaml Ethernet (IEEE 802.3) layer, used in MirageOS"
+description: """
+`ethernet` provides an [Ethernet](https://en.wikipedia.org/wiki/Ethernet)
+(specified by IEEE 802.3) layer implementation for the
+[Mirage operating system](https://mirage.io).
+"""

unikernel/duniverse/ethernet/src/dune

@@ -0,0 +1,4 @@
+(library
+ (name ethernet)
+ (public_name ethernet)
+ (libraries cstruct macaddr mirage-net logs lwt))

unikernel/duniverse/ethernet/src/ethernet.ml

@@ -0,0 +1,129 @@
+(*
+ * Copyright (c) 2010-2011 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2011 Richard Mortier <richard.mortier@nottingham.ac.uk>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *
+ *)
+
+module Packet = struct
+  type proto = Ethernet_packet.proto
+  let pp_proto = Ethernet_packet.pp_proto
+
+  type t = Ethernet_packet.t =  {
+    source : Macaddr.t;
+    destination : Macaddr.t;
+    ethertype : proto;
+  }
+
+
+  let sizeof_ethernet = Ethernet_packet.sizeof_ethernet
+
+  let of_cstruct = Ethernet_packet.Unmarshal.of_cstruct
+
+  let into_cstruct = Ethernet_packet.Marshal.into_cstruct
+
+  let make_cstruct = Ethernet_packet.Marshal.make_cstruct
+end
+
+module type S = sig
+  type nonrec error = private [> `Exceeds_mtu ]
+  val pp_error: error Fmt.t
+  type t
+  val disconnect : t -> unit Lwt.t
+  val write: t -> ?src:Macaddr.t -> Macaddr.t -> Packet.proto -> ?size:int ->
+    (Cstruct.t -> int) -> (unit, error) result Lwt.t
+  val mac: t -> Macaddr.t
+  val mtu: t -> int
+  val input:
+    arpv4:(Cstruct.t -> unit Lwt.t) ->
+    ipv4:(Cstruct.t -> unit Lwt.t) ->
+    ipv6:(Cstruct.t -> unit Lwt.t) ->
+    t -> Cstruct.t -> unit Lwt.t
+end
+
+open Lwt.Infix
+
+let src = Logs.Src.create "ethernet" ~doc:"Mirage Ethernet"
+module Log = (val Logs.src_log src : Logs.LOG)
+
+module Make (Netif : Mirage_net.S) = struct
+
+  type error = [ `Exceeds_mtu | `Netif of Netif.error ]
+  let pp_error ppf = function
+    | `Exceeds_mtu -> Fmt.string ppf "exceeds MTU"
+    | `Netif e -> Netif.pp_error ppf e
+
+  type t = {
+    netif: Netif.t;
+  }
+
+  let mac t = Netif.mac t.netif
+  let mtu t = Netif.mtu t.netif (* interface MTU excludes Ethernet header *)
+
+  let input ~arpv4 ~ipv4 ~ipv6 t frame =
+    let open Ethernet_packet in
+    let of_interest dest =
+      Macaddr.compare dest (mac t) = 0 || not (Macaddr.is_unicast dest)
+    in
+    match Unmarshal.of_cstruct frame with
+    | Ok (header, payload) when of_interest header.destination ->
+      begin
+        match header.Ethernet_packet.ethertype with
+        | `ARP -> arpv4 payload
+        | `IPv4 -> ipv4 payload
+        | `IPv6 -> ipv6 payload
+      end
+    | Ok _ -> Lwt.return_unit
+    | Error s ->
+      Log.debug (fun f -> f "dropping Ethernet frame: %s" s);
+      Lwt.return_unit
+
+  let write t ?src destination ethertype ?size payload =
+    let source = match src with None -> mac t | Some x -> x
+    and eth_hdr_size = Ethernet_packet.sizeof_ethernet
+    and mtu = mtu t
+    in
+    match
+      match size with
+      | None -> Ok mtu
+      | Some s -> if s > mtu then Error () else Ok s
+    with
+    | Error () -> Lwt.return (Error `Exceeds_mtu)
+    | Ok size ->
+      let size = eth_hdr_size + size in
+      let hdr = { Ethernet_packet.source ; destination ; ethertype } in
+      let fill frame =
+        match Ethernet_packet.Marshal.into_cstruct hdr frame with
+        | Error msg ->
+          Log.err (fun m -> m "error %s while marshalling ethernet header into allocated buffer" msg);
+          0
+        | Ok () ->
+          let len = payload (Cstruct.shift frame eth_hdr_size) in
+          eth_hdr_size + len
+      in
+      Netif.write t.netif ~size fill >|= function
+      | Ok () -> Ok ()
+      | Error e ->
+        Log.warn (fun f -> f "netif write errored %a" Netif.pp_error e) ;
+        Error (`Netif e)
+
+  let connect netif =
+    let t = { netif } in
+    Log.info (fun f -> f "Connected Ethernet interface %a" Macaddr.pp (mac t));
+    Lwt.return t
+
+  let disconnect t =
+    Log.info (fun f -> f "Disconnected Ethernet interface %a" Macaddr.pp (mac t));
+    Lwt.return_unit
+end

unikernel/duniverse/ethernet/src/ethernet.mli

@@ -0,0 +1,105 @@
+(*
+ * Copyright (c) 2010-2019 Anil Madhavapeddy <anil@recoil.org>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *
+ *)
+
+(** OCaml Ethernet (IEEE 802.3) layer *)
+
+(** Ethernet (IEEE 802.3) is a widely used data link layer. The hardware is
+   usually a twisted pair or fibre connection, on the software side it consists
+   of an Ethernet header where source and destination mac addresses, and a type
+   field, indicating the type of the next layer, are present. The Ethernet layer
+   consists of network card mac address and MTU information, and provides
+   decapsulation and encapsulation. *)
+
+(** {2 Ethernet layer} *)
+
+module Packet : sig
+  (** Ethernet protocols. *)
+  type proto = [ `ARP | `IPv4 | `IPv6 ]
+
+  (** [pp_proto ppf proto] pretty-prints the ethernet protocol [proto] on [ppf]. *)
+  val pp_proto: proto Fmt.t
+
+  (** The type of an Ethernet packet. *)
+  type t = {
+    source : Macaddr.t;
+    destination : Macaddr.t;
+    ethertype : proto;
+  }
+
+  (** [sizeof_ethernet] is the byte size of the ethernet header. *)
+  val sizeof_ethernet : int
+
+  (** [of_cstruct buffer] attempts to decode the buffer as ethernet packet. It
+      may result an error if the buffer is too small, or the protocol is not
+      supported. *)
+  val of_cstruct : Cstruct.t -> (t * Cstruct.t, string) result
+
+  (** [into_cstruct t cs] attempts to encode the ethernet packet [t] into the
+      buffer [cs] (at offset 0). This may fail if the buffer is not big
+      enough. *)
+  val into_cstruct : t -> Cstruct.t -> (unit, string) result
+
+  (** [make_cstruct t] encodes the ethernet packet [t] into a freshly allocated
+      buffer. *)
+  val make_cstruct : t -> Cstruct.t
+end
+
+module type S = sig
+
+  type nonrec error = private [> `Exceeds_mtu ]
+  (** The type for ethernet interface errors. *)
+
+  val pp_error: error Fmt.t
+  (** [pp_error] is the pretty-printer for errors. *)
+
+  type t
+  (** The type representing the internal state of the ethernet layer. *)
+
+  val disconnect: t -> unit Lwt.t
+  (** Disconnect from the ethernet layer. While this might take some time to
+      complete, it can never result in an error. *)
+
+  val write: t -> ?src:Macaddr.t -> Macaddr.t -> Packet.proto -> ?size:int ->
+    (Cstruct.t -> int) -> (unit, error) result Lwt.t
+  (** [write eth ~src dst proto ~size payload] outputs an ethernet frame which
+     header is filled by [eth], and its payload is the buffer from the call to
+     [payload]. [Payload] gets a buffer of [size] (defaults to mtu) to fill with
+     their payload. If [size] exceeds {!mtu}, an error is returned. *)
+
+  val mac: t -> Macaddr.t
+  (** [mac eth] is the MAC address of [eth]. *)
+
+  val mtu: t -> int
+  (** [mtu eth] is the Maximum Transmission Unit of the [eth] i.e. the maximum
+      size of the payload, excluding the ethernet frame header. *)
+
+  val input:
+    arpv4:(Cstruct.t -> unit Lwt.t) ->
+    ipv4:(Cstruct.t -> unit Lwt.t) ->
+    ipv6:(Cstruct.t -> unit Lwt.t) ->
+    t -> Cstruct.t -> unit Lwt.t
+  (** [input ~arpv4 ~ipv4 ~ipv6 eth buffer] decodes the buffer and demultiplexes
+      it depending on the protocol to the callback. *)
+end
+
+module Make (N : Mirage_net.S) : sig
+  include S
+
+  val connect : N.t -> t Lwt.t
+  (** [connect netif] connects an ethernet layer on top of the raw
+      network device [netif]. *)
+end

unikernel/duniverse/ethernet/src/ethernet_packet.ml

@@ -0,0 +1,73 @@
+type proto = [ `ARP | `IPv4 | `IPv6 ]
+
+let pp_proto ppf = function
+  | `ARP -> Fmt.string ppf "ARP"
+  | `IPv4 -> Fmt.string ppf "IPv4"
+  | `IPv6 -> Fmt.string ppf "IPv6"
+
+type t = {
+  source : Macaddr.t;
+  destination : Macaddr.t;
+  ethertype : proto;
+}
+
+let sizeof_ethernet = 14
+
+let ethertype_to_int = function
+  | `ARP -> 0x0806
+  | `IPv4 -> 0x0800
+  | `IPv6 -> 0x86dd
+
+let int_to_ethertype = function
+  | 0x0806 -> Some `ARP
+  | 0x0800 -> Some `IPv4
+  | 0x86dd -> Some `IPv6
+  | _ -> None
+
+type error = string
+
+let pp fmt t =
+  Format.fprintf fmt "%a -> %a: %a" Macaddr.pp t.source
+    Macaddr.pp t.destination pp_proto t.ethertype
+
+let equal {source; destination; ethertype} q =
+  (Macaddr.compare source q.source) = 0 &&
+  (Macaddr.compare destination q.destination) = 0 &&
+  compare (ethertype_to_int ethertype) (ethertype_to_int q.ethertype) = 0
+
+module Unmarshal = struct
+
+  let of_cstruct frame =
+    if Cstruct.length frame >= sizeof_ethernet then
+      let raw_typ = Cstruct.BE.get_uint16 frame 12 in
+      match raw_typ |> int_to_ethertype with
+      | None -> Error (Printf.sprintf "unknown ethertype 0x%x in frame" raw_typ)
+      | Some ethertype ->
+        let payload = Cstruct.shift frame sizeof_ethernet
+        and source = Macaddr.of_octets_exn (Cstruct.to_string ~off:6 ~len:6 frame)
+        and destination = Macaddr.of_octets_exn (Cstruct.to_string ~off:0 ~len:6 frame)
+        in
+        Ok ({ destination; source; ethertype;}, payload)
+    else
+      Error "frame too small to contain a valid ethernet header"
+end
+
+module Marshal = struct
+  let check_len buf =
+    if sizeof_ethernet > Cstruct.length buf then
+      Error "Not enough space for an Ethernet header"
+    else Ok ()
+
+  let unsafe_fill t buf =
+    Cstruct.blit_from_string (Macaddr.to_octets t.destination) 0 buf 0 6;
+    Cstruct.blit_from_string (Macaddr.to_octets t.source) 0 buf 6 6;
+    Cstruct.BE.set_uint16 buf 12 (ethertype_to_int t.ethertype)
+
+  let into_cstruct t buf =
+    Result.map (fun () -> unsafe_fill t buf) (check_len buf)
+
+  let make_cstruct t =
+    let buf = Cstruct.create sizeof_ethernet in
+    unsafe_fill t buf;
+    buf
+end

unikernel/duniverse/ethernet/src/ethernet_packet.mli

@@ -0,0 +1,34 @@
+type proto = [ `ARP | `IPv4 | `IPv6 ]
+val pp_proto: proto Fmt.t
+
+type t = {
+  source : Macaddr.t;
+  destination : Macaddr.t;
+  ethertype : proto;
+}
+
+val sizeof_ethernet : int
+
+type error = string
+
+val pp : Format.formatter -> t -> unit
+val equal : t -> t -> bool
+
+module Unmarshal : sig
+  val of_cstruct : Cstruct.t -> ((t * Cstruct.t), error) result
+end
+
+module Marshal : sig
+  (** [into_cstruct t buf] writes a 14-byte ethernet header representing
+      [t.ethertype], [t.src_mac], and [t.dst_mac] to [buf] at offset 0.
+      Returns [Ok ()] on success and [Error error] on failure.
+      Currently, the only possibility for failure
+      is a [buf] too small to contain the header; to avoid this, provide a
+      buffer of size at least 14. *)
+  val into_cstruct : t -> Cstruct.t -> (unit, error) result
+
+  (** given a [t], construct and return an Ethernet header representing
+      [t.ethertype], [t.source], and [t.destination].  [make_cstruct] will allocate
+      a new 14 bytes for the Ethernet header it returns. *)
+  val make_cstruct : t -> Cstruct.t
+end