Merge pull request #96 from roburio/squash

QubesOS 4.0 support

CHANGES.md

@@ -1,3 +1,18 @@
+### master branch
+
+This version adapts qubes-mirage-firewall with
+- dynamic rulesets via QubesDB (as defined in Qubes 4.0), and
+- adds support for DNS hostnames in rules, using the pf-qubes library for parsing.
+
+The DNS client is provided by DNS (>= 4.2.0) which uses a cache for name lookups. Not every packet will lead to a DNS lookup if DNS rules are in place.
+
+A test unikernel is available in the test subdirectory.
+
+This project was done by @linse and @yomimono in summer 2019, see PR #96.
+
+Additional changes and bugfixes:
+TODO: describe based on commit log de7d05e .. 02e515d
+
 ### 0.6
 
 Changes to rules language:

Dockerfile

@@ -7,9 +7,9 @@ FROM ocurrent/opam@sha256:3f3ce7e577a94942c7f9c63cbdd1ecbfe0ea793f581f69047f3155
 # Pin last known-good version for reproducible builds.
 # Remove this line (and the base image pin above) if you want to test with the
 # latest versions.
-RUN cd ~/opam-repository && git fetch origin master && git reset --hard ebac42783217016bd2c4108bbbef102aab56cdde && opam update
+RUN cd ~/opam-repository && git fetch origin master && git reset --hard 3548c2a8537029b8165466cd9c5a94bb7bc30405 && opam update
 
-RUN opam depext -i -y mirage.3.7.4 lwt.4.5.0
+RUN opam depext -i -y mirage.3.7.6 lwt.5.2.0
 RUN mkdir /home/opam/qubes-mirage-firewall
 ADD config.ml /home/opam/qubes-mirage-firewall/config.ml
 WORKDIR /home/opam/qubes-mirage-firewall

Makefile.builder

@@ -4,5 +4,5 @@ SOURCE_BUILD_DEP := firewall-build-dep
 
 firewall-build-dep:
 	opam install -y depext
-	opam depext -i -y mirage.3.7.4 lwt.4.5.0
+	opam depext -i -y mirage.3.7.6 lwt.5.2.0
 

Makefile.user

@@ -5,3 +5,8 @@ tar: build
 	touch _build/mirage-firewall/modules.img
 	cat /dev/null | gzip -n > _build/mirage-firewall/initramfs
 	tar cjf mirage-firewall.tar.bz2 -C _build --mtime=./build-with-docker.sh mirage-firewall
+
+fetchmotron: qubes_firewall.xen
+	test-mirage qubes_firewall.xen mirage-fw-test &
+	sleep 1
+	boot-mirage fetchmotron

README.md

@@ -165,6 +165,13 @@ This takes a little more setting up the first time, but will be much quicker aft
     2017-03-18 11:32:38 -00:00: INF [dao] Watching backend/vif
     2017-03-18 11:32:38 -00:00: INF [qubes.db] got update: "/qubes-netvm-domid" = "1"
 
+# Testing if the firewall works
+
+Build the test unikernel in the test directory.
+Install it to a vm which has the firewall as netvm.
+Set the rules for the testvm to "textfile".
+Run the test unikernel.
+
 # Security advisories
 
 See [issues tagged "security"](https://github.com/mirage/qubes-mirage-firewall/issues?utf8=%E2%9C%93&q=label%3Asecurity+) for security advisories affecting the firewall.

build-with-docker.sh

@@ -5,5 +5,5 @@ docker build -t qubes-mirage-firewall .
 echo Building Firewall...
 docker run --rm -i -v `pwd`:/home/opam/qubes-mirage-firewall qubes-mirage-firewall
 echo "SHA2 of build:   $(sha256sum qubes_firewall.xen)"
-echo "SHA2 last known: 83b96bd453c3c3cfb282076be81055026eca437b621b3ef3f2642af04ad782e2"
+echo "SHA2 last known: 7a6b003e712256cce7ac8741239f6d8d5a0db4b71656396f7ee734568282c72d"
 echo "(hashes should match for released versions)"

client_net.ml

@@ -30,6 +30,9 @@ class client_iface eth ~domid ~gateway_ip ~client_ip client_mac : client_link =
   let log_header = Fmt.strf "dom%d:%a" domid Ipaddr.V4.pp client_ip in
   object
     val queue = FrameQ.create (Ipaddr.V4.to_string client_ip)
+    val mutable rules = []
+    method get_rules = rules
+    method set_rules new_db = rules <- Dao.read_rules new_db client_ip
     method my_mac = ClientEth.mac eth
     method other_mac = client_mac
     method my_ip = gateway_ip
@@ -56,7 +59,7 @@ let input_arp ~fixed_arp ~iface request =
       iface#writev `ARP (fun b -> Arp_packet.encode_into response b; Arp_packet.size)
 
 (** Handle an IPv4 packet from the client. *)
-let input_ipv4 get_ts cache ~iface ~router packet =
+let input_ipv4 get_ts cache ~iface ~router dns_client packet =
   let cache', r = Nat_packet.of_ipv4_packet !cache ~now:(get_ts ()) packet in
   cache := cache';
   match r with
@@ -67,15 +70,15 @@ let input_ipv4 get_ts cache ~iface ~router packet =
   | Ok (Some packet) ->
     let `IPv4 (ip, _) = packet in
     let src = ip.Ipv4_packet.src in
-    if src = iface#other_ip then Firewall.ipv4_from_client router ~src:iface packet
+    if src = iface#other_ip then Firewall.ipv4_from_client dns_client router ~src:iface packet
     else (
       Log.warn (fun f -> f "Incorrect source IP %a in IP packet from %a (dropping)"
                    Ipaddr.V4.pp src Ipaddr.V4.pp iface#other_ip);
       Lwt.return_unit
     )
 
-(** Connect to a new client's interface and listen for incoming frames. *)
+(** Connect to a new client's interface and listen for incoming frames and firewall rule changes. *)
-let add_vif get_ts { Dao.ClientVif.domid; device_id } ~client_ip ~router ~cleanup_tasks =
+let add_vif get_ts { Dao.ClientVif.domid; device_id } dns_client ~client_ip ~router ~cleanup_tasks qubesDB =
   Netback.make ~domid ~device_id >>= fun backend ->
   Log.info (fun f -> f "Client %d (IP: %s) ready" domid (Ipaddr.V4.to_string client_ip));
   ClientEth.connect backend >>= fun eth ->
@@ -83,28 +86,59 @@ let add_vif get_ts { Dao.ClientVif.domid; device_id } ~client_ip ~router ~cleanu
   let client_eth = router.Router.client_eth in
   let gateway_ip = Client_eth.client_gw client_eth in
   let iface = new client_iface eth ~domid ~gateway_ip ~client_ip client_mac in
+  (* update the rules whenever QubesDB notices a change for this IP *)
+  let qubesdb_updater =
+    Lwt.catch
+      (fun () ->
+        let rec update current_db current_rules =
+          Qubes.DB.got_new_commit qubesDB (Dao.db_root client_ip) current_db >>= fun new_db ->
+          iface#set_rules new_db;
+          let new_rules = iface#get_rules in
+          (if current_rules = new_rules then
+            Log.debug (fun m -> m "Rules did not change for %s" (Ipaddr.V4.to_string client_ip))
+          else begin
+            Log.debug (fun m -> m "New firewall rules for %s@.%a"
+                        (Ipaddr.V4.to_string client_ip)
+                        Fmt.(list ~sep:(unit "@.") Pf_qubes.Parse_qubes.pp_rule) new_rules);
+            (* empty NAT table if rules are updated: they might deny old connections *)
+            My_nat.remove_connections router.Router.nat router.Router.ports client_ip;
+          end);
+          update new_db new_rules
+        in
+        update Qubes.DB.KeyMap.empty [])
+      (function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e)
+  in
+  Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel qubesdb_updater);
   Router.add_client router iface >>= fun () ->
   Cleanup.on_cleanup cleanup_tasks (fun () -> Router.remove_client router iface);
   let fixed_arp = Client_eth.ARP.create ~net:client_eth iface in
   let fragment_cache = ref (Fragments.Cache.empty (256 * 1024)) in
+  let listener =
+    Lwt.catch
+      (fun () ->
         Netback.listen backend ~header_size:Ethernet_wire.sizeof_ethernet (fun frame ->
           match Ethernet_packet.Unmarshal.of_cstruct frame with
           | Error err -> Log.warn (fun f -> f "Invalid Ethernet frame: %s" err); Lwt.return_unit
           | Ok (eth, payload) ->
               match eth.Ethernet_packet.ethertype with
               | `ARP -> input_arp ~fixed_arp ~iface payload
-        | `IPv4 -> input_ipv4 get_ts fragment_cache ~iface ~router payload
+              | `IPv4 -> input_ipv4 get_ts fragment_cache ~iface ~router dns_client payload
               | `IPv6 -> Lwt.return_unit (* TODO: oh no! *)
         )
-  >|= or_raise "Listen on client interface" Netback.pp_error
+        >|= or_raise "Listen on client interface" Netback.pp_error)
+      (function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e)
+  in
+  Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel listener);
+  Lwt.pick [ qubesdb_updater ; listener ]
 
 (** A new client VM has been found in XenStore. Find its interface and connect to it. *)
-let add_client get_ts ~router vif client_ip =
+let add_client get_ts dns_client ~router vif client_ip qubesDB =
   let cleanup_tasks = Cleanup.create () in
-  Log.info (fun f -> f "add client vif %a with IP %a" Dao.ClientVif.pp vif Ipaddr.V4.pp client_ip);
+  Log.info (fun f -> f "add client vif %a with IP %a"
+               Dao.ClientVif.pp vif Ipaddr.V4.pp client_ip);
   Lwt.async (fun () ->
       Lwt.catch (fun () ->
-          add_vif get_ts vif ~client_ip ~router ~cleanup_tasks
+          add_vif get_ts vif dns_client ~client_ip ~router ~cleanup_tasks qubesDB
         )
         (fun ex ->
            Log.warn (fun f -> f "Error with client %a: %s"
@@ -115,7 +149,7 @@ let add_client get_ts ~router vif client_ip =
   cleanup_tasks
 
 (** Watch XenStore for notifications of new clients. *)
-let listen get_ts router =
+let listen get_ts dns_client qubesDB router =
   Dao.watch_clients (fun new_set ->
     (* Check for removed clients *)
     !clients |> Dao.VifMap.iter (fun key cleanup ->
@@ -128,7 +162,8 @@ let listen get_ts router =
     (* Check for added clients *)
     new_set |> Dao.VifMap.iter (fun key ip_addr ->
       if not (Dao.VifMap.mem key !clients) then (
-        let cleanup = add_client get_ts ~router key ip_addr in
+        let cleanup = add_client get_ts dns_client ~router key ip_addr qubesDB in
+        Log.debug (fun f -> f "client %a arrived" Dao.ClientVif.pp key);
         clients := !clients |> Dao.VifMap.add key cleanup
       )
     )

client_net.mli

@@ -3,8 +3,10 @@
 
 (** Handling client VMs. *)
 
-val listen : (unit -> int64) -> Router.t -> 'a Lwt.t
+val listen : (unit -> int64) ->
-(** [listen get_timestamp router] is a thread that watches for clients being
+  ([ `host ] Domain_name.t -> (int32 * Dns.Rr_map.Ipv4_set.t, [> `Msg of string ]) result Lwt.t) ->
-    added to and removed from XenStore. Clients are connected to the client
+  Qubes.DB.t -> Router.t -> 'a Lwt.t
-    network and packets are sent via [router]. We ensure the source IP address
+(** [listen get_timestamp resolver db router] is a thread that watches for clients being added to and
-    is correct before routing a packet. *)
+    removed from XenStore. Clients are connected to the client network and
+    packets are sent via [router]. We ensure the source IP address is correct
+    before routing a packet. *)

config.ml

@@ -30,13 +30,15 @@ let main =
       package "netchannel" ~min:"1.11.0";
       package "mirage-net-xen";
       package "ipaddr" ~min:"4.0.0";
-      package "mirage-qubes" ~min:"0.8.0";
+      package "mirage-qubes" ~min:"0.8.2";
-      package "mirage-nat" ~min:"2.1.0";
+      package "mirage-nat" ~min:"2.2.1";
       package "mirage-logs";
       package "mirage-xen" ~min:"5.0.0";
+      package ~min:"4.5.0" "dns-client";
+      package "pf-qubes";
     ]
-    "Unikernel.Main" (mclock @-> job)
+    "Unikernel.Main" (random @-> mclock @-> job)
 
 let () =
-  register "qubes-firewall" [main $ default_monotonic_clock]
+  register "qubes-firewall" [main $ default_random $ default_monotonic_clock]
     ~argv:no_argv

dao.ml

@@ -33,6 +33,38 @@ let directory ~handle dir =
   | [""] -> []      (* XenStore client bug *)
   | items -> items
 
+let db_root client_ip =
+  "/qubes-firewall/" ^ (Ipaddr.V4.to_string client_ip)
+
+let read_rules rules client_ip =
+  let root = db_root client_ip in
+  let rec get_rule n l : (Pf_qubes.Parse_qubes.rule list, string) result =
+    let pattern = root ^ "/" ^ Printf.sprintf "%04d" n in
+    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);
+      Ok (List.rev l)
+    | Some rule ->
+      Log.debug (fun f -> f "rule %d: %s" n rule);
+      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
+      | 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);
+    [ Pf_qubes.Parse_qubes.({action = Drop;
+                             proto = None;
+                             specialtarget = None;
+                             dst = `any;
+                             dstports = None;
+                             icmp_type = None;
+                             number = 0;})]
+
 let vifs ~handle domid =
   match String.to_int domid with
   | None -> Log.err (fun f -> f "Invalid domid %S" domid); Lwt.return []

dao.mli

@@ -30,4 +30,11 @@ val read_network_config : Qubes.DB.t -> network_config Lwt.t
 (** [read_network_config db] fetches the configuration from QubesDB.
     If it isn't 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. *)
+
+val read_rules : string Qubes.DB.KeyMap.t -> Ipaddr.V4.t -> Pf_qubes.Parse_qubes.rule list
+(** [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 set_iptables_error : Qubes.DB.t -> string -> unit Lwt.t

diagrams/components.txt

@@ -1,6 +1,12 @@
-                                  +----------+
+                              +--------------------+
-                                  |  rules   |
+                              | rules from QubesDB |
-                                  +----------+
+                              +--------------------+
+                                        ^
+                          if-not-in-nat | then check
+                                        |
+                                  +-----------+
+                                  | nat-table |
+                                  +-----------+
                                         ^
                                         |checks
                                         |

firewall.ml

@@ -16,7 +16,7 @@ let transmit_ipv4 packet iface =
        iface#writev `IPv4 (fun b ->
            match Nat_packet.into_cstruct packet b with
            | Error e ->
-             Log.warn (fun f -> f "Failed to NAT packet to %a: %a"
+             Log.warn (fun f -> f "Failed to write packet to %a: %a"
                           Ipaddr.V4.pp iface#other_ip
                           Nat_packet.pp_error e);
              0
@@ -38,72 +38,6 @@ let forward_ipv4 t packet =
   | Some iface -> transmit_ipv4 packet iface
   | None -> Lwt.return_unit
 
-(* Packet classification *)
-
-let parse_ips ips = List.map (fun (ip_str, id) -> (Ipaddr.of_string_exn ip_str, id)) ips
-
-let clients = parse_ips Rules.clients
-let externals = parse_ips Rules.externals
-
-let resolve_client client =
-  `Client (try List.assoc (Ipaddr.V4 client#other_ip) clients with Not_found -> `Unknown)
-
-let resolve_host = function
-  | `Client c -> resolve_client c
-  | `External ip -> `External (try List.assoc ip externals with Not_found -> `Unknown)
-  | (`Firewall | `NetVM) as x -> x
-
-let classify ~src ~dst packet =
-  let `IPv4 (_ip, transport) = packet in
-  let proto =
-    match transport with
-    | `TCP ({Tcp.Tcp_packet.src_port; dst_port; _}, _) -> `TCP {sport = src_port; dport = dst_port}
-    | `UDP ({Udp_packet.src_port; dst_port; _}, _)     -> `UDP {sport = src_port; dport = dst_port}
-    | `ICMP _                                          -> `ICMP
-  in
-  Some {
-    packet;
-    src;
-    dst;
-    proto;
-  }
-
-let pp_ports fmt {sport; dport} =
-  Format.fprintf fmt "sport=%d dport=%d" sport dport
-
-let pp_host fmt = function
-  | `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
-  | `Firewall -> Format.pp_print_string fmt "firewall"
-
-let pp_proto fmt = function
-  | `UDP ports -> Format.fprintf fmt "UDP(%a)" pp_ports ports
-  | `TCP ports -> Format.fprintf fmt "TCP(%a)" pp_ports ports
-  | `ICMP -> Format.pp_print_string fmt "ICMP"
-  | `Unknown -> Format.pp_print_string fmt "UnknownProtocol"
-
-let pp_packet t fmt {src = _; dst = _; proto; packet} =
-  let `IPv4 (ip, _transport) = packet in
-  let src = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.src) in
-  let dst = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in
-  Format.fprintf fmt "[src=%a dst=%a proto=%a]"
-    pp_host src
-    pp_host dst
-    pp_proto proto
-
-let pp_transport_headers 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_header f = function
-  | `IPv4 (ip, transport) ->
-    Fmt.pf f "%a %a"
-      Ipv4_packet.pp ip
-      pp_transport_headers transport
-
 (* NAT *)
 
 let translate t packet =
@@ -111,50 +45,53 @@ let translate t packet =
 
 (* Add a NAT rule for the endpoints in this frame, via a random port on the firewall. *)
 let add_nat_and_forward_ipv4 t packet =
-  let xl_host = t.Router.uplink#my_ip in
+  let open Router in
-  My_nat.add_nat_rule_and_translate t.Router.nat ~xl_host `NAT packet >>= function
+  let xl_host = t.uplink#my_ip in
+  My_nat.add_nat_rule_and_translate t.nat t.ports ~xl_host `NAT packet >>= function
   | Ok packet -> forward_ipv4 t packet
   | Error e ->
-    Log.warn (fun f -> f "Failed to add NAT rewrite rule: %s (%a)" e pp_header packet);
+    Log.warn (fun f -> f "Failed to add NAT rewrite rule: %s (%a)" e Nat_packet.pp packet);
     Lwt.return_unit
 
 (* Add a NAT rule to redirect this conversation to [host:port] instead of us. *)
 let nat_to t ~host ~port packet =
-  match Router.resolve t host with
+  let open Router in
+  match resolve t host with
   | Ipaddr.V6 _ -> Log.warn (fun f -> f "Cannot NAT with IPv6"); Lwt.return_unit
   | Ipaddr.V4 target ->
-    let xl_host = t.Router.uplink#my_ip in
+    let xl_host = t.uplink#my_ip in
-    My_nat.add_nat_rule_and_translate t.Router.nat ~xl_host (`Redirect (target, port)) packet >>= function
+    My_nat.add_nat_rule_and_translate t.nat t.ports ~xl_host (`Redirect (target, port)) packet >>= function
     | Ok packet -> forward_ipv4 t packet
     | Error e ->
-      Log.warn (fun f -> f "Failed to add NAT redirect rule: %s (%a)" e pp_header packet);
+      Log.warn (fun f -> f "Failed to add NAT redirect rule: %s (%a)" e Nat_packet.pp packet);
       Lwt.return_unit
 
-(* Handle incoming packets *)
+let apply_rules t (rules : ('a, 'b) Packet.t -> Packet.action Lwt.t) ~dst (annotated_packet : ('a, 'b) Packet.t) : unit Lwt.t =
-
+  let packet = to_mirage_nat_packet annotated_packet in
-let apply_rules t rules ~dst info =
+  rules annotated_packet >>= fun action ->
-  let packet = info.packet in
+  match action, dst with
-  match rules info, dst with
   | `Accept, `Client client_link -> transmit_ipv4 packet client_link
   | `Accept, (`External _ | `NetVM) -> transmit_ipv4 packet t.Router.uplink
   | `Accept, `Firewall ->
-      Log.warn (fun f -> f "Bad rule: firewall can't accept packets %a" (pp_packet t) info);
+      Log.warn (fun f -> f "Bad rule: firewall can't accept packets %a" Nat_packet.pp packet);
       Lwt.return_unit
-  | `NAT, _ -> add_nat_and_forward_ipv4 t packet
+  | `NAT, _ ->
+      Log.debug (fun f -> f "adding NAT rule for %a" Nat_packet.pp packet);
+      add_nat_and_forward_ipv4 t packet
   | `NAT_to (host, port), _ -> nat_to t packet ~host ~port
   | `Drop reason, _ ->
-      Log.info (fun f -> f "Dropped packet (%s) %a" reason (pp_packet t) info);
+      Log.debug (fun f -> f "Dropped packet (%s) %a" reason Nat_packet.pp packet);
       Lwt.return_unit
 
 let handle_low_memory t =
   match Memory_pressure.status () with
   | `Memory_critical -> (* TODO: should happen before copying and async *)
       Log.warn (fun f -> f "Memory low - dropping packet and resetting NAT table");
-      My_nat.reset t.Router.nat >|= fun () ->
+      My_nat.reset t.Router.nat t.Router.ports >|= fun () ->
       `Memory_critical
   | `Ok -> Lwt.return `Ok
 
-let ipv4_from_client t ~src packet =
+let ipv4_from_client resolver t ~src packet =
   handle_low_memory t >>= function
   | `Memory_critical -> Lwt.return_unit
   | `Ok ->
@@ -165,9 +102,9 @@ let ipv4_from_client t ~src packet =
   (* No existing NAT entry. Check the firewall rules. *)
   let `IPv4 (ip, _transport) = packet in
   let dst = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in
-  match classify ~src:(resolve_client src) ~dst:(resolve_host dst) packet with
+  match of_mirage_nat_packet ~src:(`Client src) ~dst packet with
   | None -> Lwt.return_unit
-  | Some info -> apply_rules t Rules.from_client ~dst info
+  | Some firewall_packet -> apply_rules t (Rules.from_client resolver) ~dst firewall_packet
 
 let ipv4_from_netvm t packet =
   handle_low_memory t >>= function
@@ -176,15 +113,17 @@ let ipv4_from_netvm t packet =
   let `IPv4 (ip, _transport) = packet in
   let src = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.src) in
   let dst = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in
-  match classify ~src ~dst:(resolve_host dst) packet with
+  match Packet.of_mirage_nat_packet ~src ~dst packet with
   | None -> Lwt.return_unit
-  | Some info ->
+  | Some _ ->
   match src with
   | `Client _ | `Firewall ->
-    Log.warn (fun f -> f "Frame from NetVM has internal source IP address! %a" (pp_packet t) info);
+    Log.warn (fun f -> f "Frame from NetVM has internal source IP address! %a" Nat_packet.pp packet);
     Lwt.return_unit
   | `External _ | `NetVM as src ->
   translate t packet >>= function
   | Some frame -> forward_ipv4 t frame
   | None ->
-    apply_rules t Rules.from_netvm ~dst { info with src }
+    match Packet.of_mirage_nat_packet ~src ~dst packet with
+    | None -> Lwt.return_unit
+    | Some packet -> apply_rules t Rules.from_netvm ~dst packet

firewall.mli

@@ -6,6 +6,8 @@
 val ipv4_from_netvm : Router.t -> Nat_packet.t -> unit Lwt.t
 (** Handle a packet from the outside world (this module will validate the source IP). *)
 
-val ipv4_from_client : Router.t -> src:Fw_utils.client_link -> Nat_packet.t -> unit Lwt.t
+(* TODO the function type is a workaround, rework the module dependencies / functors to get rid of it *)
+val ipv4_from_client : ([ `host ] Domain_name.t -> (int32 * Dns.Rr_map.Ipv4_set.t, [> `Msg of string ]) result Lwt.t) ->
+  Router.t -> src:Fw_utils.client_link -> Nat_packet.t -> unit Lwt.t
 (** Handle a packet from a client. Caller must check the source IP matches the client's
     before calling this. *)

fw_utils.ml

@@ -31,6 +31,8 @@ class type client_link = object
   inherit interface
   method other_mac : Macaddr.t
   method log_header : string  (* For log messages *)
+  method get_rules: Pf_qubes.Parse_qubes.rule list
+  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. *)

my_dns.ml

@@ -0,0 +1,57 @@
+open Lwt.Infix
+
+module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) = struct
+  type +'a io = 'a Lwt.t
+  type io_addr = Ipaddr.V4.t * int
+  type ns_addr = [ `TCP | `UDP ] * io_addr
+  type stack = Router.t * (src_port:int -> dst:Ipaddr.V4.t -> dst_port:int -> Cstruct.t -> (unit, [ `Msg of string ]) result Lwt.t) * (Udp_packet.t * Cstruct.t) Lwt_mvar.t
+
+  type t = {
+    nameserver : ns_addr ;
+    stack : stack ;
+    timeout_ns : int64 ;
+  }
+  type context = { t : t ; timeout_ns : int64 ref; mutable src_port : int }
+
+  let nameserver t = t.nameserver
+  let rng = R.generate ?g:None
+  let clock = C.elapsed_ns
+
+  let create ?(nameserver = `UDP, (Ipaddr.V4.of_string_exn "91.239.100.100", 53)) ~timeout stack =
+    { nameserver ; stack ; timeout_ns = timeout }
+
+  let with_timeout ctx f =
+    let timeout = OS.Time.sleep_ns !(ctx.timeout_ns) >|= fun () -> Error (`Msg "DNS request timeout") in
+    let start = clock () in
+    Lwt.pick [ f ; timeout ] >|= fun result ->
+    let stop = clock () in
+    ctx.timeout_ns := Int64.sub !(ctx.timeout_ns) (Int64.sub stop start);
+    result
+
+  let connect ?nameserver:_ (t : t) = Lwt.return (Ok { t ; timeout_ns = ref t.timeout_ns ; src_port = 0 })
+
+  let send (ctx : context) buf : (unit, [> `Msg of string ]) result Lwt.t =
+    let open Router in
+    let open My_nat in
+    let dst, dst_port = snd ctx.t.nameserver in
+    let router, send_udp, _ = ctx.t.stack in
+    let src_port = Ports.pick_free_port ~consult:router.ports.nat_udp router.ports.dns_udp in
+    ctx.src_port <- src_port;
+    with_timeout ctx (send_udp ~src_port ~dst ~dst_port buf >|= Rresult.R.open_error_msg)
+
+  let recv ctx =
+    let open Router in
+    let open My_nat in
+    let router, _, answers = ctx.t.stack in
+    with_timeout ctx
+      (Lwt_mvar.take answers >|= fun (_, dns_response) -> Ok dns_response) >|= fun result ->
+    router.ports.dns_udp := Ports.remove ctx.src_port !(router.ports.dns_udp);
+    result
+
+  let close _ = Lwt.return_unit
+
+  let bind = Lwt.bind
+
+  let lift = Lwt.return
+end
+

my_nat.ml

@@ -11,6 +11,20 @@ type action = [
   | `Redirect of Mirage_nat.endpoint
 ]
 
+type ports = {
+  nat_tcp : Ports.t ref;
+  nat_udp : Ports.t ref;
+  nat_icmp : Ports.t ref;
+  dns_udp : Ports.t ref;
+}
+
+let empty_ports () =
+  let nat_tcp = ref Ports.empty in
+  let nat_udp = ref Ports.empty in
+  let nat_icmp = ref Ports.empty in
+  let dns_udp = ref Ports.empty in
+  { nat_tcp ; nat_udp ; nat_icmp ; dns_udp }
+
 module Nat = Mirage_nat_lru
 
 type t = {
@@ -33,13 +47,23 @@ let translate t packet =
     None
   | Ok packet -> Some packet
 
-let random_user_port () =
+let pick_free_port ~nat_ports ~dns_ports =
-  1024 + Random.int (0xffff - 1024)
+  Ports.pick_free_port ~consult:dns_ports nat_ports
 
-let reset t =
+(* just clears the nat ports, dns ports stay as is *)
+let reset t ports =
+  ports.nat_tcp := Ports.empty;
+  ports.nat_udp := Ports.empty;
+  ports.nat_icmp := Ports.empty;
   Nat.reset t.table
 
-let add_nat_rule_and_translate t ~xl_host action packet =
+let remove_connections t ports ip =
+  let freed_ports = Nat.remove_connections t.table ip in
+  ports.nat_tcp := Ports.diff !(ports.nat_tcp) (Ports.of_list freed_ports.Mirage_nat.tcp);
+  ports.nat_udp := Ports.diff !(ports.nat_udp) (Ports.of_list freed_ports.Mirage_nat.udp);
+  ports.nat_icmp := Ports.diff !(ports.nat_icmp) (Ports.of_list freed_ports.Mirage_nat.icmp)
+
+let add_nat_rule_and_translate t ports ~xl_host action packet =
   let apply_action xl_port =
     Lwt.catch (fun () ->
         Nat.add t.table packet (xl_host, xl_port) action
@@ -50,19 +74,25 @@ let add_nat_rule_and_translate t ~xl_host action packet =
       )
   in
   let rec aux ~retries =
-    let xl_port = random_user_port () in
+    let nat_ports, dns_ports =
+      match packet with
+      | `IPv4 (_, `TCP _) -> ports.nat_tcp, ref Ports.empty
+      | `IPv4 (_, `UDP _) -> ports.nat_udp, ports.dns_udp
+      | `IPv4 (_, `ICMP _) -> ports.nat_icmp, ref Ports.empty
+    in
+    let xl_port = pick_free_port ~nat_ports ~dns_ports in
     apply_action xl_port >>= function
     | Error `Out_of_memory ->
       (* Because hash tables resize in big steps, this can happen even if we have a fair
          chunk of free memory. *)
       Log.warn (fun f -> f "Out_of_memory adding NAT rule. Dropping NAT table...");
-      Nat.reset t.table >>= fun () ->
+      reset t ports >>= fun () ->
       aux ~retries:(retries - 1)
     | Error `Overlap when retries < 0 -> Lwt.return (Error "Too many retries")
     | Error `Overlap ->
       if retries = 0 then (
         Log.warn (fun f -> f "Failed to find a free port; resetting NAT table");
-        Nat.reset t.table >>= fun () ->
+        reset t ports >>= fun () ->
         aux ~retries:(retries - 1)
       ) else (
         aux ~retries:(retries - 1)

my_nat.mli

@@ -3,6 +3,15 @@
 
 (* Abstract over NAT interface (todo: remove this) *)
 
+type ports = private {
+  nat_tcp : Ports.t ref;
+  nat_udp : Ports.t ref;
+  nat_icmp : Ports.t ref;
+  dns_udp : Ports.t ref;
+}
+
+val empty_ports : unit -> ports
+
 type t
 
 type action = [
@@ -11,7 +20,8 @@ type action = [
 ]
 
 val create : max_entries:int -> t Lwt.t
-val reset : t -> unit Lwt.t
+val reset : t -> ports -> unit Lwt.t
+val remove_connections : t -> ports -> Ipaddr.V4.t -> unit
 val translate : t -> Nat_packet.t -> Nat_packet.t option Lwt.t
-val add_nat_rule_and_translate : t -> xl_host:Ipaddr.V4.t ->
+val add_nat_rule_and_translate : t -> ports ->
-  action -> Nat_packet.t -> (Nat_packet.t, string) result Lwt.t
+  xl_host:Ipaddr.V4.t -> action -> Nat_packet.t -> (Nat_packet.t, string) result Lwt.t

packet.ml

@@ -5,33 +5,60 @@ open Fw_utils
 
 type port = int
 
-type ports = {
-  sport : port; (* Source port *)
-  dport : port; (* Destination *)
-}
-
 type host =
   [ `Client of client_link | `Firewall | `NetVM | `External of Ipaddr.t ]
 
-type ('src, 'dst) info = {
+type transport_header = [`TCP of Tcp.Tcp_packet.t
-  packet : Nat_packet.t;
+                        |`UDP of Udp_packet.t
+                        |`ICMP of Icmpv4_packet.t]
+
+type ('src, 'dst) t = {
+  ipv4_header : Ipv4_packet.t;
+  transport_header : transport_header;
+  transport_payload : Cstruct.t;
   src : 'src;
   dst : 'dst;
-  proto : [ `UDP of ports | `TCP of ports | `ICMP | `Unknown ];
 }
+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
 
-(* The first message in a TCP connection has SYN set and ACK clear. *)
+let pp_host fmt = function
-let is_tcp_start = function
+  | `Client c -> Ipaddr.V4.pp fmt (c#other_ip)
-  | `IPv4 (_ip, `TCP (hdr, _body)) -> Tcp.Tcp_packet.(hdr.syn && not hdr.ack)
+  | `Unknown_client ip -> Format.fprintf fmt "unknown-client(%a)" Ipaddr.pp ip
-  | _ -> false
+  | `NetVM -> Format.pp_print_string fmt "net-vm"
+  | `External ip -> Format.fprintf fmt "external(%a)" Ipaddr.pp ip
+  | `Firewall -> Format.pp_print_string fmt "firewall(client-gw)"
 
-(* The possible actions we can take for a packet: *)
+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)))
+  | `UDP h  -> `IPv4 (t.ipv4_header, (`UDP (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 transport_header, transport_payload = match ipv4_payload with
+    | `TCP (h, p) -> `TCP h, p
+    | `UDP (h, p) -> `UDP h, p
+    | `ICMP (h, p) -> `ICMP h, p
+  in
+  Some {
+    ipv4_header;
+    transport_header;
+    transport_payload;
+    src;
+    dst;
+  }
+
+(* possible actions to take for a packet: *)
 type action = [
-  | `Accept (* Send the packet to its destination. *)
+  | `Accept (* Send to destination, unmodified. *)
-  | `NAT    (* Rewrite the packet's source field so packet appears to
+  | `NAT    (* Rewrite source field to the firewall's IP, with a fresh source port.
-               have come from the firewall, via an unused port.
+               Also, add translation rules for future traffic in both directions,
-               Also, add NAT rules so related packets will be translated accordingly. *)
+               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
                               destination fields so it will be sent to [host:port]. *)
-  | `Drop of string (* Drop the packet and log the given reason. *)
+  | `Drop of string (* Drop packet for this reason. *)
 ]

packet.mli

@@ -0,0 +1,39 @@
+type port = int
+
+type host =
+  [ `Client of Fw_utils.client_link (** an IP address on the private network *)
+  | `Firewall (** the firewall's IP on the private network *)
+  | `NetVM (** the IP of the firewall's default route *)
+  | `External of Ipaddr.t (** an IP on the public network *)
+  ]
+
+type transport_header = [`TCP of Tcp.Tcp_packet.t
+                        |`UDP of Udp_packet.t
+                        |`ICMP of Icmpv4_packet.t]
+
+type ('src, 'dst) t = {
+  ipv4_header : Ipv4_packet.t;
+  transport_header : transport_header;
+  transport_payload : Cstruct.t;
+  src : 'src;
+  dst : 'dst;
+}
+
+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 = [
+  | `Accept (* Send to destination, unmodified. *)
+  | `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
+                              destination fields so it will be sent to [host:port]. *)
+  | `Drop of string (* Drop packet for this reason. *)
+]

ports.ml

@@ -0,0 +1,16 @@
+module Set = Set.Make(struct
+  type t = int
+  let compare a b = compare a b
+end)
+
+include Set
+
+let rec pick_free_port ?(retries = 10) ~consult add_to =
+  let p = 1024 + Random.int (0xffff - 1024) in
+  if (mem p !consult || mem p !add_to) && retries <> 0
+  then pick_free_port ~retries:(retries - 1) ~consult add_to
+  else
+    begin
+      add_to := add p !add_to;
+      p
+    end

router.ml

@@ -9,10 +9,13 @@ type t = {
   client_eth : Client_eth.t;
   nat : My_nat.t;
   uplink : interface;
+  (* NOTE: do not try to make this pure, it relies on mvars / side effects *)
+  ports : My_nat.ports;
 }
 
 let create ~client_eth ~uplink ~nat =
-  { client_eth; nat; uplink }
+  let ports = My_nat.empty_ports () in
+  { client_eth; nat; uplink; ports }
 
 let target t buf =
   let dst_ip = buf.Ipv4_packet.dst in

router.mli

@@ -9,15 +9,15 @@ type t = private {
   client_eth : Client_eth.t;
   nat : My_nat.t;
   uplink : interface;
+  ports : My_nat.ports;
 }
-(** A routing table. *)
 
 val create :
   client_eth:Client_eth.t ->
   uplink:interface ->
   nat:My_nat.t ->
   t
-(** [create ~client_eth ~uplink] is a new routing table
+(** [create ~client_eth ~uplink ~nat] is a new routing table
     that routes packets outside of [client_eth] via [uplink]. *)
 
 val target : t -> Ipv4_packet.t -> interface option

rules.ml

@@ -1,62 +1,110 @@
 (* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
    See the README file for details. *)
 
-(** Put your firewall rules in this file. *)
+(** This module applies firewall rules from QubesDB. *)
 
-open Packet   (* Allow us to use definitions in packet.ml *)
+open Packet
+open Lwt.Infix
+module Q = Pf_qubes.Parse_qubes
 
-(* List your AppVM IP addresses here if you want to match on them in the rules below.
+let src = Logs.Src.create "rules" ~doc:"Firewall rules"
-   Any client not listed here will appear as [`Client `Unknown]. *)
+module Log = (val Logs.src_log src : Logs.LOG)
-let clients = [
+
-  (*
+(* the upstream NetVM will redirect TCP and UDP port 53 traffic with
-  "10.137.0.12", `Dev;
+   these destination IPs to its upstream nameserver. *)
-  "10.137.0.14", `Untrusted;
+let default_dns_servers = [
-  *)
+  Ipaddr.V4.of_string_exn "10.139.1.1";
+  Ipaddr.V4.of_string_exn "10.139.1.2";
 ]
+let dns_port = 53
 
-(* List your external (non-AppVM) IP addresses here if you want to match on them in the rules below.
+module Classifier = struct
-   Any external machine not listed here will appear as [`External `Unknown]. *)
-let externals = [
-  (*
-  "8.8.8.8", `GoogleDNS;
-  *)
-]
 
-(* OCaml normally warns if you don't match all fields, but that's OK here. *)
+  let matches_port dstports (port : int) = match dstports with
-[@@@ocaml.warning "-9"]
+    | None -> true
+    | Some (Q.Range_inclusive (min, max)) -> min <= port && port <= max
 
-(** This function decides what to do with a packet from a client VM.
+  let matches_proto rule packet = match rule.Q.proto, rule.Q.specialtarget with
+    | None, None -> true
+    | None, Some `dns when List.mem packet.ipv4_header.Ipv4_packet.dst default_dns_servers -> begin
+      (* specialtarget=dns applies only to the specialtarget destination IPs, and
+         specialtarget=dns is also implicitly tcp/udp port 53 *)
+      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
+      end
+   (* 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
+      | `tcp, `TCP header -> matches_port rule.Q.dstports header.Tcp.Tcp_packet.dst_port
+      | `udp, `UDP header -> matches_port rule.Q.dstports header.Udp_packet.dst_port
+      | `icmp, `ICMP header ->
+      begin
+        match rule.Q.icmp_type with
+        | None -> true
+        | Some rule_icmp_type ->
+          0 = compare rule_icmp_type @@ Icmpv4_wire.ty_to_int header.Icmpv4_packet.ty
+      end
+      | _, _ -> false
 
-    It takes as input an argument [info] (of type [Packet.info]) describing the
+  let matches_dest dns_client rule packet =
-    packet, and returns an action (of type [Packet.action]) to perform.
+    let ip = packet.ipv4_header.Ipv4_packet.dst in
+    match rule.Q.dst with
+    | `any ->  Lwt.return @@ `Match rule
+    | `hosts subnet ->
+      Lwt.return @@ if (Ipaddr.Prefix.mem Ipaddr.(V4 ip) subnet) then `Match rule else `No_match
+    | `dnsname name ->
+      Log.debug (fun f -> f "Resolving %a" Domain_name.pp name);
+      dns_client name >|= function
+      | Ok (_ttl, found_ips) ->
+        if Dns.Rr_map.Ipv4_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 *)
 
-    See packet.ml for the definitions of [info] and [action].
+end
 
-    Note: If the packet matched an existing NAT rule then this isn't called. *)
+let find_first_match dns_client packet acc rule =
-let from_client (info : ([`Client of _], _) Packet.info) : Packet.action =
+  match acc with
-  match info with
+  | `No_match ->
-  (* Examples (add your own rules here):
+    if Classifier.matches_proto rule packet
+    then Classifier.matches_dest dns_client rule packet
+    else Lwt.return `No_match
+  | q -> Lwt.return q
 
-     1. Allows Dev to send SSH packets to Untrusted.
+(* Does the packet match our rules? *)
-        Note: responses are not covered by this!
+let classify_client_packet dns_client (packet : ([`Client of Fw_utils.client_link], _) Packet.t)  =
-     2. Allows Untrusted to reply to Dev.
+  let (`Client client_link) = packet.src in
-     3. Blocks an external site.
+  let rules = client_link#get_rules in
+  Lwt_list.fold_left_s (find_first_match dns_client packet) `No_match rules >|= function
+  | `No_match -> `Drop "No matching rule; assuming default drop"
+  | `Match {Q.action = Q.Accept; _} -> `Accept
+  | `Match ({Q.action = Q.Drop; _} as rule) ->
+    `Drop (Format.asprintf "rule number %a explicitly drops this packet" Q.pp_rule rule)
 
-     In all cases, make sure you've added the VM name to [clients] or [externals] above, or it won't
+let translate_accepted_packets dns_client packet =
-     match anything! *)
+  classify_client_packet dns_client packet >|= function
-  (*
+  | `Accept -> `NAT
-  | { src = `Client `Dev; dst = `Client `Untrusted; proto = `TCP { dport = 22 } } -> `Accept
+  | `Drop s -> `Drop s
-  | { src = `Client `Untrusted; dst = `Client `Dev; proto = `TCP _; packet }
-                                        when not (is_tcp_start packet) -> `Accept
-  | { dst = `External `GoogleDNS } -> `Drop "block Google DNS"
-  *)
-  | { dst = (`External _ | `NetVM) } -> `NAT
-  | { dst = `Firewall; proto = `UDP { dport = 53 } } -> `NAT_to (`NetVM, 53)
-  | { dst = `Firewall } -> `Drop "packet addressed to firewall itself"
-  | { dst = `Client _ } -> `Drop "prevent communication between client VMs by default"
 
-(** Decide what to do with a packet received from the outside world.
+(** Packets from the private interface that don't match any NAT table entry are being checked against the fw rules here *)
-    Note: If the packet matched an existing NAT rule then this isn't called. *)
+let from_client dns_client (packet : ([`Client of Fw_utils.client_link], _) Packet.t) : Packet.action Lwt.t =
-let from_netvm (info : ([`NetVM | `External of _], _) Packet.info) : Packet.action =
+  match packet with
-  match info with
+  | { dst = `Firewall; transport_header = `UDP header; _ } ->
-  | _ -> `Drop "drop by default"
+    if header.Udp_packet.dst_port = dns_port
+    then Lwt.return @@ `NAT_to (`NetVM, dns_port)
+    else Lwt.return @@ `Drop "packet addressed to client gateway"
+  | { dst = `External _ ; _ } | { dst = `NetVM; _ } -> translate_accepted_packets dns_client packet
+  | { dst = `Firewall ; _ } -> Lwt.return @@ `Drop "packet addressed to firewall itself"
+  | { dst = `Client _ ; _ } -> classify_client_packet dns_client 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 *)
+let from_netvm (_packet : ([`NetVM | `External of _], _) Packet.t) : Packet.action Lwt.t =
+  Lwt.return @@ `Drop "drop by default"

test/config.ml

@@ -0,0 +1,27 @@
+open Mirage
+
+let pin = "git+https://github.com/roburio/alcotest.git#mirage"
+
+let packages = [
+  package "ethernet";
+  package "arp";
+  package "arp-mirage";
+  package "ipaddr";
+  package "tcpip" ~sublibs:["stack-direct"; "icmpv4"; "ipv4"; "udp"; "tcp"];
+  package "mirage-qubes";
+  package "mirage-qubes-ipv4";
+  package "dns-client" ~sublibs:["mirage"];
+  package ~pin "alcotest";
+  package ~pin "alcotest-mirage";
+]
+
+let client =
+  foreign ~packages
+    "Unikernel.Client" @@ 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
+  register "http-fetch" job

test/test.sh

@@ -0,0 +1,138 @@
+#!/bin/bash
+function explain_commands {
+    echo "1) Set up test qubes:"
+echo "First, set up the test-mirage script from https://github.com/talex5/qubes-test-mirage.git"
+
+echo "Then, use `qubes-manager` to create two new AppVMs called `mirage-fw-test` and `fetchmotron`.
+You can make it standalone or not and use any template (it doesn't matter
+because unikernels already contain all their code and don't need to use a disk
+to boot)."
+
+echo "Next, still in dom0, create a new `mirage-fw-test` and `fetchmotron` kernels, with an empty `modules.img` and `vmlinuz` and a compressed empty file for the initramfs, and then set that as the kernel for the new VMs:
+
+    mkdir /var/lib/qubes/vm-kernels/mirage-fw-test
+    cd /var/lib/qubes/vm-kernels/mirage-fw-test
+    touch modules.img vmlinuz test-mirage-ok
+    cat /dev/null | gzip > initramfs
+    qvm-prefs -s mirage-fw-test kernel mirage-fw-test
+
+    mkdir /var/lib/qubes/vm-kernels/fetchmotron
+    cd /var/lib/qubes/vm-kernels/fetchmotron
+    touch modules.img vmlinuz test-mirage-ok
+    cat /dev/null | gzip > initramfs
+    qvm-prefs -s fetchmotron kernel fetchmotron
+"
+}
+
+function explain_service {
+echo "2) Set up rule update service:"
+echo "In dom0, make a new service:
+
+sudo bash
+echo /usr/local/bin/update-firewall > /etc/qubes-rpc/yomimono.updateFirewall
+
+Make a policy file for this service, YOUR_DEV_VM being the qube from which you build (e.g. ocamldev):
+
+cd /etc/qubes-rpc/policy
+cat << EOF >> yomimono.updateFirewall
+YOUR_DEV_VM dom0 allow
+
+copy the update-firewall script:
+
+cd /usr/local/bin
+qvm-run -p YOUR_DEV_VM 'cat /path/to/qubes-mirage-firewall/test/update-firewall.sh' > update-firewall
+chmod +x update-firewall
+
+Now, back to YOUR_DEV_VM. Let's test to change fetchmotron's firewall rules:
+
+qrexec-client-vm dom0 yomimono.updateFirewall"
+}
+
+function explain_upstream {
+echo "Also, start the test services on the upstream NetVM (which is available at 10.137.0.5 from the test unikernel).
+For the UDP and TCP reply services:
+Install nmap-ncat (to persist this package, install it in your sys-net template VM):
+
+sudo dnf install nmap-ncat
+
+Allow incoming traffic from local virtual interfaces on the appropriate ports,
+then run the services:
+
+sudo iptables -I INPUT -i vif+ -p udp --dport $udp_echo_port -j ACCEPT
+sudo iptables -I INPUT -i vif+ -p tcp --dport $tcp_echo_port_lower -j ACCEPT
+sudo iptables -I INPUT -i vif+ -p tcp --dport $tcp_echo_port_upper -j ACCEPT
+ncat -e /bin/cat -k -u -l $udp_echo_port &
+ncat -e /bin/cat -k -l $tcp_echo_port_lower &
+ncat -e /bin/cat -k -l $tcp_echo_port_upper &
+"
+}
+
+if ! [ -x "$(command -v test-mirage)" ]; then
+  echo 'Error: test-mirage is not installed.' >&2
+  explain_commands >&2
+  exit 1
+fi
+qrexec-client-vm dom0 yomimono.updateFirewall
+if [ $? -ne 0 ]; then
+  echo "Error: can't update firewall rules." >&2
+  explain_service >&2
+  exit 1
+fi
+echo_host=10.137.0.5
+udp_echo_port=1235
+tcp_echo_port_lower=6668
+tcp_echo_port_upper=6670
+
+# Pretest that checks if our echo servers work.
+# NOTE: we assume the dev qube has the same netvm as fetchmotron.
+# If yours is different, this test will fail (comment it out)
+function pretest {
+  protocol=$1
+  port=$2
+  if [ "$protocol" = "udp" ]; then
+    udp_arg="-u"
+  else
+    udp_arg=""
+  fi
+  reply=$(echo hi | nc $udp_arg $echo_host -w 1 $port)
+  if [ "$reply" != "hi" ]; then
+    echo "echo hi | nc $udp_arg $echo_host -w 1 $port"
+    echo "echo services not reachable at $protocol $echo_host:$port" >&2
+    explain_upstream >&2
+    exit 1
+  fi
+}
+
+pretest "udp" "$udp_echo_port"
+pretest "tcp" "$tcp_echo_port_lower"
+pretest "tcp" "$tcp_echo_port_upper"
+
+echo "We're gonna set up a unikernel for the mirage-fw-test qube"
+cd ..
+make clean && \
+#mirage configure -t xen -l "application:error,net-xen xenstore:error,firewall:debug,frameQ:debug,uplink:debug,rules:debug,udp:debug,ipv4:debug,fw-resolver:debug" && \
+mirage configure -t xen -l "net-xen xenstore:error,application:warning,qubes.db:warning" && \
+#mirage configure -t xen -l "*:debug" && \
+make depend && \
+make
+if [ $? -ne 0 ]; then
+  echo "Could not build unikernel for mirage-fw-test qube" >&2
+  exit 1
+fi
+cd test
+
+echo "We're gonna set up a unikernel for fetchmotron qube"
+make clean && \
+mirage configure -t qubes -l "net-xen frontend:error,firewall test:debug" && \
+#mirage configure -t qubes -l "*:error" && \
+make depend && \
+make
+if [ $? -ne 0 ]; then
+  echo "Could not build unikernel for fetchmotron qube" >&2
+  exit 1
+fi
+
+cd ..
+test-mirage qubes_firewall.xen mirage-fw-test &
+cd test
+test-mirage http_fetch.xen fetchmotron

test/unikernel.ml

@@ -0,0 +1,357 @@
+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
+ * things we can have in rule
+ * - action:
+    x accept (UDP fetch test)
+    x drop (TCP connect denied test)
+ * - proto:
+    x None (TCP connect denied test)
+    x TCP (TCP connect test)
+    x UDP (UDP fetch test)
+    x ICMP (ping test)
+ * - specialtarget:
+    x None (UDP fetch test, TCP connect denied test)
+    x DNS (TCP connect test, TCP connect denied test)
+ * - destination:
+    x Any (TCP connect denied test)
+    x Some ipv4 host (UDP fetch test)
+      Some ipv6 host (we can't do this right now)
+      Some hostname (need a bunch of DNS stuff for that)
+ * - destination ports:
+    x none (TCP connect denied test)
+    x range is one port (UDP fetch test)
+    x range has different ports in pair
+ * - icmp type:
+    x None (TCP connect denied, UDP fetch test)
+    x query type (ping test)
+      error type
+    x - errors related to allowed traffic (does it have a host waiting for it?)
+    x - directly allowed outbound icmp errors (e.g. for forwarding)
+ * - number (ordering over rules, to resolve conflicts by precedence)
+      no overlap between rules, i.e. ordering unimportant
+      error case: multiple rules with same number?
+    x conflicting rules (specific accept rules with low numbers, drop all with high number)
+*)
+
+(* 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"
+
+module Client (R: Mirage_random.S) (Time: Mirage_time.S) (Clock : Mirage_clock.MCLOCK) (NET: Mirage_net.S) (DB : Qubes.S.DB) = struct
+  module E = Ethernet.Make(NET)
+  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
+       server. The DHCP server needs to get the entire Ethernet frame, because
+       the Ethernet source address is the address to send replies to, its IPv4
+       addresses (source, destination) do not matter (since the DHCP client that
+       sent this request does not have an IP address yet). ARP cannot be used
+       by DHCP, because the client does not have an IP address (and thus no ARP
+       replies). *)
+
+    module UDPV4 = U
+    module TCPV4 = T
+    module IPV4 = I
+
+    type t = {
+      net : NET.t ; eth : E.t ; arp : A.t ;
+      ip : I.t ; 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 udpv4 { udp ; _ } = udp
+    let tcpv4 { tcp ; _ } = tcp
+    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 =
+      Hashtbl.replace udp_listeners port cb
+
+    let stop_listen_udpv4 { udp_listeners ; _ } ~port =
+      Hashtbl.remove udp_listeners port
+
+    let listen_tcpv4 ?keepalive { tcp_listeners ; _ } ~port cb =
+      Hashtbl.replace tcp_listeners port { T.process = cb ; T.keepalive }
+
+    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
+          ~arpv4:(A.input t.arp)
+          ~ipv4:(
+            I.input
+              ~tcp:(T.input t.tcp ~listeners:(listener t.tcp_listeners))
+              ~udp:(U.input t.udp ~listeners:(udp_listener t.udp_listeners))
+              ~default:(fun ~proto ~src ~dst buf ->
+                  match proto with
+                  | 1 ->
+                     begin match t.icmp_listener with
+                     | None -> Icmp.input t.icmp ~src ~dst buf
+                     | Some cb -> cb ~src ~dst buf
+                     end
+                  | _ -> Lwt.return_unit)
+              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) ;
+        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 ;
+        tcp_listeners = Hashtbl.create 2 ;
+        icmp_listener = None ;
+      }
+
+    let disconnect _ =
+      Logs.warn (fun m -> m "ignoring disconnect");
+      Lwt.return_unit
+  end
+
+  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 *)
+                         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) &&
+    packet.Icmpv4_packet.code = 0 &&
+    packet.Icmpv4_packet.ty = Icmpv4_wire.Echo_reply &&
+    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);
+      match Icmpv4_packet.Unmarshal.of_cstruct buf with
+      | Error e -> 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);
+         if is_ping_reply src server packet then resp_received := true;
+         Lwt.return_unit
+    in
+    Stack.listen_icmp stack (Some icmp_listener)
+
+  let ping_expect_failure server stack () =
+    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
+    | 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);
+      Time.sleep_ns 2_000_000_000L >>= fun () ->
+      (if !resp_received then
+        Log.err (fun f -> f "ping test failed: server %s got a response, block expected :(" server)
+      else
+        Log.err (fun f -> f "ping test passed: successfully blocked :)")
+      );
+      Stack.listen_icmp stack None;
+      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
+          (* TODO: check that packet is error packet *)
+          match Icmpv4_packet.Unmarshal.of_cstruct buf with
+          | Error e -> Log.err (fun f -> f "Error parsing icmp packet %s" e)
+          | Ok (packet, _) ->
+             (* TODO don't hardcode the numbers, make a datatype *)
+             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)
+        end;
+      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
+    | Ok () -> (* .. listener: test with accept rule, if we get reply we're good *)
+       Time.sleep_ns 1_000_000_000L >>= fun () ->
+       if !resp_correct
+       then 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"
+                           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);
+    let ip = Ipaddr.V4.of_string_exn server in
+    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');
+      T.close flow
+    | Error e -> 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 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)
+    in
+    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"
+                 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 ->
+        Log.debug (fun f -> f "listen_udpv4 function invoked for packet: %a" Cstruct.hexdump_pp buf);
+        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 *)
+            Log.err (fun f -> f "UDP fetch test to port %d: failed. :( Packet corrupted; expected %a but got %a"
+                        echo_server_port Cstruct.hexdump_pp content Cstruct.hexdump_pp buf);
+            Lwt.return_unit
+        else
+          begin
+            (* disregard this packet *)
+            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
+          end
+      )
+    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
+    | Ok () -> (* .. listener: test with accept rule, if we get reply we're good *)
+      Time.sleep_ns 1_000_000_000L >>= fun () ->
+      Stack.stop_listen_udpv4 stack ~port:src_port;
+      if !resp_correct then Lwt.return_unit else begin
+        Log.err (fun f -> f "UDP fetch test to port %d: failed. :( correct response not received" echo_server_port);
+        Lwt.return_unit
+      end
+    | Error e ->
+      Log.err (fun f -> f "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 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"
+                                      nameserver s);
+      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 :("
+                             nameserver s);
+       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);
+    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
+    | Ok addr ->
+      Log.debug (fun f -> f "looked up ip for %s: %a" server Ipaddr.V4.pp addr);
+      Log.err (fun f -> f "Do more stuff here!!!! :(");
+      Lwt.return_unit
+
+  let start _random _time _clock network db =
+    E.connect network >>= fun ethernet ->
+    A.connect ethernet >>= fun arp ->
+    I.connect db ethernet arp >>= fun ipv4 ->
+    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
+    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", [
+        ("UDP fetch", `Quick,  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", [
+        (* 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 "when trying below range" netvm 6667 tcp);
+        ("TCP connect", `Quick, 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", [
+        ("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,
+         * we should re-enable this test. *)
+        ("DNS lookup + TCP connect", `Quick, dns_then_tcp_denied "google.com" stack);
+      ] in
+    Alcotest.run "name" [ stack_tests ]
+end

test/update-firewall.sh

@@ -0,0 +1,54 @@
+#!/bin/sh
+
+# this script sets a deny-all rule for a particular VM, set here as TEST_VM.
+# it is intended to be used as part of a test suite which analyzes whether
+# an upstream FirewallVM correctly applies rule changes when they occur.
+
+# Copy this script into dom0 at /usr/local/bin/update-firewall.sh so it can be
+# remotely triggered by your development VM as part of the firewall testing
+# script.
+
+TEST_VM=fetchmotron
+
+#echo "Current $TEST_VM firewall rules:"
+#qvm-firewall $TEST_VM list
+
+echo "Removing $TEST_VM rules..."
+rc=0
+while [ "$rc" = "0" ]; do
+    qvm-firewall $TEST_VM del --rule-no 0
+    rc=$?
+done
+
+#echo "$TEST_VM firewall rules are now:"
+#qvm-firewall $TEST_VM list
+
+#echo "Setting $TEST_VM specialtarget=dns rule:"
+qvm-firewall $TEST_VM add accept specialtarget=dns
+
+#echo "Setting $TEST_VM allow rule for UDP port 1235 to 10.137.0.5:"
+qvm-firewall $TEST_VM add accept 10.137.0.5 udp 1235
+
+#echo "Setting $TEST_VM allow rule for UDP port 1338 to 10.137.0.5:"
+qvm-firewall $TEST_VM add accept 10.137.0.5 udp 1338
+
+#echo "Setting $TEST_VM allow rule for TCP port 6668-6670 to 10.137.0.5:"
+qvm-firewall $TEST_VM add accept 10.137.0.5 tcp 6668-6670
+
+#echo "Setting $TEST_VM allow rule for ICMP type 8 (ping) to 10.137.0.5:"
+qvm-firewall $TEST_VM add accept 10.137.0.5 icmp icmptype=8
+
+#echo "Setting $TEST_VM allow rule for bogus.linse.me:"
+qvm-firewall $TEST_VM add accept dsthost=bogus.linse.me
+
+#echo "Setting deny rule to host google.com:"
+qvm-firewall $TEST_VM add drop dsthost=google.com
+
+#echo "Setting allow-all on port 443 rule:"
+qvm-firewall $TEST_VM add accept proto=tcp dstports=443-443
+
+#echo "Setting $TEST_VM deny-all rule:"
+qvm-firewall $TEST_VM add drop
+
+echo "$TEST_VM firewall rules are now:"
+qvm-firewall $TEST_VM list

unikernel.ml

@@ -7,28 +7,19 @@ open Qubes
 let src = Logs.Src.create "unikernel" ~doc:"Main unikernel code"
 module Log = (val Logs.src_log src : Logs.LOG)
 
-module Main (Clock : Mirage_clock.MCLOCK) = struct
+module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK) = struct
+  module Uplink = Uplink.Make(R)(Clock)
+  module Dns_transport = My_dns.Transport(R)(Clock)
+  module Dns_client = Dns_client.Make(Dns_transport)
+
   (* Set up networking and listen for incoming packets. *)
-  let network nat qubesDB =
+  let network dns_client dns_responses uplink qubesDB router =
-    (* Read configuration from QubesDB *)
-    Dao.read_network_config qubesDB >>= fun config ->
-    (* Initialise connection to NetVM *)
-    Uplink.connect config >>= fun uplink ->
     (* Report success *)
     Dao.set_iptables_error qubesDB "" >>= fun () ->
-    (* Set up client-side networking *)
-    let client_eth = Client_eth.create
-      ~client_gw:config.Dao.clients_our_ip in
-    (* Set up routing between networks and hosts *)
-    let router = Router.create
-      ~client_eth
-      ~uplink:(Uplink.interface uplink)
-      ~nat
-    in
     (* Handle packets from both networks *)
     Lwt.choose [
-      Client_net.listen Clock.elapsed_ns router;
+      Client_net.listen Clock.elapsed_ns dns_client qubesDB router;
-      Uplink.listen uplink Clock.elapsed_ns router
+      Uplink.listen uplink Clock.elapsed_ns dns_responses router
     ]
 
   (* We don't use the GUI, but it's interesting to keep an eye on it.
@@ -49,12 +40,13 @@ module Main (Clock : Mirage_clock.MCLOCK) = struct
     )
 
   (* Main unikernel entry point (called from auto-generated main.ml). *)
-  let start _clock =
+  let start _random _clock =
     let start_time = Clock.elapsed_ns () in
     (* Start qrexec agent, GUI agent and QubesDB agent in parallel *)
     let qrexec = RExec.connect ~domid:0 () in
     GUI.connect ~domid:0 () |> watch_gui;
     let qubesDB = DB.connect ~domid:0 () in
+
     (* Wait for clients to connect *)
     qrexec >>= fun qrexec ->
     let agent_listener = RExec.listen qrexec Command.handler in
@@ -72,7 +64,27 @@ module Main (Clock : Mirage_clock.MCLOCK) = struct
     (* Set up networking *)
     let max_entries = Key_gen.nat_table_size () in
     My_nat.create ~max_entries >>= fun nat ->
-    let net_listener = network nat qubesDB in
+
+    (* Read network configuration from QubesDB *)
+    Dao.read_network_config qubesDB >>= fun config ->
+
+    Uplink.connect config >>= fun uplink ->
+    (* Set up client-side networking *)
+    let client_eth = Client_eth.create
+      ~client_gw:config.Dao.clients_our_ip in
+    (* Set up routing between networks and hosts *)
+    let router = Router.create
+      ~client_eth
+      ~uplink:(Uplink.interface uplink)
+      ~nat
+    in
+
+    let send_dns_query = Uplink.send_dns_client_query uplink in
+    let dns_mvar = Lwt_mvar.create_empty () in
+    let dns_client = Dns_client.create (router, send_dns_query, dns_mvar) in
+
+    let net_listener = network (Dns_client.getaddrinfo dns_client Dns.Rr_map.A) dns_mvar uplink qubesDB router in
+
     (* Report memory usage to XenStore *)
     Memory_pressure.init ();
     (* Run until something fails or we get a shutdown request. *)

uplink.ml

@@ -9,15 +9,20 @@ module Eth = Ethernet.Make(Netif)
 let src = Logs.Src.create "uplink" ~doc:"Network connection to NetVM"
 module Log = (val Logs.src_log src : Logs.LOG)
 
-module Arp = Arp.Make(Eth)(OS.Time)
+module Make (R:Mirage_random.S) (Clock : Mirage_clock.MCLOCK) = struct
+  module Arp = Arp.Make(Eth)(OS.Time)
+  module I = Static_ipv4.Make(R)(Clock)(Eth)(Arp)
+  module U = Udp.Make(I)(R)
 
-type t = {
+  type t = {
     net : Netif.t;
     eth : Eth.t;
     arp : Arp.t;
     interface : interface;
     mutable fragments : Fragments.Cache.t;
-}
+    ip : I.t;
+    udp: U.t;
+  }
 
 class netvm_iface eth mac ~my_ip ~other_ip : interface = object
   val queue = FrameQ.create (Ipaddr.V4.to_string other_ip)
@@ -31,7 +36,23 @@ class netvm_iface eth mac ~my_ip ~other_ip : interface = object
     )
 end
 
-let listen t get_ts router =
+  let send_dns_client_query t ~src_port ~dst ~dst_port buf =
+    U.write ~src_port ~dst ~dst_port t.udp buf >|= function
+    | Error s -> Log.err (fun f -> f "error sending udp packet: %a" U.pp_error s); Error (`Msg "failure")
+    | Ok () -> Ok ()
+
+  let listen t get_ts dns_responses router =
+    let handle_packet ip_header ip_packet =
+      let open Udp_packet in
+
+      Log.debug (fun f -> f "received ipv4 packet from %a on uplink" Ipaddr.V4.pp ip_header.Ipv4_packet.src);
+      match ip_packet with
+      | `UDP (header, packet) when Ports.mem header.dst_port !(router.Router.ports.My_nat.dns_udp) ->
+        Log.debug (fun f -> f "found a DNS packet whose dst_port (%d) was in the list of dns_client ports" header.dst_port);
+        Lwt_mvar.put dns_responses (header, packet)
+      | _ ->
+        Firewall.ipv4_from_netvm router (`IPv4 (ip_header, ip_packet))
+    in
     Netif.listen t.net ~header_size:Ethernet_wire.sizeof_ethernet (fun frame ->
         (* Handle one Ethernet frame from NetVM *)
         Eth.input t.eth
@@ -44,28 +65,33 @@ let listen t get_ts router =
             match r with
               | Error e ->
                 Log.warn (fun f -> f "Ignored unknown IPv4 message from uplink: %a" Nat_packet.pp_error e);
-              Lwt.return_unit
+                Lwt.return ()
               | Ok None -> Lwt.return_unit
-            | Ok (Some packet) ->
+              | Ok (Some (`IPv4 (header, packet))) -> handle_packet header packet
-              Firewall.ipv4_from_netvm router packet
             )
         ~ipv6:(fun _ip -> Lwt.return_unit)
         frame
     ) >|= or_raise "Uplink listen loop" Netif.pp_error
 
+
 let interface t = t.interface
 
 let connect config =
-  let ip = config.Dao.uplink_our_ip in
+  let my_ip = config.Dao.uplink_our_ip in
+  let gateway = config.Dao.uplink_netvm_ip in
   Netif.connect "0" >>= fun net ->
   Eth.connect net >>= fun eth ->
   Arp.connect eth >>= fun arp ->
-  Arp.add_ip arp ip >>= fun () ->
+  Arp.add_ip arp my_ip >>= fun () ->
+  let network = Ipaddr.V4.Prefix.make 0 Ipaddr.V4.any in
+  I.connect ~ip:(network, my_ip) ~gateway eth arp >>= fun ip ->
+  U.connect ip >>= fun udp ->
   let netvm_mac =
-    Arp.query arp config.Dao.uplink_netvm_ip
+    Arp.query arp gateway
     >|= or_raise "Getting MAC of our NetVM" Arp.pp_error in
   let interface = new netvm_iface eth netvm_mac
-    ~my_ip:ip
+    ~my_ip
     ~other_ip:config.Dao.uplink_netvm_ip in
   let fragments = Fragments.Cache.empty (256 * 1024) in
-  Lwt.return { net; eth; arp; interface ; fragments }
+  Lwt.return { net; eth; arp; interface ; fragments ; ip ; udp }
+end

uplink.mli

@@ -5,13 +5,18 @@
 
 open Fw_utils
 
-type t
+[@@@ocaml.warning "-67"]
+module Make (R: Mirage_random.S)(Clock : Mirage_clock.MCLOCK) : sig
+  type t
 
-val connect : Dao.network_config -> t Lwt.t
+  val connect : Dao.network_config -> t Lwt.t
-(** Connect to our NetVM (gateway). *)
+  (** Connect to our NetVM (gateway). *)
 
-val interface : t -> interface
+  val interface : t -> interface
-(** The network interface to NetVM. *)
+  (** The network interface to NetVM. *)
 
-val listen : t -> (unit -> int64) -> Router.t -> unit Lwt.t
+  val listen : t -> (unit -> int64) -> (Udp_packet.t * Cstruct.t) Lwt_mvar.t -> Router.t -> unit Lwt.t
-(** Handle incoming frames from NetVM. *)
+  (** Handle incoming frames from NetVM. *)
+
+  val send_dns_client_query: t -> src_port:int-> dst:Ipaddr.V4.t -> dst_port:int -> Cstruct.t -> (unit, [`Msg of string]) result Lwt.t
+end