Initial import

.gitignore

@@ -0,0 +1,9 @@
+Makefile
+_build/
+log
+key_gen.ml
+main.ml
+main.native
+mir-qubes-test
+qubes-firewall.xl.in
+qubes-firewall_libvirt.xml

.merlin

@@ -0,0 +1,3 @@
+S .
+B _build
+PKG vchan.xen lwt mirage mirage-net-xen tcpip mirage-nat

.travis.yml

@@ -0,0 +1,22 @@
+language: c
+install: wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-mirage.sh
+script: bash -ex .travis-mirage.sh
+sudo: required
+dist: trusty
+addons:
+  apt:
+    sources:
+    - avsm
+    packages:
+    - ocaml
+    - ocaml-base
+    - ocaml-native-compilers
+    - ocaml-compiler-libs
+    - ocaml-interp
+    - ocaml-base-nox
+    - ocaml-nox
+    - camlp4
+    - camlp4-extra
+    - time
+env:
+  - FORK_USER=talex5 FORK_BRANCH=unikernel OCAML_VERSION=4.02 MIRAGE_BACKEND=xen PINS="mirage-clock-xen:https://github.com/mirage/mirage-clock.git mirage-xen:https://github.com/talex5/mirage-platform.git#mm mirage-qubes:https://github.com/talex5/mirage-qubes.git mirage-nat:https://github.com/talex5/mirage-nat.git#simplify-checksum tcpip:https://github.com/mirage/mirage-tcpip.git mirage-net-xen:https://github.com/talex5/mirage-net-xen.git#disconnect"

README.md

@@ -0,0 +1,89 @@
+# qubes-mirage-firewall
+
+An **experimental** unikernel that can run as a QubesOS ProxyVM, replacing `sys-firewall`.
+It uses the [mirage-qubes][] library to implement the Qubes protocols.
+
+Note: This firewall *ignores the rules set in the Qubes GUI*.
+
+Currently it only prevents incoming connections from the outside world (which is really just a side-effect of doing NAT). So currently it's really just a router rather than a firewall.
+
+Also, it doesn't yet proxy DNS requests.
+
+To build:
+
+    $ opam install mirage
+    $ opam pin add mirage-clock-xen https://github.com/mirage/mirage-clock.git
+    $ opam pin add mirage-net-xen 'https://github.com/talex5/mirage-net-xen.git#disconnect'
+    $ opam pin add tcpip https://github.com/mirage/mirage-tcpip.git
+    $ opam pin add mirage-xen 'https://github.com/talex5/mirage-platform.git#mm'
+    $ opam pin add mirage-qubes https://github.com/talex5/mirage-qubes.git
+    $ opam pin add mirage-nat 'https://github.com/talex5/mirage-nat.git#simplify-checksum'
+    $ mirage configure --xen
+    $ make
+
+You can use this with the [test-mirage][] scripts to deploy the unikernel (`mir-qubes-firewall.xen`) from your development AppVM. e.g.
+
+    $ test-mirage mir-firewall.xen mirage-firewall
+    Waiting for 'Ready'... OK
+    Uploading 'mir-qubes-firewall.xen' (4843304 bytes) to "mirage-firewall"
+    Waiting for 'Booting'... OK
+    --> Loading the VM (type = ProxyVM)...
+    --> Starting Qubes DB...
+    --> Setting Qubes DB info for the VM...
+    --> Updating firewall rules...
+    --> Starting the VM...
+    --> Starting the qrexec daemon...
+    Waiting for VM's qrexec agent.connected
+    --> Starting Qubes GUId...
+    Connecting to VM's GUI agent: .connected
+    --> Sending monitor layout...
+    --> Waiting for qubes-session...
+    Connecting to mirage-firewall console...
+    MirageOS booting...
+    Initialising timer interface
+    Initialising console ... done.
+    Netif: add resume hook
+    gnttab_stubs.c: initialised mini-os gntmap
+    2015-12-30 10:04.42: INF [qubes.rexec] waiting for client...
+    2015-12-30 10:04.42: INF [qubes.gui] waiting for client...
+    2015-12-30 10:04.42: INF [qubes.db] connecting to server...
+    2015-12-30 10:04.42: INF [qubes.db] connected
+    2015-12-30 10:04.42: INF [qubes.rexec] client connected, using protocol version 2
+    2015-12-30 10:04.42: INF [qubes.db] got update: "/qubes-keyboard" = "xkb_keymap {\n\txkb_keycodes  { include \"evdev+aliases(qwerty)\"\t};\n\txkb_types     { include \"complete\"\t};\n\txkb_compat    { include \"complete\"\t};\n\txkb_symbols   { include \"pc+gb+inet(evdev)\"\t};\n\txkb_geometry  { include \"pc(pc104)\"\t};\n};"
+    2015-12-30 10:04.42: INF [qubes.gui] client connected (screen size: 6720x2160)
+    2015-12-30 10:04.42: INF [unikernel] agents connected in 0.052 s (CPU time used since boot: 0.007 s)
+    Netif.connect 0
+    Netfront.create: id=0 domid=1
+     sg:true gso_tcpv4:true rx_copy:true rx_flip:false smart_poll:false
+    MAC: 00:16:3e:5e:6c:0b
+    ARP: sending gratuitous from 10.137.1.13
+    2015-12-30 10:04.42: INF [application] Client (internal) network is 10.137.3.0/24
+    ARP: transmitting probe -> 10.137.1.1
+    2015-12-30 10:04.42: INF [net] Watching backend/vif
+    2015-12-30 10:04.42: INF [qubes.rexec] Execute "user:QUBESRPC qubes.SetMonitorLayout dom0\000"
+    2015-12-30 10:04.42: WRN [command] << Unknown command "QUBESRPC qubes.SetMonitorLayout dom0"
+    2015-12-30 10:04.42: INF [qubes.rexec] Execute "root:QUBESRPC qubes.WaitForSession none\000"
+    2015-12-30 10:04.42: WRN [command] << Unknown command "QUBESRPC qubes.WaitForSession none"
+    2015-12-30 10:04.42: INF [qubes.db] got update: "/qubes-netvm-domid" = "1"
+    ARP: retrying 10.137.1.1 (n=1)
+    ARP: transmitting probe -> 10.137.1.1
+    ARP: updating 10.137.1.1 -> fe:ff:ff:ff:ff:ff
+
+
+
+# LICENSE
+
+Copyright (c) 2015, Thomas Leonard
+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.
+gg
+
+[test-mirage]: https://github.com/talex5/qubes-test-mirage
+[mirage-qubes]: https://github.com/talex5/mirage-qubes

_tags

@@ -0,0 +1,2 @@
+not <main.*>: warn(A-4), strict_sequence
+<qubes_protocol.*>: package(cstruct.syntax)

cleanup.ml

@@ -0,0 +1,14 @@
+(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
+   See the README file for details. *)
+
+type t = (unit -> unit) list ref
+
+let create () = ref []
+
+let on_cleanup t fn =
+  t := fn :: !t
+
+let cleanup t =
+  let tasks = !t in
+  t := [];
+  List.iter (fun f -> f ()) tasks

cleanup.mli

@@ -0,0 +1,15 @@
+(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
+   See the README file for details. *)
+
+(** Register actions to take when a resource is finished.
+    Like [Lwt_switch], but synchronous. *)
+
+type t
+
+val create : unit -> t
+
+val on_cleanup : t -> (unit -> unit) -> unit
+(** Register a new action to take on cleanup. *)
+
+val cleanup : t -> unit
+(** Run cleanup tasks, starting with the most recently added. *)

client_net.ml

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

client_net.mli

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

command.ml

@@ -0,0 +1,20 @@
+(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
+   See the README file for details. *)
+
+(** 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 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 ->
+    Log.warn "<< %s" (fun f -> f s);
+    Flow.ewritef flow "%s [while processing %S]" s cmd >|= fun () -> 1 in
+  match cmd with
+  | cmd -> error "Unknown command %S" cmd

config.ml

@@ -0,0 +1,15 @@
+(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
+   See the README file for details. *)
+
+(** Configuration for the "mirage" tool. *)
+
+open Mirage
+
+let main =
+  foreign
+    ~libraries:["mirage-net-xen"; "tcpip.stack-direct"; "tcpip.xen"; "mirage-qubes"; "mirage-nat"]
+    ~packages:["vchan"; "cstruct"; "tcpip"; "mirage-net-xen"; "mirage-qubes"; "mirage-nat"]
+    "Unikernel.Main" (clock @-> job)
+
+let () =
+  register "qubes-firewall" [main $ default_clock]

memory_pressure.ml

@@ -0,0 +1,16 @@
+(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
+   See the README file for details. *)
+
+let total_pages = OS.MM.Heap_pages.total () |> float_of_int
+
+let status () =
+  let used = OS.MM.Heap_pages.used () |> float_of_int in
+  let frac = used /. total_pages in
+  if frac < 0.9 then `Ok
+  else (
+    Gc.full_major ();
+    let used = OS.MM.Heap_pages.used () |> float_of_int in
+    let frac = used /. total_pages in
+    if frac > 0.9 then `Memory_critical
+    else `Ok
+  )

memory_pressure.mli

@@ -0,0 +1,8 @@
+(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
+   See the README file for details. *)
+
+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. *)

mirage_logs.ml

@@ -0,0 +1,35 @@
+(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
+   See the README file for details. *)
+
+let buf = Buffer.create 200
+let log_fmt = Format.formatter_of_buffer buf
+
+let string_of_level =
+  let open Logs in function
+  | App -> "APP"
+  | Error -> "ERR"
+  | Warning -> "WRN"
+  | Info -> "INF"
+  | Debug -> "DBG"
+
+let fmt_timestamp tm =
+  let open Clock in
+  Printf.sprintf "%04d-%02d-%02d %02d:%02d.%02d"
+    (tm.tm_year + 1900) (tm.tm_mon + 1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec
+
+module Make (C : V1.CLOCK) = struct
+  let init_logging () =
+    let report src level k fmt msgf =
+      let now = C.time () |> Clock.gmtime |> fmt_timestamp in
+      let lvl = string_of_level level in
+      let k _ =
+        let msg = Buffer.contents buf in
+        Buffer.clear buf;
+        output_string stderr (msg ^ "\n");
+        flush stderr;
+        MProf.Trace.label msg;
+        k () in
+      msgf @@ fun ?header:_ ?tags:_ ->
+      Format.kfprintf k log_fmt ("%s: %s [%s] " ^^ fmt) now lvl (Logs.Src.name src) in
+    Logs.set_reporter { Logs.report }
+end

mirage_logs.mli

@@ -0,0 +1,14 @@
+(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
+   See the README file for details. *)
+
+(** Mirage support for Logs library. *)
+
+module Make (Clock : V1.CLOCK) : sig
+  val init_logging : unit -> unit
+  (** [init_logging ()] configures the Logs library to log to stderr,
+      with time-stamps provided by [Clock].
+      If logs are written faster than the backend can consume them,
+      the whole unikernel will block until there is space (so log messages
+      will not be lost, but unikernels generating a lot of log output
+      may run slowly). *)
+end

nat_rules.ml

@@ -0,0 +1,57 @@
+(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
+   See the README file for details. *)
+
+(** Perform NAT on the interface to our NetVM.
+    Based on https://github.com/yomimono/simple-nat *)
+
+let src = Logs.Src.create "nat-rules" ~doc:"Firewall NAT rules"
+module Log = (val Logs.src_log src : Logs.LOG)
+
+let random_user_port () =
+  1024 + Random.int (0xffff - 1024)
+
+(* Add a NAT rule for the endpoints in this frame, via a random port on [ip]. *)
+let allow_nat_traffic table frame (ip : Ipaddr.t) =
+  let rec stubborn_insert port =
+    (* TODO: in the unlikely event that no port is available, this
+       function will never terminate (this is really a tcpip todo) *)
+    let open Nat_rewrite in
+    match make_nat_entry table frame ip port with
+    | Ok t ->
+        Log.info "added NAT entry: %s:%d -> firewall:%d -> %s:%d"
+          (fun f ->
+            match Nat_rewrite.layers frame with
+            | None -> assert false
+            | Some (_eth, ip, transport) ->
+            let src, dst = Nat_rewrite.addresses_of_ip ip in
+            let sport, dport = Nat_rewrite.ports_of_transport transport in
+            f (Ipaddr.to_string src) sport port (Ipaddr.to_string dst) dport
+          );
+        Some t
+    | Unparseable -> None
+    | Overlap -> stubborn_insert (random_user_port ())
+  in
+  (* TODO: connection tracking logic *)
+  stubborn_insert (random_user_port ())
+
+(** Perform translation on [frame] and return translated packet.
+    Update NAT table for new outbound connections. *)
+let nat translation_ip nat_table direction frame =
+  let rec retry () =
+    (* typical NAT logic: traffic from the internal "trusted" interface gets
+       new mappings by default; traffic from other interfaces gets dropped if
+       no mapping exists (which it doesn't, since we already checked) *)
+    let open Nat_rewrite in
+    match direction, Nat_rewrite.translate nat_table direction frame with
+    | _, Some f -> Some f
+    | Destination, None -> None (* nothing in the table, drop it *)
+    | Source, None ->
+      (* mutate nat_table to include entries for the frame *)
+      match allow_nat_traffic nat_table frame translation_ip with
+      | Some _t ->
+          (* try rewriting again; we should now have an entry for this packet *)
+          retry ()
+      | None ->
+          (* this frame is hopeless! *)
+          None in
+  retry ()

net.ml

@@ -0,0 +1,227 @@
+(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
+   See the README file for details. *)
+
+(** General network stuff (needs reorganising). *)
+
+open Lwt.Infix
+open Utils
+open Qubes
+
+module StringMap = Map.Make(String)
+module StringSet = Set.Make(String)
+
+module Eth = Ethif.Make(Netif)
+
+module Netback = Netchannel.Backend.Make(Netchannel.Xenstore.Make(OS.Xs))
+module ClientEth = Ethif.Make(Netback)
+
+let src = Logs.Src.create "net" ~doc:"Firewall networking"
+module Log = (val Logs.src_log src : Logs.LOG)
+
+(* The checksum logic doesn't depend on ARP or Eth, but we can't access
+   IPv4.checksum without applying the functor. *)
+let fixup_checksums frame =
+  match Nat_rewrite.layers frame with
+  | None -> raise (Invalid_argument "NAT transformation rendered packet unparseable")
+  | Some (ether, ip, tx) ->
+    let (just_headers, higherlevel_data) =
+      Nat_rewrite.recalculate_transport_checksum (ether, ip, tx)
+    in
+    [just_headers; higherlevel_data]
+
+module Make(Clock : V1.CLOCK) = struct
+  module Arp = Arpv4.Make(Eth)(Clock)(OS.Time)
+  module IPv4 = Ipv4.Make(Eth)(Arp)
+  module Xs = OS.Xs
+
+  let eth_header ~src ~dst =
+    let open Wire_structs in
+    let frame = Cstruct.create sizeof_ethernet in
+    frame |> set_ethernet_src (Macaddr.to_bytes src) 0;
+    frame |> set_ethernet_dst (Macaddr.to_bytes dst) 0;
+    set_ethernet_ethertype frame (ethertype_to_int IPv4);
+    frame
+
+  class netvm_iface eth my_ip mac nat_table : interface = object
+    method my_mac = Eth.mac eth
+    method writev ip =
+      mac >>= fun dst ->
+      let eth_hdr = eth_header ~src:(Eth.mac eth) ~dst in
+      match Nat_rules.nat my_ip nat_table Nat_rewrite.Source (Cstruct.concat (eth_hdr :: ip)) with
+      | None -> return ()
+      | Some frame -> Eth.writev eth (fixup_checksums frame)
+  end
+
+  class client_iface eth client_ip client_mac : client_link = object
+    method my_mac = ClientEth.mac eth
+    method client_mac = client_mac
+    method client_ip = client_ip
+    method writev ip =
+      let eth_hdr = eth_header ~src:(ClientEth.mac eth) ~dst:client_mac in
+      ClientEth.writev eth (fixup_checksums (Cstruct.concat (eth_hdr :: ip)))
+  end
+
+  let random_user_port () =
+    1024 + Random.int (0xffff - 1024)
+
+  let pp_ip4 = Ipaddr.V4.pp_hum
+
+  let or_fail msg = function
+    | `Ok x -> return x
+    | `Error _ -> fail (Failure msg)
+
+  let clients : Cleanup.t StringMap.t ref = ref StringMap.empty
+
+  let forward_ipv4 router buf =
+    match Memory_pressure.status () with
+    | `Memory_critical -> (* TODO: should happen before copying and async *)
+        print_endline "Memory low - dropping packet";
+        return ()
+    | `Ok ->
+    match Router.target router buf with
+    | Some iface -> iface#writev [buf]
+    | None -> return ()
+
+  let start_client ~router domid =
+    let cleanup_tasks = Cleanup.create () in
+    Log.info "start_client in domain %s" (fun f -> f domid);
+    Lwt.async (fun () ->
+      Lwt.catch (fun () ->
+        let domid = int_of_string domid in
+        let path = Printf.sprintf "backend/vif/%d" domid in
+        OS.Xs.make () >>= fun xs ->
+        OS.Xs.immediate xs (fun h ->
+          OS.Xs.directory h path >>= function
+          | [] -> return None
+          | device_id :: others ->
+              if others <> [] then Log.warn "Client has multiple interfaces; using first" Logs.unit;
+              let device_id = int_of_string device_id in
+              OS.Xs.read h (Printf.sprintf "%s/%d/ip" path device_id) >>= fun client_ip ->
+              Netback.make ~domid ~device_id >|= fun backend ->
+              Some (backend, Ipaddr.V4.of_string_exn client_ip)
+        ) >>= function
+        | None -> Log.warn "Client has no interfaces" Logs.unit; return ()
+        | Some (backend, client_ip) ->
+        Log.info "Client %d (IP: %s) ready" (fun f ->
+          f domid (Ipaddr.V4.to_string client_ip));
+        ClientEth.connect backend >>= or_fail "Can't make Ethernet device" >>= fun eth ->
+        let client_mac = Netback.mac backend in
+        let iface = new client_iface eth client_ip client_mac in
+        let fixed_arp = Client_net.ARP.create ~net:(Router.client_net router) iface in
+        Router.add_client router iface;
+        Cleanup.on_cleanup cleanup_tasks (fun () -> Router.remove_client router iface);
+        Netback.listen backend (
+          ClientEth.input
+            ~arpv4:(fun buf ->
+              match Client_net.ARP.input fixed_arp buf with
+              | None -> return ()
+              | Some frame -> ClientEth.write eth frame
+            )
+            ~ipv4:(fun packet ->
+              let src = Wire_structs.Ipv4_wire.get_ipv4_src packet |> Ipaddr.V4.of_int32 in
+              if src === client_ip then forward_ipv4 router packet
+              else (
+                Log.warn "Incorrect source IP %a in IP packet from %a (dropping)"
+                  (fun f -> f Ipaddr.V4.pp_hum src Ipaddr.V4.pp_hum client_ip);
+                return ()
+              )
+            )
+            ~ipv6:(fun _buf -> return ())
+            eth
+        )
+      )
+      (fun ex ->
+        Log.warn "Error connecting client domain %s: %s"
+          (fun f -> f domid (Printexc.to_string ex));
+        return ()
+      )
+    );
+    cleanup_tasks
+
+  let watch_clients ~router xs =
+    let backend_vifs = "backend/vif" in
+    Log.info "Watching %s" (fun f -> f backend_vifs);
+    Xs.wait xs (fun handle ->
+      begin Lwt.catch
+        (fun () -> Xs.directory handle backend_vifs)
+        (function
+          | Xs_protocol.Enoent _ -> return []
+          | ex -> fail ex)
+      end >>= fun items ->
+      Log.debug "Items: %s" (fun f -> f (String.concat ", " items));
+      let new_set = items
+        |> List.fold_left (fun acc key -> StringSet.add key acc) StringSet.empty in
+      (* Check for removed clients *)
+      !clients |> StringMap.iter (fun key cleanup ->
+        if not (StringSet.mem key new_set) then (
+          clients := !clients |> StringMap.remove key;
+          Log.info "stop_client %S" (fun f -> f key);
+          Cleanup.cleanup cleanup
+        )
+      );
+      (* Check for added clients *)
+      new_set |> StringSet.iter (fun key ->
+        if not (StringMap.mem key !clients) then (
+          let cleanup = start_client ~router key in
+          clients := !clients |> StringMap.add key cleanup
+        )
+      );
+      (* Wait for further updates *)
+      fail Xs_protocol.Eagain
+    )
+
+  let connect qubesDB ~xs =
+    let nat_table = Nat_lookup.empty () in
+    let get name =
+      match DB.read qubesDB name with
+      | None -> raise (error "QubesDB key %S not present" name)
+      | Some value -> value in
+    let ip = get "/qubes-ip" |> Ipaddr.of_string_exn in
+    (* let netmask = get "/qubes-netmask" |> Ipaddr.V4.of_string_exn in *)
+    let gateway = get "/qubes-gateway" |> Ipaddr.V4.of_string_exn in
+    (* This is oddly named: seems to be the network we provde to our clients *)
+    let client_prefix =
+      let client_network = get "/qubes-netvm-network" |> Ipaddr.V4.of_string_exn in
+      let client_netmask = get "/qubes-netvm-netmask" |> Ipaddr.V4.of_string_exn in
+      Ipaddr.V4.Prefix.of_netmask client_netmask client_network in
+    let client_gw = get "/qubes-netvm-gateway" |> Ipaddr.V4.of_string_exn in
+    Netif.connect "tap0" >>= function
+    | `Error (`Unknown msg) -> failwith msg
+    | `Error `Disconnected -> failwith "Disconnected"
+    | `Error `Unimplemented -> failwith "Unimplemented"
+    | `Ok net0 ->
+    Eth.connect net0 >>= or_fail "Can't make Ethernet device for tap" >>= fun eth0 ->
+    Arp.connect eth0 >>= or_fail "Can't add ARP" >>= fun arp0 ->
+    match Ipaddr.to_v4 ip with
+    | None -> failwith "Don't have an IPv4 address!"
+    | Some ip4 ->
+    Arp.add_ip arp0 ip4 >>= fun () ->
+    DB.write qubesDB "/qubes-iptables-error" "" >>= fun () ->
+    Logs.info "Client (internal) network is %a"
+      (fun f -> f Ipaddr.V4.Prefix.pp_hum client_prefix);
+    let netvm_iface =
+      let netvm_mac = Arp.query arp0 gateway >|= function
+        | `Timeout -> failwith "ARP timeout getting MAC of our NetVM"
+        | `Ok netvm_mac -> netvm_mac in
+      new netvm_iface eth0 ip netvm_mac nat_table in
+    let client_net = Client_net.create ~client_gw ~prefix:client_prefix in
+    let router = Router.create ~default_gateway:netvm_iface ~client_net in
+    let clients = watch_clients ~router xs in
+    let wan =
+      let unnat frame _ip = 
+        match Nat_rules.nat ip nat_table Nat_rewrite.Destination frame with
+        | None ->
+            Log.debug "Discarding unexpected frame" Logs.unit;
+            return ()
+        | Some frame ->
+            let frame = fixup_checksums frame |> Cstruct.concat in
+            forward_ipv4 router (Cstruct.shift frame Wire_structs.sizeof_ethernet) in
+      Netif.listen net0 (fun frame ->
+        Eth.input
+          ~arpv4:(Arp.input arp0)
+          ~ipv4:(unnat frame)
+          ~ipv6:(fun _buf -> return ())
+          eth0 frame
+      ) in
+    Lwt.join [clients; wan]
+end

router.ml

@@ -0,0 +1,32 @@
+(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
+   See the README file for details. *)
+
+open Utils
+
+let src = Logs.Src.create "router" ~doc:"Router"
+module Log = (val Logs.src_log src : Logs.LOG)
+
+type t = {
+  client_net : Client_net.t;
+  default_gateway : interface;
+}
+
+let create ~client_net ~default_gateway = { client_net; default_gateway }
+
+let client_net t = t.client_net
+
+let target t buf =
+  let open Wire_structs.Ipv4_wire in
+  let dst_ip = get_ipv4_dst buf |> Ipaddr.V4.of_int32 in
+  Log.debug "Got IPv4: dst=%s" (fun f -> f (Ipaddr.V4.to_string dst_ip));
+  if Ipaddr.V4.Prefix.mem dst_ip (Client_net.prefix t.client_net) then (
+    match Client_net.lookup t.client_net dst_ip with
+    | Some client_link -> Some (client_link :> interface)
+    | None ->
+      Log.warn "Packet to unknown internal client %a - dropping"
+        (fun f -> f Ipaddr.V4.pp_hum dst_ip);
+      None
+  ) else Some t.default_gateway
+
+let add_client t = Client_net.add_client t.client_net
+let remove_client t = Client_net.remove_client t.client_net

router.mli

@@ -0,0 +1,27 @@
+(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
+   See the README file for details. *)
+
+(** Routing packets to the right network interface. *)
+
+open Utils
+
+type t
+(** A routing table. *)
+
+val create :
+  client_net:Client_net.t ->
+  default_gateway:interface ->
+  t
+(** [create ~client_net ~default_gateway] is a new routing table that routes packets outside
+    of [client_net] to [default_gateway]. *)
+
+val client_net : t -> Client_net.t
+
+val target : t -> Cstruct.t -> interface option
+(** [target t packet] is the interface to which [packet] (an IP packet) should be routed. *)
+
+val add_client : t -> client_link -> unit
+(** [add_client t iface] adds a rule for routing packets addressed to [iface].
+    The client's IP address must be within the [client_net] passed to [create]. *)
+
+val remove_client : t -> client_link -> unit

unikernel.ml

@@ -0,0 +1,46 @@
+(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
+   See the README file for details. *)
+
+open Lwt
+open Qubes
+
+let src = Logs.Src.create "unikernel" ~doc:"Main unikernel code"
+module Log = (val Logs.src_log src : Logs.LOG)
+
+let () =
+  let open Logs in
+  (* Set default log level *)
+  set_level (Some Logs.Info);
+  (* Debug-level logging for XenStore while tracking down occasional EACCES error. *)
+  Src.list () |> List.find (fun src -> Src.name src = "xenstore.client") |> fun xs ->
+  Src.set_level xs (Some Debug)
+
+module Main (Clock : V1.CLOCK) = struct
+  module N = Net.Make(Clock)
+  module Log_reporter = Mirage_logs.Make(Clock)
+
+  let start () =
+    let start_time = Clock.time () in
+    Log_reporter.init_logging ();
+    (* Start qrexec agent, GUI agent and QubesDB agent in parallel *)
+    let qrexec = RExec.connect ~domid:0 () in
+    let gui = GUI.connect ~domid:0 () in
+    let qubesDB = DB.connect ~domid:0 () in
+    (* Wait for clients to connect *)
+    qrexec >>= fun qrexec ->
+    let agent_listener = RExec.listen qrexec Command.handler in
+    gui >>= fun gui ->
+    Lwt.async (fun () -> GUI.listen gui);
+    qubesDB >>= fun qubesDB ->
+    Log.info "agents connected in %.3f s (CPU time used since boot: %.3f s)"
+      (fun f -> f (Clock.time () -. start_time) (Sys.time ()));
+    (* Watch for shutdown requests from Qubes *)
+    let shutdown_rq = OS.Lifecycle.await_shutdown () >|= function `Poweroff | `Reboot -> () in
+    (* Set up networking *)
+    OS.Xs.make () >>= fun xs ->
+    let net = N.connect ~xs qubesDB in
+    (* Run until something fails or we get a shutdown request. *)
+    Lwt.choose [agent_listener; net; shutdown_rq] >>= fun () ->
+    (* Give the console daemon time to show any final log messages. *)
+    OS.Time.sleep 1.0
+end

utils.ml

@@ -0,0 +1,39 @@
+(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
+   See the README file for details. *)
+
+(** General utility functions. *)
+
+module IpMap = struct
+  include Map.Make(Ipaddr.V4)
+  let find x map =
+    try Some (find x map)
+    with Not_found -> None
+end
+
+(** An Ethernet interface. *)
+class type interface = object
+  method my_mac : Macaddr.t
+  method writev : Cstruct.t list -> unit Lwt.t
+end
+
+(** An Ethernet interface connected to a clientVM. *)
+class type client_link = object
+  inherit interface
+  method client_ip : Ipaddr.V4.t
+  method client_mac : Macaddr.t
+end
+
+let (===) a b = (Ipaddr.V4.compare a b = 0)
+
+let error fmt =
+  let err s = Failure s in
+  Printf.ksprintf err fmt
+
+let return = Lwt.return
+let fail = Lwt.fail
+
+(* Copy str to the start of buffer and fill the rest with zeros *)
+let set_fixed_string buffer str =
+  let len = String.length str in
+  Cstruct.blit_from_string str 0 buffer 0 len;
+  Cstruct.memset (Cstruct.shift buffer len) 0