Moved client networking to its own module

Renamed the old Client_net to Client_eth, as it just handles the
Ethernet layer.

client_eth.ml

@@ -0,0 +1,128 @@
+(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
+   See the README file for details. *)
+
+open Utils
+
+let src = Logs.Src.create "client_eth" ~doc:"Ethernet for NetVM clients"
+module Log = (val Logs.src_log src : Logs.LOG)
+
+type t = {
+  mutable iface_of_ip : client_link IpMap.t;
+  prefix : Ipaddr.V4.Prefix.t;
+  client_gw : Ipaddr.V4.t;  (* The IP that clients are given as their default gateway. *)
+}
+
+let create ~prefix ~client_gw =
+  { iface_of_ip = IpMap.empty; client_gw; prefix }
+
+let prefix t = t.prefix
+
+let add_client t iface =
+  let ip = iface#client_ip in
+  assert (Ipaddr.V4.Prefix.mem ip t.prefix);
+  (* TODO: Should probably wait for the previous client to disappear. *)
+  (* assert (not (IpMap.mem ip t.iface_of_ip)); *)
+  t.iface_of_ip <- t.iface_of_ip |> IpMap.add ip iface
+
+let remove_client t iface =
+  let ip = iface#client_ip in
+  assert (IpMap.mem ip t.iface_of_ip);
+  t.iface_of_ip <- t.iface_of_ip |> IpMap.remove ip
+
+let lookup t ip = IpMap.find ip t.iface_of_ip
+
+module ARP = struct
+  type arp = {
+    net : t;
+    client_link : client_link;
+  }
+
+  let lookup t ip =
+    if ip === t.net.client_gw then Some t.client_link#my_mac
+    else match IpMap.find ip t.net.iface_of_ip with
+    | Some client_iface -> Some client_iface#client_mac
+    | None -> None
+
+  let create ~net client_link = {net; client_link}
+
+  type arp_msg = {
+    op: [ `Request |`Reply |`Unknown of int ];
+    sha: Macaddr.t;
+    spa: Ipaddr.V4.t;
+    tha: Macaddr.t;
+    tpa: Ipaddr.V4.t;
+  }
+
+  let to_wire arp =
+    let open Arpv4_wire in
+    (* Obtain a buffer to write into *)
+    let buf = Cstruct.create (Wire_structs.sizeof_ethernet + sizeof_arp) in
+    (* Write the ARP packet *)
+    let dmac = Macaddr.to_bytes arp.tha in
+    let smac = Macaddr.to_bytes arp.sha in
+    let spa = Ipaddr.V4.to_int32 arp.spa in
+    let tpa = Ipaddr.V4.to_int32 arp.tpa in
+    let op =
+      match arp.op with
+      |`Request -> 1
+      |`Reply -> 2
+      |`Unknown n -> n
+    in
+    Wire_structs.set_ethernet_dst dmac 0 buf;
+    Wire_structs.set_ethernet_src smac 0 buf;
+    Wire_structs.set_ethernet_ethertype buf 0x0806; (* ARP *)
+    let arpbuf = Cstruct.shift buf 14 in
+    set_arp_htype arpbuf 1;
+    set_arp_ptype arpbuf 0x0800; (* IPv4 *)
+    set_arp_hlen arpbuf 6; (* ethernet mac size *)
+    set_arp_plen arpbuf 4; (* ipv4 size *)
+    set_arp_op arpbuf op;
+    set_arp_sha smac 0 arpbuf;
+    set_arp_spa arpbuf spa;
+    set_arp_tha dmac 0 arpbuf;
+    set_arp_tpa arpbuf tpa;
+    buf
+
+  let input_query t frame =
+    let open Arpv4_wire in
+    let req_ipv4 = Ipaddr.V4.of_int32 (get_arp_tpa frame) in
+    Log.info "who-has %s?" (fun f -> f (Ipaddr.V4.to_string req_ipv4));
+    if req_ipv4 === t.client_link#client_ip then (
+      Log.info "ignoring request for client's own IP" Logs.unit;
+      None
+    ) else match lookup t req_ipv4 with
+    | None ->
+        Log.info "unknown address; not responding" Logs.unit;
+        None
+    | Some req_mac ->
+        Log.info "responding to: who-has %s?" (fun f -> f (Ipaddr.V4.to_string req_ipv4));
+        Some (to_wire {
+          op = `Reply;
+          (* The Target Hardware Address and IP are copied from the request *)
+          tha = Macaddr.of_bytes_exn (copy_arp_sha frame);
+          tpa = Ipaddr.V4.of_int32 (get_arp_spa frame);
+          sha = req_mac;
+          spa = req_ipv4;
+        })
+
+  let input_gratuitous t frame =
+    let open Arpv4_wire in
+    let spa = Ipaddr.V4.of_int32 (get_arp_spa frame) in
+    let sha = Macaddr.of_bytes_exn (copy_arp_sha frame) in
+    match lookup t spa with
+    | Some real_mac when Macaddr.compare sha real_mac = 0 ->
+        Log.info "client suggests updating %s -> %s (as expected)"
+          (fun f -> f (Ipaddr.V4.to_string spa) (Macaddr.to_string sha));
+    | Some other_mac ->
+        Log.warn "client suggests incorrect update %s -> %s (should be %s)"
+          (fun f -> f (Ipaddr.V4.to_string spa) (Macaddr.to_string sha) (Macaddr.to_string other_mac));
+    | None ->
+        Log.warn "client suggests incorrect update %s -> %s (unexpected IP)"
+          (fun f -> f (Ipaddr.V4.to_string spa) (Macaddr.to_string sha))
+
+  let input t frame =
+    match Arpv4_wire.get_arp_op frame with
+    |1 -> input_query t frame
+    |2 -> input_gratuitous t frame; None
+    |n -> Log.warn "unknown message %d - ignored" (fun f -> f n); None
+end

client_eth.mli

@@ -0,0 +1,40 @@
+(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
+   See the README file for details. *)
+
+(** The ethernet network our client AppVMs are on. *)
+
+open Utils
+
+type t
+(** A network for client AppVMs to join. *)
+
+val create : prefix:Ipaddr.V4.Prefix.t -> client_gw:Ipaddr.V4.t -> t
+(** [create ~prefix ~client_gw] is a network of client machines.
+    Their IP addresses all start with [prefix] and they are configured to
+    use [client_gw] as their default gateway. *)
+
+val add_client : t -> client_link -> unit
+val remove_client : t -> client_link -> unit
+
+val prefix : t -> Ipaddr.V4.Prefix.t
+
+val lookup : t -> Ipaddr.V4.t -> client_link option
+
+module ARP : sig
+  (** We already know the correct mapping of IP addresses to MAC addresses, so we never
+      allow clients to update it. We log a warning if a client attempts to set incorrect
+      information. *)
+
+  type arp
+  (** An ARP-responder for one client. *)
+
+  val create : net:t -> client_link -> arp
+  (** [create ~net client_link] is an ARP responder for [client_link].
+      It answers on behalf of other clients in [net] (but not for the client
+      itself, since the client might be trying to check that its own address is
+      free). It also answers for the client's gateway address. *)
+
+  val input : arp -> Cstruct.t -> Cstruct.t option
+  (** Process one ethernet frame containing an ARP message.
+      Returns a response frame, if one is needed. *)
+end

client_net.ml

@@ -1,128 +1,94 @@
 (* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
    See the README file for details. *)
 
+open Lwt.Infix
 open Utils
 
-let src = Logs.Src.create "client_arp" ~doc:"ARP for NetVM clients"
+module Netback = Netchannel.Backend.Make(Netchannel.Xenstore.Make(OS.Xs))
+module ClientEth = Ethif.Make(Netback)
+
+let src = Logs.Src.create "net" ~doc:"Client networking"
 module Log = (val Logs.src_log src : Logs.LOG)
 
-type t = {
+class client_iface eth client_ip client_mac : client_link = object
-  mutable iface_of_ip : client_link IpMap.t;
+  method my_mac = ClientEth.mac eth
-  prefix : Ipaddr.V4.Prefix.t;
+  method client_mac = client_mac
-  client_gw : Ipaddr.V4.t;  (* The IP that clients are given as their default gateway. *)
+  method client_ip = client_ip
-}
+  method writev ip =
-
+    let eth_hdr = eth_header_ipv4 ~src:(ClientEth.mac eth) ~dst:client_mac in
-let create ~prefix ~client_gw =
+    ClientEth.writev eth (fixup_checksums (Cstruct.concat (eth_hdr :: ip)))
-  { iface_of_ip = IpMap.empty; client_gw; prefix }
-
-let prefix t = t.prefix
-
-let add_client t iface =
-  let ip = iface#client_ip in
-  assert (Ipaddr.V4.Prefix.mem ip t.prefix);
-  (* TODO: Should probably wait for the previous client to disappear. *)
-  (* assert (not (IpMap.mem ip t.iface_of_ip)); *)
-  t.iface_of_ip <- t.iface_of_ip |> IpMap.add ip iface
-
-let remove_client t iface =
-  let ip = iface#client_ip in
-  assert (IpMap.mem ip t.iface_of_ip);
-  t.iface_of_ip <- t.iface_of_ip |> IpMap.remove ip
-
-let lookup t ip = IpMap.find ip t.iface_of_ip
-
-module ARP = struct
-  type arp = {
-    net : t;
-    client_link : client_link;
-  }
-
-  let lookup t ip =
-    if ip === t.net.client_gw then Some t.client_link#my_mac
-    else match IpMap.find ip t.net.iface_of_ip with
-    | Some client_iface -> Some client_iface#client_mac
-    | None -> None
-
-  let create ~net client_link = {net; client_link}
-
-  type arp_msg = {
-    op: [ `Request |`Reply |`Unknown of int ];
-    sha: Macaddr.t;
-    spa: Ipaddr.V4.t;
-    tha: Macaddr.t;
-    tpa: Ipaddr.V4.t;
-  }
-
-  let to_wire arp =
-    let open Arpv4_wire in
-    (* Obtain a buffer to write into *)
-    let buf = Cstruct.create (Wire_structs.sizeof_ethernet + sizeof_arp) in
-    (* Write the ARP packet *)
-    let dmac = Macaddr.to_bytes arp.tha in
-    let smac = Macaddr.to_bytes arp.sha in
-    let spa = Ipaddr.V4.to_int32 arp.spa in
-    let tpa = Ipaddr.V4.to_int32 arp.tpa in
-    let op =
-      match arp.op with
-      |`Request -> 1
-      |`Reply -> 2
-      |`Unknown n -> n
-    in
-    Wire_structs.set_ethernet_dst dmac 0 buf;
-    Wire_structs.set_ethernet_src smac 0 buf;
-    Wire_structs.set_ethernet_ethertype buf 0x0806; (* ARP *)
-    let arpbuf = Cstruct.shift buf 14 in
-    set_arp_htype arpbuf 1;
-    set_arp_ptype arpbuf 0x0800; (* IPv4 *)
-    set_arp_hlen arpbuf 6; (* ethernet mac size *)
-    set_arp_plen arpbuf 4; (* ipv4 size *)
-    set_arp_op arpbuf op;
-    set_arp_sha smac 0 arpbuf;
-    set_arp_spa arpbuf spa;
-    set_arp_tha dmac 0 arpbuf;
-    set_arp_tpa arpbuf tpa;
-    buf
-
-  let input_query t frame =
-    let open Arpv4_wire in
-    let req_ipv4 = Ipaddr.V4.of_int32 (get_arp_tpa frame) in
-    Log.info "who-has %s?" (fun f -> f (Ipaddr.V4.to_string req_ipv4));
-    if req_ipv4 === t.client_link#client_ip then (
-      Log.info "ignoring request for client's own IP" Logs.unit;
-      None
-    ) else match lookup t req_ipv4 with
-    | None ->
-        Log.info "unknown address; not responding" Logs.unit;
-        None
-    | Some req_mac ->
-        Log.info "responding to: who-has %s?" (fun f -> f (Ipaddr.V4.to_string req_ipv4));
-        Some (to_wire {
-          op = `Reply;
-          (* The Target Hardware Address and IP are copied from the request *)
-          tha = Macaddr.of_bytes_exn (copy_arp_sha frame);
-          tpa = Ipaddr.V4.of_int32 (get_arp_spa frame);
-          sha = req_mac;
-          spa = req_ipv4;
-        })
-
-  let input_gratuitous t frame =
-    let open Arpv4_wire in
-    let spa = Ipaddr.V4.of_int32 (get_arp_spa frame) in
-    let sha = Macaddr.of_bytes_exn (copy_arp_sha frame) in
-    match lookup t spa with
-    | Some real_mac when Macaddr.compare sha real_mac = 0 ->
-        Log.info "client suggests updating %s -> %s (as expected)"
-          (fun f -> f (Ipaddr.V4.to_string spa) (Macaddr.to_string sha));
-    | Some other_mac ->
-        Log.warn "client suggests incorrect update %s -> %s (should be %s)"
-          (fun f -> f (Ipaddr.V4.to_string spa) (Macaddr.to_string sha) (Macaddr.to_string other_mac));
-    | None ->
-        Log.warn "client suggests incorrect update %s -> %s (unexpected IP)"
-          (fun f -> f (Ipaddr.V4.to_string spa) (Macaddr.to_string sha))
-
-  let input t frame =
-    match Arpv4_wire.get_arp_op frame with
-    |1 -> input_query t frame
-    |2 -> input_gratuitous t frame; None
-    |n -> Log.warn "unknown message %d - ignored" (fun f -> f n); None
 end
+
+let clients : Cleanup.t IntMap.t ref = ref IntMap.empty
+
+let start_client ~router domid =
+  let cleanup_tasks = Cleanup.create () in
+  Log.info "start_client in domain %d" (fun f -> f domid);
+  Lwt.async (fun () ->
+    Lwt.catch (fun () ->
+      Dao.client_vifs domid >>= (function
+      | [] -> return None
+      | vif :: others ->
+          if others <> [] then Log.warn "Client has multiple interfaces; using first" Logs.unit;
+          let { Dao.domid; device_id; client_ip } = vif in
+          Netback.make ~domid ~device_id >|= fun backend ->
+          Some (backend, client_ip)
+      ) >>= function
+      | None -> Log.warn "Client has no interfaces" Logs.unit; return ()
+      | Some (backend, client_ip) ->
+      Log.info "Client %d (IP: %s) ready" (fun f ->
+        f domid (Ipaddr.V4.to_string client_ip));
+      ClientEth.connect backend >>= or_fail "Can't make Ethernet device" >>= fun eth ->
+      let client_mac = Netback.mac backend in
+      let iface = new client_iface eth client_ip client_mac in
+      let fixed_arp = Client_eth.ARP.create ~net:(Router.client_eth router) iface in
+      Router.add_client router iface;
+      Cleanup.on_cleanup cleanup_tasks (fun () -> Router.remove_client router iface);
+      Netback.listen backend (
+        ClientEth.input
+          ~arpv4:(fun buf ->
+            match Client_eth.ARP.input fixed_arp buf with
+            | None -> return ()
+            | Some frame -> ClientEth.write eth frame
+          )
+          ~ipv4:(fun packet ->
+            let src = Wire_structs.Ipv4_wire.get_ipv4_src packet |> Ipaddr.V4.of_int32 in
+            if src === client_ip then Router.forward_ipv4 router packet
+            else (
+              Log.warn "Incorrect source IP %a in IP packet from %a (dropping)"
+                (fun f -> f Ipaddr.V4.pp_hum src Ipaddr.V4.pp_hum client_ip);
+              return ()
+            )
+          )
+          ~ipv6:(fun _buf -> return ())
+          eth
+      )
+    )
+    (fun ex ->
+      Log.warn "Error connecting client domain %d: %s"
+        (fun f -> f domid (Printexc.to_string ex));
+      return ()
+    )
+  );
+  cleanup_tasks
+
+let listen router =
+  let backend_vifs = "backend/vif" in
+  Log.info "Watching %s" (fun f -> f backend_vifs);
+  Dao.watch_clients (fun new_set ->
+    (* Check for removed clients *)
+    !clients |> IntMap.iter (fun key cleanup ->
+      if not (IntSet.mem key new_set) then (
+        clients := !clients |> IntMap.remove key;
+        Log.info "stop_client %d" (fun f -> f key);
+        Cleanup.cleanup cleanup
+      )
+    );
+    (* Check for added clients *)
+    new_set |> IntSet.iter (fun key ->
+      if not (IntMap.mem key !clients) then (
+        let cleanup = start_client ~router key in
+        clients := !clients |> IntMap.add key cleanup
+      )
+    )
+  )

client_net.mli

@@ -1,40 +1,10 @@
 (* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
    See the README file for details. *)
 
-(** The ethernet network our client AppVMs are on. *)
+(** Handling client VMs. *)
 
-open Utils
+val listen : Router.t -> 'a Lwt.t
-
+(** [listen router] is a thread that watches for clients being added to and
-type t
+    removed from XenStore. Clients are connected to the client network and
-(** A network for client AppVMs to join. *)
+    packets are sent via [router]. We ensure the source IP address is correct
-
+    before routing a packet. *)
-val create : prefix:Ipaddr.V4.Prefix.t -> client_gw:Ipaddr.V4.t -> t
-(** [create ~prefix ~client_gw] is a network of client machines.
-    Their IP addresses all start with [prefix] and they are configured to
-    use [client_gw] as their default gateway. *)
-
-val add_client : t -> client_link -> unit
-val remove_client : t -> client_link -> unit
-
-val prefix : t -> Ipaddr.V4.Prefix.t
-
-val lookup : t -> Ipaddr.V4.t -> client_link option
-
-module ARP : sig
-  (** We already know the correct mapping of IP addresses to MAC addresses, so we never
-      allow clients to update it. We log a warning if a client attempts to set incorrect
-      information. *)
-
-  type arp
-  (** An ARP-responder for one client. *)
-
-  val create : net:t -> client_link -> arp
-  (** [create ~net client_link] is an ARP responder for [client_link].
-      It answers on behalf of other clients in [net] (but not for the client
-      itself, since the client might be trying to check that its own address is
-      free). It also answers for the client's gateway address. *)
-
-  val input : arp -> Cstruct.t -> Cstruct.t option
-  (** Process one ethernet frame containing an ARP message.
-      Returns a response frame, if one is needed. *)
-end

net.ml

@@ -14,137 +14,21 @@ module ClientEth = Ethif.Make(Netback)
 let src = Logs.Src.create "net" ~doc:"Firewall networking"
 module Log = (val Logs.src_log src : Logs.LOG)
 
-(* The checksum logic doesn't depend on ARP or Eth, but we can't access
-   IPv4.checksum without applying the functor. *)
-let fixup_checksums frame =
-  match Nat_rewrite.layers frame with
-  | None -> raise (Invalid_argument "NAT transformation rendered packet unparseable")
-  | Some (ether, ip, tx) ->
-    let (just_headers, higherlevel_data) =
-      Nat_rewrite.recalculate_transport_checksum (ether, ip, tx)
-    in
-    [just_headers; higherlevel_data]
-
 module Make(Clock : V1.CLOCK) = struct
   module Arp = Arpv4.Make(Eth)(Clock)(OS.Time)
   module IPv4 = Ipv4.Make(Eth)(Arp)
   module Xs = OS.Xs
 
-  let eth_header ~src ~dst =
-    let open Wire_structs in
-    let frame = Cstruct.create sizeof_ethernet in
-    frame |> set_ethernet_src (Macaddr.to_bytes src) 0;
-    frame |> set_ethernet_dst (Macaddr.to_bytes dst) 0;
-    set_ethernet_ethertype frame (ethertype_to_int IPv4);
-    frame
-
   class netvm_iface eth my_ip mac nat_table : interface = object
     method my_mac = Eth.mac eth
     method writev ip =
       mac >>= fun dst ->
-      let eth_hdr = eth_header ~src:(Eth.mac eth) ~dst in
+      let eth_hdr = eth_header_ipv4 ~src:(Eth.mac eth) ~dst in
       match Nat_rules.nat my_ip nat_table Nat_rewrite.Source (Cstruct.concat (eth_hdr :: ip)) with
       | None -> return ()
       | Some frame -> Eth.writev eth (fixup_checksums frame)
   end
 
-  class client_iface eth client_ip client_mac : client_link = object
-    method my_mac = ClientEth.mac eth
-    method client_mac = client_mac
-    method client_ip = client_ip
-    method writev ip =
-      let eth_hdr = eth_header ~src:(ClientEth.mac eth) ~dst:client_mac in
-      ClientEth.writev eth (fixup_checksums (Cstruct.concat (eth_hdr :: ip)))
-  end
-
-  let or_fail msg = function
-    | `Ok x -> return x
-    | `Error _ -> fail (Failure msg)
-
-  let clients : Cleanup.t IntMap.t ref = ref IntMap.empty
-
-  let forward_ipv4 router buf =
-    match Memory_pressure.status () with
-    | `Memory_critical -> (* TODO: should happen before copying and async *)
-        print_endline "Memory low - dropping packet";
-        return ()
-    | `Ok ->
-    match Router.target router buf with
-    | Some iface -> iface#writev [buf]
-    | None -> return ()
-
-  let start_client ~router domid =
-    let cleanup_tasks = Cleanup.create () in
-    Log.info "start_client in domain %d" (fun f -> f domid);
-    Lwt.async (fun () ->
-      Lwt.catch (fun () ->
-        Dao.client_vifs domid >>= (function
-        | [] -> return None
-        | vif :: others ->
-            if others <> [] then Log.warn "Client has multiple interfaces; using first" Logs.unit;
-            let { Dao.domid; device_id; client_ip } = vif in
-            Netback.make ~domid ~device_id >|= fun backend ->
-            Some (backend, client_ip)
-        ) >>= function
-        | None -> Log.warn "Client has no interfaces" Logs.unit; return ()
-        | Some (backend, client_ip) ->
-        Log.info "Client %d (IP: %s) ready" (fun f ->
-          f domid (Ipaddr.V4.to_string client_ip));
-        ClientEth.connect backend >>= or_fail "Can't make Ethernet device" >>= fun eth ->
-        let client_mac = Netback.mac backend in
-        let iface = new client_iface eth client_ip client_mac in
-        let fixed_arp = Client_net.ARP.create ~net:(Router.client_net router) iface in
-        Router.add_client router iface;
-        Cleanup.on_cleanup cleanup_tasks (fun () -> Router.remove_client router iface);
-        Netback.listen backend (
-          ClientEth.input
-            ~arpv4:(fun buf ->
-              match Client_net.ARP.input fixed_arp buf with
-              | None -> return ()
-              | Some frame -> ClientEth.write eth frame
-            )
-            ~ipv4:(fun packet ->
-              let src = Wire_structs.Ipv4_wire.get_ipv4_src packet |> Ipaddr.V4.of_int32 in
-              if src === client_ip then forward_ipv4 router packet
-              else (
-                Log.warn "Incorrect source IP %a in IP packet from %a (dropping)"
-                  (fun f -> f Ipaddr.V4.pp_hum src Ipaddr.V4.pp_hum client_ip);
-                return ()
-              )
-            )
-            ~ipv6:(fun _buf -> return ())
-            eth
-        )
-      )
-      (fun ex ->
-        Log.warn "Error connecting client domain %d: %s"
-          (fun f -> f domid (Printexc.to_string ex));
-        return ()
-      )
-    );
-    cleanup_tasks
-
-  let watch_clients router =
-    let backend_vifs = "backend/vif" in
-    Log.info "Watching %s" (fun f -> f backend_vifs);
-    Dao.watch_clients (fun new_set ->
-      (* Check for removed clients *)
-      !clients |> IntMap.iter (fun key cleanup ->
-        if not (IntSet.mem key new_set) then (
-          clients := !clients |> IntMap.remove key;
-          Log.info "stop_client %d" (fun f -> f key);
-          Cleanup.cleanup cleanup
-        )
-      );
-      (* Check for added clients *)
-      new_set |> IntSet.iter (fun key ->
-        if not (IntMap.mem key !clients) then (
-          let cleanup = start_client ~router key in
-          clients := !clients |> IntMap.add key cleanup
-        )
-      )
-    )
-
   let connect_uplink config =
     let nat_table = Nat_lookup.empty () in
     let ip = config.Dao.uplink_our_ip in
@@ -169,7 +53,7 @@ module Make(Clock : V1.CLOCK) = struct
             return ()
         | Some frame ->
             let frame = fixup_checksums frame |> Cstruct.concat in
-            forward_ipv4 router (Cstruct.shift frame Wire_structs.sizeof_ethernet) in
+            Router.forward_ipv4 router (Cstruct.shift frame Wire_structs.sizeof_ethernet) in
       Netif.listen net0 (fun frame ->
         Eth.input
           ~arpv4:(Arp.input arp0)
@@ -185,14 +69,14 @@ module Make(Clock : V1.CLOCK) = struct
     Dao.set_iptables_error qubesDB "" >>= fun () ->
     Logs.info "Client (internal) network is %a"
       (fun f -> f Ipaddr.V4.Prefix.pp_hum config.Dao.clients_prefix);
-    let client_net = Client_net.create
+    let client_eth = Client_eth.create
       ~client_gw:config.Dao.clients_our_ip
       ~prefix:config.Dao.clients_prefix in
     let router = Router.create
       ~default_gateway:netvm_iface
-      ~client_net in
+      ~client_eth in
     Lwt.join [
-      watch_clients router;
+      Client_net.listen router;
       netvm_listen router
     ]
 end

router.ml

@@ -7,20 +7,20 @@ let src = Logs.Src.create "router" ~doc:"Router"
 module Log = (val Logs.src_log src : Logs.LOG)
 
 type t = {
-  client_net : Client_net.t;
+  client_eth : Client_eth.t;
   default_gateway : interface;
 }
 
-let create ~client_net ~default_gateway = { client_net; default_gateway }
+let create ~client_eth ~default_gateway = { client_eth; default_gateway }
 
-let client_net t = t.client_net
+let client_eth t = t.client_eth
 
 let target t buf =
   let open Wire_structs.Ipv4_wire in
   let dst_ip = get_ipv4_dst buf |> Ipaddr.V4.of_int32 in
   Log.debug "Got IPv4: dst=%s" (fun f -> f (Ipaddr.V4.to_string dst_ip));
-  if Ipaddr.V4.Prefix.mem dst_ip (Client_net.prefix t.client_net) then (
+  if Ipaddr.V4.Prefix.mem dst_ip (Client_eth.prefix t.client_eth) then (
-    match Client_net.lookup t.client_net dst_ip with
+    match Client_eth.lookup t.client_eth dst_ip with
     | Some client_link -> Some (client_link :> interface)
     | None ->
       Log.warn "Packet to unknown internal client %a - dropping"
@@ -28,5 +28,15 @@ let target t buf =
       None
   ) else Some t.default_gateway
 
-let add_client t = Client_net.add_client t.client_net
+let add_client t = Client_eth.add_client t.client_eth
-let remove_client t = Client_net.remove_client t.client_net
+let remove_client t = Client_eth.remove_client t.client_eth
+
+let forward_ipv4 router buf =
+  match Memory_pressure.status () with
+  | `Memory_critical -> (* TODO: should happen before copying and async *)
+      print_endline "Memory low - dropping packet";
+      return ()
+  | `Ok ->
+  match target router buf with
+  | Some iface -> iface#writev [buf]
+  | None -> return ()

router.mli

@@ -9,19 +9,22 @@ type t
 (** A routing table. *)
 
 val create :
-  client_net:Client_net.t ->
+  client_eth:Client_eth.t ->
   default_gateway:interface ->
   t
-(** [create ~client_net ~default_gateway] is a new routing table that routes packets outside
+(** [create ~client_eth ~default_gateway] is a new routing table that routes packets outside
-    of [client_net] to [default_gateway]. *)
+    of [client_eth] to [default_gateway]. *)
 
-val client_net : t -> Client_net.t
+val client_eth : t -> Client_eth.t
 
 val target : t -> Cstruct.t -> interface option
 (** [target t packet] is the interface to which [packet] (an IP packet) should be routed. *)
 
 val add_client : t -> client_link -> unit
 (** [add_client t iface] adds a rule for routing packets addressed to [iface].
-    The client's IP address must be within the [client_net] passed to [create]. *)
+    The client's IP address must be within the [client_eth] passed to [create]. *)
 
 val remove_client : t -> client_link -> unit
+
+val forward_ipv4 : t -> Cstruct.t -> unit Lwt.t
+(** [forward_ipv4 t packet] sends the packet to [target t packet]. *)

utils.ml

@@ -31,6 +31,27 @@ class type client_link = object
   method client_mac : Macaddr.t
 end
 
+(** An Ethernet header from [src]'s MAC address to [dst]'s with an IPv4 payload. *)
+let eth_header_ipv4 ~src ~dst =
+  let open Wire_structs in
+  let frame = Cstruct.create sizeof_ethernet in
+  frame |> set_ethernet_src (Macaddr.to_bytes src) 0;
+  frame |> set_ethernet_dst (Macaddr.to_bytes dst) 0;
+  set_ethernet_ethertype frame (ethertype_to_int IPv4);
+  frame
+
+(** Recalculate checksums after modifying packets.
+    Note that frames often arrive with invalid checksums due to checksum offload.
+    For now, we always calculate valid checksums for out-bound frames. *)
+let fixup_checksums frame =
+  match Nat_rewrite.layers frame with
+  | None -> raise (Invalid_argument "NAT transformation rendered packet unparseable")
+  | Some (ether, ip, tx) ->
+    let (just_headers, higherlevel_data) =
+      Nat_rewrite.recalculate_transport_checksum (ether, ip, tx)
+    in
+    [just_headers; higherlevel_data]
+
 let (===) a b = (Ipaddr.V4.compare a b = 0)
 
 let error fmt =
@@ -45,3 +66,7 @@ let set_fixed_string buffer str =
   let len = String.length str in
   Cstruct.blit_from_string str 0 buffer 0 len;
   Cstruct.memset (Cstruct.shift buffer len) 0
+
+let or_fail msg = function
+  | `Ok x -> return x
+  | `Error _ -> fail (Failure msg)