Merge pull request #218 from mirage/tst

minor change

.github/workflows/docker.yml

@@ -19,14 +19,14 @@ jobs:
 
     steps:
       - name: Checkout code
-        uses: actions/checkout@v2
+        uses: actions/checkout@v4
 
       - run: ./build-with.sh docker
 
-      - 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'
+      - run: sh -exc 'if [ "$(sha256sum dist/qubes-firewall.xen)" = "$(cat qubes-firewall.sha256)" ]; then echo "SHA256 MATCHES"; else exit 42; fi'
 
       - name: Upload Artifact
-        uses: actions/upload-artifact@v3
+        uses: actions/upload-artifact@v4
         with:
-          name: mirage-firewall.tar.bz2
+          name: qubes-firewall.xen
-          path: mirage-firewall.tar.bz2
+          path: qubes-firewall.xen

.github/workflows/format.yml

@@ -0,0 +1,42 @@
+name: ocamlformat
+
+on: [push]
+
+jobs:
+  format:
+    name: ocamlformat
+
+    strategy:
+      fail-fast: false
+      matrix:
+        ocaml-version: ["4.14.2"]
+        operating-system: [ubuntu-latest]
+
+    runs-on: ${{ matrix.operating-system }}
+
+    steps:
+      - name: Checkout code
+        uses: actions/checkout@v4
+
+      - name: Use OCaml ${{ matrix.ocaml-version }}
+        uses: ocaml/setup-ocaml@v3
+        with:
+          ocaml-compiler: ${{ matrix.ocaml-version }}
+
+      - name: Install ocamlformat
+        run: grep ^version .ocamlformat | cut -d '=' -f 2 | xargs -I V opam install ocamlformat=V
+
+      - name: Format code
+        run: git ls-files '*.ml' '*.mli' | xargs opam exec -- ocamlformat --inplace
+
+      - name: Check for modified files
+        id: git-check
+        run: echo "modified=$(if git diff-index --quiet HEAD --; then echo "false"; else echo "true"; fi)" >> $GITHUB_OUTPUT
+
+      - name: Commit and push changes
+        if: steps.git-check.outputs.modified == 'true'
+        run: |
+          git config --global user.name "Automated ocamlformat GitHub action, developed by robur.coop"
+          git config --global user.email "autoformat@robur.coop"
+          git commit -m "formatted code" .
+          git push

.github/workflows/podman.yml

@@ -19,14 +19,14 @@ jobs:
 
     steps:
       - name: Checkout code
-        uses: actions/checkout@v2
+        uses: actions/checkout@v4
 
       - 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'
+      - run: sh -exc 'if [ "$(sha256sum dist/qubes-firewall.xen)" = "$(cat qubes-firewall.sha256)" ]; then echo "SHA256 MATCHES"; else exit 42; fi'
 
       - name: Upload Artifact
-        uses: actions/upload-artifact@v3
+        uses: actions/upload-artifact@v4
         with:
-          name: mirage-firewall.tar.bz2
+          name: qubes-firewall.xen
-          path: mirage-firewall.tar.bz2
+          path: qubes-firewall.xen

.ocamlformat

@@ -0,0 +1,3 @@
+version = 0.27.0
+profile = conventional
+parse-docstrings = true

CHANGES.md

@@ -1,3 +1,29 @@
+### 0.9.4 (2025-02-10)
+
+- Fix an issue when qubes-mirage-firewall is used a a mullvad AppVM client. If
+  our netvm does not reply to our ARP requests we can not construct the ethernet
+  header. However in Linux VMs, Qubes adds a default netvm address associated to
+  `fe:ff:ff:ff:ff:ff`, so if ARP fails, we fall back on that address.
+  (#213, @palainp, reported in the Qubes forum #212, reviewed by @hannesm)
+
+### 0.9.3 (2025-01-04)
+
+- Fix an issue when qubes-mirage-firewall is used along with *BSD sys-net
+  (#209, @palainp, reported in the Qubes forum #208, reviewed by @dinosaure)
+
+### 0.9.2 (2024-10-16)
+
+- Code refactoring and improvements (#197, @dinosaure)
+- Build tooling updates: opam 2.2.1, solo5 0.9, mirage 4.8.1 (#199, #201, #202,
+  #203, @hannesm)
+
+### 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

Dockerfile

@@ -12,10 +12,10 @@ RUN printf "deb [check-valid-until=no] http://snapshot.debian.org/archive/debian
 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 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
+RUN wget -O /usr/bin/opam https://github.com/ocaml/opam/releases/download/2.3.0/opam-2.3.0-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
+"4c0e8771889a36bad4d5f964e2e662d5b611e6f112777d3d4eea3eea919d109cd17826beba38e6cfa1ad9553a0a989d9268f911ea5485968da04b1e08efc7de2" || exit
 
 ENV OPAMROOT=/tmp
 ENV OPAMCONFIRMLEVEL=unsafe-yes
@@ -23,13 +23,13 @@ ENV OPAMCONFIRMLEVEL=unsafe-yes
 # Remove this line (and the base image pin above) if you want to test with the
 # latest versions.
 # taken from https://github.com/ocaml/opam-repository
-RUN opam init --disable-sandboxing -a --bare https://github.com/ocaml/opam-repository.git#4399f486aa6edefdc96d5e206a65ce42288ebfdd
+RUN opam init --disable-sandboxing -a --bare https://github.com/ocaml/opam-repository.git#8f63148a9025a7b775a069a6c0b0385c22ad51d3
-RUN opam switch create myswitch 4.14.1
+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 --extra-repos=\
-opam-overlays:https://github.com/dune-universe/opam-overlays.git#4e75ee36715b27550d5bdb87686bb4ae4c9e89c4,\
+opam-overlays:https://github.com/dune-universe/opam-overlays.git#f2bec38beca4aea9e481f2fd3ee319c519124649,\
 mirage-overlays:https://github.com/dune-universe/mirage-opam-overlays.git#797cb363df3ff763c43c8fbec5cd44de2878757e \
-&& make depend && make tar'
+&& make depend && make unikernel'

LICENSE.md

@@ -0,0 +1,23 @@
+Copyright (X) 2015-2024, the Qubes Mirage Firewall authors
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without modification,
+are permitted provided that the following conditions are met:
+
+* Redistributions of source code must retain the above copyright notice, this
+  list of conditions and the following disclaimer.
+
+* Redistributions in binary form must reproduce the above copyright notice, this
+  list of conditions and the following disclaimer in the documentation and/or
+  other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR
+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

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

@@ -1,13 +1,8 @@
-tar: build
+unikernel: build
-	rm -rf _build/mirage-firewall
-	mkdir _build/mirage-firewall
 	cp dist/qubes-firewall.xen dist/qubes-firewall.xen.debug
 	strip dist/qubes-firewall.xen
-	cp dist/qubes-firewall.xen _build/mirage-firewall/vmlinuz
+	cp dist/qubes-firewall.xen .
-	touch _build/mirage-firewall/modules.img
+	sha256sum qubes-firewall.xen
-	cat /dev/null | gzip -n > _build/mirage-firewall/initramfs
-	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

@@ -48,7 +48,7 @@ It's OK to install the Docker or Podman package in a template VM if you want it
 after a reboot, but the build of the firewall itself should be done in a regular AppVM.
 
 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.
+see [the Mirage installation instructions](https://mirageos.org/wiki/install) for details.
 
 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
@@ -58,20 +58,15 @@ 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`,
+If you want to deploy manually, you just need to download `qubes-firewall.xen` and
-which is the unikernel itself, plus a dummy initramfs file that Qubes requires:
+`qubes-firewall.sha256` in domU and check that the `.xen` file has a corresponding
-
+hashsum. `qubes-firewall.xen` is the unikernel itself and should be copied to
-    [user@dev ~]$ tar xjf mirage-firewall.tar.bz2
+`vmlinuz` in the `/var/lib/qubes/vm-kernels/mirage-firewall` directory in dom0, e.g.
-
+(if `dev` is the AppVM where you built it):
-Copy `vmlinuz` to `/var/lib/qubes/vm-kernels/mirage-firewall` directory in dom0, e.g. (if `dev` is the AppVM where you built it):
 
     [tal@dom0 ~]$ mkdir -p /var/lib/qubes/vm-kernels/mirage-firewall/
     [tal@dom0 ~]$ cd /var/lib/qubes/vm-kernels/mirage-firewall/
-    [tal@dom0 mirage-firewall]$ qvm-run -p dev 'cat mirage-firewall/vmlinuz' > vmlinuz
+    [tal@dom0 mirage-firewall]$ qvm-run -p dev 'cat mirage-firewall/qubes-firewall.xen' > vmlinuz
-
-Finally, create [a dummy file required by Qubes OS](https://github.com/QubesOS/qubes-issues/issues/5516):
-
-    [tal@dom0 mirage-firewall]$ gzip -n9 < /dev/null > initramfs
 
 Run this command in dom0 to create a `mirage-firewall` VM using the `mirage-firewall` kernel you added above
 
@@ -212,16 +207,7 @@ See [issues tagged "security"](https://github.com/mirage/qubes-mirage-firewall/i
 
 # LICENSE
 
-Copyright (c) 2019, Thomas Leonard
+See [LICENSE.md](https://github.com/mirage/qubes-mirage-firewall/blob/main/LICENSE.md)
-All rights reserved.
-
-Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
-
-1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
-
-2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
 [test-mirage]: https://github.com/talex5/qubes-test-mirage
 [mirage-qubes]: https://github.com/mirage/mirage-qubes

SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls

@@ -10,13 +10,14 @@
 {% set DownloadVM = "DownloadVmMirage" %}
 {% set MirageFW = "sys-mirage-fw" %}
 {% set GithubUrl = "https://github.com/mirage/qubes-mirage-firewall" %}
-{% set Filename = "mirage-firewall.tar.bz2" %}
+{% set Kernel = "qubes-firewall.xen" %}
+{% set Shasum = "qubes-firewall-release.sha256" %}
 {% 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") %}
+{% if Release != salt['cmd.shell']("test -e " ~ MirageInstallDir ~ "/version.txt" ~ " || mkdir " ~ MirageInstallDir ~ " ; touch " ~ MirageInstallDir ~ "/version.txt" ~ " ; cat " ~ MirageInstallDir ~ "/version.txt") %}
 
 create-downloader-VM:
   qvm.vm:
@@ -28,13 +29,14 @@ create-downloader-VM:
        - template: {{ DownloadVMTemplate }}
        - include-in-backups: false
 
-{% set DownloadBinary = GithubUrl ~ "/releases/download/" ~ Release ~ "/" ~ Filename %}
+{% set DownloadBinary = GithubUrl ~ "/releases/download/" ~ Release ~ "/" ~ Kernel %}
+{% set DownloadShasum = GithubUrl ~ "/releases/download/" ~ Release ~ "/" ~ Shasum %}
 
 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 }}
+      - qvm-run --pass-io {{ DownloadVM }} {{ "curl -L -O " ~ DownloadShasum }}
     - require: 
       - create-downloader-VM
 
@@ -42,23 +44,22 @@ download-and-unpack-in-DownloadVM4mirage:
 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 release on github:\\\";cat " ~ Shasum ~ " | cut -d\' \' -f1\"" }}
-      - qvm-run --pass-io {{ DownloadVM }} {{ "\"echo \\\"Checksum of downloaded local file:\\\";sha256sum ~/mirage-firewall/vmlinuz | cut -d\' \' -f1\"" }}
+      - qvm-run --pass-io {{ DownloadVM }} {{ "\"echo \\\"Checksum of downloaded local file:\\\";sha256sum " ~ Kernel ~ " | 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
+      - qvm-run --pass-io {{ DownloadVM }} {{ "\"diff <(cat " ~ Shasum ~ " | cut -d\' \' -f1) <(sha256sum " ~ Kernel ~ " | cut -d\' \' -f1) && echo \\\"Checksums DO match.\\\" || (echo \\\"Checksums do NOT match.\\\";exit 101)\"" }}
     - 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" }}
+    - name: mkdir -p {{ MirageInstallDir }}; qvm-run --pass-io --no-gui {{ DownloadVM }} {{ "cat " ~ Kernel }} > {{ MirageInstallDir ~ "/vmlinuz" }}
     - require: 
       - download-and-unpack-in-DownloadVM4mirage
       - check-checksum-in-DownloadVM
 
-create-initramfs:
+update-version:
   cmd.run: 
     - names: 
-      - gzip -n9 < /dev/null > {{ MirageInstallDir ~ "/initramfs" }}
       - echo {{ Release }} > {{ MirageInstallDir ~ "/version.txt" }}
     - require: 
       - copy-mirage-kernel-to-dom0
@@ -90,9 +91,9 @@ create-sys-mirage-fw:
 cleanup-in-DownloadVM:
   cmd.run:
    - names:
-      - qvm-run -a --pass-io --no-gui {{ DownloadVM }} "{{ "rm " ~ Filename ~ "; rm -R ~/mirage-firewall" }}"
+      - qvm-run -a --pass-io --no-gui {{ DownloadVM }} "{{ "rm " ~ Kernel ~ " " ~ Shasum }}"
    - require: 
-     - create-initramfs
+     - update-version 
 
 remove-DownloadVM4mirage:
   qvm.absent:

build-with.sh

@@ -19,6 +19,7 @@ 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 of build:     $(sha256sum ./dist/qubes-firewall.xen | cut -d' ' -f1)"
-echo "SHA2 last known:  163991ea96842e03d378501a0be99057ad2489440aff8ae81d850624d98fd3f0"
+echo "SHA2 current head: $(cat qubes-firewall.sha256 | cut -d' ' -f1)"
-echo "(hashes should match for released versions)"
+echo "SHA2 last release: $(cat qubes-firewall-release.sha256 | cut -d' ' -f1)"
+echo "(hashes should match for head versions)"

cleanup.ml

@@ -4,9 +4,7 @@
 type t = (unit -> unit) list ref
 
 let create () = ref []
-
+let on_cleanup t fn = t := fn :: !t
-let on_cleanup t fn =
-  t := fn :: !t
 
 let cleanup t =
   let tasks = !t in

cleanup.mli

@@ -1,8 +1,8 @@
 (* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
    See the README file for details. *)
 
-(** Register actions to take when a resource is finished.
+(** Register actions to take when a resource is finished. Like [Lwt_switch], but
-    Like [Lwt_switch], but synchronous. *)
+    synchronous. *)
 
 type t
 

client_eth.ml

@@ -4,59 +4,63 @@
 open Fw_utils
 open Lwt.Infix
 
-let src = Logs.Src.create "client_eth" ~doc:"Ethernet networks for NetVM clients"
+let src =
+  Logs.Src.create "client_eth" ~doc:"Ethernet networks for NetVM clients"
+
 module Log = (val Logs.src_log src : Logs.LOG)
 
 type t = {
-  mutable iface_of_ip : client_link IpMap.t;
+  mutable iface_of_ip : client_link Ipaddr.V4.Map.t;
-  changed : unit Lwt_condition.t;   (* Fires when [iface_of_ip] changes. *)
+  changed : unit Lwt_condition.t; (* Fires when [iface_of_ip] changes. *)
-  my_ip : 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 =
+type host = [ `Client of client_link | `Firewall | `External of Ipaddr.t ]
-  [ `Client of client_link
-  | `Firewall
-  | `External of Ipaddr.t ]
 
 let create config =
   let changed = Lwt_condition.create () in
   let my_ip = config.Dao.our_ip in
-  Lwt.return { iface_of_ip = IpMap.empty; my_ip; changed }
+  Lwt.return { iface_of_ip = Ipaddr.V4.Map.empty; my_ip; changed }
 
 let client_gw t = t.my_ip
 
 let add_client t iface =
   let ip = iface#other_ip in
   let rec aux () =
-    match IpMap.find ip t.iface_of_ip with
+    match Ipaddr.V4.Map.find_opt ip t.iface_of_ip with
     | Some old ->
-      (* Wait for old client to disappear before adding one with the same IP address.
+        (* Wait for old client to disappear before adding one with the same IP address.
          Otherwise, its [remove_client] call will remove the new client instead. *)
-      Log.info (fun f -> f ~header:iface#log_header "Waiting for old client %s to go away before accepting new one" old#log_header);
+        Log.info (fun f ->
-      Lwt_condition.wait t.changed >>= aux
+            f ~header:iface#log_header
+              "Waiting for old client %s to go away before accepting new one"
+              old#log_header);
+        Lwt_condition.wait t.changed >>= aux
     | None ->
-      t.iface_of_ip <- t.iface_of_ip |> IpMap.add ip iface;
+        t.iface_of_ip <- t.iface_of_ip |> Ipaddr.V4.Map.add ip iface;
-      Lwt_condition.broadcast t.changed ();
+        Lwt_condition.broadcast t.changed ();
-      Lwt.return_unit
+        Lwt.return_unit
   in
   aux ()
 
 let remove_client t iface =
   let ip = iface#other_ip in
-  assert (IpMap.mem ip t.iface_of_ip);
+  assert (Ipaddr.V4.Map.mem ip t.iface_of_ip);
-  t.iface_of_ip <- t.iface_of_ip |> IpMap.remove ip;
+  t.iface_of_ip <- t.iface_of_ip |> Ipaddr.V4.Map.remove ip;
   Lwt_condition.broadcast t.changed ()
 
-let lookup t ip = IpMap.find ip t.iface_of_ip
+let lookup t ip = Ipaddr.V4.Map.find_opt ip t.iface_of_ip
 
 let classify t ip =
   match ip with
   | Ipaddr.V6 _ -> `External ip
-  | Ipaddr.V4 ip4 ->
+  | Ipaddr.V4 ip4 -> (
-    if ip4 = t.my_ip then `Firewall
+      if ip4 = t.my_ip then `Firewall
-    else match lookup t ip4 with
+      else
-      | Some client_link -> `Client client_link
+        match lookup t ip4 with
-      | None -> `External ip
+        | 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
@@ -64,50 +68,53 @@ let resolve t : host -> Ipaddr.t = function
   | `External addr -> addr
 
 module ARP = struct
-  type arp = {
+  type arp = { net : t; client_link : client_link }
-    net : t;
-    client_link : client_link;
-  }
 
   let lookup t ip =
     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
+      Log.info (fun f ->
-                   "Request for %a is invalid, but pretending it's me (see Qubes issue #5022)" Ipaddr.V4.pp ip);
+          f ~header:t.client_link#log_header
-      Some t.client_link#my_mac
+            "Request for %a is invalid, but pretending it's me (see Qubes \
-    ) else None
+             issue #5022)"
+            Ipaddr.V4.pp ip);
+      Some t.client_link#my_mac)
+    else None
   (* We're now treating client networks as point-to-point links,
      so we no longer respond on behalf of other clients. *)
-    (*
+  (*
-    else match IpMap.find ip t.net.iface_of_ip with
+    else match Ipaddr.V4.Map.find_opt ip t.net.iface_of_ip with
     | Some client_iface -> Some client_iface#other_mac
     | None -> None
      *)
 
-  let create ~net client_link = {net; client_link}
+  let create ~net client_link = { net; client_link }
 
   let input_query t arp =
     let req_ipv4 = arp.Arp_packet.target_ip in
     let pf (f : ?header:string -> ?tags:_ -> _) fmt =
-      f ~header:t.client_link#log_header ("who-has %a? " ^^ fmt) Ipaddr.V4.pp req_ipv4
+      f ~header:t.client_link#log_header ("who-has %a? " ^^ fmt) Ipaddr.V4.pp
+        req_ipv4
     in
     if req_ipv4 = t.client_link#other_ip then (
       Log.info (fun f -> pf f "ignoring request for client's own IP");
-      None
+      None)
-    ) else match lookup t req_ipv4 with
+    else
+      match lookup t req_ipv4 with
       | None ->
-        Log.info (fun f -> pf f "unknown address; not responding");
+          Log.info (fun f -> pf f "unknown address; not responding");
-        None
+          None
       | Some req_mac ->
-        Log.info (fun f -> pf f "responding with %a" Macaddr.pp req_mac);
+          Log.info (fun f -> pf f "responding with %a" Macaddr.pp req_mac);
-        Some { Arp_packet.
+          Some
-               operation = Arp_packet.Reply;
+            {
-               (* The Target Hardware Address and IP are copied from the request *)
+              Arp_packet.operation = Arp_packet.Reply;
-               target_ip = arp.Arp_packet.source_ip;
+              (* The Target Hardware Address and IP are copied from the request *)
-               target_mac = arp.Arp_packet.source_mac;
+              target_ip = arp.Arp_packet.source_ip;
-               source_ip = req_ipv4;
+              target_mac = arp.Arp_packet.source_mac;
-               source_mac = req_mac;
+              source_ip = req_ipv4;
-             }
+              source_mac = req_mac;
+            }
 
   let input_gratuitous t arp =
     let source_ip = arp.Arp_packet.source_ip in
@@ -115,18 +122,28 @@ module ARP = struct
     let header = t.client_link#log_header in
     match lookup t source_ip with
     | Some real_mac when Macaddr.compare source_mac real_mac = 0 ->
-      Log.info (fun f -> f ~header "client suggests updating %s -> %s (as expected)"
+        Log.info (fun f ->
-                   (Ipaddr.V4.to_string source_ip) (Macaddr.to_string source_mac));
+            f ~header "client suggests updating %s -> %s (as expected)"
+              (Ipaddr.V4.to_string source_ip)
+              (Macaddr.to_string source_mac))
     | Some other_mac ->
-      Log.warn (fun f -> f ~header "client suggests incorrect update %s -> %s (should be %s)"
+        Log.warn (fun f ->
-                   (Ipaddr.V4.to_string source_ip) (Macaddr.to_string source_mac) (Macaddr.to_string other_mac));
+            f ~header "client suggests incorrect update %s -> %s (should be %s)"
+              (Ipaddr.V4.to_string source_ip)
+              (Macaddr.to_string source_mac)
+              (Macaddr.to_string other_mac))
     | None ->
-      Log.warn (fun f -> f ~header "client suggests incorrect update %s -> %s (unexpected IP)"
+        Log.warn (fun f ->
-                   (Ipaddr.V4.to_string source_ip) (Macaddr.to_string source_mac))
+            f ~header
+              "client suggests incorrect update %s -> %s (unexpected IP)"
+              (Ipaddr.V4.to_string source_ip)
+              (Macaddr.to_string source_mac))
 
   let input t arp =
     let op = arp.Arp_packet.operation in
     match op with
     | Arp_packet.Request -> input_query t arp
-    | Arp_packet.Reply -> input_gratuitous t arp; None
+    | Arp_packet.Reply ->
+        input_gratuitous t arp;
+        None
 end

client_eth.mli

@@ -1,34 +1,32 @@
 (* Copyright (C) 2016, Thomas Leonard <thomas.leonard@unikernel.com>
    See the README file for details. *)
 
-(** The ethernet networks connecting us to our client AppVMs.
+(** The ethernet networks connecting us to our client AppVMs. Note: each AppVM
-    Note: each AppVM is on a point-to-point link, each link being considered to be a separate Ethernet network. *)
+    is on a point-to-point link, each link being considered to be a separate
+    Ethernet network. *)
 
 open Fw_utils
 
 type t
 (** A collection of clients. *)
 
-type host =
+type host = [ `Client of client_link | `Firewall | `External of Ipaddr.t ]
-  [ `Client of client_link
-  | `Firewall
-  | `External of Ipaddr.t ]
 (* Note: Qubes does not allow us to distinguish between an external address and a
    disconnected client.
    See: https://github.com/talex5/qubes-mirage-firewall/issues/9#issuecomment-246956850 *)
 
 val create : Dao.network_config -> t Lwt.t
-(** [create ~client_gw] is a network of client machines.
+(** [create ~client_gw] is a network of client machines. Qubes will have
-    Qubes will have configured the client machines to use [client_gw] as their default gateway. *)
+    configured the client machines to use [client_gw] as their default gateway.
+*)
 
 val add_client : t -> client_link -> unit Lwt.t
-(** [add_client t client] registers a new client. If a client with this IP address is already registered,
+(** [add_client t client] registers a new client. If a client with this IP
-    it waits for [remove_client] to be called on that before adding the new client and returning. *)
+    address is already registered, it waits for [remove_client] to be called on
+    that before adding the new client and returning. *)
 
 val remove_client : t -> client_link -> unit
-
 val client_gw : t -> Ipaddr.V4.t
-
 val classify : t -> Ipaddr.t -> host
 val resolve : t -> host -> Ipaddr.t
 
@@ -36,18 +34,18 @@ val lookup : t -> Ipaddr.V4.t -> client_link option
 (** [lookup t addr] is the client with IP address [addr], if connected. *)
 
 module ARP : sig
-  (** We already know the correct mapping of IP addresses to MAC addresses, so we never
+  (** We already know the correct mapping of IP addresses to MAC addresses, so
-      allow clients to update it. We log a warning if a client attempts to set incorrect
+      we never allow clients to update it. We log a warning if a client attempts
-      information. *)
+      to set incorrect information. *)
 
   type arp
   (** An ARP-responder for one client. *)
 
   val create : net:t -> client_link -> arp
-  (** [create ~net client_link] is an ARP responder for [client_link].
+  (** [create ~net client_link] is an ARP responder for [client_link]. It
-      It answers only for the client's gateway address. *)
+      answers only for the client's gateway address. *)
 
   val input : arp -> Arp_packet.t -> Arp_packet.t option
-  (** Process one ethernet frame containing an ARP message.
+  (** Process one ethernet frame containing an ARP message. Returns a response
-      Returns a response frame, if one is needed. *)
+      frame, if one is needed. *)
 end

command.ml

@@ -4,24 +4,30 @@
 (** Commands we provide via qvm-run. *)
 
 open Lwt
-
 module Flow = Qubes.RExec.Flow
 
 let src = Logs.Src.create "command" ~doc:"qrexec command handler"
+
 module Log = (val Logs.src_log src : Logs.LOG)
 
 let set_date_time flow =
   Flow.read_line flow >|= function
-  | `Eof -> Log.warn (fun f -> f "EOF reading time from dom0"); 1
+  | `Eof ->
-  | `Ok line -> Log.info (fun f -> f "TODO: set time to %S" line); 0
+      Log.warn (fun f -> f "EOF reading time from dom0");
+      1
+  | `Ok line ->
+      Log.info (fun f -> f "TODO: set time to %S" line);
+      0
 
 let handler ~user:_ cmd flow =
   (* Write a message to the client and return an exit status of 1. *)
   let error fmt =
-    fmt |> Printf.ksprintf @@ fun s ->
+    fmt
-    Log.warn (fun f -> f "<< %s" s);
+    |> Printf.ksprintf @@ fun s ->
-    Flow.ewritef flow "%s [while processing %S]" s cmd >|= fun () -> 1 in
+       Log.warn (fun f -> f "<< %s" s);
+       Flow.ewritef flow "%s [while processing %S]" s cmd >|= fun () -> 1
+  in
   match cmd with
   | "QUBESRPC qubes.SetDateTime dom0" -> set_date_time flow
-  | "QUBESRPC qubes.WaitForSession none" -> return 0  (* Always ready! *)
+  | "QUBESRPC qubes.WaitForSession none" -> return 0 (* Always ready! *)
   | cmd -> error "Unknown command %S" cmd

config.ml

@@ -1,4 +1,4 @@
-(* mirage >= 4.5.0 & < 5.0.0 *)
+(* mirage >= 4.9.0 & < 4.10.0 *)
 (* Copyright (C) 2017, Thomas Leonard <thomas.leonard@unikernel.com>
    See the README file for details. *)
 
@@ -6,34 +6,25 @@
 
 open Mirage
 
-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 =
-   main
+  main
-    ~runtime_args:[ nat_table_size; ipv4; ipv4_gw; ipv4_dns; ipv4_dns2; ]
+    ~packages:
-    ~packages:[
+      [
-      package "vchan" ~min:"4.0.2";
+        package "vchan" ~min:"4.0.2";
-      package "cstruct";
+        package "cstruct";
-      package "astring";
+        package "tcpip" ~min:"3.7.0";
-      package "tcpip" ~min:"3.7.0";
+        package ~min:"2.3.0" ~sublibs:[ "mirage" ] "arp";
-      package ~min:"2.3.0" ~sublibs:["mirage"] "arp";
+        package ~min:"3.0.0" "ethernet";
-      package ~min:"3.0.0" "ethernet";
+        package "shared-memory-ring" ~min:"3.0.0";
-      package "shared-memory-ring" ~min:"3.0.0";
+        package "mirage-net-xen" ~min:"2.1.4";
-      package ~min:"2.1.3" "netchannel";
+        package "ipaddr" ~min:"5.2.0";
-      package "mirage-net-xen" ~min:"2.1.3";
+        package "mirage-qubes" ~min:"0.9.1";
-      package "ipaddr" ~min:"5.2.0";
+        package ~min:"3.0.1" "mirage-nat";
-      package "mirage-qubes" ~min:"0.9.1";
+        package "mirage-logs";
-      package ~min:"3.0.1" "mirage-nat";
+        package "mirage-xen" ~min:"8.0.0";
-      package "mirage-logs";
+        package ~min:"6.4.0" "dns-client";
-      package "mirage-xen" ~min:"8.0.0";
+        package "pf-qubes";
-      package ~min:"6.4.0" "dns-client";
+      ]
-      package "pf-qubes";
+    "Unikernel" job
-    ]
-    "Unikernel.Main" (random @-> mclock @-> time @-> job)
 
-let () =
+let () = register "qubes-firewall" [ main ]
-  register "qubes-firewall" [main $ default_random $ default_monotonic_clock $ default_time]

dao.ml

@@ -3,38 +3,36 @@
 
 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)
 
 module ClientVif = struct
-  type t = {
+  type t = { domid : int; device_id : int }
-    domid : int;
-    device_id : int;
-  }
 
-  let pp f { domid; device_id } = Fmt.pf f "{domid=%d;device_id=%d}" domid device_id
+  let pp f { domid; device_id } =
+    Fmt.pf f "{domid=%d;device_id=%d}" domid device_id
 
   let compare = compare
 end
+
 module VifMap = struct
-  include Map.Make(ClientVif)
+  include Map.Make (ClientVif)
+
   let rec of_list = function
     | [] -> empty
     | (k, v) :: rest -> add k v (of_list rest)
-  let find key t =
+
-    try Some (find key t)
+  let find key t = try Some (find key t) with Not_found -> None
-    with Not_found -> None
 end
 
 let directory ~handle dir =
   Xen_os.Xs.directory handle dir >|= function
-  | [""] -> []      (* XenStore client bug *)
+  | [ "" ] -> [] (* XenStore client bug *)
   | items -> items
 
-let db_root client_ip =
+let db_root client_ip = "/qubes-firewall/" ^ Ipaddr.V4.to_string client_ip
-  "/qubes-firewall/" ^ (Ipaddr.V4.to_string client_ip)
 
 let read_rules rules client_ip =
   let root = db_root client_ip in
@@ -43,89 +41,101 @@ let read_rules rules client_ip =
     Log.debug (fun f -> f "reading %s" pattern);
     match Qubes.DB.KeyMap.find_opt pattern rules with
     | None ->
-      Log.debug (fun f -> f "rule %d does not exist; won't look for more" n);
+        Log.debug (fun f -> f "rule %d does not exist; won't look for more" n);
-      Ok (List.rev l)
+        Ok (List.rev l)
-    | Some rule ->
+    | Some rule -> (
-      Log.debug (fun f -> f "rule %d: %s" n rule);
+        Log.debug (fun f -> f "rule %d: %s" n rule);
-      match Pf_qubes.Parse_qubes.parse_qubes ~number:n rule with
+        match Pf_qubes.Parse_qubes.parse_qubes ~number:n rule with
-      | Error e -> Log.warn (fun f -> f "Error parsing rule %d: %s" n e); Error e
+        | Error e ->
-      | Ok rule ->
+            Log.warn (fun f -> f "Error parsing rule %d: %s" n e);
-        Log.debug (fun f -> f "parsed rule: %a" Pf_qubes.Parse_qubes.pp_rule rule);
+            Error e
-        get_rule (n+1) (rule :: l)
+        | Ok rule ->
+            Log.debug (fun f ->
+                f "parsed rule: %a" Pf_qubes.Parse_qubes.pp_rule rule);
+            get_rule (n + 1) (rule :: l))
   in
   match get_rule 0 [] with
   | Ok l -> l
   | Error e ->
-    Log.warn (fun f -> f "Defaulting to deny-all because of rule parse failure (%s)" e);
+      Log.warn (fun f ->
-    [ Pf_qubes.Parse_qubes.({action = Drop;
+          f "Defaulting to deny-all because of rule parse failure (%s)" e);
-                             proto = None;
+      [
-                             specialtarget = None;
+        Pf_qubes.Parse_qubes.
-                             dst = `any;
+          {
-                             dstports = None;
+            action = Drop;
-                             icmp_type = None;
+            proto = None;
-                             number = 0;})]
+            specialtarget = None;
+            dst = `any;
+            dstports = None;
+            icmp_type = None;
+            number = 0;
+          };
+      ]
 
 let vifs client domid =
-  match String.to_int domid with
+  let open Lwt.Syntax in
-  | None -> Log.err (fun f -> f "Invalid domid %S" domid); Lwt.return []
+  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
+      let path = Fmt.str "backend/vif/%d" domid in
-    Xen_os.Xs.immediate client (fun handle ->
+      let vifs_of_domain handle =
-        directory ~handle path >>=
+        let* devices = directory ~handle path in
-        Lwt_list.filter_map_p (fun device_id ->
+        let ip_of_vif 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
+          | None ->
-            | Some device_id ->
+              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
+              let get_client_ip () =
-                (fun () -> Xen_os.Xs.read handle (Printf.sprintf "%s/%d/ip" path device_id))
+                let* str =
-                (fun client_ip ->
+                  Xen_os.Xs.read handle (Fmt.str "%s/%d/ip" path device_id)
-                   let client_ip' = match String.cuts ~sep:" " client_ip with
+                in
-                     | [] -> Log.err (fun m -> m "unexpected empty list"); ""
+                let client_ip = List.hd (String.split_on_char ' ' str) in
-                     | [ ip ] -> ip
+                (* NOTE(dinosaure): it's safe to use [List.hd] here,
-                     | ip::rest ->
+               [String.split_on_char] can not return an empty list. *)
-                       Log.warn (fun m -> m "ignoring IPs %s from %a, we support one IP per client"
+                Lwt.return_some (vif, Ipaddr.V4.of_string_exn client_ip)
-                                    (String.concat ~sep:" " rest) ClientVif.pp vif);
+              in
-                       ip
+              Lwt.catch get_client_ip @@ function
-                   in
+              | Xs_protocol.Enoent _ -> Lwt.return_none
-                   match Ipaddr.V4.of_string client_ip' with
+              | Ipaddr.Parse_error (msg, client_ip) ->
-                   | Ok ip -> Lwt.return (Some (vif, ip))
+                  Log.err (fun f ->
-                   | Error `Msg msg  ->
+                      f "Error parsing IP address of %a from %s: %s"
-                     Log.err (fun f -> f "Error parsing IP address of %a from %s: %s"
+                        ClientVif.pp vif client_ip msg);
-                                 ClientVif.pp vif client_ip msg);
+                  Lwt.return_none
-                     Lwt.return None
+              | exn ->
-                )
+                  Log.err (fun f ->
-                (function
+                      f "Error getting IP address of %a: %s" ClientVif.pp vif
-                  | Xs_protocol.Enoent _ -> Lwt.return None
+                        (Printexc.to_string exn));
-                  | ex ->
+                  Lwt.return_none)
-                    Log.err (fun f -> f "Error getting IP address of %a: %s"
+        in
-                                ClientVif.pp vif (Printexc.to_string ex));
+        Lwt_list.filter_map_p ip_of_vif devices
-                    Lwt.return None
+      in
-                )
+      Xen_os.Xs.immediate client vifs_of_domain
-          ))
 
 let watch_clients fn =
   Xen_os.Xs.make () >>= fun xs ->
   let backend_vifs = "backend/vif" in
   Log.info (fun f -> f "Watching %s" backend_vifs);
   Xen_os.Xs.wait xs (fun handle ->
-    begin Lwt.catch
+      Lwt.catch
-      (fun () -> directory ~handle backend_vifs)
+        (fun () -> directory ~handle backend_vifs)
-      (function
+        (function Xs_protocol.Enoent _ -> Lwt.return [] | ex -> Lwt.fail ex)
-        | Xs_protocol.Enoent _ -> Lwt.return []
+      >>= fun items ->
-        | ex -> Lwt.fail ex)
+      Xen_os.Xs.make () >>= fun xs ->
-    end >>= fun items ->
+      Lwt_list.map_p (vifs xs) items >>= fun items ->
-    Xen_os.Xs.make () >>= fun xs ->
+      fn (List.concat items |> VifMap.of_list) >>= fun () ->
-    Lwt_list.map_p (vifs xs) items >>= fun items ->
+      (* Wait for further updates *)
-    fn (List.concat items |> VifMap.of_list);
+      Lwt.fail Xs_protocol.Eagain)
-    (* Wait for further updates *)
-    Lwt.fail Xs_protocol.Eagain
-  )
 
 type network_config = {
-  from_cmdline : bool;         (* Specify if we have network configuration from command line or from qubesDB*)
+  from_cmdline : bool;
-  netvm_ip : Ipaddr.V4.t;      (* The IP address of NetVM (our gateway) *)
+      (* Specify if we have network configuration from command line or from qubesDB*)
-  our_ip : Ipaddr.V4.t;        (* The IP address of our interface to NetVM *)
+  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;
 }
@@ -136,31 +146,36 @@ let try_read_network_config db =
   let get name =
     match DB.KeyMap.find_opt name db with
     | None -> raise (Missing_key name)
-    | Some value -> Ipaddr.V4.of_string_exn value in
+    | Some value -> Ipaddr.V4.of_string_exn value
-  let our_ip = get "/qubes-ip" in (* - IP address for this VM (only when VM has netvm set) *)
+  in
-  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 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 }
+  { from_cmdline = false; netvm_ip; our_ip; dns; dns2 }
 
 let read_network_config qubesDB =
   let rec aux bindings =
     try Lwt.return (try_read_network_config bindings)
     with Missing_key key ->
-      Log.warn (fun f -> f "QubesDB key %S not (yet) present; waiting for QubesDB to change..." key);
+      Log.warn (fun f ->
+          f "QubesDB key %S not (yet) present; waiting for QubesDB to change..."
+            key);
       DB.after qubesDB bindings >>= aux
   in
   aux (DB.bindings qubesDB)
 
 let print_network_config config =
-  Log.info (fun f -> f "@[<v2>Current network configuration (QubesDB or command line):@,\
+  Log.info (fun f ->
-                        NetVM IP on uplink network: %a@,\
+      f
-                        Our IP on client networks:  %a@,\
+        "@[<v2>Current network configuration (QubesDB or command line):@,\
-                        DNS primary resolver:       %a@,\
+         NetVM IP on uplink network: %a@,\
-                        DNS secondary resolver:     %a@]"
+         Our IP on client networks:  %a@,\
-               Ipaddr.V4.pp config.netvm_ip
+         DNS primary resolver:       %a@,\
-               Ipaddr.V4.pp config.our_ip
+         DNS secondary resolver:     %a@]"
-               Ipaddr.V4.pp config.dns
+        Ipaddr.V4.pp config.netvm_ip Ipaddr.V4.pp config.our_ip Ipaddr.V4.pp
-               Ipaddr.V4.pp config.dns2)
+        config.dns Ipaddr.V4.pp config.dns2)
 
 let set_iptables_error db = Qubes.DB.write db "/qubes-iptables-error"

dao.mli

@@ -4,40 +4,43 @@
 (** Wrapper for XenStore and QubesDB databases. *)
 
 module ClientVif : sig
-  type t = {
+  type t = { domid : int; device_id : int }
-    domid : int;
+
-    device_id : int;
-  }
   val pp : t Fmt.t
 end
+
 module VifMap : sig
   include Map.S with type key = ClientVif.t
+
   val find : key -> 'a t -> 'a option
 end
 
-val watch_clients : (Ipaddr.V4.t VifMap.t -> unit) -> 'a Lwt.t
+val watch_clients : (Ipaddr.V4.t VifMap.t -> unit Lwt.t) -> 'a Lwt.t
-(** [watch_clients fn] calls [fn clients] with the list of backend clients
+(** [watch_clients fn] calls [fn clients] with the list of backend clients in
-    in XenStore, and again each time XenStore updates. *)
+    XenStore, and again each time XenStore updates. *)
 
 type network_config = {
-  from_cmdline : bool;         (* Specify if we have network configuration from command line or from qubesDB*)
+  from_cmdline : bool;
-  netvm_ip : Ipaddr.V4.t;      (* The IP address of NetVM (our gateway) *)
+      (* Specify if we have network configuration from command line or from qubesDB*)
-  our_ip : Ipaddr.V4.t;        (* The IP address of our interface to NetVM *)
+  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;
 }
 
 val read_network_config : Qubes.DB.t -> network_config Lwt.t
-(** [read_network_config db] fetches the configuration from QubesDB.
+(** [read_network_config db] fetches the configuration from QubesDB. If it isn't
-    If it isn't there yet, it waits until it is. *)
+    there yet, it waits until it is. *)
 
 val db_root : Ipaddr.V4.t -> string
-(** Returns the root path of the firewall rules in the QubesDB for a given IP address. *)
+(** Returns the root path of the firewall rules in the QubesDB for a given IP
+    address. *)
 
-val read_rules : string Qubes.DB.KeyMap.t -> Ipaddr.V4.t -> Pf_qubes.Parse_qubes.rule list
+val read_rules :
-(** [read_rules bindings ip] extracts firewall rule information for [ip] from [bindings].
+  string Qubes.DB.KeyMap.t -> Ipaddr.V4.t -> Pf_qubes.Parse_qubes.rule list
-    If any rules fail to parse, it will return only one rule denying all traffic. *)
+(** [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

fw_utils.ml

@@ -3,14 +3,6 @@
 
 (** General utility functions. *)
 
-module IpMap = struct
-  include Map.Make(Ipaddr.V4)
-  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. *)
 class type interface = object
   method my_mac : Macaddr.t
@@ -23,14 +15,16 @@ end
 class type client_link = object
   inherit interface
   method other_mac : Macaddr.t
-  method log_header : string  (* For log messages *)
+  method log_header : string (* For log messages *)
-  method get_rules: Pf_qubes.Parse_qubes.rule list
+  method get_rules : Pf_qubes.Parse_qubes.rule list
-  method set_rules: string Qubes.DB.KeyMap.t -> unit
+  method set_rules : string Qubes.DB.KeyMap.t -> unit
 end
 
-(** An Ethernet header from [src]'s MAC address to [dst]'s with an IPv4 payload. *)
+(** An Ethernet header from [src]'s MAC address to [dst]'s with an IPv4 payload.
+*)
 let eth_header ethertype ~src ~dst =
-  Ethernet.Packet.make_cstruct { Ethernet.Packet.source = src; destination = dst; ethertype }
+  Ethernet.Packet.make_cstruct
+    { Ethernet.Packet.source = src; destination = dst; ethertype }
 
 let error fmt =
   let err s = Failure s in

memory_pressure.ml

@@ -2,14 +2,14 @@
    See the README file for details. *)
 
 let src = Logs.Src.create "memory_pressure" ~doc:"Memory pressure monitor"
+
 module Log = (val Logs.src_log src : Logs.LOG)
 
 let fraction_free stats =
   let { Xen_os.Memory.free_words; heap_words; _ } = stats in
   float free_words /. float heap_words
 
-let init () =
+let init () = Gc.full_major ()
-  Gc.full_major ()
 
 let status () =
   let stats = Xen_os.Memory.quick_stat () in
@@ -18,6 +18,4 @@ let status () =
     Gc.full_major ();
     Xen_os.Memory.trim ();
     let stats = Xen_os.Memory.quick_stat () in
-    if fraction_free stats < 0.6 then `Memory_critical
+    if fraction_free stats < 0.6 then `Memory_critical else `Ok)
-    else `Ok
-  )

memory_pressure.mli

@@ -8,5 +8,5 @@ val status : unit -> [ `Ok | `Memory_critical ]
 (** Check the memory situation. If we're running low, do a GC (work-around for
     http://caml.inria.fr/mantis/view.php?id=7100 and OCaml GC needing to malloc
     extra space to run finalisers). Returns [`Memory_critical] if memory is
-    still low - caller should take action to reduce memory use.
+    still low - caller should take action to reduce memory use. After GC,
-    After GC, updates meminfo in XenStore. *)
+    updates meminfo in XenStore. *)

my_dns.ml

@@ -1,74 +1,81 @@
 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 +'a io = 'a Lwt.t
+type io_addr = Ipaddr.V4.t * int
-  type io_addr = Ipaddr.V4.t * int
-  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)
+type stack =
+  Dispatcher.t
+  * (src_port:int ->
+    dst:Ipaddr.V4.t ->
+    dst_port:int ->
+    string ->
+    (unit, [ `Msg of string ]) result Lwt.t)
+  * (Udp_packet.t * string) Lwt_mvar.t
 
-  type t = {
+module IM = Map.Make (Int)
-    protocol : Dns.proto ;
-    nameserver : io_addr ;
-    stack : stack ;
-    timeout_ns : int64 ;
-    mutable requests : Cstruct.t Lwt_condition.t IM.t ;
-  }
-  type context = t
 
-  let nameservers { protocol ; nameserver ; _ } = protocol, [ nameserver ]
+type t = {
-  let rng = R.generate ?g:None
+  protocol : Dns.proto;
-  let clock = C.elapsed_ns
+  nameserver : io_addr;
+  stack : stack;
+  timeout_ns : int64;
+  mutable requests : string Lwt_condition.t IM.t;
+}
 
-  let rec read t =
+type context = t
-    let _, _, answer = t.stack in
-    Lwt_mvar.take answer >>= fun (_, data) ->
-    if Cstruct.length data > 2 then begin
-      match IM.find_opt (Cstruct.BE.get_uint16 data 0) t.requests with
-      | Some cond -> Lwt_condition.broadcast cond data
-      | None -> ()
-    end;
-    read t
 
-  let create ?nameservers ~timeout stack =
+let nameservers { protocol; nameserver; _ } = (protocol, [ nameserver ])
-    let protocol, nameserver = match nameservers with
+let rng = Mirage_crypto_rng.generate ?g:None
-      | None | Some (_, []) -> invalid_arg "no nameserver found"
+let clock = Mirage_mtime.elapsed_ns
-      | Some (proto, ns :: _) -> proto, ns
-    in
-    let t =
-      { protocol ; nameserver ; stack ; timeout_ns = timeout ; requests = IM.empty }
-    in
-    Lwt.async (fun () -> read t);
-    t
 
-  let with_timeout timeout_ns f =
+let rec read t =
-    let timeout = Time.sleep_ns timeout_ns >|= fun () -> Error (`Msg "DNS request timeout") in
+  let _, _, answer = t.stack in
-    Lwt.pick [ f ; timeout ]
+  Lwt_mvar.take answer >>= fun (_, data) ->
+  (if String.length data > 2 then
+     match IM.find_opt (String.get_uint16_be data 0) t.requests with
+     | Some cond -> Lwt_condition.broadcast cond data
+     | None -> ());
+  read t
 
-  let connect (t : t) = Lwt.return (Ok (t.protocol, t))
+let create ?nameservers ~timeout stack =
+  let protocol, nameserver =
+    match nameservers with
+    | None | Some (_, []) -> invalid_arg "no nameserver found"
+    | Some (proto, ns :: _) -> (proto, ns)
+  in
+  let t =
+    { protocol; nameserver; stack; timeout_ns = timeout; requests = IM.empty }
+  in
+  Lwt.async (fun () -> read t);
+  t
 
-  let send_recv (ctx : context) buf : (Cstruct.t, [> `Msg of string ]) result Lwt.t =
+let with_timeout timeout_ns f =
-    let dst, dst_port = ctx.nameserver in
+  let timeout =
-    let router, send_udp, _ = ctx.stack in
+    Mirage_sleep.ns timeout_ns >|= fun () -> Error (`Msg "DNS request timeout")
-    let src_port, evict =
+  in
-      My_nat.free_udp_port router.nat ~src:router.config.our_ip ~dst ~dst_port:53
+  Lwt.pick [ f; timeout ]
-    in
-    let id = Cstruct.BE.get_uint16 buf 0 in
-    with_timeout ctx.timeout_ns
-      (let cond = Lwt_condition.create () in
-       ctx.requests <- IM.add id cond ctx.requests;
-       (send_udp ~src_port ~dst ~dst_port buf >|= Rresult.R.open_error_msg) >>= function
-       | Ok () -> Lwt_condition.wait cond >|= fun dns_response -> Ok dns_response
-       | Error _ as e -> Lwt.return e) >|= fun result ->
-    ctx.requests <- IM.remove id ctx.requests;
-    evict ();
-    result
 
-  let close _ = Lwt.return_unit
+let connect (t : t) = Lwt.return (Ok (t.protocol, t))
 
-  let bind = Lwt.bind
+let send_recv (ctx : context) buf : (string, [> `Msg of string ]) result Lwt.t =
-
+  let dst, dst_port = ctx.nameserver in
-  let lift = Lwt.return
+  let router, send_udp, _ = ctx.stack in
-end
+  let src_port, evict =
+    My_nat.free_udp_port router.nat ~src:router.config.our_ip ~dst ~dst_port:53
+  in
+  let id = String.get_uint16_be buf 0 in
+  with_timeout ctx.timeout_ns
+    (let cond = Lwt_condition.create () in
+     ctx.requests <- IM.add id cond ctx.requests;
+     send_udp ~src_port ~dst ~dst_port buf >|= Rresult.R.open_error_msg
+     >>= function
+     | Ok () -> Lwt_condition.wait cond >|= fun dns_response -> Ok dns_response
+     | Error _ as e -> Lwt.return e)
+  >|= fun result ->
+  ctx.requests <- IM.remove id ctx.requests;
+  evict ();
+  result
 
+let close _ = Lwt.return_unit
+let bind = Lwt.bind
+let lift = Lwt.return

my_nat.ml

@@ -2,65 +2,57 @@
    See the README file for details. *)
 
 let src = Logs.Src.create "my-nat" ~doc:"NAT shim"
+
 module Log = (val Logs.src_log src : Logs.LOG)
 
-type action = [
+type action = [ `NAT | `Redirect of Mirage_nat.endpoint ]
-  | `NAT
-  | `Redirect of Mirage_nat.endpoint
-]
 
 module Nat = Mirage_nat_lru
 
-module S =
+module S = Set.Make (struct
-  Set.Make(struct type t = int let compare (a : int) (b : int) = compare a b end)
+  type t = int
 
-type t = {
+  let compare (a : int) (b : int) = compare a b
-  table : Nat.t;
+end)
-  mutable udp_dns : S.t;
-  last_resort_port : int
-}
 
-let pick_port () =
+type t = { table : Nat.t; mutable udp_dns : S.t; last_resort_port : int }
-  1024 + Random.int (0xffff - 1024)
+
+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
   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 }
+  { table; udp_dns = S.empty; last_resort_port }
 
 let pick_free_port t proto =
   let rec go retries =
-    if retries = 0 then
+    if retries = 0 then None
-      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 ->
+      | `Udp when S.mem p t.udp_dns || p = t.last_resort_port -> go (retries - 1)
-        go (retries - 1)
       | _ -> Some p
   in
   go 10
 
 let free_udp_port t ~src ~dst ~dst_port =
   let rec go retries =
-    if retries = 0 then
+    if retries = 0 then (t.last_resort_port, Fun.id)
-      t.last_resort_port, Fun.id
     else
       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
+      if Nat.is_port_free t.table `Udp ~src ~dst ~src_port ~dst_port then
         let remove =
-          if src_port <> t.last_resort_port then begin
+          if src_port <> t.last_resort_port then (
             t.udp_dns <- S.add src_port t.udp_dns;
-            (fun () -> t.udp_dns <- S.remove src_port t.udp_dns)
+            fun () -> t.udp_dns <- S.remove src_port t.udp_dns)
-          end else Fun.id
+          else Fun.id
         in
-        src_port, remove
+        (src_port, remove)
-      end else
+      else go (retries - 1)
-        go (retries - 1)
   in
   go 10
 
@@ -68,27 +60,27 @@ let dns_port t port = S.mem port t.udp_dns || port = t.last_resort_port
 
 let translate t packet =
   match Nat.translate t.table packet with
-  | Error (`Untranslated | `TTL_exceeded as e) ->
+  | Error ((`Untranslated | `TTL_exceeded) as e) ->
-    Log.debug (fun f -> f "Failed to NAT %a: %a"
+      Log.debug (fun f ->
-                  Nat_packet.pp packet
+          f "Failed to NAT %a: %a" Nat_packet.pp packet Mirage_nat.pp_error e);
-                  Mirage_nat.pp_error e
+      None
-              );
-    None
   | Ok packet -> Some packet
 
-let remove_connections t ip =
+let remove_connections t ip = ignore (Nat.remove_connections t.table ip)
-  ignore (Nat.remove_connections t.table ip)
 
 let add_nat_rule_and_translate t ~xl_host action packet =
-  let proto = match packet with
+  let proto =
+    match packet with
     | `IPv4 (_, `TCP _) -> `Tcp
     | `IPv4 (_, `UDP _) -> `Udp
     | `IPv4 (_, `ICMP _) -> `Icmp
   in
-  match Nat.add t.table packet xl_host (fun () -> pick_free_port t proto) action with
+  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);
+      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!"
+      Option.to_result ~none:"No NAT entry, even after adding one!"
-      (translate t packet)
+        (translate t packet)

my_nat.mli

@@ -4,17 +4,23 @@
 (* Abstract over NAT interface (todo: remove this) *)
 
 type t
+type action = [ `NAT | `Redirect of Mirage_nat.endpoint ]
 
-type action = [
+val free_udp_port :
-  | `NAT
+  t ->
-  | `Redirect of Mirage_nat.endpoint
+  src:Ipaddr.V4.t ->
-]
+  dst:Ipaddr.V4.t ->
-
+  dst_port:int ->
-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
+val add_nat_rule_and_translate :
+  t ->
+  xl_host:Ipaddr.V4.t ->
+  action ->
+  Nat_packet.t ->
+  (Nat_packet.t, string) result

packet.ml

@@ -8,9 +8,8 @@ type port = int
 type host =
   [ `Client of client_link | `Firewall | `NetVM | `External of Ipaddr.t ]
 
-type transport_header = [`TCP of Tcp.Tcp_packet.t
+type transport_header =
-                        |`UDP of Udp_packet.t
+  [ `TCP of Tcp.Tcp_packet.t | `UDP of Udp_packet.t | `ICMP of Icmpv4_packet.t ]
-                        |`ICMP of Icmpv4_packet.t]
 
 type ('src, 'dst) t = {
   ipv4_header : Ipv4_packet.t;
@@ -19,13 +18,14 @@ type ('src, 'dst) t = {
   src : 'src;
   dst : 'dst;
 }
+
 let pp_transport_header f = function
   | `ICMP h -> Icmpv4_packet.pp f h
   | `TCP h -> Tcp.Tcp_packet.pp f h
   | `UDP h -> Udp_packet.pp f h
 
 let pp_host fmt = function
-  | `Client c -> Ipaddr.V4.pp fmt (c#other_ip)
+  | `Client c -> Ipaddr.V4.pp fmt c#other_ip
   | `Unknown_client ip -> Format.fprintf fmt "unknown-client(%a)" Ipaddr.pp ip
   | `NetVM -> Format.pp_print_string fmt "net-vm"
   | `External ip -> Format.fprintf fmt "external(%a)" Ipaddr.pp ip
@@ -33,32 +33,28 @@ let pp_host fmt = function
 
 let to_mirage_nat_packet t : Nat_packet.t =
   match t.transport_header with
-  | `TCP h  -> `IPv4 (t.ipv4_header, (`TCP (h, t.transport_payload)))
+  | `TCP h -> `IPv4 (t.ipv4_header, `TCP (h, t.transport_payload))
-  | `UDP h  -> `IPv4 (t.ipv4_header, (`UDP (h, t.transport_payload)))
+  | `UDP h -> `IPv4 (t.ipv4_header, `UDP (h, t.transport_payload))
-  | `ICMP h -> `IPv4 (t.ipv4_header, (`ICMP (h, t.transport_payload)))
+  | `ICMP h -> `IPv4 (t.ipv4_header, `ICMP (h, t.transport_payload))
 
 let of_mirage_nat_packet ~src ~dst packet : ('a, 'b) t option =
-  let `IPv4 (ipv4_header, ipv4_payload) = packet in
+  let (`IPv4 (ipv4_header, ipv4_payload)) = packet in
-  let transport_header, transport_payload = match ipv4_payload with
+  let transport_header, transport_payload =
-    | `TCP (h, p) -> `TCP h, p
+    match ipv4_payload with
-    | `UDP (h, p) -> `UDP h, p
+    | `TCP (h, p) -> (`TCP h, p)
-    | `ICMP (h, p) -> `ICMP h, p
+    | `UDP (h, p) -> (`UDP h, p)
+    | `ICMP (h, p) -> (`ICMP h, p)
   in
-  Some {
+  Some { ipv4_header; transport_header; transport_payload; src; dst }
-    ipv4_header;
-    transport_header;
-    transport_payload;
-    src;
-    dst;
-  }
 
 (* possible actions to take for a packet: *)
-type action = [
+type action =
-  | `Accept (* Send to destination, unmodified. *)
+  [ `Accept (* Send to destination, unmodified. *)
-  | `NAT    (* Rewrite source field to the firewall's IP, with a fresh source port.
+  | `NAT
+    (* Rewrite source field to the firewall's IP, with a fresh source port.
                Also, add translation rules for future traffic in both directions,
                between these hosts on these ports, and corresponding ICMP error traffic. *)
-  | `NAT_to of host * port (* As for [`NAT], but also rewrite the packet's
+  | `NAT_to of host * port
+    (* As for [`NAT], but also rewrite the packet's
                               destination fields so it will be sent to [host:port]. *)
-  | `Drop of string (* Drop packet for this reason. *)
+  | `Drop of string (* Drop packet for this reason. *) ]
-]

packet.mli

@@ -1,15 +1,13 @@
 type port = int
 
 type host =
-  [ `Client of Fw_utils.client_link (** an IP address on the private network *)
+  [ `Client of Fw_utils.client_link  (** an IP address on the private network *)
-  | `Firewall (** the firewall's IP on the private network *)
+  | `Firewall  (** the firewall's IP on the private network *)
-  | `NetVM (** the IP of the firewall's default route *)
+  | `NetVM  (** the IP of the firewall's default route *)
-  | `External of Ipaddr.t (** an IP on the public network *)
+  | `External of Ipaddr.t  (** an IP on the public network *) ]
-  ]
 
-type transport_header = [`TCP of Tcp.Tcp_packet.t
+type transport_header =
-                        |`UDP of Udp_packet.t
+  [ `TCP of Tcp.Tcp_packet.t | `UDP of Udp_packet.t | `ICMP of Icmpv4_packet.t ]
-                        |`ICMP of Icmpv4_packet.t]
 
 type ('src, 'dst) t = {
   ipv4_header : Ipv4_packet.t;
@@ -20,20 +18,18 @@ type ('src, 'dst) t = {
 }
 
 val pp_transport_header : Format.formatter -> transport_header -> unit
-
 val pp_host : Format.formatter -> host -> unit
-
 val to_mirage_nat_packet : ('a, 'b) t -> Nat_packet.t
-
 val of_mirage_nat_packet : src:'a -> dst:'b -> Nat_packet.t -> ('a, 'b) t option
 
 (* possible actions to take for a packet: *)
-type action = [
+type action =
-  | `Accept (* Send to destination, unmodified. *)
+  [ `Accept (* Send to destination, unmodified. *)
-  | `NAT    (* Rewrite source field to the firewall's IP, with a fresh source port.
+  | `NAT
+    (* Rewrite source field to the firewall's IP, with a fresh source port.
                Also, add translation rules for future traffic in both directions,
                between these hosts on these ports, and corresponding ICMP error traffic. *)
-  | `NAT_to of host * port (* As for [`NAT], but also rewrite the packet's
+  | `NAT_to of host * port
+    (* As for [`NAT], but also rewrite the packet's
                               destination fields so it will be sent to [host:port]. *)
-  | `Drop of string (* Drop packet for this reason. *)
+  | `Drop of string (* Drop packet for this reason. *) ]
-]

qubes-firewall-release.sha256

@@ -0,0 +1 @@
+0c3c2c0e62a834112c69d7cddc5dd6f70ecb93afa988768fb860ed26e423b1f8  dist/qubes-firewall.xen

qubes-firewall.sha256

@@ -0,0 +1 @@
+ac049069b35f786fa11b18a2261d7dbecd588301af0363ef6888ec9d924dc989  dist/qubes-firewall.xen

rules.ml

@@ -8,93 +8,115 @@ open Lwt.Infix
 module Q = Pf_qubes.Parse_qubes
 
 let src = Logs.Src.create "rules" ~doc:"Firewall rules"
+
 module Log = (val Logs.src_log src : Logs.LOG)
 
 let dns_port = 53
 
 module Classifier = struct
-
+  let matches_port dstports (port : int) =
-  let matches_port dstports (port : int) = match dstports with
+    match dstports with
     | None -> true
     | Some (Q.Range_inclusive (min, max)) -> min <= port && port <= max
 
-  let matches_proto rule dns_servers packet = match rule.Q.proto, rule.Q.specialtarget with
+  let matches_proto rule dns_servers packet =
+    match (rule.Q.proto, rule.Q.specialtarget) with
     | None, None -> true
-    | None, Some `dns when List.mem packet.ipv4_header.Ipv4_packet.dst dns_servers -> begin
+    | None, Some `dns
-      (* specialtarget=dns applies only to the specialtarget destination IPs, and
+      when List.mem packet.ipv4_header.Ipv4_packet.dst dns_servers -> (
+        (* specialtarget=dns applies only to the specialtarget destination IPs, and
          specialtarget=dns is also implicitly tcp/udp port 53 *)
-      match packet.transport_header with
+        match packet.transport_header with
         | `TCP header -> header.Tcp.Tcp_packet.dst_port = dns_port
         | `UDP header -> header.Udp_packet.dst_port = dns_port
-        | _ -> false
+        | _ -> false)
-      end
+    (* DNS rules can only match traffic headed to the specialtarget hosts, so any other destination
-   (* DNS rules can only match traffic headed to the specialtarget hosts, so any other destination
    isn't a match for DNS rules *)
     | None, Some `dns -> false
-    | Some rule_proto, _ -> match rule_proto, packet.transport_header with
+    | Some rule_proto, _ -> (
-      | `tcp, `TCP header -> matches_port rule.Q.dstports header.Tcp.Tcp_packet.dst_port
+        match (rule_proto, packet.transport_header) with
-      | `udp, `UDP header -> matches_port rule.Q.dstports header.Udp_packet.dst_port
+        | `tcp, `TCP header ->
-      | `icmp, `ICMP header ->
+            matches_port rule.Q.dstports header.Tcp.Tcp_packet.dst_port
-      begin
+        | `udp, `UDP header ->
-        match rule.Q.icmp_type with
+            matches_port rule.Q.dstports header.Udp_packet.dst_port
-        | None -> true
+        | `icmp, `ICMP header -> (
-        | Some rule_icmp_type ->
+            match rule.Q.icmp_type with
-          0 = compare rule_icmp_type @@ Icmpv4_wire.ty_to_int header.Icmpv4_packet.ty
+            | None -> true
-      end
+            | Some rule_icmp_type ->
-      | _, _ -> false
+                0
+                = compare rule_icmp_type
+                  @@ Icmpv4_wire.ty_to_int header.Icmpv4_packet.ty)
+        | _, _ -> false)
 
   let matches_dest dns_client rule packet =
     let ip = packet.ipv4_header.Ipv4_packet.dst in
     match rule.Q.dst with
-    | `any ->  Lwt.return @@ `Match rule
+    | `any -> Lwt.return @@ `Match rule
     | `hosts subnet ->
-      Lwt.return @@ if (Ipaddr.Prefix.mem Ipaddr.(V4 ip) subnet) then `Match rule else `No_match
+        Lwt.return
-    | `dnsname name ->
+        @@
-      Log.debug (fun f -> f "Resolving %a" Domain_name.pp name);
+        if Ipaddr.Prefix.mem Ipaddr.(V4 ip) subnet then `Match rule
-      dns_client name >|= function
-      | Ok (_ttl, found_ips) ->
-        if Ipaddr.V4.Set.mem ip found_ips
-        then `Match rule
         else `No_match
-      | Error (`Msg m) ->
+    | `dnsname name -> (
-        Log.warn (fun f -> f "Ignoring rule %a, could not resolve" Q.pp_rule rule);
+        Log.debug (fun f -> f "Resolving %a" Domain_name.pp name);
-        Log.debug (fun f -> f "%s" m);
+        dns_client name >|= function
-        `No_match
+        | Ok (_ttl, found_ips) ->
-      | Error _ -> assert false (* TODO: fix type of dns_client so that this case can go *)
+            if Ipaddr.V4.Set.mem ip found_ips then `Match rule else `No_match
-
+        | Error (`Msg m) ->
+            Log.warn (fun f ->
+                f "Ignoring rule %a, could not resolve" Q.pp_rule rule);
+            Log.debug (fun f -> f "%s" m);
+            `No_match
+        | Error _ ->
+            assert
+              false (* TODO: fix type of dns_client so that this case can go *))
 end
 
 let find_first_match dns_client dns_servers packet acc rule =
   match acc with
   | `No_match ->
-    if Classifier.matches_proto rule dns_servers packet
+      if Classifier.matches_proto rule dns_servers packet then
-    then Classifier.matches_dest dns_client rule packet
+        Classifier.matches_dest dns_client rule packet
-    else Lwt.return `No_match
+      else Lwt.return `No_match
   | q -> Lwt.return q
 
 (* Does the packet match our rules? *)
-let classify_client_packet dns_client dns_servers (packet : ([`Client of Fw_utils.client_link], _) Packet.t)  =
+let classify_client_packet dns_client dns_servers
+    (packet : ([ `Client of Fw_utils.client_link ], _) Packet.t) =
   let (`Client client_link) = packet.src in
   let rules = client_link#get_rules in
-  Lwt_list.fold_left_s (find_first_match dns_client dns_servers packet) `No_match rules >|= function
+  Lwt_list.fold_left_s
+    (find_first_match dns_client dns_servers packet)
+    `No_match rules
+  >|= function
   | `No_match -> `Drop "No matching rule; assuming default drop"
-  | `Match {Q.action = Q.Accept; _} -> `Accept
+  | `Match { Q.action = Q.Accept; _ } -> `Accept
-  | `Match ({Q.action = Q.Drop; _} as rule) ->
+  | `Match ({ Q.action = Q.Drop; _ } as rule) ->
-    `Drop (Format.asprintf "rule number %a explicitly drops this packet" Q.pp_rule rule)
+      `Drop
+        (Format.asprintf "rule number %a explicitly drops this packet" Q.pp_rule
+           rule)
 
 let translate_accepted_packets dns_client dns_servers packet =
   classify_client_packet dns_client dns_servers packet >|= function
   | `Accept -> `NAT
   | `Drop s -> `Drop s
 
-(** Packets from the private interface that don't match any NAT table entry are being checked against the fw rules here *)
+(** Packets from the private interface that don't match any NAT table entry are
-let from_client dns_client dns_servers (packet : ([`Client of Fw_utils.client_link], _) Packet.t) : Packet.action Lwt.t =
+    being checked against the fw rules here *)
+let from_client dns_client dns_servers
+    (packet : ([ `Client of Fw_utils.client_link ], _) Packet.t) :
+    Packet.action Lwt.t =
   match packet with
-  | { dst = `External _ ; _ } | { dst = `NetVM; _ } -> translate_accepted_packets dns_client dns_servers packet
+  | { dst = `External _; _ } | { dst = `NetVM; _ } ->
-  | { dst = `Firewall ; _ } -> Lwt.return @@ `Drop "packet addressed to firewall itself"
+      translate_accepted_packets dns_client dns_servers packet
-  | { dst = `Client _ ; _ } -> classify_client_packet dns_client dns_servers packet
+  | { dst = `Firewall; _ } ->
+      Lwt.return @@ `Drop "packet addressed to firewall itself"
+  | { dst = `Client _; _ } ->
+      classify_client_packet dns_client dns_servers packet
   | _ -> Lwt.return @@ `Drop "could not classify packet"
 
-(** Packets from the outside world that don't match any NAT table entry are being dropped by default *)
+(** Packets from the outside world that don't match any NAT table entry are
-let from_netvm (_packet : ([`NetVM | `External of _], _) Packet.t) : Packet.action Lwt.t =
+    being dropped by default *)
+let from_netvm (_packet : ([ `NetVM | `External of _ ], _) Packet.t) :
+    Packet.action Lwt.t =
   Lwt.return @@ `Drop "drop by default"

test/config.ml

@@ -2,26 +2,32 @@ open Mirage
 
 let pin = "git+https://github.com/roburio/alcotest.git#mirage"
 
-let packages = [
+let packages =
-  package "ethernet";
+  [
-  package "arp";
+    package "ethernet";
-  package "arp-mirage";
+    package "arp";
-  package "ipaddr";
+    package "arp-mirage";
-  package "tcpip" ~sublibs:["stack-direct"; "icmpv4"; "ipv4"; "udp"; "tcp"];
+    package "ipaddr";
-  package "mirage-qubes";
+    package "tcpip" ~sublibs:[ "stack-direct"; "icmpv4"; "ipv4"; "udp"; "tcp" ];
-  package "mirage-qubes-ipv4";
+    package "mirage-qubes";
-  package "dns-client" ~sublibs:["mirage"];
+    package "mirage-qubes-ipv4";
-  package ~pin "alcotest";
+    package "dns-client" ~sublibs:[ "mirage" ];
-  package ~pin "alcotest-mirage";
+    package ~pin "alcotest";
-]
+    package ~pin "alcotest-mirage";
+  ]
 
 let client =
-  foreign ~packages
+  foreign ~packages "Unikernel.Client"
-    "Unikernel.Client" @@ random @-> time @-> mclock @-> network @-> qubesdb @-> job
+  @@ random @-> time @-> mclock @-> network @-> qubesdb @-> job
 
 let db = default_qubesdb
 let network = default_network
 
 let () =
-  let job =  [ client $ default_random $ default_time $ default_monotonic_clock $ network $ db ] in
+  let job =
+    [
+      client $ default_random $ default_time $ default_monotonic_clock $ network
+      $ db;
+    ]
+  in
   register "http-fetch" job

test/unikernel.ml

@@ -1,6 +1,8 @@
 open Lwt.Infix
+
 (* https://www.qubes-os.org/doc/vm-interface/#firewall-rules-in-4x *)
 let src = Logs.Src.create "firewall test" ~doc:"Firewalltest"
+
 module Log = (val Logs.src_log src : Logs.LOG)
 
 (* TODO
@@ -39,18 +41,24 @@ module Log = (val Logs.src_log src : Logs.LOG)
 
 (* Point-to-point links out of a netvm always have this IP TODO clarify with Marek *)
 let netvm = "10.137.0.5"
+
 (* default "nameserver"s, which netvm redirects to whatever its real nameservers are *)
-let nameserver_1, nameserver_2 = "10.139.1.1", "10.139.1.2"
+let nameserver_1, nameserver_2 = ("10.139.1.1", "10.139.1.2")
 
-module Client (R: Mirage_random.S) (Time: Mirage_time.S) (Clock : Mirage_clock.MCLOCK) (NET: Mirage_net.S) (DB : Qubes.S.DB) = struct
+module Client
-  module E = Ethernet.Make(NET)
+    (R : Mirage_crypto_rng_mirage.S)
-  module A = Arp.Make(E)(Time)
+    (Time : Mirage_time.S)
-  module I = Qubesdb_ipv4.Make(DB)(R)(Clock)(E)(A)
+    (Clock : Mirage_clock.MCLOCK)
-  module Icmp = Icmpv4.Make(I)
+    (NET : Mirage_net.S)
-  module U = Udp.Make(I)(R)
+    (DB : Qubes.S.DB) =
-  module T = Tcp.Flow.Make(I)(Time)(Clock)(R)
+struct
-
+  module E = Ethernet.Make (NET)
-  module Alcotest = Alcotest_mirage.Make(Clock)
+  module A = Arp.Make (E) (Time)
+  module I = Qubesdb_ipv4.Make (DB) (R) (Clock) (E) (A)
+  module Icmp = Icmpv4.Make (I)
+  module U = Udp.Make (I) (R)
+  module T = Tcp.Flow.Make (I) (Time) (Clock) (R)
+  module Alcotest = Alcotest_mirage.Make (Clock)
 
   module Stack = struct
     (* A Mirage_stack.V4 implementation which diverts DHCP messages to a DHCP
@@ -66,67 +74,77 @@ module Client (R: Mirage_random.S) (Time: Mirage_time.S) (Clock : Mirage_clock.M
     module IPV4 = I
 
     type t = {
-      net : NET.t ; eth : E.t ; arp : A.t ;
+      net : NET.t;
-      ip : I.t ; icmp : Icmp.t ; udp : U.t ; tcp : T.t ;
+      eth : E.t;
-      udp_listeners : (int, U.callback) Hashtbl.t ;
+      arp : A.t;
-      tcp_listeners : (int, T.listener) Hashtbl.t ;
+      ip : I.t;
-      mutable icmp_listener : (src:Ipaddr.V4.t -> dst:Ipaddr.V4.t -> Cstruct.t -> unit Lwt.t) option ;
+      icmp : Icmp.t;
+      udp : U.t;
+      tcp : T.t;
+      udp_listeners : (int, U.callback) Hashtbl.t;
+      tcp_listeners : (int, T.listener) Hashtbl.t;
+      mutable icmp_listener :
+        (src:Ipaddr.V4.t -> dst:Ipaddr.V4.t -> Cstruct.t -> unit Lwt.t) option;
     }
 
-    let ipv4 { ip ; _ } = ip
+    let ipv4 { ip; _ } = ip
-    let udpv4 { udp ; _ } = udp
+    let udpv4 { udp; _ } = udp
-    let tcpv4 { tcp ; _ } = tcp
+    let tcpv4 { tcp; _ } = tcp
-    let icmpv4 { icmp ; _ } = icmp
+    let icmpv4 { icmp; _ } = icmp
-
     let listener h port = Hashtbl.find_opt h port
     let udp_listener h ~dst_port = listener h dst_port
 
-    let listen_udpv4 { udp_listeners ; _ } ~port cb =
+    let listen_udpv4 { udp_listeners; _ } ~port cb =
       Hashtbl.replace udp_listeners port cb
 
-    let stop_listen_udpv4 { udp_listeners ; _ } ~port =
+    let stop_listen_udpv4 { udp_listeners; _ } ~port =
       Hashtbl.remove udp_listeners port
 
-    let listen_tcpv4 ?keepalive { tcp_listeners ; _ } ~port cb =
+    let listen_tcpv4 ?keepalive { tcp_listeners; _ } ~port cb =
-      Hashtbl.replace tcp_listeners port { T.process = cb ; T.keepalive }
+      Hashtbl.replace tcp_listeners port { T.process = cb; T.keepalive }
 
-    let stop_listen_tcpv4 { tcp_listeners ; _ } ~port =
+    let stop_listen_tcpv4 { tcp_listeners; _ } ~port =
       Hashtbl.remove tcp_listeners port
 
     let listen_icmp t cb = t.icmp_listener <- cb
 
     let listen t =
       let ethif_listener =
-        E.input
+        E.input ~arpv4:(A.input t.arp)
-          ~arpv4:(A.input t.arp)
+          ~ipv4:
-          ~ipv4:(
+            (I.input
-            I.input
+               ~tcp:(T.input t.tcp ~listeners:(listener t.tcp_listeners))
-              ~tcp:(T.input t.tcp ~listeners:(listener t.tcp_listeners))
+               ~udp:(U.input t.udp ~listeners:(udp_listener t.udp_listeners))
-              ~udp:(U.input t.udp ~listeners:(udp_listener t.udp_listeners))
+               ~default:(fun ~proto ~src ~dst buf ->
-              ~default:(fun ~proto ~src ~dst buf ->
+                 match proto with
-                  match proto with
+                 | 1 -> (
-                  | 1 ->
+                     match t.icmp_listener with
-                     begin match t.icmp_listener with
                      | None -> Icmp.input t.icmp ~src ~dst buf
-                     | Some cb -> cb ~src ~dst buf
+                     | Some cb -> cb ~src ~dst buf)
-                     end
+                 | _ -> Lwt.return_unit)
-                  | _ -> Lwt.return_unit)
+               t.ip)
-              t.ip)
           ~ipv6:(fun _ -> Lwt.return_unit)
           t.eth
       in
       NET.listen t.net ~header_size:Ethernet_wire.sizeof_ethernet ethif_listener
       >>= function
       | Error e ->
-        Logs.warn (fun p -> p "%a" NET.pp_error e) ;
+          Logs.warn (fun p -> p "%a" NET.pp_error e);
-        Lwt.return_unit
+          Lwt.return_unit
       | Ok _res -> Lwt.return_unit
 
     let connect net eth arp ip icmp udp tcp =
-      { net ; eth ; arp ; ip ; icmp ; udp ; tcp ;
+      {
-        udp_listeners = Hashtbl.create 2 ;
+        net;
-        tcp_listeners = Hashtbl.create 2 ;
+        eth;
-        icmp_listener = None ;
+        arp;
+        ip;
+        icmp;
+        udp;
+        tcp;
+        udp_listeners = Hashtbl.create 2;
+        tcp_listeners = Hashtbl.create 2;
+        icmp_listener = None;
       }
 
     let disconnect _ =
@@ -134,31 +152,39 @@ module Client (R: Mirage_random.S) (Time: Mirage_time.S) (Clock : Mirage_clock.M
       Lwt.return_unit
   end
 
-  module Dns = Dns_client_mirage.Make(R)(Time)(Clock)(Stack)
+  module Dns = Dns_client_mirage.Make (R) (Time) (Clock) (Stack)
 
   let make_ping_packet payload =
-    let echo_request = { Icmpv4_packet.code = 0; (* constant for echo request/reply *)
+    let echo_request =
-                         ty = Icmpv4_wire.Echo_request;
+      {
-                         subheader = Icmpv4_packet.(Id_and_seq (0, 0)); } in
+        Icmpv4_packet.code = 0;
+        (* constant for echo request/reply *)
+        ty = Icmpv4_wire.Echo_request;
+        subheader = Icmpv4_packet.(Id_and_seq (0, 0));
+      }
+    in
     Icmpv4_packet.Marshal.make_cstruct echo_request ~payload
 
   let is_ping_reply src server packet =
-    0 = Ipaddr.V4.(compare src @@ of_string_exn server) &&
+    (0 = Ipaddr.V4.(compare src @@ of_string_exn server))
-    packet.Icmpv4_packet.code = 0 &&
+    && packet.Icmpv4_packet.code = 0
-    packet.Icmpv4_packet.ty = Icmpv4_wire.Echo_reply &&
+    && packet.Icmpv4_packet.ty = Icmpv4_wire.Echo_reply
-    packet.Icmpv4_packet.subheader = Icmpv4_packet.(Id_and_seq (0, 0))
+    && packet.Icmpv4_packet.subheader = Icmpv4_packet.(Id_and_seq (0, 0))
 
   let ping_denied_listener server resp_received stack =
     let icmp_listener ~src ~dst:_ buf =
       (* hopefully this is a reply to an ICMP echo request we sent *)
-      Log.info (fun f -> f "ping test: ICMP message received from %a: %a" I.pp_ipaddr src Cstruct.hexdump_pp buf);
+      Log.info (fun f ->
+          f "ping test: ICMP message received from %a: %a" I.pp_ipaddr src
+            Cstruct.hexdump_pp buf);
       match Icmpv4_packet.Unmarshal.of_cstruct buf with
-      | Error e -> Log.err (fun f -> f "couldn't parse ICMP packet: %s" e);
+      | Error e ->
-                   Lwt.return_unit
+          Log.err (fun f -> f "couldn't parse ICMP packet: %s" e);
+          Lwt.return_unit
       | Ok (packet, _payload) ->
-         Log.info (fun f -> f "ICMP message: %a" Icmpv4_packet.pp packet);
+          Log.info (fun f -> f "ICMP message: %a" Icmpv4_packet.pp packet);
-         if is_ping_reply src server packet then resp_received := true;
+          if is_ping_reply src server packet then resp_received := true;
-         Lwt.return_unit
+          Lwt.return_unit
     in
     Stack.listen_icmp stack (Some icmp_listener)
 
@@ -166,49 +192,68 @@ module Client (R: Mirage_random.S) (Time: Mirage_time.S) (Clock : Mirage_clock.M
     let resp_received = ref false in
     Log.info (fun f -> f "Entering ping test: %s" server);
     ping_denied_listener server resp_received stack;
-    Icmp.write (Stack.icmpv4 stack) ~dst:(Ipaddr.V4.of_string_exn server) (make_ping_packet (Cstruct.of_string "hi")) >>= function
+    Icmp.write (Stack.icmpv4 stack)
-    | Error e -> Log.err (fun f -> f "ping test: error sending ping: %a" Icmp.pp_error e); Lwt.return_unit
+      ~dst:(Ipaddr.V4.of_string_exn server)
+      (make_ping_packet (Cstruct.of_string "hi"))
+    >>= function
+    | Error e ->
+        Log.err (fun f -> f "ping test: error sending ping: %a" Icmp.pp_error e);
+        Lwt.return_unit
     | Ok () ->
-      Log.info (fun f -> f "ping test: sent ping to %s" server);
+        Log.info (fun f -> f "ping test: sent ping to %s" server);
-      Time.sleep_ns 2_000_000_000L >>= fun () ->
+        Time.sleep_ns 2_000_000_000L >>= fun () ->
-      (if !resp_received then
+        if !resp_received then
-        Log.err (fun f -> f "ping test failed: server %s got a response, block expected :(" server)
+          Log.err (fun f ->
-      else
+              f "ping test failed: server %s got a response, block expected :("
-        Log.err (fun f -> f "ping test passed: successfully blocked :)")
+                server)
-      );
+        else Log.err (fun f -> f "ping test passed: successfully blocked :)");
-      Stack.listen_icmp stack None;
+        Stack.listen_icmp stack None;
-      Lwt.return_unit
+        Lwt.return_unit
 
   let icmp_error_type stack () =
     let resp_correct = ref false in
     let echo_server = Ipaddr.V4.of_string_exn netvm in
     let icmp_callback ~src ~dst:_ buf =
-      if Ipaddr.V4.compare src echo_server = 0 then begin
+      (if Ipaddr.V4.compare src echo_server = 0 then
-          (* TODO: check that packet is error packet *)
+         (* TODO: check that packet is error packet *)
-          match Icmpv4_packet.Unmarshal.of_cstruct buf with
+         match Icmpv4_packet.Unmarshal.of_cstruct buf with
-          | Error e -> Log.err (fun f -> f "Error parsing icmp packet %s" e)
+         | Error e -> Log.err (fun f -> f "Error parsing icmp packet %s" e)
-          | Ok (packet, _) ->
+         | Ok (packet, _) ->
              (* TODO don't hardcode the numbers, make a datatype *)
-             if packet.Icmpv4_packet.code = 10 (* unreachable, admin prohibited *)
+             if
+               packet.Icmpv4_packet.code
+               = 10 (* unreachable, admin prohibited *)
              then resp_correct := true
-             else Log.debug (fun f -> f "Unrelated icmp packet %a" Icmpv4_packet.pp packet)
+             else
-        end;
+               Log.debug (fun f ->
+                   f "Unrelated icmp packet %a" Icmpv4_packet.pp packet));
       Lwt.return_unit
     in
     let content = Cstruct.of_string "important data" in
     Stack.listen_icmp stack (Some icmp_callback);
-    U.write ~src_port:1337 ~dst:echo_server ~dst_port:1338 (Stack.udpv4 stack) content >>= function
+    U.write ~src_port:1337 ~dst:echo_server ~dst_port:1338 (Stack.udpv4 stack)
-    | Ok () -> (* .. listener: test with accept rule, if we get reply we're good *)
+      content
-       Time.sleep_ns 1_000_000_000L >>= fun () ->
+    >>= function
-       if !resp_correct
+    | Ok () ->
-       then Log.info (fun m -> m "UDP fetch test to port %d succeeded :)" 1338)
+        (* .. listener: test with accept rule, if we get reply we're good *)
-       else Log.err (fun f -> f "UDP fetch test to port %d: failed. :( correct response not received" 1338);
+        Time.sleep_ns 1_000_000_000L >>= fun () ->
-       Stack.listen_icmp stack None;
+        if !resp_correct then
-       Lwt.return_unit
+          Log.info (fun m -> m "UDP fetch test to port %d succeeded :)" 1338)
+        else
+          Log.err (fun f ->
+              f
+                "UDP fetch test to port %d: failed. :( correct response not \
+                 received"
+                1338);
+        Stack.listen_icmp stack None;
+        Lwt.return_unit
     | Error e ->
-       Log.err (fun f -> f "UDP fetch test to port %d failed: :( couldn't write the packet: %a"
+        Log.err (fun f ->
-                           1338 U.pp_error e);
+            f
-      Lwt.return_unit
+              "UDP fetch test to port %d failed: :( couldn't write the packet: \
+               %a"
+              1338 U.pp_error e);
+        Lwt.return_unit
 
   let tcp_connect msg server port tcp () =
     Log.info (fun f -> f "Entering tcp connect test: %s:%d" server port);
@@ -216,98 +261,141 @@ module Client (R: Mirage_random.S) (Time: Mirage_time.S) (Clock : Mirage_clock.M
     let msg' = Printf.sprintf "TCP connect test %s to %s:%d" msg server port in
     T.create_connection tcp (ip, port) >>= function
     | Ok flow ->
-      Log.info (fun f -> f "%s passed :)" msg');
+        Log.info (fun f -> f "%s passed :)" msg');
-      T.close flow
+        T.close flow
-    | Error e -> Log.err (fun f -> f "%s failed: Connection failed (%a) :(" msg' T.pp_error e);
+    | Error e ->
-      Lwt.return_unit
+        Log.err (fun f ->
+            f "%s failed: Connection failed (%a) :(" msg' T.pp_error e);
+        Lwt.return_unit
 
   let tcp_connect_denied msg server port tcp () =
     let ip = Ipaddr.V4.of_string_exn server in
-    let msg' = Printf.sprintf "TCP connect denied test %s to %s:%d" msg server port in
+    let msg' =
-    let connect = (T.create_connection tcp (ip, port) >>= function
+      Printf.sprintf "TCP connect denied test %s to %s:%d" msg server port
-    | Ok flow ->
-      Log.err (fun f -> f "%s failed: Connection should be denied, but was not. :(" msg');
-      T.close flow
-    | Error e -> Log.info (fun f -> f "%s passed (error text: %a) :)" msg' T.pp_error e);
-      Lwt.return_unit)
     in
-    let timeout = (
+    let connect =
+      T.create_connection tcp (ip, port) >>= function
+      | Ok flow ->
+          Log.err (fun f ->
+              f "%s failed: Connection should be denied, but was not. :(" msg');
+          T.close flow
+      | Error e ->
+          Log.info (fun f ->
+              f "%s passed (error text: %a) :)" msg' T.pp_error e);
+          Lwt.return_unit
+    in
+    let timeout =
       Time.sleep_ns 1_000_000_000L >>= fun () ->
       Log.info (fun f -> f "%s passed :)" msg');
-      Lwt.return_unit)
+      Lwt.return_unit
     in
-    Lwt.pick [ connect ; timeout ]
+    Lwt.pick [ connect; timeout ]
 
   let udp_fetch ~src_port ~echo_server_port stack () =
-    Log.info (fun f -> f "Entering udp fetch test: %d -> %s:%d"
+    Log.info (fun f ->
-                 src_port netvm echo_server_port);
+        f "Entering udp fetch test: %d -> %s:%d" src_port netvm echo_server_port);
     let resp_correct = ref false in
     let echo_server = Ipaddr.V4.of_string_exn netvm in
     let content = Cstruct.of_string "important data" in
-    let udp_listener : U.callback = (fun ~src ~dst:_ ~src_port buf ->
+    let udp_listener : U.callback =
-        Log.debug (fun f -> f "listen_udpv4 function invoked for packet: %a" Cstruct.hexdump_pp buf);
+     fun ~src ~dst:_ ~src_port buf ->
-        if ((0 = Ipaddr.V4.compare echo_server src) && src_port = echo_server_port) then
+      Log.debug (fun f ->
-          match Cstruct.equal buf content with
+          f "listen_udpv4 function invoked for packet: %a" Cstruct.hexdump_pp
-          | true -> (* yay *)
+            buf);
-            Log.info (fun f -> f "UDP fetch test to port %d: passed :)" echo_server_port);
+      if 0 = Ipaddr.V4.compare echo_server src && src_port = echo_server_port
+      then (
+        match Cstruct.equal buf content with
+        | true ->
+            (* yay *)
+            Log.info (fun f ->
+                f "UDP fetch test to port %d: passed :)" echo_server_port);
             resp_correct := true;
             Lwt.return_unit
-          | false -> (* oh no *)
+        | false ->
-            Log.err (fun f -> f "UDP fetch test to port %d: failed. :( Packet corrupted; expected %a but got %a"
+            (* oh no *)
-                        echo_server_port Cstruct.hexdump_pp content Cstruct.hexdump_pp buf);
+            Log.err (fun f ->
-            Lwt.return_unit
+                f
-        else
+                  "UDP fetch test to port %d: failed. :( Packet corrupted; \
-          begin
+                   expected %a but got %a"
-            (* disregard this packet *)
+                  echo_server_port Cstruct.hexdump_pp content Cstruct.hexdump_pp
-            Log.debug (fun f -> f "packet is not from the echo server or has the wrong source port (%d but we wanted %d)"
+                  buf);
-                      src_port echo_server_port);
+            Lwt.return_unit)
-            (* don't cancel the listener, since we want to keep listening *)
+      else (
-            Lwt.return_unit
+        (* disregard this packet *)
-          end
+        Log.debug (fun f ->
-      )
+            f
+              "packet is not from the echo server or has the wrong source port \
+               (%d but we wanted %d)"
+              src_port echo_server_port);
+        (* don't cancel the listener, since we want to keep listening *)
+        Lwt.return_unit)
     in
     Stack.listen_udpv4 stack ~port:src_port udp_listener;
-    U.write ~src_port ~dst:echo_server ~dst_port:echo_server_port (Stack.udpv4 stack) content >>= function
+    U.write ~src_port ~dst:echo_server ~dst_port:echo_server_port
-    | Ok () -> (* .. listener: test with accept rule, if we get reply we're good *)
+      (Stack.udpv4 stack) content
-      Time.sleep_ns 1_000_000_000L >>= fun () ->
+    >>= function
-      Stack.stop_listen_udpv4 stack ~port:src_port;
+    | Ok () ->
-      if !resp_correct then Lwt.return_unit else begin
+        (* .. listener: test with accept rule, if we get reply we're good *)
-        Log.err (fun f -> f "UDP fetch test to port %d: failed. :( correct response not received" echo_server_port);
+        Time.sleep_ns 1_000_000_000L >>= fun () ->
-        Lwt.return_unit
+        Stack.stop_listen_udpv4 stack ~port:src_port;
-      end
+        if !resp_correct then Lwt.return_unit
+        else (
+          Log.err (fun f ->
+              f
+                "UDP fetch test to port %d: failed. :( correct response not \
+                 received"
+                echo_server_port);
+          Lwt.return_unit)
     | Error e ->
-      Log.err (fun f -> f "UDP fetch test to port %d failed: :( couldn't write the packet: %a"
+        Log.err (fun f ->
-                  echo_server_port U.pp_error e);
+            f
-      Lwt.return_unit
+              "UDP fetch test to port %d failed: :( couldn't write the packet: \
+               %a"
+              echo_server_port U.pp_error e);
+        Lwt.return_unit
 
   let dns_expect_failure ~nameserver ~hostname stack () =
     let lookup = Domain_name.(of_string_exn hostname |> host_exn) in
-    let nameserver' = `UDP, (Ipaddr.V4.of_string_exn nameserver, 53) in
+    let nameserver' = (`UDP, (Ipaddr.V4.of_string_exn nameserver, 53)) in
     let dns = Dns.create ~nameserver:nameserver' stack in
     Dns.gethostbyname dns lookup >>= function
-    | Error (`Msg s) when String.compare s "Truncated UDP response" <> 0 -> Log.debug (fun f -> f "DNS test to %s failed as expected: %s"
+    | Error (`Msg s) when String.compare s "Truncated UDP response" <> 0 ->
-                                      nameserver s);
+        Log.debug (fun f ->
-      Log.info (fun f -> f "DNS traffic to %s correctly blocked :)" nameserver);
+            f "DNS test to %s failed as expected: %s" nameserver s);
-      Lwt.return_unit
+        Log.info (fun f ->
+            f "DNS traffic to %s correctly blocked :)" nameserver);
+        Lwt.return_unit
     | Error (`Msg s) ->
-       Log.debug (fun f -> f "DNS test to %s failed unexpectedly (truncated response): %s :("
+        Log.debug (fun f ->
-                             nameserver s);
+            f "DNS test to %s failed unexpectedly (truncated response): %s :("
-       Lwt.return_unit
+              nameserver s);
-    | Ok addr -> Log.err (fun f -> f "DNS test to %s should have been blocked, but looked up %s:%a" nameserver hostname Ipaddr.V4.pp addr);
+        Lwt.return_unit
-      Lwt.return_unit
+    | Ok addr ->
+        Log.err (fun f ->
+            f "DNS test to %s should have been blocked, but looked up %s:%a"
+              nameserver hostname Ipaddr.V4.pp addr);
+        Lwt.return_unit
 
   let dns_then_tcp_denied server stack () =
     let parsed_server = Domain_name.(of_string_exn server |> host_exn) in
     (* ask dns about server *)
-    Log.debug (fun f -> f "going to make a dns thing using nameserver %s" nameserver_1);
+    Log.debug (fun f ->
-    let dns = Dns.create ~nameserver:(`UDP, ((Ipaddr.V4.of_string_exn nameserver_1), 53)) stack in
+        f "going to make a dns thing using nameserver %s" nameserver_1);
+    let dns =
+      Dns.create
+        ~nameserver:(`UDP, (Ipaddr.V4.of_string_exn nameserver_1, 53))
+        stack
+    in
     Log.debug (fun f -> f "OK, going to look up %s now" server);
     Dns.gethostbyname dns parsed_server >>= function
-    | Error (`Msg s) -> Log.err (fun f -> f "couldn't look up ip for %s: %s" server s); Lwt.return_unit
+    | Error (`Msg s) ->
+        Log.err (fun f -> f "couldn't look up ip for %s: %s" server s);
+        Lwt.return_unit
     | Ok addr ->
-      Log.debug (fun f -> f "looked up ip for %s: %a" server Ipaddr.V4.pp addr);
+        Log.debug (fun f ->
-      Log.err (fun f -> f "Do more stuff here!!!! :(");
+            f "looked up ip for %s: %a" server Ipaddr.V4.pp addr);
-      Lwt.return_unit
+        Log.err (fun f -> f "Do more stuff here!!!! :(");
+        Lwt.return_unit
 
   let start _random _time _clock network db =
     E.connect network >>= fun ethernet ->
@@ -316,42 +404,64 @@ module Client (R: Mirage_random.S) (Time: Mirage_time.S) (Clock : Mirage_clock.M
     Icmp.connect ipv4 >>= fun icmp ->
     U.connect ipv4 >>= fun udp ->
     T.connect ipv4 >>= fun tcp ->
-
+    let stack = Stack.connect network ethernet arp ipv4 icmp udp tcp in
-    let stack = Stack.connect network ethernet arp ipv4 icmp udp tcp  in
     Lwt.async (fun () -> Stack.listen stack);
 
     (* put this first because tcp_connect_denied tests also generate icmp messages *)
-    let general_tests : unit Alcotest.test = ("firewall tests", [
+    let general_tests : unit Alcotest.test =
-        ("UDP fetch", `Quick,  udp_fetch ~src_port:9090 ~echo_server_port:1235 stack);
+      ( "firewall tests",
-        ("Ping expect failure", `Quick, ping_expect_failure "8.8.8.8" stack );
+        [
-        (* TODO: ping_expect_success to the netvm, for which we have an icmptype rule in update-firewall.sh *)
+          ( "UDP fetch",
-        ("ICMP error type", `Quick, icmp_error_type stack)
+            `Quick,
-       ] ) in
+            udp_fetch ~src_port:9090 ~echo_server_port:1235 stack );
+          ("Ping expect failure", `Quick, ping_expect_failure "8.8.8.8" stack);
+          (* TODO: ping_expect_success to the netvm, for which we have an icmptype rule in update-firewall.sh *)
+          ("ICMP error type", `Quick, icmp_error_type stack);
+        ] )
+    in
     Alcotest.run ~and_exit:false "name" [ general_tests ] >>= fun () ->
-    let tcp_tests : unit Alcotest.test = ("tcp tests", [
+    let tcp_tests : unit Alcotest.test =
-        (* this test fails on 4.0R3
+      ( "tcp tests",
+        [
+          (* this test fails on 4.0R3
         ("TCP connect", `Quick, tcp_connect "when trying specialtarget" nameserver_1 53 tcp); *)
-        ("TCP connect", `Quick, tcp_connect_denied "" netvm 53 tcp);
+          ("TCP connect", `Quick, tcp_connect_denied "" netvm 53 tcp);
-        ("TCP connect", `Quick, tcp_connect_denied "when trying below range" netvm 6667 tcp);
+          ( "TCP connect",
-        ("TCP connect", `Quick, tcp_connect "when trying lower bound in range" netvm 6668 tcp);
+            `Quick,
-        ("TCP connect", `Quick, tcp_connect "when trying upper bound in range" netvm 6670 tcp);
+            tcp_connect_denied "when trying below range" netvm 6667 tcp );
-        ("TCP connect", `Quick, tcp_connect_denied "when trying above range" netvm 6671 tcp);
+          ( "TCP connect",
-        ("TCP connect", `Quick, tcp_connect_denied "" netvm 8082 tcp);
+            `Quick,
-      ] ) in
+            tcp_connect "when trying lower bound in range" netvm 6668 tcp );
+          ( "TCP connect",
+            `Quick,
+            tcp_connect "when trying upper bound in range" netvm 6670 tcp );
+          ( "TCP connect",
+            `Quick,
+            tcp_connect_denied "when trying above range" netvm 6671 tcp );
+          ("TCP connect", `Quick, tcp_connect_denied "" netvm 8082 tcp);
+        ] )
+    in
 
     (* replace the udp-related listeners with the right one for tcp *)
     Alcotest.run "name" [ tcp_tests ] >>= fun () ->
     (* use the stack abstraction only after the other tests have run, since it's not friendly with outside use of its modules *)
-    let stack_tests = "stack tests", [
+    let stack_tests =
-        ("DNS expect failure", `Quick, dns_expect_failure ~nameserver:"8.8.8.8" ~hostname:"mirage.io" stack);
+      ( "stack tests",
-
+        [
-        (* the test below won't work on @linse's internet,
+          ( "DNS expect failure",
+            `Quick,
+            dns_expect_failure ~nameserver:"8.8.8.8" ~hostname:"mirage.io" stack
+          );
+          (* the test below won't work on @linse's internet,
          * because the nameserver there doesn't answer on TCP port 53,
          * only UDP port 53.  Dns_mirage_client.ml disregards our request
          * to use UDP and uses TCP anyway, so this request can never work there. *)
-        (* If we can figure out a way to have this test unikernel do a UDP lookup with minimal pain,
+          (* If we can figure out a way to have this test unikernel do a UDP lookup with minimal pain,
          * we should re-enable this test. *)
-        ("DNS lookup + TCP connect", `Quick, dns_then_tcp_denied "google.com" stack);
+          ( "DNS lookup + TCP connect",
-      ] in
+            `Quick,
+            dns_then_tcp_denied "google.com" stack );
+        ] )
+    in
     Alcotest.run "name" [ stack_tests ]
 end

unikernel.ml

@@ -6,115 +6,121 @@ 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
+  let doc =
-  Arg.(value & opt int 5_000 doc)
+    Arg.info ~doc:"The number of NAT entries to allocate." [ "nat-table-size" ]
+  in
+  Mirage_runtime.register_arg 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)
+  Mirage_runtime.register_arg 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)
+  Mirage_runtime.register_arg 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)
+  Mirage_runtime.register_arg 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)
+  Mirage_runtime.register_arg 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 Dns_client = Dns_client.Make (My_dns)
-  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. *)
+(* Set up networking and listen for incoming packets. *)
-  let network dns_client dns_responses dns_servers qubesDB router =
+let network dns_client dns_responses dns_servers qubesDB router =
-    (* Report success *)
+  (* Report success *)
-    Dao.set_iptables_error qubesDB "" >>= fun () ->
+  Dao.set_iptables_error qubesDB "" >>= fun () ->
-    (* Handle packets from both networks *)
+  (* Handle packets from both networks *)
-    Lwt.choose [
+  Lwt.choose
-      Dispatcher.wait_clients Clock.elapsed_ns dns_client dns_servers qubesDB router ;
+    [
-      Dispatcher.uplink_wait_update qubesDB router ;
+      Dispatcher.wait_clients Mirage_mtime.elapsed_ns dns_client dns_servers
-      Dispatcher.uplink_listen Clock.elapsed_ns dns_responses router
+        qubesDB router;
+      Dispatcher.uplink_wait_update qubesDB router;
+      Dispatcher.uplink_listen Mirage_mtime.elapsed_ns dns_responses router;
     ]
 
-  (* Main unikernel entry point (called from auto-generated main.ml). *)
+(* Main unikernel entry point (called from auto-generated main.ml). *)
-  let start _random _clock _time nat_table_size ipv4 ipv4_gw ipv4_dns ipv4_dns2 =
+let start () =
-    let start_time = Clock.elapsed_ns () in
+  let open Lwt.Syntax in
-    (* Start qrexec agent and QubesDB agent in parallel *)
+  let start_time = Mirage_mtime.elapsed_ns () in
-    let qrexec = RExec.connect ~domid:0 () in
+  (* Start qrexec agent and QubesDB agent in parallel *)
-    let qubesDB = DB.connect ~domid:0 () in
+  let* qrexec = RExec.connect ~domid:0 () in
+  let agent_listener = RExec.listen qrexec Command.handler in
+  let* qubesDB = DB.connect ~domid:0 () in
+  let startup_time =
+    let ( - ) = Int64.sub in
+    let time_in_ns = Mirage_mtime.elapsed_ns () - start_time in
+    Int64.to_float time_in_ns /. 1e9
+  in
+  Log.info (fun f ->
+      f "QubesDB and qrexec agents connected in %.3f s" startup_time);
+  (* Watch for shutdown requests from Qubes *)
+  let shutdown_rq =
+    Xen_os.Lifecycle.await_shutdown_request () >>= fun (`Poweroff | `Reboot) ->
+    Lwt.return_unit
+  in
+  (* Set up networking *)
+  let nat = My_nat.create ~max_entries:(nat_table_size ()) in
 
-    (* Wait for clients to connect *)
+  let netvm_ip = Ipaddr.V4.of_string_exn (ipv4_gw ()) in
-    qrexec >>= fun qrexec ->
+  let our_ip = Ipaddr.V4.of_string_exn (ipv4 ()) in
-    let agent_listener = RExec.listen qrexec Command.handler in
+  let dns = Ipaddr.V4.of_string_exn (ipv4_dns ()) in
-    qubesDB >>= fun qubesDB ->
+  let dns2 = Ipaddr.V4.of_string_exn (ipv4_dns2 ()) in
-    let startup_time =
-      let (-) = Int64.sub in
-      let time_in_ns = Clock.elapsed_ns () - start_time in
-      Int64.to_float time_in_ns /. 1e9
-    in
-    Log.info (fun f -> f "QubesDB and qrexec agents connected in %.3f s" startup_time);
-    (* Watch for shutdown requests from Qubes *)
-    let shutdown_rq =
-      Xen_os.Lifecycle.await_shutdown_request () >>= fun (`Poweroff | `Reboot) ->
-      Lwt.return_unit in
-    (* Set up networking *)
-    let nat = My_nat.create ~max_entries:nat_table_size in
 
-    let netvm_ip = Ipaddr.V4.of_string_exn ipv4_gw in
+  let zero_ip = Ipaddr.V4.any 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 *)
+  let network_config =
-    Dao.print_network_config 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
+      let config : Dao.network_config =
+        { from_cmdline = true; netvm_ip; our_ip; dns; dns2 }
+      in
+      Lwt.return config
+  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;
 
-    (* Set up client-side networking *)
+  (* Set up client-side networking *)
-    Client_eth.create config >>= fun clients ->
+  let* clients = Client_eth.create config in
 
-    (* Set up routing between networks and hosts *)
+  (* Set up routing between networks and hosts *)
-    let router = Dispatcher.create
+  let router = Dispatcher.create ~config ~clients ~nat ~uplink:None in
-      ~config
-      ~clients
-      ~nat
-      ~uplink:None
-    in
 
-    let send_dns_query = Dispatcher.send_dns_client_query None in
+  let send_dns_query = Dispatcher.send_dns_client_query router in
-    let dns_mvar = Lwt_mvar.create_empty () in
+  let dns_mvar = Lwt_mvar.create_empty () in
-    let nameservers = `Udp, [ config.Dao.dns, 53 ; config.Dao.dns2, 53 ] 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_client =
+    Dns_client.create ~nameservers (router, send_dns_query, dns_mvar)
+  in
 
-    let dns_servers = [ config.Dao.dns ; config.Dao.dns2 ] 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 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 *)
+  (* Report memory usage to XenStore *)
-    Memory_pressure.init ();
+  Memory_pressure.init ();
-    (* Run until something fails or we get a shutdown request. *)
+  (* Run until something fails or we get a shutdown request. *)
-    Lwt.choose [agent_listener; net_listener; shutdown_rq] >>= fun () ->
+  Lwt.choose [ agent_listener; net_listener; shutdown_rq ] >>= fun () ->
-    (* Give the console daemon time to show any final log messages. *)
+  (* Give the console daemon time to show any final log messages. *)
-    Time.sleep_ns (1.0 *. 1e9 |> Int64.of_float)
+  Mirage_sleep.ns (1.0 *. 1e9 |> Int64.of_float)
-end