Merge pull request #199 from hannesm/update-opam-repo

update opam repository in Dockerfile

.github/workflows/docker.yml

@@ -21,9 +21,9 @@ jobs:
       - name: Checkout code
         uses: actions/checkout@v2
 
-      - run: ./build-with-docker.sh
+      - run: ./build-with.sh docker
 
-      - run: sh -exc 'if [ $(sha256sum dist/qubes-firewall.xen | cut -d " " -f 1) = $(grep "SHA2 last known" build-with-docker.sh | rev | cut -d ":" -f 1 | rev | cut -d "\"" -f 1 | tr -d " ") ]; then echo "SHA256 MATCHES"; else exit 42; fi'
+      - run: sh -exc 'if [ $(sha256sum dist/qubes-firewall.xen | cut -d " " -f 1) = $(grep "SHA2 last known" build-with.sh | rev | cut -d ":" -f 1 | rev | cut -d "\"" -f 1 | tr -d " ") ]; then echo "SHA256 MATCHES"; else exit 42; fi'
 
       - name: Upload Artifact
         uses: actions/upload-artifact@v3

.github/workflows/podman.yml

@@ -0,0 +1,32 @@
+name: Main workflow
+
+on:
+  pull_request:
+  push:
+  schedule:
+    # Prime the caches every Monday
+    - cron: 0 1 * * MON
+
+jobs:
+  build:
+    strategy:
+      fail-fast: false
+      matrix:
+        os:
+          - ubuntu-latest
+
+    runs-on: ${{ matrix.os }}
+
+    steps:
+      - name: Checkout code
+        uses: actions/checkout@v2
+
+      - run: ./build-with.sh podman
+
+      - run: sh -exc 'if [ $(sha256sum dist/qubes-firewall.xen | cut -d " " -f 1) = $(grep "SHA2 last known" build-with.sh | rev | cut -d ":" -f 1 | rev | cut -d "\"" -f 1 | tr -d " ") ]; then echo "SHA256 MATCHES"; else exit 42; fi'
+
+      - name: Upload Artifact
+        uses: actions/upload-artifact@v3
+        with:
+          name: mirage-firewall.tar.bz2
+          path: mirage-firewall.tar.bz2

CHANGES.md

@@ -1,3 +1,35 @@
+### 0.9.1 (2024-05-10)
+
+- Drop astring dependency, update mirage-net-xen, and OCaml 4.14.2 -- the
+  latest LTS release (#193, @hannesm)
+- Allow the firewall to use domains requests in rules (#193, @palainp,
+  reported in the Qubes forum, fix confirmed by @neoniobium)
+
+### 0.9.0 (2024-04-24)
+
+- Fix an incorrect free memory estimation (fix in mirage/ocaml-solo5#135
+  @palainp)
+- Update to mirage 4.5.0, allowing openBSD to be used as netvm (#146 reported
+  by @Szewcson), and recover from a netvm change (#156 reported by @xaki-23)
+  (#178 @palainp)
+
+### 0.8.6 (2023-11-08)
+
+- Fix Docker build issue with newest SELinux policies (#183 @palainp, reported
+  by @Szewcson)
+- Update build script (change to debian repositories, update debian image, update
+  opam-repository commit, set commit for opam-overlay and mirage-overlay) (#184
+  @palainp, reported by @ben-grande)
+- Update disk usage value during local compilation (#186 @palainp, reported by
+  @ben-grande)
+
+### 0.8.5 (2023-07-05)
+
+- Remove memreport to Xen to avoid Qubes trying to get back some memory
+  (#176 @palainp)
+- Use bookworm and snapshot.notset.fr debian packages for reproducibility
+  (#175 @palainp)
+
 ### 0.8.4 (2022-12-07)
 
 - Fix remote denial of service due to excessive console output (#166 @burghardt,

Dockerfile

@@ -1,21 +1,35 @@
 # Pin the base image to a specific hash for maximum reproducibility.
 # It will probably still work on newer images, though, unless an update
 # changes some compiler optimisations (unlikely).
-# ubuntu-20.04
-FROM ubuntu@sha256:b25ef49a40b7797937d0d23eca3b0a41701af6757afca23d504d50826f0b37ce
+# bookworm-slim taken from https://hub.docker.com/_/debian/tags?page=1&name=bookworm-slim
+FROM debian@sha256:3d5df92588469a4c503adbead0e4129ef3f88e223954011c2169073897547cac
+# install remove default packages repository
+RUN rm /etc/apt/sources.list.d/debian.sources
+# and set the package source to a specific release too
+# taken from https://snapshot.debian.org/archive/debian
+RUN printf "deb [check-valid-until=no] http://snapshot.debian.org/archive/debian/20240419T024211Z bookworm main\n" > /etc/apt/sources.list
+# taken from https://snapshot.debian.org/archive/debian-security/
+RUN printf "deb [check-valid-until=no] http://snapshot.debian.org/archive/debian-security/20240419T111010Z bookworm-security main\n" >> /etc/apt/sources.list
 
-RUN apt update && apt install --no-install-recommends --no-install-suggests -y wget ca-certificates git patch unzip make gcc g++ libc-dev
-RUN wget -O /usr/bin/opam https://github.com/ocaml/opam/releases/download/2.1.3/opam-2.1.3-i686-linux && chmod 755 /usr/bin/opam
+RUN apt update && apt install --no-install-recommends --no-install-suggests -y wget ca-certificates git patch unzip bzip2 make gcc g++ libc-dev
+RUN wget -O /usr/bin/opam https://github.com/ocaml/opam/releases/download/2.1.5/opam-2.1.5-i686-linux && chmod 755 /usr/bin/opam
+# taken from https://raw.githubusercontent.com/ocaml/opam/master/shell/install.sh
+RUN test `sha512sum /usr/bin/opam | cut -d' ' -f1` = \
+"38802b3079eeceb27aab3465bfd0f9f05a710dccf9487eb35fa2c02fbaf9a0659e1447aa19dd36df9cd01f760229de28c523c08c1c86a3aa3f5e25dbe7b551dd" || exit
 
 ENV OPAMROOT=/tmp
 ENV OPAMCONFIRMLEVEL=unsafe-yes
 # 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 opam init --disable-sandboxing -a --bare https://github.com/ocaml/opam-repository.git#c9b2f766b7c7009be8cd68ac423d0d5b36044aca
-RUN opam switch create myswitch 4.14.0
+# taken from https://github.com/ocaml/opam-repository
+RUN opam init --disable-sandboxing -a --bare https://github.com/ocaml/opam-repository.git#13acffc3de9c22953d1e08bad3e56ee6e965eeed
+RUN opam switch create myswitch 4.14.2
 RUN opam exec -- opam install -y mirage opam-monorepo ocaml-solo5
 RUN mkdir /tmp/orb-build
 ADD config.ml /tmp/orb-build/config.ml
 WORKDIR /tmp/orb-build
-CMD opam exec -- sh -exc 'mirage configure -t xen --allocation-policy=best-fit && make depend && make tar'
+CMD opam exec -- sh -exc 'mirage configure -t xen --extra-repos=\
+opam-overlays:https://github.com/dune-universe/opam-overlays.git#4e75ee36715b27550d5bdb87686bb4ae4c9e89c4,\
+mirage-overlays:https://github.com/dune-universe/mirage-opam-overlays.git#797cb363df3ff763c43c8fbec5cd44de2878757e \
+&& make depend && make tar'

Makefile.builder

@@ -1,5 +1,5 @@
 MIRAGE_KERNEL_NAME = dist/qubes-firewall.xen
-OCAML_VERSION ?= 4.14.0
+OCAML_VERSION ?= 4.14.2
 SOURCE_BUILD_DEP := firewall-build-dep
 
 firewall-build-dep:

Makefile.user

@@ -6,7 +6,8 @@ tar: build
 	cp dist/qubes-firewall.xen _build/mirage-firewall/vmlinuz
 	touch _build/mirage-firewall/modules.img
 	cat /dev/null | gzip -n > _build/mirage-firewall/initramfs
-	tar cjf mirage-firewall.tar.bz2 -C _build --mtime=./build-with-docker.sh mirage-firewall
+	tar cjf mirage-firewall.tar.bz2 -C _build --mtime=./build-with.sh mirage-firewall
+	sha256sum mirage-firewall.tar.bz2 > mirage-firewall.sha256
 
 fetchmotron: qubes_firewall.xen
 	test-mirage qubes_firewall.xen mirage-fw-test &

README.md

@@ -13,42 +13,51 @@ See the [Deploy](#deploy) section below for installation instructions.
 
 ## Build from source
 
-Note: The most reliable way to build is using Docker.
-Fedora 35 works well for this and Debian 11 also works, but you'll need to follow the instructions at [docker.com][debian-docker] to get Docker
+Note: The most reliable way to build is using Docker or Podman.
+Fedora 38 works well for this, Debian 12 also works, but you'll need to follow the instructions at [docker.com][debian-docker] to get Docker
 (don't use Debian's version).
 
-Create a new Fedora-35 AppVM (or reuse an existing one). In the Qube's Settings (Basic / Disk storage), increase the private storage max size from the default 2048 MiB to 4096 MiB. Open a terminal.
+Create a new Fedora-38 AppVM (or reuse an existing one). In the Qube's Settings (Basic / Disk storage), increase the private storage max size from the default 2048 MiB to 8192 MiB. Open a terminal.
 
-Clone this Git repository and run the `build-with-docker.sh` script:
+Clone this Git repository and run the `build-with.sh` script with either `docker` or `podman` as argument (Note: The `chcon` call is mandatory on Fedora with new SELinux policies which do not allow to standardly keep the docker images in homedir):
 
     mkdir /home/user/docker
     sudo ln -s /home/user/docker /var/lib/docker
+    sudo chcon -Rt container_file_t /home/user/docker
     sudo dnf install docker
     sudo systemctl start docker
     git clone https://github.com/mirage/qubes-mirage-firewall.git
     cd qubes-mirage-firewall
-    sudo ./build-with-docker.sh
+    sudo ./build-with.sh docker
 
-This took about 10 minutes on my laptop (it will be much quicker if you run it again).
-The symlink step at the start isn't needed if your build VM is standalone.
-It gives Docker more disk space and avoids losing the Docker image cache when you reboot the Qube.
+Or
+
+    sudo systemctl start podman
+    git clone https://github.com/mirage/qubes-mirage-firewall.git
+    cd qubes-mirage-firewall
+    ./build-with.sh podman
+
+This took about 15 minutes on my laptop (it will be much quicker if you run it again).
+The symlink step at the start isn't needed if your build VM is standalone. It gives Docker more disk space and avoids losing the Docker image cache when you reboot the Qube.
+It's not needed with Podman as the containers lives in your home directory by default.
 
 Note: the object files are stored in the `_build` directory to speed up incremental builds.
 If you change the dependencies, you will need to delete this directory before rebuilding.
 
-It's OK to install the Docker package in a template VM if you want it to remain
+It's OK to install the Docker or Podman package in a template VM if you want it to remain
 after a reboot, but the build of the firewall itself should be done in a regular AppVM.
 
-You can also build without Docker, as for any normal Mirage unikernel;
+You can also build without that script, as for any normal Mirage unikernel;
 see [the Mirage installation instructions](https://mirage.io/wiki/install) for details.
 
-The Docker build fixes the versions of the libraries it uses, ensuring that you will get
-exactly the same binary that is in the release. If you build without Docker, it will build
+The build script fixes the versions of the libraries it uses, ensuring that you will get
+exactly the same binary that is in the release. If you build without it, it will build
 against the latest versions instead (and the hash will therefore probably not match).
 However, it should still work fine.
 
 ## Deploy
 
+### Manual deployment
 If you want to deploy manually, unpack `mirage-firewall.tar.bz2` in domU. The tarball contains `vmlinuz`,
 which is the unikernel itself, plus a dummy initramfs file that Qubes requires:
 
@@ -84,6 +93,9 @@ qvm-features mirage-firewall qubes-firewall 1
 qvm-features mirage-firewall no-default-kernelopts 1
 ```
 
+### Deployment using saltstack
+If you're familiar how to run salt states in Qubes, you can also use the script `SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls` to automatically deploy the latest version of mirage firewall in your Qubes OS. An introduction can be found [here](https://forum.qubes-os.org/t/qubes-salt-beginners-guide/20126) and [here](https://www.qubes-os.org/doc/salt/). Following the instructions from the former link, you can run the script in dom0 with the command `sudo qubesctl --show-output state.apply SaltScriptToDownloadAndInstallMirageFirewallInQubes saltenv=user`. The script checks the checksum from the integration server and compares with the latest version provided in the github releases. It might be necessary to adjust the VM templates in the script which are used for downloading of the mirage unikernel, if your default templates do not have the tools `curl` and `tar` installed by default. Also don't forget to change the VMs in which the uni kernel should be used or adjust the "Qubes Global Settings".
+
 ## Upgrading
 
 To upgrade from an earlier release, just overwrite `/var/lib/qubes/vm-kernels/mirage-firewall/vmlinuz` with the new version and restart the firewall VM.
@@ -109,6 +121,17 @@ https://www.qubes-os.org/doc/software-update-dom0/ says:
 > there are no significant security implications in this choice. By default,
 > this role is assigned to the firewallvm.
 
+### Configure firewall with OpenBSD-like netvm
+
+OpenBSD is currently unable to be used as netvm, so if you want to use a BSD as your sys-net VM, you'll need to set its netvm to qubes-mirage-firewall (see https://github.com/mirage/qubes-mirage-firewall/issues/146 for more information).
+That means you'll have `AppVMs -> qubes-mirage-firewall <- OpenBSD` with the arrow standing for the netvm property setting.
+
+In that case you'll have to tell qubes-mirage-firewall which AppVM client should be used as uplink:
+```
+qvm-prefs --set mirage-firewall -- kernelopts '--ipv4=X.X.X.X --ipv4-gw=Y.Y.Y.Y'
+```
+with `X.X.X.X` the IP address for mirage-firewall and `Y.Y.Y.Y` the IP address of your OpenBSD HVM.
+
 ### Components
 
 This diagram show the main components (each box corresponds to a source `.ml` file with the same name):
@@ -137,7 +160,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 dist/qubes-firewall.xen mirage-firewall
+    [user@dev ~]$ 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

SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls

@@ -0,0 +1,103 @@
+# How to install the superlight mirage-firewall for Qubes OS by using saltstack
+# Tested on Qubes v4.1 and mirage v0.8.5
+# After the install, you have to switch your AppVMs to use the mirage firewall vm created by this script e.g. by using "Qubes Global Settings"
+# inspired by: https://github.com/one7two99/my-qubes/tree/master/mirage-firewall
+
+# default template + dispvm template are used. Possible optimization is to use min-dvms
+{% set DownloadVMTemplate = salt['cmd.shell']("qubes-prefs default_template") %}
+{% set DispVM = salt['cmd.shell']("qubes-prefs default_dispvm") %}
+
+{% set DownloadVM = "DownloadVmMirage" %}
+{% set MirageFW = "sys-mirage-fw" %}
+{% set GithubUrl = "https://github.com/mirage/qubes-mirage-firewall" %}
+{% set Filename = "mirage-firewall.tar.bz2" %}
+{% set MirageInstallDir = "/var/lib/qubes/vm-kernels/mirage-firewall" %}
+
+#download and install the latest version
+{% set Release = salt['cmd.shell']("qvm-run --dispvm " ~ DispVM ~ " --pass-io \"curl --silent --location -o /dev/null -w %{url_effective} " ~ GithubUrl ~ "/releases/latest | rev | cut -d \"/\" -f 1 | rev\"") %}
+
+{% if Release != salt['cmd.shell']("[ ! -f " ~ MirageInstallDir ~ "/version.txt" ~ " ] && touch " ~ MirageInstallDir ~ "/version.txt" ~ ";cat " ~ MirageInstallDir ~ "/version.txt") %}
+
+create-downloader-VM:
+  qvm.vm:
+     - name: {{ DownloadVM }}
+     - present:
+       - template: {{ DownloadVMTemplate }}
+       - label: red
+     - prefs:
+       - template: {{ DownloadVMTemplate }}
+       - include-in-backups: false
+
+{% set DownloadBinary = GithubUrl ~ "/releases/download/" ~ Release ~ "/" ~ Filename %}
+
+download-and-unpack-in-DownloadVM4mirage:
+  cmd.run: 
+    - names:
+      - qvm-run --pass-io {{ DownloadVM }} {{ "curl -L -O " ~ DownloadBinary }}
+      - qvm-run --pass-io {{ DownloadVM }} {{ "tar -xvjf " ~ Filename }}
+    - require: 
+      - create-downloader-VM
+
+
+check-checksum-in-DownloadVM:
+  cmd.run: 
+    - names:
+      - qvm-run --pass-io {{ DownloadVM }} {{ "\"echo \\\"Checksum of last build on github:\\\";curl -s https://raw.githubusercontent.com/mirage/qubes-mirage-firewall/main/build-with.sh  | grep \\\"SHA2 last known:\\\" | cut -d\' \' -f5 | tr -d \\\\\\\"\"" }}
+      - qvm-run --pass-io {{ DownloadVM }} {{ "\"echo \\\"Checksum of downloaded local file:\\\";sha256sum ~/mirage-firewall/vmlinuz | cut -d\' \' -f1\"" }}
+      - qvm-run --pass-io {{ DownloadVM }} {{ "\"diff <(curl -s https://raw.githubusercontent.com/mirage/qubes-mirage-firewall/main/build-with.sh  | grep \\\"SHA2 last known:\\\" | cut -d\' \' -f5 | tr -d \\\\\\\") <(sha256sum ~/mirage-firewall/vmlinuz | cut -d\' \' -f1) && echo \\\"Checksums DO match.\\\" || (echo \\\"Checksums do NOT match.\\\";exit 101)\"" }} #~/mirage-firewall/modules.img
+    - require: 
+      - download-and-unpack-in-DownloadVM4mirage
+
+copy-mirage-kernel-to-dom0:
+  cmd.run: 
+    - name: mkdir -p {{ MirageInstallDir }}; qvm-run --pass-io --no-gui {{ DownloadVM }} "cat ~/mirage-firewall/vmlinuz" > {{ MirageInstallDir ~ "/vmlinuz" }}
+    - require: 
+      - download-and-unpack-in-DownloadVM4mirage
+      - check-checksum-in-DownloadVM
+
+create-initramfs:
+  cmd.run: 
+    - names: 
+      - gzip -n9 < /dev/null > {{ MirageInstallDir ~ "/initramfs" }}
+      - echo {{ Release }} > {{ MirageInstallDir ~ "/version.txt" }}
+    - require: 
+      - copy-mirage-kernel-to-dom0
+
+create-sys-mirage-fw:
+  qvm.vm:
+    - name: {{ MirageFW }}
+    - present:
+      - class: StandaloneVM
+      - label: black
+    - prefs:
+      - kernel: mirage-firewall
+      - kernelopts:
+      - include-in-backups: False
+      - memory: 32
+      - maxmem: 32
+      - netvm: sys-net
+      - provides-network: True
+      - vcpus: 1
+      - virt-mode: pvh
+    - features:
+      - enable:
+        - qubes-firewall
+        - no-default-kernelopts
+    - require: 
+      - copy-mirage-kernel-to-dom0
+
+
+cleanup-in-DownloadVM:
+  cmd.run:
+   - names:
+      - qvm-run -a --pass-io --no-gui {{ DownloadVM }} "{{ "rm " ~ Filename ~ "; rm -R ~/mirage-firewall" }}"
+   - require: 
+     - create-initramfs
+
+remove-DownloadVM4mirage:
+  qvm.absent:
+    - name: {{ DownloadVM }}
+    - require: 
+      - cleanup-in-DownloadVM
+
+{% endif %}

build-with-docker.sh

@@ -1,9 +0,0 @@
-#!/bin/sh
-set -eu
-echo Building Docker image with dependencies..
-docker build -t qubes-mirage-firewall .
-echo Building Firewall...
-docker run --rm -i -v `pwd`:/tmp/orb-build qubes-mirage-firewall
-echo "SHA2 of build:   $(sha256sum ./dist/qubes-firewall.xen)"
-echo "SHA2 last known: 55a2f823d66473c7d0be66a93289d48b6557f18c9257c6f98aa5a4583663d3c2"
-echo "(hashes should match for released versions)"

build-with.sh

@@ -0,0 +1,24 @@
+#!/bin/sh
+set -eu
+
+if [[ $# -ne 1 ]] ; then
+	echo "Usage: build-with.sh { docker | podman }"
+	exit 1
+fi
+
+builder=$1
+case $builder in
+	docker|podman)
+	;;
+	*)
+	echo "You should use either docker or podman for building"
+	exit 2
+esac
+
+echo Building $builder image with dependencies..
+$builder build -t qubes-mirage-firewall .
+echo Building Firewall...
+$builder run --rm -i -v `pwd`:/tmp/orb-build:Z qubes-mirage-firewall
+echo "SHA2 of build:   $(sha256sum ./dist/qubes-firewall.xen)"
+echo "SHA2 last known: 5805e94755334af02fd4244b0b163c7a90fef9061d826e365db3be8adfe8abcc"
+echo "(hashes should match for released versions)"

client_eth.ml

@@ -10,7 +10,7 @@ module Log = (val Logs.src_log src : Logs.LOG)
 type t = {
   mutable iface_of_ip : client_link IpMap.t;
   changed : unit Lwt_condition.t;   (* Fires when [iface_of_ip] changes. *)
-  client_gw : Ipaddr.V4.t;  (* The IP that clients are given as their default gateway. *)
+  my_ip : Ipaddr.V4.t;  (* The IP that clients are given as their default gateway. *)
 }
 
 type host =
@@ -18,11 +18,12 @@ type host =
   | `Firewall
   | `External of Ipaddr.t ]
 
-let create ~client_gw =
+let create config =
   let changed = Lwt_condition.create () in
-  { iface_of_ip = IpMap.empty; client_gw; changed }
+  let my_ip = config.Dao.our_ip in
+  Lwt.return { iface_of_ip = IpMap.empty; my_ip; changed }
 
-let client_gw t = t.client_gw
+let client_gw t = t.my_ip
 
 let add_client t iface =
   let ip = iface#other_ip in
@@ -52,14 +53,14 @@ let classify t ip =
   match ip with
   | Ipaddr.V6 _ -> `External ip
   | Ipaddr.V4 ip4 ->
-    if ip4 = t.client_gw then `Firewall
+    if ip4 = t.my_ip then `Firewall
     else match lookup t ip4 with
       | Some client_link -> `Client client_link
       | None -> `External ip
 
 let resolve t : host -> Ipaddr.t = function
   | `Client client_link -> Ipaddr.V4 client_link#other_ip
-  | `Firewall -> Ipaddr.V4 t.client_gw
+  | `Firewall -> Ipaddr.V4 t.my_ip
   | `External addr -> addr
 
 module ARP = struct
@@ -69,7 +70,7 @@ module ARP = struct
   }
 
   let lookup t ip =
-    if ip = t.net.client_gw then Some t.client_link#my_mac
+    if ip = t.net.my_ip then Some t.client_link#my_mac
     else if (Ipaddr.V4.to_octets ip).[3] = '\x01' then (
       Log.info (fun f -> f ~header:t.client_link#log_header
                    "Request for %a is invalid, but pretending it's me (see Qubes issue #5022)" Ipaddr.V4.pp ip);

client_eth.mli

@@ -17,7 +17,7 @@ type host =
    disconnected client.
    See: https://github.com/talex5/qubes-mirage-firewall/issues/9#issuecomment-246956850 *)
 
-val create : client_gw:Ipaddr.V4.t -> t
+val create : Dao.network_config -> t Lwt.t
 (** [create ~client_gw] is a network of client machines.
     Qubes will have configured the client machines to use [client_gw] as their default gateway. *)
 

client_net.ml

@@ -1,167 +0,0 @@
-(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
-   See the README file for details. *)
-
-open Lwt.Infix
-open Fw_utils
-
-module Netback = Netchannel.Backend.Make(Netchannel.Xenstore.Make(Xen_os.Xs))
-module ClientEth = Ethernet.Make(Netback)
-
-let src = Logs.Src.create "client_net" ~doc:"Client networking"
-module Log = (val Logs.src_log src : Logs.LOG)
-
-let writev eth dst proto fillfn =
-  Lwt.catch
-    (fun () ->
-       ClientEth.write eth dst proto fillfn >|= function
-       | Ok () -> ()
-       | Error e ->
-         Log.err (fun f -> f "error trying to send to client: @[%a@]"
-                     ClientEth.pp_error e);
-    )
-    (fun ex ->
-       (* Usually Netback_shutdown, because the client disconnected *)
-       Log.err (fun f -> f "uncaught exception trying to send to client: @[%s@]"
-                   (Printexc.to_string ex));
-       Lwt.return_unit
-    )
-
-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 mutable rules = []
-    method get_rules = rules
-    method set_rules new_db = rules <- Dao.read_rules new_db client_ip
-    method my_mac = ClientEth.mac eth
-    method other_mac = client_mac
-    method my_ip = gateway_ip
-    method other_ip = client_ip
-    method writev proto fillfn =
-        writev eth client_mac proto fillfn
-    method log_header = log_header
-  end
-
-let clients : Cleanup.t Dao.VifMap.t ref = ref Dao.VifMap.empty
-
-(** Handle an ARP message from the client. *)
-let input_arp ~fixed_arp ~iface request =
-  match Arp_packet.decode request with
-  | Error e ->
-    Log.warn (fun f -> f "Ignored unknown ARP message: %a" Arp_packet.pp_error e);
-    Lwt.return_unit
-  | Ok arp ->
-    match Client_eth.ARP.input fixed_arp arp with
-    | None -> Lwt.return_unit
-    | Some response ->
-      iface#writev `ARP (fun b -> Arp_packet.encode_into response b; Arp_packet.size)
-
-(** Handle an IPv4 packet from the client. *)
-let input_ipv4 get_ts cache ~iface ~router dns_client dns_servers packet =
-  let cache', r = Nat_packet.of_ipv4_packet !cache ~now:(get_ts ()) packet in
-  cache := cache';
-  match r with
-  | Error e ->
-    Log.warn (fun f -> f "Ignored unknown IPv4 message: %a" Nat_packet.pp_error e);
-    Lwt.return_unit
-  | Ok None -> Lwt.return_unit
-  | Ok (Some packet) ->
-    let `IPv4 (ip, _) = packet in
-    let src = ip.Ipv4_packet.src in
-    if src = iface#other_ip then Firewall.ipv4_from_client dns_client dns_servers router ~src:iface packet
-    else (
-      Log.warn (fun f -> f "Incorrect source IP %a in IP packet from %a (dropping)"
-                   Ipaddr.V4.pp src Ipaddr.V4.pp iface#other_ip);
-      Lwt.return_unit
-    )
-
-(** Connect to a new client's interface and listen for incoming frames and firewall rule changes. *)
-let add_vif get_ts { Dao.ClientVif.domid; device_id } dns_client dns_servers ~client_ip ~router ~cleanup_tasks qubesDB =
-  Netback.make ~domid ~device_id >>= fun backend ->
-  Log.info (fun f -> f "Client %d (IP: %s) ready" domid (Ipaddr.V4.to_string client_ip));
-  ClientEth.connect backend >>= fun eth ->
-  let client_mac = Netback.frontend_mac backend in
-  let client_eth = router.Router.client_eth in
-  let gateway_ip = Client_eth.client_gw client_eth in
-  let iface = new client_iface eth ~domid ~gateway_ip ~client_ip client_mac in
-  (* update the rules whenever QubesDB notices a change for this IP *)
-  let qubesdb_updater =
-    Lwt.catch
-      (fun () ->
-        let rec update current_db current_rules =
-          Qubes.DB.got_new_commit qubesDB (Dao.db_root client_ip) current_db >>= fun new_db ->
-          iface#set_rules new_db;
-          let new_rules = iface#get_rules in
-          (if current_rules = new_rules then
-            Log.debug (fun m -> m "Rules did not change for %s" (Ipaddr.V4.to_string client_ip))
-          else begin
-            Log.debug (fun m -> m "New firewall rules for %s@.%a"
-                        (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 client_ip;
-          end);
-          update new_db new_rules
-        in
-        update Qubes.DB.KeyMap.empty [])
-      (function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e)
-  in
-  Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel qubesdb_updater);
-  Router.add_client router iface >>= fun () ->
-  Cleanup.on_cleanup cleanup_tasks (fun () -> Router.remove_client router iface);
-  let fixed_arp = Client_eth.ARP.create ~net:client_eth iface in
-  let fragment_cache = ref (Fragments.Cache.empty (256 * 1024)) in
-  let listener =
-    Lwt.catch
-      (fun () ->
-        Netback.listen backend ~header_size:Ethernet.Packet.sizeof_ethernet (fun frame ->
-          match Ethernet.Packet.of_cstruct frame with
-          | Error err -> Log.warn (fun f -> f "Invalid Ethernet frame: %s" err); Lwt.return_unit
-          | Ok (eth, payload) ->
-              match eth.Ethernet.Packet.ethertype with
-              | `ARP -> input_arp ~fixed_arp ~iface payload
-              | `IPv4 -> input_ipv4 get_ts fragment_cache ~iface ~router dns_client dns_servers payload
-              | `IPv6 -> Lwt.return_unit (* TODO: oh no! *)
-        )
-        >|= or_raise "Listen on client interface" Netback.pp_error)
-      (function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e)
-  in
-  Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel listener);
-  Lwt.pick [ qubesdb_updater ; listener ]
-
-(** A new client VM has been found in XenStore. Find its interface and connect to it. *)
-let add_client get_ts dns_client dns_servers ~router vif client_ip qubesDB =
-  let cleanup_tasks = Cleanup.create () in
-  Log.info (fun f -> f "add client vif %a with IP %a"
-               Dao.ClientVif.pp vif Ipaddr.V4.pp client_ip);
-  Lwt.async (fun () ->
-      Lwt.catch (fun () ->
-          add_vif get_ts vif dns_client dns_servers ~client_ip ~router ~cleanup_tasks qubesDB
-        )
-        (fun ex ->
-           Log.warn (fun f -> f "Error with client %a: %s"
-                        Dao.ClientVif.pp vif (Printexc.to_string ex));
-           Lwt.return_unit
-        )
-    );
-  cleanup_tasks
-
-(** Watch XenStore for notifications of new clients. *)
-let listen get_ts dns_client dns_servers qubesDB router =
-  Dao.watch_clients (fun new_set ->
-    (* Check for removed clients *)
-    !clients |> Dao.VifMap.iter (fun key cleanup ->
-      if not (Dao.VifMap.mem key new_set) then (
-        clients := !clients |> Dao.VifMap.remove key;
-        Log.info (fun f -> f "client %a has gone" Dao.ClientVif.pp key);
-        Cleanup.cleanup cleanup
-      )
-    );
-    (* Check for added clients *)
-    new_set |> Dao.VifMap.iter (fun key ip_addr ->
-      if not (Dao.VifMap.mem key !clients) then (
-        let cleanup = add_client get_ts dns_client dns_servers ~router key ip_addr qubesDB in
-        Log.debug (fun f -> f "client %a arrived" Dao.ClientVif.pp key);
-        clients := !clients |> Dao.VifMap.add key cleanup
-      )
-    )
-  )

client_net.mli

@@ -1,12 +0,0 @@
-(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
-   See the README file for details. *)
-
-(** Handling client VMs. *)
-
-val listen : (unit -> int64) ->
-  ([ `host ] Domain_name.t -> (int32 * Ipaddr.V4.Set.t, [> `Msg of string ]) result Lwt.t) ->
-  Ipaddr.V4.t list -> Qubes.DB.t -> Router.t -> 'a Lwt.t
-(** [listen get_timestamp resolver dns_servers db router] is a thread that watches for clients being added to and
-    removed from XenStore. Clients are connected to the client network and
-    packets are sent via [router]. We ensure the source IP address is correct
-    before routing a packet. *)

config.ml

@@ -1,3 +1,4 @@
+(* mirage >= 4.5.0 & < 5.0.0 *)
 (* Copyright (C) 2017, Thomas Leonard <thomas.leonard@unikernel.com>
    See the README file for details. *)
 
@@ -5,27 +6,23 @@
 
 open Mirage
 
-let table_size =
-  let info = Key.Arg.info
-      ~doc:"The number of NAT entries to allocate."
-      ~docv:"ENTRIES" ["nat-table-size"]
-  in
-  let key = Key.Arg.opt ~stage:`Both Key.Arg.int 5_000 info in
-  Key.create "nat_table_size" key
+let nat_table_size = runtime_arg ~pos:__POS__ "Unikernel.nat_table_size"
+let ipv4 = runtime_arg ~pos:__POS__ "Unikernel.ipv4"
+let ipv4_gw = runtime_arg ~pos:__POS__ "Unikernel.ipv4_gw"
+let ipv4_dns = runtime_arg ~pos:__POS__ "Unikernel.ipv4_dns"
+let ipv4_dns2 = runtime_arg ~pos:__POS__ "Unikernel.ipv4_dns2"
 
 let main =
-  foreign
-    ~keys:[Key.v table_size]
+   main
+    ~runtime_args:[ nat_table_size; ipv4; ipv4_gw; ipv4_dns; ipv4_dns2; ]
     ~packages:[
       package "vchan" ~min:"4.0.2";
       package "cstruct";
-      package "astring";
       package "tcpip" ~min:"3.7.0";
       package ~min:"2.3.0" ~sublibs:["mirage"] "arp";
       package ~min:"3.0.0" "ethernet";
       package "shared-memory-ring" ~min:"3.0.0";
-      package ~min:"2.1.2" "netchannel";
-      package "mirage-net-xen";
+      package "mirage-net-xen" ~min:"2.1.4";
       package "ipaddr" ~min:"5.2.0";
       package "mirage-qubes" ~min:"0.9.1";
       package ~min:"3.0.1" "mirage-nat";

dao.ml

@@ -3,7 +3,6 @@
 
 open Lwt.Infix
 open Qubes
-open Astring
 
 let src = Logs.Src.create "dao" ~doc:"QubesDB data access"
 module Log = (val Logs.src_log src : Logs.LOG)
@@ -66,26 +65,26 @@ let read_rules rules client_ip =
                              number = 0;})]
 
 let vifs client domid =
-  match String.to_int domid with
+  match int_of_string_opt domid with
   | None -> Log.err (fun f -> f "Invalid domid %S" domid); Lwt.return []
   | Some domid ->
     let path = Printf.sprintf "backend/vif/%d" domid in
     Xen_os.Xs.immediate client (fun handle ->
         directory ~handle path >>=
         Lwt_list.filter_map_p (fun device_id ->
-            match String.to_int device_id with
+            match int_of_string_opt device_id with
             | None -> Log.err (fun f -> f "Invalid device ID %S for domid %d" device_id domid); Lwt.return_none
             | Some device_id ->
               let vif = { ClientVif.domid; device_id } in
               Lwt.try_bind
                 (fun () -> Xen_os.Xs.read handle (Printf.sprintf "%s/%d/ip" path device_id))
                 (fun client_ip ->
-                   let client_ip' = match String.cuts ~sep:" " client_ip with
+                   let client_ip' = match String.split_on_char ' ' client_ip with
                      | [] -> Log.err (fun m -> m "unexpected empty list"); ""
                      | [ ip ] -> ip
                      | ip::rest ->
                        Log.warn (fun m -> m "ignoring IPs %s from %a, we support one IP per client"
-                                    (String.concat ~sep:" " rest) ClientVif.pp vif);
+                                    (String.concat " " rest) ClientVif.pp vif);
                        ip
                    in
                    match Ipaddr.V4.of_string client_ip' with
@@ -123,10 +122,9 @@ let watch_clients fn =
   )
 
 type network_config = {
-  uplink_netvm_ip : Ipaddr.V4.t;      (* The IP address of NetVM (our gateway) *)
-  uplink_our_ip : Ipaddr.V4.t;        (* The IP address of our interface to NetVM *)
-
-  clients_our_ip : Ipaddr.V4.t;        (* The IP address of our interface to our client VMs (their gateway) *)
+  from_cmdline : bool;         (* Specify if we have network configuration from command line or from qubesDB*)
+  netvm_ip : Ipaddr.V4.t;      (* The IP address of NetVM (our gateway) *)
+  our_ip : Ipaddr.V4.t;        (* The IP address of our interface to NetVM *)
   dns : Ipaddr.V4.t;
   dns2 : Ipaddr.V4.t;
 }
@@ -137,24 +135,12 @@ let try_read_network_config db =
   let get name =
     match DB.KeyMap.find_opt name db with
     | None -> raise (Missing_key name)
-    | Some value -> value in
-  let uplink_our_ip = get "/qubes-ip" |> Ipaddr.V4.of_string_exn in
-  let uplink_netvm_ip = get "/qubes-gateway" |> Ipaddr.V4.of_string_exn in
-  let clients_our_ip = get "/qubes-netvm-gateway" |> Ipaddr.V4.of_string_exn in
-  let dns = get "/qubes-primary-dns" |> Ipaddr.V4.of_string_exn in
-  let dns2 = get "/qubes-secondary-dns" |> Ipaddr.V4.of_string_exn in
-  Log.info (fun f -> f "@[<v2>Got network configuration from QubesDB:@,\
-                        NetVM IP on uplink network: %a@,\
-                        Our IP on uplink network:   %a@,\
-                        Our IP on client networks:  %a@,\
-                        DNS primary resolver:       %a@,\
-                        DNS secondary resolver:     %a@]"
-               Ipaddr.V4.pp uplink_netvm_ip
-               Ipaddr.V4.pp uplink_our_ip
-               Ipaddr.V4.pp clients_our_ip
-               Ipaddr.V4.pp dns
-               Ipaddr.V4.pp dns2);
-  { uplink_netvm_ip; uplink_our_ip; clients_our_ip ; dns ; dns2 }
+    | Some value -> Ipaddr.V4.of_string_exn value in
+  let our_ip = get "/qubes-ip" in (* - IP address for this VM (only when VM has netvm set) *)
+  let netvm_ip = get "/qubes-gateway" in (* - default gateway IP (only when VM has netvm set); VM should add host route to this address directly via eth0 (or whatever default interface name is) *)
+  let dns = get "/qubes-primary-dns" in
+  let dns2 = get "/qubes-secondary-dns" in
+  { from_cmdline=false; netvm_ip ; our_ip ; dns ; dns2 }
 
 let read_network_config qubesDB =
   let rec aux bindings =
@@ -165,4 +151,15 @@ let read_network_config qubesDB =
   in
   aux (DB.bindings qubesDB)
 
+let print_network_config config =
+  Log.info (fun f -> f "@[<v2>Current network configuration (QubesDB or command line):@,\
+                        NetVM IP on uplink network: %a@,\
+                        Our IP on client networks:  %a@,\
+                        DNS primary resolver:       %a@,\
+                        DNS secondary resolver:     %a@]"
+               Ipaddr.V4.pp config.netvm_ip
+               Ipaddr.V4.pp config.our_ip
+               Ipaddr.V4.pp config.dns
+               Ipaddr.V4.pp config.dns2)
+
 let set_iptables_error db = Qubes.DB.write db "/qubes-iptables-error"

dao.mli

@@ -20,10 +20,9 @@ val watch_clients : (Ipaddr.V4.t VifMap.t -> unit) -> 'a Lwt.t
     in XenStore, and again each time XenStore updates. *)
 
 type network_config = {
-  uplink_netvm_ip : Ipaddr.V4.t;      (* The IP address of NetVM (our gateway) *)
-  uplink_our_ip : Ipaddr.V4.t;        (* The IP address of our interface to NetVM *)
-
-  clients_our_ip : Ipaddr.V4.t;        (* The IP address of our interface to our client VMs (their gateway) *)
+  from_cmdline : bool;         (* Specify if we have network configuration from command line or from qubesDB*)
+  netvm_ip : Ipaddr.V4.t;      (* The IP address of NetVM (our gateway) *)
+  our_ip : Ipaddr.V4.t;        (* The IP address of our interface to NetVM *)
   dns : Ipaddr.V4.t;
   dns2 : Ipaddr.V4.t;
 }
@@ -39,4 +38,6 @@ val read_rules : string Qubes.DB.KeyMap.t -> Ipaddr.V4.t -> Pf_qubes.Parse_qubes
 (** [read_rules bindings ip] extracts firewall rule information for [ip] from [bindings].
     If any rules fail to parse, it will return only one rule denying all traffic. *)
 
+val print_network_config : network_config -> unit
+
 val set_iptables_error : Qubes.DB.t -> string -> unit Lwt.t

dispatcher.ml

@@ -0,0 +1,607 @@
+open Lwt.Infix
+open Fw_utils
+module Netback = Backend.Make (Xenstore.Make (Xen_os.Xs))
+module ClientEth = Ethernet.Make (Netback)
+module UplinkEth = Ethernet.Make (Netif)
+
+let src = Logs.Src.create "dispatcher" ~doc:"Networking dispatch"
+
+module Log = (val Logs.src_log src : Logs.LOG)
+
+module Make
+    (R : Mirage_random.S)
+    (Clock : Mirage_clock.MCLOCK)
+    (Time : Mirage_time.S) =
+struct
+  module Arp = Arp.Make (UplinkEth) (Time)
+  module I = Static_ipv4.Make (R) (Clock) (UplinkEth) (Arp)
+  module U = Udp.Make (I) (R)
+
+  let clients : Cleanup.t Dao.VifMap.t ref = ref Dao.VifMap.empty
+
+  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 mutable rules = []
+      method get_rules = rules
+      method set_rules new_db = rules <- Dao.read_rules new_db client_ip
+      method my_mac = ClientEth.mac eth
+      method other_mac = client_mac
+      method my_ip = gateway_ip
+      method other_ip = client_ip
+
+      method writev proto fillfn =
+        Lwt.catch
+          (fun () ->
+            ClientEth.write eth client_mac proto fillfn >|= function
+            | Ok () -> ()
+            | Error e ->
+                Log.err (fun f ->
+                    f "error trying to send to client: @[%a@]"
+                      ClientEth.pp_error e))
+          (fun ex ->
+            (* Usually Netback_shutdown, because the client disconnected *)
+            Log.err (fun f ->
+                f "uncaught exception trying to send to client: @[%s@]"
+                  (Printexc.to_string ex));
+            Lwt.return_unit)
+
+      method log_header = log_header
+    end
+
+  class netvm_iface eth mac ~my_ip ~other_ip : interface =
+    object
+      method my_mac = UplinkEth.mac eth
+      method my_ip = my_ip
+      method other_ip = other_ip
+
+      method writev ethertype fillfn =
+        Lwt.catch
+          (fun () ->
+            mac >>= fun dst ->
+            UplinkEth.write eth dst ethertype fillfn
+            >|= or_raise "Write to uplink" UplinkEth.pp_error)
+          (fun ex ->
+            Log.err (fun f ->
+                f "uncaught exception trying to send to uplink: @[%s@]"
+                  (Printexc.to_string ex));
+            Lwt.return_unit)
+    end
+
+  type uplink = {
+    net : Netif.t;
+    eth : UplinkEth.t;
+    arp : Arp.t;
+    interface : interface;
+    mutable fragments : Fragments.Cache.t;
+    ip : I.t;
+    udp : U.t;
+  }
+
+  type t = {
+    uplink_connected : unit Lwt_condition.t;
+    uplink_disconnect : unit Lwt_condition.t;
+    uplink_disconnected : unit Lwt_condition.t;
+    mutable config : Dao.network_config;
+    clients : Client_eth.t;
+    nat : My_nat.t;
+    mutable uplink : uplink option;
+  }
+
+  let create ~config ~clients ~nat ~uplink =
+    {
+      uplink_connected = Lwt_condition.create ();
+      uplink_disconnect = Lwt_condition.create ();
+      uplink_disconnected = Lwt_condition.create ();
+      config;
+      clients;
+      nat;
+      uplink;
+    }
+
+  let update t ~config ~uplink =
+    t.config <- config;
+    t.uplink <- uplink;
+    Lwt.return_unit
+
+  let target t buf =
+    let dst_ip = buf.Ipv4_packet.dst in
+    match Client_eth.lookup t.clients dst_ip with
+    | Some client_link -> Some (client_link :> interface)
+    | None -> ( (* if dest is not a client, transfer it to our uplink *)
+        match t.uplink with
+        | None -> (
+            match Client_eth.lookup t.clients t.config.netvm_ip with
+            | Some uplink ->
+              Some (uplink :> interface)
+            | None ->
+              Log.err (fun f -> f "We have a command line configuration %a but it's currently not connected to us (please check its netvm property)...%!" Ipaddr.V4.pp t.config.netvm_ip);
+              None)
+        | Some uplink -> Some uplink.interface)
+
+  let add_client t = Client_eth.add_client t.clients
+  let remove_client t = Client_eth.remove_client t.clients
+
+  let classify t ip =
+    if ip = Ipaddr.V4 t.config.our_ip then `Firewall
+    else if ip = Ipaddr.V4 t.config.netvm_ip then `NetVM
+    else (Client_eth.classify t.clients ip :> Packet.host)
+
+  let resolve t = function
+    | `Firewall -> Ipaddr.V4 t.config.our_ip
+    | `NetVM -> Ipaddr.V4 t.config.netvm_ip
+    | #Client_eth.host as host -> Client_eth.resolve t.clients host
+
+  (* Transmission *)
+
+  let transmit_ipv4 packet iface =
+    Lwt.catch
+      (fun () ->
+        let fragments = ref [] in
+        iface#writev `IPv4 (fun b ->
+            match Nat_packet.into_cstruct packet b with
+            | Error e ->
+                Log.warn (fun f ->
+                    f "Failed to write packet to %a: %a" Ipaddr.V4.pp
+                      iface#other_ip Nat_packet.pp_error e);
+                0
+            | Ok (n, frags) ->
+                fragments := frags;
+                n)
+        >>= fun () ->
+        Lwt_list.iter_s
+          (fun f ->
+            let size = Cstruct.length f in
+            iface#writev `IPv4 (fun b ->
+                Cstruct.blit f 0 b 0 size;
+                size))
+          !fragments)
+      (fun ex ->
+        Log.warn (fun f ->
+            f "Failed to write packet to %a: %s" Ipaddr.V4.pp iface#other_ip
+              (Printexc.to_string ex));
+        Lwt.return_unit)
+
+  let forward_ipv4 t packet =
+    let (`IPv4 (ip, _)) = packet in
+    Lwt.catch
+    (fun () ->
+      match target t ip with
+      | Some iface -> transmit_ipv4 packet iface
+      | None -> Lwt.return_unit)
+    (fun ex ->
+      let dst_ip = ip.Ipv4_packet.dst in
+      Log.warn (fun f ->
+          f "Failed to lookup for target %a: %s" Ipaddr.V4.pp dst_ip
+            (Printexc.to_string ex));
+      Lwt.return_unit)
+
+  (* NAT *)
+
+  let translate t packet = My_nat.translate t.nat packet
+
+  (* Add a NAT rule for the endpoints in this frame, via a random port on the firewall. *)
+  let add_nat_and_forward_ipv4 t packet =
+    let xl_host = t.config.our_ip in
+    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);
+        Lwt.return_unit
+
+  (* Add a NAT rule to redirect this conversation to [host:port] instead of us. *)
+  let nat_to t ~host ~port packet =
+    match resolve t host with
+    | Ipaddr.V6 _ ->
+        Log.warn (fun f -> f "Cannot NAT with IPv6");
+        Lwt.return_unit
+    | Ipaddr.V4 target -> (
+        let xl_host = t.config.our_ip in
+        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);
+            Lwt.return_unit)
+
+  let apply_rules t (rules : ('a, 'b) Packet.t -> Packet.action Lwt.t) ~dst
+      (annotated_packet : ('a, 'b) Packet.t) : unit Lwt.t =
+    let packet = Packet.to_mirage_nat_packet annotated_packet in
+    rules annotated_packet >>= fun action ->
+    match (action, dst) with
+    | `Accept, `Client client_link -> transmit_ipv4 packet client_link
+    | `Accept, (`External _ | `NetVM) -> (
+        match t.uplink with
+        | Some uplink -> transmit_ipv4 packet uplink.interface
+        | None -> (
+            match Client_eth.lookup t.clients t.config.netvm_ip with
+            | Some iface -> transmit_ipv4 packet iface
+            | None ->
+                Log.warn (fun f ->
+                    f "No output interface for %a : drop" Nat_packet.pp packet);
+                Lwt.return_unit))
+    | `Accept, `Firewall ->
+        Log.warn (fun f ->
+            f "Bad rule: firewall can't accept packets %a" Nat_packet.pp packet);
+        Lwt.return_unit
+    | `NAT, _ ->
+        Log.debug (fun f -> f "adding NAT rule for %a" Nat_packet.pp packet);
+        add_nat_and_forward_ipv4 t packet
+    | `NAT_to (host, port), _ -> nat_to t packet ~host ~port
+    | `Drop reason, _ ->
+        Log.debug (fun f ->
+            f "Dropped packet (%s) %a" reason Nat_packet.pp packet);
+        Lwt.return_unit
+
+  let ipv4_from_netvm t packet =
+    match Memory_pressure.status () with
+    | `Memory_critical -> Lwt.return_unit
+    | `Ok -> (
+        let (`IPv4 (ip, _transport)) = packet in
+        let src = classify t (Ipaddr.V4 ip.Ipv4_packet.src) in
+        let dst = 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 -> (
+                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)
+                )))
+
+  let ipv4_from_client resolver dns_servers t ~src packet =
+    match Memory_pressure.status () with
+    | `Memory_critical -> Lwt.return_unit
+    | `Ok -> (
+        (* Check for existing NAT entry for this 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
+            match classify t (Ipaddr.V4 ip.Ipv4_packet.src) with
+            | `Client _ | `Firewall -> (
+                let dst = classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in
+                match
+                  Packet.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)
+            | `NetVM -> ipv4_from_netvm t packet
+            | `External _ ->
+                Log.warn (fun f ->
+                    f "Frame from Inside has external source IP address! %a"
+                      Nat_packet.pp packet);
+                Lwt.return_unit))
+
+  (** Handle an ARP message from the client. *)
+  let client_handle_arp ~fixed_arp ~iface request =
+    match Arp_packet.decode request with
+    | Error e ->
+        Log.warn (fun f ->
+            f "Ignored unknown ARP message: %a" Arp_packet.pp_error e);
+        Lwt.return_unit
+    | Ok arp -> (
+        match Client_eth.ARP.input fixed_arp arp with
+        | None -> Lwt.return_unit
+        | Some response ->
+          Lwt.catch
+            (fun () ->
+                  iface#writev `ARP (fun b ->
+                      Arp_packet.encode_into response b;
+                      Arp_packet.size))
+            (fun ex ->
+              Log.warn (fun f ->
+                  f "Failed to write APR to %a: %s" Ipaddr.V4.pp iface#other_ip
+                    (Printexc.to_string ex));
+              Lwt.return_unit)
+     )
+
+  (** Handle an IPv4 packet from the client. *)
+  let client_handle_ipv4 get_ts cache ~iface ~router dns_client dns_servers
+      packet =
+    let cache', r = Nat_packet.of_ipv4_packet !cache ~now:(get_ts ()) packet in
+    cache := cache';
+    match r with
+    | Error e ->
+        Log.warn (fun f ->
+            f "Ignored unknown IPv4 message: %a" Nat_packet.pp_error e);
+        Lwt.return_unit
+    | Ok None -> Lwt.return_unit
+    | Ok (Some packet) ->
+        let (`IPv4 (ip, _)) = packet in
+        let src = ip.Ipv4_packet.src in
+        if src = iface#other_ip then
+          ipv4_from_client dns_client dns_servers router ~src:iface packet
+        else if iface#other_ip = router.config.netvm_ip then
+          (* This can occurs when used with *BSD as netvm (and a gateway is set) *)
+          ipv4_from_netvm router packet
+        else (
+          Log.warn (fun f ->
+              f "Incorrect source IP %a in IP packet from %a (dropping)"
+                Ipaddr.V4.pp src Ipaddr.V4.pp iface#other_ip);
+          Lwt.return_unit)
+
+  (** Connect to a new client's interface and listen for incoming frames and firewall rule changes. *)
+  let add_vif get_ts { Dao.ClientVif.domid; device_id } dns_client dns_servers
+      ~client_ip ~router ~cleanup_tasks qubesDB =
+    Netback.make ~domid ~device_id >>= fun backend ->
+    Log.info (fun f ->
+        f "Client %d (IP: %s) ready" domid (Ipaddr.V4.to_string client_ip));
+    ClientEth.connect backend >>= fun eth ->
+    let client_mac = Netback.frontend_mac backend in
+    let client_eth = router.clients in
+    let gateway_ip = Client_eth.client_gw client_eth in
+    let iface = new client_iface eth ~domid ~gateway_ip ~client_ip client_mac in
+    (* update the rules whenever QubesDB notices a change for this IP *)
+    let qubesdb_updater =
+      Lwt.catch
+        (fun () ->
+          let rec update current_db current_rules =
+            Qubes.DB.got_new_commit qubesDB (Dao.db_root client_ip) current_db
+            >>= fun new_db ->
+            iface#set_rules new_db;
+            let new_rules = iface#get_rules in
+            if current_rules = new_rules then
+              Log.info (fun m ->
+                  m "Rules did not change for %s"
+                    (Ipaddr.V4.to_string client_ip))
+            else (
+              Log.info (fun m ->
+                  m "New firewall rules for %s@.%a"
+                    (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.nat client_ip);
+            update new_db new_rules
+          in
+          update Qubes.DB.KeyMap.empty [])
+        (function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e)
+    in
+    Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel qubesdb_updater);
+    add_client router iface >>= fun () ->
+    Cleanup.on_cleanup cleanup_tasks (fun () -> remove_client router iface);
+    let fixed_arp = Client_eth.ARP.create ~net:client_eth iface in
+    let fragment_cache = ref (Fragments.Cache.empty (256 * 1024)) in
+    let listener =
+      Lwt.catch
+        (fun () ->
+          Netback.listen backend ~header_size:Ethernet.Packet.sizeof_ethernet
+            (fun frame ->
+              match Ethernet.Packet.of_cstruct frame with
+              | Error err ->
+                  Log.warn (fun f -> f "Invalid Ethernet frame: %s" err);
+                  Lwt.return_unit
+              | Ok (eth, payload) -> (
+                  match eth.Ethernet.Packet.ethertype with
+                  | `ARP -> client_handle_arp ~fixed_arp ~iface payload
+                  | `IPv4 ->
+                      client_handle_ipv4 get_ts fragment_cache ~iface ~router
+                        dns_client dns_servers payload
+                  | `IPv6 -> Lwt.return_unit (* TODO: oh no! *)))
+          >|= or_raise "Listen on client interface" Netback.pp_error)
+        (function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e)
+    in
+    Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel listener);
+    Lwt.pick [ qubesdb_updater; listener ]
+
+  (** A new client VM has been found in XenStore. Find its interface and connect to it. *)
+  let add_client get_ts dns_client dns_servers ~router vif client_ip qubesDB =
+    let cleanup_tasks = Cleanup.create () in
+    Log.info (fun f ->
+        f "add client vif %a with IP %a" Dao.ClientVif.pp vif Ipaddr.V4.pp
+          client_ip);
+    Lwt.async (fun () ->
+        Lwt.catch
+          (fun () ->
+            add_vif get_ts vif dns_client dns_servers ~client_ip ~router
+              ~cleanup_tasks qubesDB)
+          (fun ex ->
+            Log.warn (fun f ->
+                f "Error with client %a: %s" Dao.ClientVif.pp vif
+                  (Printexc.to_string ex));
+            Lwt.return_unit));
+    cleanup_tasks
+
+  (** Watch XenStore for notifications of new clients. *)
+  let wait_clients get_ts dns_client dns_servers qubesDB router =
+    Dao.watch_clients (fun new_set ->
+        (* Check for removed clients *)
+        !clients
+        |> Dao.VifMap.iter (fun key cleanup ->
+               if not (Dao.VifMap.mem key new_set) then (
+                 clients := !clients |> Dao.VifMap.remove key;
+                 Log.info (fun f -> f "client %a has gone" Dao.ClientVif.pp key);
+                 Cleanup.cleanup cleanup));
+        (* Check for added clients *)
+        new_set
+        |> Dao.VifMap.iter (fun key ip_addr ->
+               if not (Dao.VifMap.mem key !clients) then (
+                 let cleanup =
+                   add_client get_ts dns_client dns_servers ~router key ip_addr
+                     qubesDB
+                 in
+                 Log.debug (fun f -> f "client %a arrived" Dao.ClientVif.pp key);
+                 clients := !clients |> Dao.VifMap.add key cleanup)))
+
+  let send_dns_client_query t ~src_port ~dst ~dst_port buf =
+    match t.uplink with
+    | None ->
+        Log.err (fun f -> f "No uplink interface");
+        Lwt.return (Error (`Msg "failure"))
+    | Some uplink -> (
+        Lwt.catch
+          (fun () ->
+            U.write ~src_port ~dst ~dst_port uplink.udp buf >|= function
+            | Error s ->
+                Log.err (fun f -> f "error sending udp packet: %a" U.pp_error s);
+                Error (`Msg "failure")
+            | Ok () -> Ok ())
+          (fun ex ->
+            Log.err (fun f ->
+                f "uncaught exception trying to send DNS request to uplink: @[%s@]"
+                  (Printexc.to_string ex));
+            Lwt.return (Error (`Msg "DNS request not sent"))))
+
+  (** Wait for packet from our uplink (we must have an uplink here...). *)
+  let rec uplink_listen get_ts dns_responses router =
+    Lwt_condition.wait router.uplink_connected >>= fun () ->
+    match router.uplink with
+    | None ->
+          Log.err (fun f ->
+              f
+                "Uplink is connected but not found in the router, retrying...%!");
+        uplink_listen get_ts dns_responses router
+    | Some uplink ->
+        let listen =
+        Lwt.catch
+        (fun () ->
+          Netif.listen uplink.net ~header_size:Ethernet.Packet.sizeof_ethernet
+            (fun frame ->
+              (* Handle one Ethernet frame from NetVM *)
+              UplinkEth.input uplink.eth ~arpv4:(Arp.input uplink.arp)
+                ~ipv4:(fun ip ->
+                  let cache, r =
+                    Nat_packet.of_ipv4_packet uplink.fragments ~now:(get_ts ())
+                      ip
+                  in
+                  uplink.fragments <- cache;
+                  begin match r with
+                  | Error e ->
+                      Log.warn (fun f ->
+                          f "Ignored unknown IPv4 message from uplink: %a"
+                            Nat_packet.pp_error e);
+                      Lwt.return ()
+                  | Ok None -> Lwt.return_unit
+                  | Ok (Some (`IPv4 (header, packet))) ->
+                      let open Udp_packet in
+                      Log.debug (fun f ->
+                          f "received ipv4 packet from %a on uplink" Ipaddr.V4.pp
+                            header.Ipv4_packet.src);
+                      begin match packet with
+                      | `UDP (header, packet) when My_nat.dns_port 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)
+                      | _ -> ipv4_from_netvm router (`IPv4 (header, packet))
+                      end
+                   end)
+                ~ipv6:(fun _ip -> Lwt.return_unit)
+                frame)
+          >|= or_raise "Uplink listen loop" Netif.pp_error)
+          (function Lwt.Canceled ->
+            (* We can be cancelled if reconnect_uplink is achieved (via the Lwt_condition), so we need to disconnect and broadcast when it's done
+               currently we delay 1s as Netif.disconnect is non-blocking... (need to fix upstream?) *)
+            Log.info (fun f ->
+               f "disconnecting from our uplink");
+            U.disconnect uplink.udp >>= fun () ->
+            I.disconnect uplink.ip  >>= fun () ->
+            (* mutable fragments : Fragments.Cache.t; *)
+            (* interface : interface; *)
+            Arp.disconnect uplink.arp >>= fun () ->
+            UplinkEth.disconnect uplink.eth >>= fun () ->
+            Netif.disconnect uplink.net >>= fun () ->
+            Lwt_condition.broadcast router.uplink_disconnected ();
+            Lwt.return_unit
+          | e -> Lwt.fail e)
+        in
+        let reconnect_uplink =
+          Lwt_condition.wait router.uplink_disconnect >>= fun () ->
+          Log.info (fun f ->
+             f "we need to reconnect to the new uplink");
+          Lwt.return_unit
+        in
+        Lwt.pick [ listen ; reconnect_uplink ] >>= fun () ->
+        uplink_listen get_ts dns_responses router
+
+  (** Connect to our uplink backend (we must have an uplink here...). *)
+  let connect config =
+    let my_ip = config.Dao.our_ip in
+    let gateway = config.Dao.netvm_ip in
+    Netif.connect "0" >>= fun net ->
+    UplinkEth.connect net >>= fun eth ->
+    Arp.connect eth >>= fun arp ->
+    Arp.add_ip arp my_ip >>= fun () ->
+    let cidr = Ipaddr.V4.Prefix.make 0 my_ip in
+    I.connect ~cidr ~gateway eth arp >>= fun ip ->
+    U.connect ip >>= fun udp ->
+    let netvm_mac =
+      Arp.query arp gateway >|= or_raise "Getting MAC of our NetVM" Arp.pp_error
+    in
+    let interface =
+      new netvm_iface eth netvm_mac ~my_ip ~other_ip:config.Dao.netvm_ip
+    in
+    let fragments = Fragments.Cache.empty (256 * 1024) in
+    Lwt.return { net; eth; arp; interface; fragments; ip; udp }
+
+  (** Wait Xenstore for our uplink changes (we must have an uplink here...). *)
+  let uplink_wait_update qubesDB router =
+    let rec aux current_db =
+      let netvm = "/qubes-gateway" in
+      Log.info (fun f -> f "Waiting for netvm changes to %S...%!" netvm);
+      Qubes.DB.after qubesDB current_db >>= fun new_db ->
+      (match (router.uplink, Qubes.DB.KeyMap.find_opt netvm new_db) with
+      | Some uplink, Some netvm
+        when not
+               (String.equal netvm
+                  (Ipaddr.V4.to_string uplink.interface#other_ip)) ->
+          Log.info (fun f ->
+              f "Our netvm IP has changed, before it was %s, now it's: %s%!"
+                (Ipaddr.V4.to_string uplink.interface#other_ip)
+                netvm);
+          Lwt_condition.broadcast router.uplink_disconnect ();
+          (* wait for uplink disconnexion *)
+          Lwt_condition.wait router.uplink_disconnected >>= fun () ->
+          Dao.read_network_config qubesDB >>= fun config ->
+          Dao.print_network_config config;
+          connect config >>= fun uplink ->
+          update router ~config ~uplink:(Some uplink) >>= fun () ->
+          Lwt_condition.broadcast router.uplink_connected ();
+          Lwt.return_unit
+      | None, Some _ ->
+          (* a new interface is attributed to qubes-mirage-firewall *)
+          Log.info (fun f -> f "Going from netvm not connected to %s%!" netvm);
+          Dao.read_network_config qubesDB >>= fun config ->
+          Dao.print_network_config config;
+          connect config >>= fun uplink ->
+          update router ~config ~uplink:(Some uplink) >>= fun () ->
+          Lwt_condition.broadcast router.uplink_connected ();
+          Lwt.return_unit
+      | Some _, None ->
+          (* This currently is never triggered :( *)
+          Log.info (fun f ->
+              f "TODO: Our netvm disapeared, troubles are coming!%!");
+          Lwt.return_unit
+      | Some _, Some _ (* The new netvm IP is unchanged (it's our old netvm IP) *)
+      | None, None  ->
+          Log.info (fun f ->
+              f "QubesDB has changed but not the situation of our netvm!%!");
+          Lwt.return_unit)
+      >>= fun () -> aux new_db
+    in
+    aux Qubes.DB.KeyMap.empty
+end

firewall.ml

@@ -1,121 +0,0 @@
-(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
-   See the README file for details. *)
-
-open Packet
-open Lwt.Infix
-
-let src = Logs.Src.create "firewall" ~doc:"Packet handler"
-module Log = (val Logs.src_log src : Logs.LOG)
-
-(* Transmission *)
-
-let transmit_ipv4 packet iface =
-  Lwt.catch
-    (fun () ->
-       let fragments = ref [] in
-       iface#writev `IPv4 (fun b ->
-           match Nat_packet.into_cstruct packet b with
-           | Error e ->
-             Log.warn (fun f -> f "Failed to write packet to %a: %a"
-                          Ipaddr.V4.pp iface#other_ip
-                          Nat_packet.pp_error e);
-             0
-           | Ok (n, frags) -> fragments := frags ; n) >>= fun () ->
-       Lwt_list.iter_s (fun f ->
-           let size = Cstruct.length f in
-           iface#writev `IPv4 (fun b -> Cstruct.blit f 0 b 0 size ; size))
-         !fragments)
-    (fun ex ->
-       Log.warn (fun f -> f "Failed to write packet to %a: %s"
-                    Ipaddr.V4.pp iface#other_ip
-                    (Printexc.to_string ex));
-       Lwt.return_unit
-    )
-
-let forward_ipv4 t packet =
-  let `IPv4 (ip, _) = packet in
-  match Router.target t ip with
-  | Some iface -> transmit_ipv4 packet iface
-  | None -> Lwt.return_unit
-
-(* NAT *)
-
-let translate t packet =
-  My_nat.translate t.Router.nat packet
-
-(* Add a NAT rule for the endpoints in this frame, via a random port on the firewall. *)
-let add_nat_and_forward_ipv4 t packet =
-  let open Router in
-  let xl_host = t.uplink#my_ip in
-  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);
-    Lwt.return_unit
-
-(* Add a NAT rule to redirect this conversation to [host:port] instead of us. *)
-let nat_to t ~host ~port packet =
-  let open Router in
-  match resolve t host with
-  | 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
-    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);
-      Lwt.return_unit
-
-let apply_rules t (rules : ('a, 'b) Packet.t -> Packet.action Lwt.t) ~dst (annotated_packet : ('a, 'b) Packet.t) : unit Lwt.t =
-  let packet = to_mirage_nat_packet annotated_packet in
-  rules annotated_packet >>= fun action ->
-  match action, dst with
-  | `Accept, `Client client_link -> transmit_ipv4 packet client_link
-  | `Accept, (`External _ | `NetVM) -> transmit_ipv4 packet t.Router.uplink
-  | `Accept, `Firewall ->
-      Log.warn (fun f -> f "Bad rule: firewall can't accept packets %a" Nat_packet.pp packet);
-      Lwt.return_unit
-  | `NAT, _ ->
-      Log.debug (fun f -> f "adding NAT rule for %a" Nat_packet.pp packet);
-      add_nat_and_forward_ipv4 t packet
-  | `NAT_to (host, port), _ -> nat_to t packet ~host ~port
-  | `Drop reason, _ ->
-      Log.debug (fun f -> f "Dropped packet (%s) %a" reason Nat_packet.pp packet);
-      Lwt.return_unit
-
-let ipv4_from_client resolver dns_servers t ~src packet =
-  match Memory_pressure.status () with
-  | `Memory_critical -> Lwt.return_unit
-  | `Ok ->
-  (* Check for existing NAT entry for this 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 =
-  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 ->
-        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

firewall.mli

@@ -1,13 +0,0 @@
-(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
-   See the README file for details. *)
-
-(** Classify IP packets, apply rules and send as appropriate. *)
-
-val ipv4_from_netvm : Router.t -> Nat_packet.t -> unit Lwt.t
-(** Handle a packet from the outside world (this module will validate the source IP). *)
-
-(* TODO the function type is a workaround, rework the module dependencies / functors to get rid of it *)
-val ipv4_from_client : ([ `host ] Domain_name.t -> (int32 * Ipaddr.V4.Set.t, [> `Msg of string ]) result Lwt.t) ->
-  Ipaddr.V4.t list -> Router.t -> src:Fw_utils.client_link -> Nat_packet.t -> unit Lwt.t
-(** Handle a packet from a client. Caller must check the source IP matches the client's
-    before calling this. *)

fw_utils.ml

@@ -8,6 +8,7 @@ module IpMap = struct
   let find x map =
     try Some (find x map)
     with Not_found -> None
+    | _ -> Logs.err( fun f -> f "uncaught exception in find...%!"); None
 end
 
 (** An Ethernet interface. *)

memory_pressure.ml

@@ -1,45 +1,15 @@
 (* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
    See the README file for details. *)
 
-open Lwt
-
 let src = Logs.Src.create "memory_pressure" ~doc:"Memory pressure monitor"
 module Log = (val Logs.src_log src : Logs.LOG)
 
-let wordsize_in_bytes = Sys.word_size / 8
-
 let fraction_free stats =
   let { Xen_os.Memory.free_words; heap_words; _ } = stats in
   float free_words /. float heap_words
 
-let meminfo stats =
-  let { Xen_os.Memory.free_words; heap_words; _ } = stats in
-  let mem_total = heap_words * wordsize_in_bytes in
-  let mem_free = free_words * wordsize_in_bytes in
-  Log.info (fun f -> f "Writing meminfo: free %a / %a (%.2f %%)"
-    Fmt.bi_byte_size mem_free
-    Fmt.bi_byte_size mem_total
-    (fraction_free stats *. 100.0));
-  Printf.sprintf "MemTotal: %d kB\n\
-                  MemFree: %d kB\n\
-                  Buffers: 0 kB\n\
-                  Cached: 0 kB\n\
-                  SwapTotal: 0 kB\n\
-                  SwapFree: 0 kB\n" (mem_total / 1024) (mem_free / 1024)
-
-let report_mem_usage stats =
-  Lwt.async (fun () ->
-    let open Xen_os in
-    Xs.make () >>= fun xs ->
-    Xs.immediate xs (fun h ->
-      Xs.write h "memory/meminfo" (meminfo stats)
-    )
-  )
-
 let init () =
-  Gc.full_major ();
-  let stats = Xen_os.Memory.quick_stat () in
-  report_mem_usage stats
+  Gc.full_major ()
 
 let status () =
   let stats = Xen_os.Memory.quick_stat () in
@@ -48,8 +18,6 @@ let status () =
     Gc.full_major ();
     Xen_os.Memory.trim ();
     let stats = Xen_os.Memory.quick_stat () in
-    if fraction_free stats < 0.6 then begin
-      report_mem_usage stats;
-      `Memory_critical
-    end else `Ok
+    if fraction_free stats < 0.6 then `Memory_critical
+    else `Ok
   )

my_dns.ml

@@ -3,7 +3,8 @@ open Lwt.Infix
 module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) (Time : Mirage_time.S) = struct
   type +'a io = 'a Lwt.t
   type io_addr = Ipaddr.V4.t * int
-  type stack = Router.t * (src_port:int -> dst:Ipaddr.V4.t -> dst_port:int -> Cstruct.t -> (unit, [ `Msg of string ]) result Lwt.t) * (Udp_packet.t * Cstruct.t) Lwt_mvar.t
+  module Dispatcher = Dispatcher.Make(R)(C)(Time)
+  type stack = Dispatcher.t * (src_port:int -> dst:Ipaddr.V4.t -> dst_port:int -> Cstruct.t -> (unit, [ `Msg of string ]) result Lwt.t) * (Udp_packet.t * Cstruct.t) Lwt_mvar.t
 
   module IM = Map.Make(Int)
 
@@ -48,11 +49,10 @@ module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) (Time : Mirage_
   let connect (t : t) = Lwt.return (Ok (t.protocol, t))
 
   let send_recv (ctx : context) buf : (Cstruct.t, [> `Msg of string ]) result Lwt.t =
-    let open Router in
     let dst, dst_port = ctx.nameserver in
     let router, send_udp, _ = ctx.stack in
     let src_port, evict =
-      My_nat.free_udp_port router.nat ~src:router.uplink#my_ip ~dst ~dst_port:53
+      My_nat.free_udp_port router.nat ~src:router.config.our_ip ~dst ~dst_port:53
     in
     let id = Cstruct.BE.get_uint16 buf 0 in
     with_timeout ctx.timeout_ns

router.ml

@@ -1,34 +0,0 @@
-(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
-   See the README file for details. *)
-
-open Fw_utils
-
-(* The routing table *)
-
-type t = {
-  client_eth : Client_eth.t;
-  nat : My_nat.t;
-  uplink : interface;
-}
-
-let create ~client_eth ~uplink ~nat =
-  { client_eth; nat; uplink }
-
-let target t buf =
-  let dst_ip = buf.Ipv4_packet.dst in
-  match Client_eth.lookup t.client_eth dst_ip with
-  | Some client_link -> Some (client_link :> interface)
-  | None -> Some t.uplink
-
-let add_client t = Client_eth.add_client t.client_eth
-let remove_client t = Client_eth.remove_client t.client_eth
-
-let classify t ip =
-  if ip = Ipaddr.V4 t.uplink#my_ip then `Firewall
-  else if ip = Ipaddr.V4 t.uplink#other_ip then `NetVM
-  else (Client_eth.classify t.client_eth ip :> Packet.host)
-
-let resolve t = function
-  | `Firewall -> Ipaddr.V4 t.uplink#my_ip
-  | `NetVM -> Ipaddr.V4 t.uplink#other_ip
-  | #Client_eth.host as host -> Client_eth.resolve t.client_eth host

router.mli

@@ -1,31 +0,0 @@
-(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
-   See the README file for details. *)
-
-(** Routing packets to the right network interface. *)
-
-open Fw_utils
-
-type t = private {
-  client_eth : Client_eth.t;
-  nat : My_nat.t;
-  uplink : interface;
-}
-
-val create :
-  client_eth:Client_eth.t ->
-  uplink:interface ->
-  nat:My_nat.t ->
-  t
-(** [create ~client_eth ~uplink ~nat] is a new routing table
-    that routes packets outside of [client_eth] via [uplink]. *)
-
-val target : t -> Ipv4_packet.t -> interface option
-(** [target t packet] is the interface to which [packet] should be routed. *)
-
-val add_client : t -> client_link -> unit Lwt.t
-(** [add_client t iface] adds a rule for routing packets addressed to [iface]. *)
-
-val remove_client : t -> client_link -> unit
-
-val classify : t -> Ipaddr.t -> Packet.host
-val resolve : t -> Packet.host -> Ipaddr.t

unikernel.ml

@@ -3,27 +3,49 @@
 
 open Lwt
 open Qubes
+open Cmdliner
 
 let src = Logs.Src.create "unikernel" ~doc:"Main unikernel code"
 module Log = (val Logs.src_log src : Logs.LOG)
 
+let nat_table_size =
+  let doc = Arg.info ~doc:"The number of NAT entries to allocate." [ "nat-table-size" ] in
+  Arg.(value & opt int 5_000 doc)
+
+let ipv4 =
+  let doc = Arg.info ~doc:"Manual IP setting." [ "ipv4" ] in
+  Arg.(value & opt string "0.0.0.0" doc)
+
+let ipv4_gw =
+  let doc = Arg.info ~doc:"Manual Gateway IP setting." [ "ipv4-gw" ] in
+  Arg.(value & opt string "0.0.0.0" doc)
+
+let ipv4_dns =
+  let doc = Arg.info ~doc:"Manual DNS IP setting." [ "ipv4-dns" ] in
+  Arg.(value & opt string "10.139.1.1" doc)
+
+let ipv4_dns2 =
+  let doc = Arg.info ~doc:"Manual Second DNS IP setting." [ "ipv4-dns2" ] in
+  Arg.(value & opt string "10.139.1.2" doc)
+
 module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_time.S) = struct
-  module Uplink = Uplink.Make(R)(Clock)(Time)
+  module Dispatcher = Dispatcher.Make(R)(Clock)(Time)
   module Dns_transport = My_dns.Transport(R)(Clock)(Time)
   module Dns_client = Dns_client.Make(Dns_transport)
 
   (* Set up networking and listen for incoming packets. *)
-  let network dns_client dns_responses dns_servers uplink qubesDB router =
+  let network dns_client dns_responses dns_servers qubesDB router =
     (* Report success *)
     Dao.set_iptables_error qubesDB "" >>= fun () ->
     (* Handle packets from both networks *)
     Lwt.choose [
-      Client_net.listen Clock.elapsed_ns dns_client dns_servers qubesDB router;
-      Uplink.listen uplink Clock.elapsed_ns dns_responses router
+      Dispatcher.wait_clients Clock.elapsed_ns dns_client dns_servers qubesDB router ;
+      Dispatcher.uplink_wait_update qubesDB router ;
+      Dispatcher.uplink_listen Clock.elapsed_ns dns_responses router
     ]
 
   (* Main unikernel entry point (called from auto-generated main.ml). *)
-  let start _random _clock _time =
+  let start _random _clock _time nat_table_size ipv4 ipv4_gw ipv4_dns ipv4_dns2 =
     let start_time = Clock.elapsed_ns () in
     (* Start qrexec agent and QubesDB agent in parallel *)
     let qrexec = RExec.connect ~domid:0 () in
@@ -44,30 +66,50 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_tim
       Xen_os.Lifecycle.await_shutdown_request () >>= fun (`Poweroff | `Reboot) ->
       Lwt.return_unit in
     (* Set up networking *)
-    let max_entries = Key_gen.nat_table_size () in
-    let nat = My_nat.create ~max_entries in
+    let nat = My_nat.create ~max_entries:nat_table_size in
 
-    (* Read network configuration from QubesDB *)
+    let netvm_ip = Ipaddr.V4.of_string_exn ipv4_gw in
+    let our_ip = Ipaddr.V4.of_string_exn ipv4 in
+    let dns = Ipaddr.V4.of_string_exn ipv4_dns in
+    let dns2 = Ipaddr.V4.of_string_exn ipv4_dns2 in
+    
+    let zero_ip = (Ipaddr.V4.make 0 0 0 0) in
+    
+    let network_config  =
+      if (netvm_ip = zero_ip && our_ip = zero_ip) then (* Read network configuration from QubesDB *)
         Dao.read_network_config qubesDB >>= fun config ->
+        if config.netvm_ip = zero_ip || config.our_ip = zero_ip then
+          Log.info (fun f -> f "We currently have no netvm nor command line for setting it up, aborting...");
+        assert (config.netvm_ip <> zero_ip && config.our_ip <> zero_ip);
+        Lwt.return config
+      else begin
+        let config:Dao.network_config = {from_cmdline=true; netvm_ip; our_ip; dns; dns2} in
+        Lwt.return config
+      end
+    in
+    network_config >>= fun config ->
+
+    (* We now must have a valid netvm IP address and our IP address or crash *)
+    Dao.print_network_config config ;
 
-    Uplink.connect config >>= fun uplink ->
     (* Set up client-side networking *)
-    let client_eth = Client_eth.create
-      ~client_gw:config.Dao.clients_our_ip in
+    Client_eth.create config >>= fun clients ->
+
     (* Set up routing between networks and hosts *)
-    let router = Router.create
-      ~client_eth
-      ~uplink:(Uplink.interface uplink)
+    let router = Dispatcher.create
+      ~config
+      ~clients
       ~nat
+      ~uplink:None
     in
 
-    let send_dns_query = Uplink.send_dns_client_query uplink in
+    let send_dns_query = Dispatcher.send_dns_client_query router in
     let dns_mvar = Lwt_mvar.create_empty () in
     let nameservers = `Udp, [ config.Dao.dns, 53 ; config.Dao.dns2, 53 ] in
     let dns_client = Dns_client.create ~nameservers (router, send_dns_query, dns_mvar) in
 
     let dns_servers = [ config.Dao.dns ; config.Dao.dns2 ] in
-    let net_listener = network (Dns_client.getaddrinfo dns_client Dns.Rr_map.A) dns_mvar dns_servers uplink qubesDB router in
+    let net_listener = network (Dns_client.getaddrinfo dns_client Dns.Rr_map.A) dns_mvar dns_servers qubesDB router in
 
     (* Report memory usage to XenStore *)
     Memory_pressure.init ();

uplink.ml

@@ -1,94 +0,0 @@
-(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
-   See the README file for details. *)
-
-open Lwt.Infix
-open Fw_utils
-
-module Eth = Ethernet.Make(Netif)
-
-let src = Logs.Src.create "uplink" ~doc:"Network connection to NetVM"
-module Log = (val Logs.src_log src : Logs.LOG)
-
-module Make (R:Mirage_random.S) (Clock : Mirage_clock.MCLOCK) (Time : Mirage_time.S) = struct
-  module Arp = Arp.Make(Eth)(Time)
-  module I = Static_ipv4.Make(R)(Clock)(Eth)(Arp)
-  module U = Udp.Make(I)(R)
-
-  type t = {
-    net : Netif.t;
-    eth : Eth.t;
-    arp : Arp.t;
-    interface : interface;
-    mutable fragments : Fragments.Cache.t;
-    ip : I.t;
-    udp: U.t;
-  }
-
-class netvm_iface eth mac ~my_ip ~other_ip : interface = object
-  method my_mac = Eth.mac eth
-  method my_ip = my_ip
-  method other_ip = other_ip
-  method writev ethertype fillfn =
-    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 =
-    U.write ~src_port ~dst ~dst_port t.udp buf >|= function
-    | Error s -> Log.err (fun f -> f "error sending udp packet: %a" U.pp_error s); Error (`Msg "failure")
-    | Ok () -> Ok ()
-
-  let listen t get_ts dns_responses router =
-    let handle_packet ip_header ip_packet =
-      let open Udp_packet in
-
-      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 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)
-      | _ ->
-        Firewall.ipv4_from_netvm router (`IPv4 (ip_header, ip_packet))
-    in
-    Netif.listen t.net ~header_size:Ethernet.Packet.sizeof_ethernet (fun frame ->
-        (* Handle one Ethernet frame from NetVM *)
-        Eth.input t.eth
-        ~arpv4:(Arp.input t.arp)
-        ~ipv4:(fun ip ->
-            let cache, r =
-              Nat_packet.of_ipv4_packet t.fragments ~now:(get_ts ()) ip
-            in
-            t.fragments <- cache;
-            match r with
-              | Error e ->
-                Log.warn (fun f -> f "Ignored unknown IPv4 message from uplink: %a" Nat_packet.pp_error e);
-                Lwt.return ()
-              | Ok None -> Lwt.return_unit
-              | Ok (Some (`IPv4 (header, packet))) -> handle_packet header packet
-            )
-        ~ipv6:(fun _ip -> Lwt.return_unit)
-        frame
-    ) >|= or_raise "Uplink listen loop" Netif.pp_error
-
-
-let interface t = t.interface
-
-let connect config =
-  let my_ip = config.Dao.uplink_our_ip in
-  let gateway = config.Dao.uplink_netvm_ip in
-  Netif.connect "0" >>= fun net ->
-  Eth.connect net >>= fun eth ->
-  Arp.connect eth >>= fun arp ->
-  Arp.add_ip arp my_ip >>= fun () ->
-  let cidr = Ipaddr.V4.Prefix.make 0 my_ip in
-  I.connect ~cidr ~gateway eth arp >>= fun ip ->
-  U.connect ip >>= fun udp ->
-  let netvm_mac =
-    Arp.query arp gateway
-    >|= or_raise "Getting MAC of our NetVM" Arp.pp_error in
-  let interface = new netvm_iface eth netvm_mac
-    ~my_ip
-    ~other_ip:config.Dao.uplink_netvm_ip in
-  let fragments = Fragments.Cache.empty (256 * 1024) in
-  Lwt.return { net; eth; arp; interface ; fragments ; ip ; udp }
-end

uplink.mli

@@ -1,21 +0,0 @@
-(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
-   See the README file for details. *)
-
-(** The link from us to NetVM (and, through that, to the outside world). *)
-
-open Fw_utils
-
-module Make (R: Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_time.S) : sig
-  type t
-
-  val connect : Dao.network_config -> t Lwt.t
-  (** Connect to our NetVM (gateway). *)
-
-  val interface : t -> interface
-  (** The network interface to NetVM. *)
-
-  val listen : t -> (unit -> int64) -> (Udp_packet.t * Cstruct.t) Lwt_mvar.t -> Router.t -> unit Lwt.t
-  (** Handle incoming frames from NetVM. *)
-
-  val send_dns_client_query: t -> src_port:int-> dst:Ipaddr.V4.t -> dst_port:int -> Cstruct.t -> (unit, [`Msg of string]) result Lwt.t
-end