Merge pull request #152 from hannesm/next-release

Next release
2024-10-01 01:05:39 -04:00 · 2022-10-12 09:05:55 +02:00 · 2022-10-12 09:05:55 +02:00 · 065c8bb69a
commit 065c8bb69a
parent 721f552a3c b958c10690
17 changed files with 124 additions and 226 deletions
--- a/2
+++ b/2
@ -11,7 +11,7 @@ RUN sudo ln -sf /usr/bin/opam-2.1 /usr/bin/opam
 # Pin last known-good version for reproducible builds.
 # Remove this line (and the base image pin above) if you want to test with the
 # latest versions.
-RUN cd /home/opam/opam-repository && git fetch origin master && git reset --hard 632ef7fd6add02a7789f896751c51b408dca0373 && opam update
+RUN cd /home/opam/opam-repository && git fetch origin master && git reset --hard 0f451c34c56458ee18495a98eb35d7dcb14f519a && opam update

 RUN opam install -y mirage opam-monorepo
 RUN mkdir /home/opam/qubes-mirage-firewall
--- a/README.md
+++ b/README.md
@ -70,8 +70,8 @@ Run this command in dom0 to create a `mirage-firewall` VM using the `mirage-fire
 qvm-create \
  --property kernel=mirage-firewall \
  --property kernelopts='' \
-  --property memory=64 \
-  --property maxmem=64 \
+  --property memory=32 \
+  --property maxmem=32 \
  --property netvm=sys-net \
  --property provides_network=True \
  --property vcpus=1 \
@ -137,7 +137,7 @@ The boot process:
 For development, use the [test-mirage][] scripts to deploy the unikernel (`qubes-firewall.xen`) from your development AppVM.
 This takes a little more setting up the first time, but will be much quicker after that. e.g.

-    $ test-mirage qubes_firewall.xen mirage-firewall
+    $ test-mirage dist/qubes-firewall.xen mirage-firewall
    Waiting for 'Ready'... OK
    Uploading 'dist/qubes-firewall.xen' (7454880 bytes) to "mirage-test"
    Waiting for 'Booting'... OK
@ -148,25 +148,25 @@ This takes a little more setting up the first time, but will be much quicker aft
    \__ \ (   | | (   |  ) |
    ____/\___/ _|\___/____/
    Solo5: Bindings version v0.7.3
-    Solo5: Memory map: 64 MB addressable:
+    Solo5: Memory map: 32 MB addressable:
    Solo5:   reserved @ (0x0 - 0xfffff)
-    Solo5:       text @ (0x100000 - 0x31bfff)
-    Solo5:     rodata @ (0x31c000 - 0x386fff)
-    Solo5:       data @ (0x387000 - 0x544fff)
-    Solo5:       heap >= 0x545000 < stack < 0x4000000
+    Solo5:       text @ (0x100000 - 0x319fff)
+    Solo5:     rodata @ (0x31a000 - 0x384fff)
+    Solo5:       data @ (0x385000 - 0x53ffff)
+    Solo5:       heap >= 0x540000 < stack < 0x2000000
    2022-08-13 14:55:38 -00:00: INF [qubes.rexec] waiting for client...
-    2022-08-13 14:55:38 -00:00: INF [qubes.gui] waiting for client...
    2022-08-13 14:55:38 -00:00: INF [qubes.db] connecting to server...
    2022-08-13 14:55:38 -00:00: INF [qubes.db] connected
    2022-08-13 14:55:38 -00:00: INF [qubes.db] got update: "/mapped-ip/10.137.0.20/visible-ip" = "10.137.0.20"
    2022-08-13 14:55:38 -00:00: INF [qubes.db] got update: "/mapped-ip/10.137.0.20/visible-gateway" = "10.137.0.23"
-    2022-08-13 14:55:38 -00:00: INF [qubes.rexec] client connected, other end wants to use protocol version 3, continuing with version 2
+    2022-08-13 14:55:38 -00:00: INF [qubes.rexec] client connected, using protocol version 3
    2022-08-13 14:55:38 -00:00: INF [unikernel] QubesDB and qrexec agents connected in 0.041 s
    2022-08-13 14:55:38 -00:00: INF [dao] Got network configuration from QubesDB:
                NetVM IP on uplink network: 10.137.0.4
                Our IP on uplink network:   10.137.0.23
                Our IP on client networks:  10.137.0.23
                DNS resolver:               10.139.1.1
+                DNS secondary resolver:     10.139.1.2
    2022-08-13 14:55:38 -00:00: INF [net-xen frontend] connect 0
    2022-08-13 14:55:38 -00:00: INF [net-xen frontend] create: id=0 domid=1
    2022-08-13 14:55:38 -00:00: INF [net-xen frontend]  sg:true gso_tcpv4:true rx_copy:true rx_flip:false smart_poll:false
@ -176,7 +176,7 @@ This takes a little more setting up the first time, but will be much quicker aft
    2022-08-13 14:55:38 -00:00: INF [ARP] Sending gratuitous ARP for 10.137.0.23 (00:16:3e:5e:6c:00)
    2022-08-13 14:55:38 -00:00: INF [udp] UDP layer connected on 10.137.0.23
    2022-08-13 14:55:38 -00:00: INF [dao] Watching backend/vif
-    2022-08-13 14:55:38 -00:00: INF [memory_pressure] Writing meminfo: free 52MiB / 59MiB (87.55 %)
+    2022-08-13 14:55:38 -00:00: INF [memory_pressure] Writing meminfo: free 20MiB / 27MiB (72.68 %)

 # Testing if the firewall works

--- a/build-with-docker.sh
+++ b/build-with-docker.sh
@ -5,5 +5,5 @@ docker build -t qubes-mirage-firewall .
 echo Building Firewall...
 docker run --rm -i -v `pwd`:/home/opam/qubes-mirage-firewall qubes-mirage-firewall
 echo "SHA2 of build:   $(sha256sum ./dist/qubes-firewall.xen)"
-echo "SHA2 last known: d0ec19d5b392509955edccf100852bcc9c0e05bf31f1ec25c9cc9c9e74c3b7bf"
+echo "SHA2 last known: 73488b0c54d6c43d662ddf58916b6d472430894f6394c6bdb8a879723abcc06f"
 echo "(hashes should match for released versions)"
--- a/client_net.ml
+++ b/client_net.ml
@ -29,7 +29,6 @@ let writev eth dst proto fillfn =
 class client_iface eth ~domid ~gateway_ip ~client_ip client_mac : client_link =
  let log_header = Fmt.str "dom%d:%a" domid Ipaddr.V4.pp client_ip in
  object
-    val queue = FrameQ.create (Ipaddr.V4.to_string client_ip)
    val mutable rules = []
    method get_rules = rules
    method set_rules new_db = rules <- Dao.read_rules new_db client_ip
@ -38,9 +37,7 @@ class client_iface eth ~domid ~gateway_ip ~client_ip client_mac : client_link =
    method my_ip = gateway_ip
    method other_ip = client_ip
    method writev proto fillfn =
-      FrameQ.send queue (fun () ->
-          writev eth client_mac proto fillfn
-        )
+        writev eth client_mac proto fillfn
    method log_header = log_header
  end

@ -101,7 +98,7 @@ let add_vif get_ts { Dao.ClientVif.domid; device_id } dns_client dns_servers ~cl
                        (Ipaddr.V4.to_string client_ip)
                        Fmt.(list ~sep:(any "@.") Pf_qubes.Parse_qubes.pp_rule) new_rules);
            (* empty NAT table if rules are updated: they might deny old connections *)
-            My_nat.remove_connections router.Router.nat router.Router.ports client_ip;
+            My_nat.remove_connections router.Router.nat client_ip;
          end);
          update new_db new_rules
        in
--- a/config.ml
+++ b/config.ml
@ -28,7 +28,7 @@ let main =
      package "mirage-net-xen";
      package "ipaddr" ~min:"5.2.0";
      package "mirage-qubes" ~min:"0.9.1";
-      package "mirage-nat" ~min:"2.2.1";
+      package "mirage-nat" ~min:"3.0.0";
      package "mirage-logs";
      package "mirage-xen" ~min:"8.0.0";
      package ~min:"6.1.0" "dns-client";
--- a/firewall.ml
+++ b/firewall.ml
@ -47,7 +47,7 @@ let translate t packet =
 let add_nat_and_forward_ipv4 t packet =
  let open Router in
  let xl_host = t.uplink#my_ip in
-  My_nat.add_nat_rule_and_translate t.nat t.ports ~xl_host `NAT packet >>= function
+  match My_nat.add_nat_rule_and_translate t.nat ~xl_host `NAT packet with
  | Ok packet -> forward_ipv4 t packet
  | Error e ->
    Log.warn (fun f -> f "Failed to add NAT rewrite rule: %s (%a)" e Nat_packet.pp packet);
@ -60,7 +60,7 @@ let nat_to t ~host ~port packet =
  | Ipaddr.V6 _ -> Log.warn (fun f -> f "Cannot NAT with IPv6"); Lwt.return_unit
  | Ipaddr.V4 target ->
    let xl_host = t.uplink#my_ip in
-    My_nat.add_nat_rule_and_translate t.nat t.ports ~xl_host (`Redirect (target, port)) packet >>= function
+    match My_nat.add_nat_rule_and_translate t.nat ~xl_host (`Redirect (target, port)) packet with
    | Ok packet -> forward_ipv4 t packet
    | Error e ->
      Log.warn (fun f -> f "Failed to add NAT redirect rule: %s (%a)" e Nat_packet.pp packet);
@ -83,47 +83,39 @@ let apply_rules t (rules : ('a, 'b) Packet.t -> Packet.action Lwt.t) ~dst (annot
      Log.debug (fun f -> f "Dropped packet (%s) %a" reason Nat_packet.pp packet);
      Lwt.return_unit

-let handle_low_memory t =
-  match Memory_pressure.status () with
-  | `Memory_critical -> (* TODO: should happen before copying and async *)
-      Log.warn (fun f -> f "Memory low - dropping packet and resetting NAT table");
-      My_nat.reset t.Router.nat t.Router.ports >|= fun () ->
-      `Memory_critical
-  | `Ok -> Lwt.return `Ok
-
 let ipv4_from_client resolver dns_servers t ~src packet =
-  handle_low_memory t >>= function
+  match Memory_pressure.status () with
  | `Memory_critical -> Lwt.return_unit
  | `Ok ->
  (* Check for existing NAT entry for this packet *)
-  translate t packet >>= function
-  | Some frame -> forward_ipv4 t frame  (* Some existing connection or redirect *)
-  | None ->
-  (* No existing NAT entry. Check the firewall rules. *)
-  let `IPv4 (ip, _transport) = packet in
-  let dst = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in
-  match of_mirage_nat_packet ~src:(`Client src) ~dst packet with
-  | None -> Lwt.return_unit
-  | Some firewall_packet -> apply_rules t (Rules.from_client resolver dns_servers) ~dst firewall_packet
+    match translate t packet with
+    | Some frame -> forward_ipv4 t frame  (* Some existing connection or redirect *)
+    | None ->
+      (* No existing NAT entry. Check the firewall rules. *)
+      let `IPv4 (ip, _transport) = packet in
+      let dst = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in
+      match of_mirage_nat_packet ~src:(`Client src) ~dst packet with
+      | None -> Lwt.return_unit
+      | Some firewall_packet -> apply_rules t (Rules.from_client resolver dns_servers) ~dst firewall_packet

 let ipv4_from_netvm t packet =
-  handle_low_memory t >>= function
+  match Memory_pressure.status () with
  | `Memory_critical -> Lwt.return_unit
  | `Ok ->
-  let `IPv4 (ip, _transport) = packet in
-  let src = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.src) in
-  let dst = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in
-  match Packet.of_mirage_nat_packet ~src ~dst packet with
-  | None -> Lwt.return_unit
-  | Some _ ->
-  match src with
-  | `Client _ | `Firewall ->
-    Log.warn (fun f -> f "Frame from NetVM has internal source IP address! %a" Nat_packet.pp packet);
-    Lwt.return_unit
-  | `External _ | `NetVM as src ->
-  translate t packet >>= function
-  | Some frame -> forward_ipv4 t frame
-  | None ->
+    let `IPv4 (ip, _transport) = packet in
+    let src = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.src) in
+    let dst = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in
    match Packet.of_mirage_nat_packet ~src ~dst packet with
    | None -> Lwt.return_unit
-    | Some packet -> apply_rules t Rules.from_netvm ~dst packet
+    | Some _ ->
+      match src with
+      | `Client _ | `Firewall ->
+        Log.warn (fun f -> f "Frame from NetVM has internal source IP address! %a" Nat_packet.pp packet);
+        Lwt.return_unit
+      | `External _ | `NetVM as src ->
+        match translate t packet with
+        | Some frame -> forward_ipv4 t frame
+        | None ->
+          match Packet.of_mirage_nat_packet ~src ~dst packet with
+          | None -> Lwt.return_unit
+          | Some packet -> apply_rules t Rules.from_netvm ~dst packet
--- a/frameQ.ml
+++ b/frameQ.ml
@ -1,32 +0,0 @@
-(* Copyright (C) 2016, Thomas Leonard <thomas.leonard@unikernel.com>
-   See the README file for details. *)
-
-let src = Logs.Src.create "frameQ" ~doc:"Interface output queue"
-module Log = (val Logs.src_log src : Logs.LOG)
-
-type t = {
-  name : string;
-  mutable items : int;
-}
-
-let create name = { name; items = 0 }
-
-(* Note: the queue is only used if we already filled the transmit buffer. *)
-let max_qlen = 10
-
-let send q fn =
-  if q.items = max_qlen then (
-    Log.warn (fun f -> f "Maximum queue length exceeded for %s: dropping frame" q.name);
-    Lwt.return_unit
-  ) else (
-    let sent = fn () in
-    if Lwt.state sent = Lwt.Sleep then (
-      q.items <- q.items + 1;
-      Log.info (fun f -> f "Queue length for %s: incr to %d" q.name q.items);
-      Lwt.on_termination sent (fun () ->
-        q.items <- q.items - 1;
-        Log.info (fun f -> f "Queue length for %s: decr to %d" q.name q.items);
-      )
-    );
-    sent
-  )
--- a/frameQ.mli
+++ b/frameQ.mli
@ -1,15 +0,0 @@
-(* Copyright (C) 2016, Thomas Leonard <thomas.leonard@unikernel.com>
-   See the README file for details. *)
-
-(** Keep track of the queue length for output buffers. *)
-
-type t
-
-val create : string -> t
-(** [create name] is a new empty queue. [name] is used in log messages. *)
-
-val send : t -> (unit -> unit Lwt.t) -> unit Lwt.t
-(** [send t fn] checks that the queue isn't overloaded and calls [fn ()] if it's OK.
-    The item is considered to be queued until the result of [fn] has resolved.
-    In the case of mirage-net-xen's [writev], this happens when the frame has been
-    added to the ring (not when it is consumed), which is fine for us. *)
--- a/memory_pressure.ml
+++ b/memory_pressure.ml
@ -54,7 +54,6 @@ let print_mem_usage =
 let init () =
  Gc.full_major ();
  let stats = Xen_os.Memory.quick_stat () in
-  print_mem_usage ;
  report_mem_usage stats

 let status () =
@ -64,7 +63,8 @@ let status () =
    Gc.full_major ();
    Xen_os.Memory.trim ();
    let stats = Xen_os.Memory.quick_stat () in
-    report_mem_usage stats;
-    if fraction_free stats < 0.6 then `Memory_critical
-    else `Ok
+    if fraction_free stats < 0.6 then begin
+      report_mem_usage stats;
+      `Memory_critical
+    end else `Ok
  )
--- a/my_dns.ml
+++ b/my_dns.ml
@ -35,12 +35,14 @@ module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) (Time : Mirage_
    let open My_nat in
    let dst, dst_port = ctx.nameserver in
    let router, send_udp, answer = ctx.stack in
-    let src_port = Ports.pick_free_port ~consult:router.ports.nat_udp router.ports.dns_udp in
+    let src_port, evict =
+      My_nat.free_udp_port router.nat ~src:router.uplink#my_ip ~dst ~dst_port:53
+    in
    with_timeout ctx.timeout_ns
      ((send_udp ~src_port ~dst ~dst_port buf >|= Rresult.R.open_error_msg) >>= function
        | Ok () -> (Lwt_mvar.take answer >|= fun (_, dns_response) -> Ok dns_response)
        | Error _ as e -> Lwt.return e) >|= fun result ->
-    router.ports.dns_udp := Ports.remove src_port !(router.ports.dns_udp);
+    evict ();
    result

  let close _ = Lwt.return_unit
--- a/my_nat.ml
+++ b/my_nat.ml
@ -11,34 +11,62 @@ type action = [
  | `Redirect of Mirage_nat.endpoint
 ]

-type ports = {
-  nat_tcp : Ports.t ref;
-  nat_udp : Ports.t ref;
-  nat_icmp : Ports.t ref;
-  dns_udp : Ports.t ref;
-}
-
-let empty_ports () =
-  let nat_tcp = ref Ports.empty in
-  let nat_udp = ref Ports.empty in
-  let nat_icmp = ref Ports.empty in
-  let dns_udp = ref Ports.empty in
-  { nat_tcp ; nat_udp ; nat_icmp ; dns_udp }
-
 module Nat = Mirage_nat_lru

+module S =
+  Set.Make(struct type t = int let compare (a : int) (b : int) = compare a b end)
+
 type t = {
  table : Nat.t;
+  mutable udp_dns : S.t;
+  last_resort_port : int
 }

+let pick_port () =
+  1024 + Random.int (0xffff - 1024)
+
 let create ~max_entries =
  let tcp_size = 7 * max_entries / 8 in
  let udp_size = max_entries - tcp_size in
-  Nat.empty ~tcp_size ~udp_size ~icmp_size:100 >|= fun table ->
-  { table }
+  let table = Nat.empty ~tcp_size ~udp_size ~icmp_size:100 in
+  let last_resort_port = pick_port () in
+  { table ; udp_dns = S.empty ; last_resort_port }
+
+let pick_free_port t proto =
+  let rec go retries =
+    if retries = 0 then
+      None
+    else
+      let p = 1024 + Random.int (0xffff - 1024) in
+      match proto with
+      | `Udp when S.mem p t.udp_dns || p = t.last_resort_port ->
+        go (retries - 1)
+      | _ -> Some p
+  in
+  go 10
+
+let free_udp_port t ~src ~dst ~dst_port =
+  let rec go () =
+    let src_port =
+      Option.value ~default:t.last_resort_port (pick_free_port t `Udp)
+    in
+    if Nat.is_port_free t.table `Udp ~src ~dst ~src_port ~dst_port then begin
+      let remove =
+        if src_port <> t.last_resort_port then begin
+          t.udp_dns <- S.add src_port t.udp_dns;
+          (fun () -> t.udp_dns <- S.remove src_port t.udp_dns)
+        end else Fun.id
+      in
+      src_port, remove
+    end else
+      go ()
+  in
+  go ()
+
+let dns_port t port = S.mem port t.udp_dns || port = t.last_resort_port

 let translate t packet =
-  Nat.translate t.table packet >|= function
+  match Nat.translate t.table packet with
  | Error (`Untranslated | `TTL_exceeded as e) ->
    Log.debug (fun f -> f "Failed to NAT %a: %a"
                  Nat_packet.pp packet
@ -47,63 +75,19 @@ let translate t packet =
    None
  | Ok packet -> Some packet

-let pick_free_port ~nat_ports ~dns_ports =
-  Ports.pick_free_port ~consult:dns_ports nat_ports
+let remove_connections t ip =
+  ignore (Nat.remove_connections t.table ip)

-(* just clears the nat ports, dns ports stay as is *)
-let reset t ports =
-  ports.nat_tcp := Ports.empty;
-  ports.nat_udp := Ports.empty;
-  ports.nat_icmp := Ports.empty;
-  Nat.reset t.table
-
-let remove_connections t ports ip =
-  let freed_ports = Nat.remove_connections t.table ip in
-  ports.nat_tcp := Ports.diff !(ports.nat_tcp) (Ports.of_list freed_ports.Mirage_nat.tcp);
-  ports.nat_udp := Ports.diff !(ports.nat_udp) (Ports.of_list freed_ports.Mirage_nat.udp);
-  ports.nat_icmp := Ports.diff !(ports.nat_icmp) (Ports.of_list freed_ports.Mirage_nat.icmp)
-
-let add_nat_rule_and_translate t ports ~xl_host action packet =
-  let apply_action xl_port =
-    Lwt.catch (fun () ->
-        Nat.add t.table packet (xl_host, xl_port) action
-      )
-      (function
-        | Out_of_memory -> Lwt.return (Error `Out_of_memory)
-        | x -> Lwt.fail x
-      )
+let add_nat_rule_and_translate t ~xl_host action packet =
+  let proto = match packet with
+    | `IPv4 (_, `TCP _) -> `Tcp
+    | `IPv4 (_, `UDP _) -> `Udp
+    | `IPv4 (_, `ICMP _) -> `Icmp
  in
-  let rec aux ~retries =
-    let nat_ports, dns_ports =
-      match packet with
-      | `IPv4 (_, `TCP _) -> ports.nat_tcp, ref Ports.empty
-      | `IPv4 (_, `UDP _) -> ports.nat_udp, ports.dns_udp
-      | `IPv4 (_, `ICMP _) -> ports.nat_icmp, ref Ports.empty
-    in
-    let xl_port = pick_free_port ~nat_ports ~dns_ports in
-    apply_action xl_port >>= function
-    | Error `Out_of_memory ->
-      (* Because hash tables resize in big steps, this can happen even if we have a fair
-         chunk of free memory. *)
-      Log.warn (fun f -> f "Out_of_memory adding NAT rule. Dropping NAT table...");
-      reset t ports >>= fun () ->
-      aux ~retries:(retries - 1)
-    | Error `Overlap when retries < 0 -> Lwt.return (Error "Too many retries")
-    | Error `Overlap ->
-      if retries = 0 then (
-        Log.warn (fun f -> f "Failed to find a free port; resetting NAT table");
-        reset t ports >>= fun () ->
-        aux ~retries:(retries - 1)
-      ) else (
-        aux ~retries:(retries - 1)
-      )
-    | Error `Cannot_NAT ->
-      Lwt.return (Error "Cannot NAT this packet")
-    | Ok () ->
-      Log.debug (fun f -> f "Updated NAT table: %a" Nat.pp_summary t.table);
-      translate t packet >|= function
-      | None -> Error "No NAT entry, even after adding one!"
-      | Some packet ->
-        Ok packet
-  in
-  aux ~retries:100
+  match Nat.add t.table packet xl_host (fun () -> pick_free_port t proto) action with
+  | Error `Overlap -> Error "Too many retries"
+  | Error `Cannot_NAT -> Error "Cannot NAT this packet"
+  | Ok () ->
+    Log.debug (fun f -> f "Updated NAT table: %a" Nat.pp_summary t.table);
+    Option.to_result ~none:"No NAT entry, even after adding one!"
+      (translate t packet)
--- a/my_nat.mli
+++ b/my_nat.mli
@ -3,15 +3,6 @@

 (* Abstract over NAT interface (todo: remove this) *)

-type ports = private {
-  nat_tcp : Ports.t ref;
-  nat_udp : Ports.t ref;
-  nat_icmp : Ports.t ref;
-  dns_udp : Ports.t ref;
-}
-
-val empty_ports : unit -> ports
-
 type t

 type action = [
@ -19,9 +10,11 @@ type action = [
  | `Redirect of Mirage_nat.endpoint
 ]

-val create : max_entries:int -> t Lwt.t
-val reset : t -> ports -> unit Lwt.t
-val remove_connections : t -> ports -> Ipaddr.V4.t -> unit
-val translate : t -> Nat_packet.t -> Nat_packet.t option Lwt.t
-val add_nat_rule_and_translate : t -> ports ->
-  xl_host:Ipaddr.V4.t -> action -> Nat_packet.t -> (Nat_packet.t, string) result Lwt.t
+val free_udp_port : t -> src:Ipaddr.V4.t -> dst:Ipaddr.V4.t -> dst_port:int ->
+  int * (unit -> unit)
+val dns_port : t -> int -> bool
+val create : max_entries:int -> t
+val remove_connections : t -> Ipaddr.V4.t -> unit
+val translate : t -> Nat_packet.t -> Nat_packet.t option
+val add_nat_rule_and_translate : t ->
+  xl_host:Ipaddr.V4.t -> action -> Nat_packet.t -> (Nat_packet.t, string) result
--- a/ports.ml
+++ b/ports.ml
@ -1,16 +0,0 @@
-module Set = Set.Make(struct
-  type t = int
-  let compare a b = compare a b
-end)
-
-include Set
-
-let rec pick_free_port ?(retries = 10) ~consult add_to =
-  let p = 1024 + Random.int (0xffff - 1024) in
-  if (mem p !consult || mem p !add_to) && retries <> 0
-  then pick_free_port ~retries:(retries - 1) ~consult add_to
-  else
-    begin
-      add_to := add p !add_to;
-      p
-    end
--- a/router.ml
+++ b/router.ml
@ -9,13 +9,10 @@ type t = {
  client_eth : Client_eth.t;
  nat : My_nat.t;
  uplink : interface;
-  (* NOTE: do not try to make this pure, it relies on mvars / side effects *)
-  ports : My_nat.ports;
 }

 let create ~client_eth ~uplink ~nat =
-  let ports = My_nat.empty_ports () in
-  { client_eth; nat; uplink; ports }
+  { client_eth; nat; uplink }

 let target t buf =
  let dst_ip = buf.Ipv4_packet.dst in
--- a/router.mli
+++ b/router.mli
@ -9,7 +9,6 @@ type t = private {
  client_eth : Client_eth.t;
  nat : My_nat.t;
  uplink : interface;
-  ports : My_nat.ports;
 }

 val create :
--- a/unikernel.ml
+++ b/unikernel.ml
@ -45,7 +45,7 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_tim
      Lwt.return_unit in
    (* Set up networking *)
    let max_entries = Key_gen.nat_table_size () in
-    My_nat.create ~max_entries >>= fun nat ->
+    let nat = My_nat.create ~max_entries in

    (* Read network configuration from QubesDB *)
    Dao.read_network_config qubesDB >>= fun config ->
--- a/uplink.ml
+++ b/uplink.ml
@ -25,15 +25,12 @@ module Make (R:Mirage_random.S) (Clock : Mirage_clock.MCLOCK) (Time : Mirage_tim
  }

 class netvm_iface eth mac ~my_ip ~other_ip : interface = object
-  val queue = FrameQ.create (Ipaddr.V4.to_string other_ip)
  method my_mac = Eth.mac eth
  method my_ip = my_ip
  method other_ip = other_ip
  method writev ethertype fillfn =
-    FrameQ.send queue (fun () ->
-      mac >>= fun dst ->
-      Eth.write eth dst ethertype fillfn >|= or_raise "Write to uplink" Eth.pp_error
-    )
+    mac >>= fun dst ->
+    Eth.write eth dst ethertype fillfn >|= or_raise "Write to uplink" Eth.pp_error
 end

  let send_dns_client_query t ~src_port ~dst ~dst_port buf =
@ -47,7 +44,7 @@ end

      Log.debug (fun f -> f "received ipv4 packet from %a on uplink" Ipaddr.V4.pp ip_header.Ipv4_packet.src);
      match ip_packet with
-      | `UDP (header, packet) when Ports.mem header.dst_port !(router.Router.ports.My_nat.dns_udp) ->
+      | `UDP (header, packet) when My_nat.dns_port router.Router.nat header.dst_port ->
        Log.debug (fun f -> f "found a DNS packet whose dst_port (%d) was in the list of dns_client ports" header.dst_port);
        Lwt_mvar.put dns_responses (header, packet)
      | _ ->