Move NAT code to router and add DNS redirects

README.md

@@ -3,11 +3,7 @@
 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*.
+Note: This firewall *ignores the rules set in the Qubes GUI*. See `rules.ml` for the actual policy.
-
-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:
 

_tags

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

client_eth.ml

@@ -18,19 +18,28 @@ let create ~prefix ~client_gw =
 let prefix t = t.prefix
 
 let add_client t iface =
-  let ip = iface#client_ip in
+  let ip = iface#other_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
+  let ip = iface#other_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
 
+let classify t = function
+  | Ipaddr.V6 _ -> `External
+  | Ipaddr.V4 ip ->
+  if ip === t.client_gw then `Client_gateway
+  else match lookup t ip with
+  | Some client_link -> `Client client_link
+  | None when Ipaddr.V4.Prefix.mem ip t.prefix -> `Unknown_client
+  | None -> `External
+
 module ARP = struct
   type arp = {
     net : t;
@@ -40,7 +49,7 @@ module ARP = struct
   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
+    | Some client_iface -> Some client_iface#other_mac
     | None -> None
 
   let create ~net client_link = {net; client_link}
@@ -87,7 +96,7 @@ module ARP = struct
     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 (
+    if req_ipv4 === t.client_link#other_ip then (
       Log.info "ignoring request for client's own IP" Logs.unit;
       None
     ) else match lookup t req_ipv4 with

client_eth.mli

@@ -18,6 +18,9 @@ val remove_client : t -> client_link -> unit
 
 val prefix : t -> Ipaddr.V4.Prefix.t
 
+val classify : t -> Ipaddr.t ->
+  [ `Client of client_link | `Unknown_client | `Client_gateway | `External ]
+
 val lookup : t -> Ipaddr.V4.t -> client_link option
 
 module ARP : sig

client_net.ml

@@ -12,8 +12,8 @@ module Log = (val Logs.src_log src : Logs.LOG)
 
 class client_iface eth client_ip client_mac : client_link = object
   method my_mac = ClientEth.mac eth
-  method client_mac = client_mac
+  method other_mac = client_mac
-  method client_ip = client_ip
+  method other_ip = client_ip
   method writev ip =
     let eth_hdr = eth_header_ipv4 ~src:(ClientEth.mac eth) ~dst:client_mac in
     ClientEth.writev eth (fixup_checksums (Cstruct.concat (eth_hdr :: ip)))
@@ -41,10 +41,10 @@ let start_client ~router domid =
       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_eth.ARP.create ~net:(Router.client_eth router) iface in
+      let fixed_arp = Client_eth.ARP.create ~net:router.Router.client_eth iface in
       Router.add_client router iface;
       Cleanup.on_cleanup cleanup_tasks (fun () -> Router.remove_client router iface);
-      Netback.listen backend (
+      Netback.listen backend (fun frame ->
         ClientEth.input
           ~arpv4:(fun buf ->
             match Client_eth.ARP.input fixed_arp buf with
@@ -53,7 +53,7 @@ let start_client ~router domid =
           )
           ~ipv4:(fun packet ->
             let src = Wire_structs.Ipv4_wire.get_ipv4_src packet |> Ipaddr.V4.of_int32 in
-            if src === client_ip then Router.forward_ipv4 router packet
+            if src === client_ip then Firewall.ipv4_from_client router frame
             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);
@@ -61,7 +61,7 @@ let start_client ~router domid =
             )
           )
           ~ipv6:(fun _buf -> return ())
-          eth
+          eth frame
       )
     )
     (fun ex ->

firewall.ml

@@ -0,0 +1,154 @@
+(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
+   See the README file for details. *)
+
+open Utils
+open Packet
+
+let src = Logs.Src.create "firewall" ~doc:"Packet handler"
+module Log = (val Logs.src_log src : Logs.LOG)
+
+(* Transmission *)
+
+let transmit ~frame iface =
+  let packet = Cstruct.shift frame Wire_structs.sizeof_ethernet in
+  iface#writev [packet]
+
+let forward_ipv4 t frame =
+  let packet = Cstruct.shift frame Wire_structs.sizeof_ethernet in
+  match Router.target t packet with
+  | Some iface -> iface#writev [packet]
+  | None -> return ()
+
+(* Packet classification *)
+
+let ports transport =
+  let sport, dport = Nat_rewrite.ports_of_transport transport in
+  { sport; dport }
+
+let classify t frame =
+  match Nat_rewrite.layers frame with
+  | None ->
+      Log.warn "Failed to parse frame" Logs.unit;
+      None
+  | Some (_eth, ip, transport) ->
+  let src, dst = Nat_rewrite.addresses_of_ip ip in
+  let proto =
+    match Nat_rewrite.proto_of_ip ip with
+    | 1 -> `ICMP
+    | 6 -> `TCP (ports transport)
+    | 17 -> `UDP (ports transport)
+    | _ -> `Unknown in
+  Some {
+    frame;
+    src = Router.classify t src;
+    dst = Router.classify t dst;
+    proto;
+  }
+
+(* NAT *)
+
+let translate t frame =
+  match Nat_rewrite.translate t.Router.nat frame with
+  | None -> None
+  | Some frame -> Some (fixup_checksums frame |> Cstruct.concat)
+
+let random_user_port () =
+  1024 + Random.int (0xffff - 1024)
+
+let rec add_nat_rule_and_transmit t frame fn fmt logf =
+  let xl_port = random_user_port () in
+  match fn xl_port with
+  | Nat_rewrite.Overlap -> add_nat_rule_and_transmit t frame fn fmt logf (* Try a different port *)
+  | Nat_rewrite.Unparseable ->
+      Log.warn "Failed to add NAT rule: Unparseable" Logs.unit;
+      return ()
+  | Nat_rewrite.Ok _ ->
+      Log.info fmt (logf xl_port);
+      match translate t frame with
+      | Some frame -> forward_ipv4 t frame
+      | None ->
+          Log.warn "No NAT entry, even after adding one!" Logs.unit;
+          return ()
+
+(* Add a NAT rule for the endpoints in this frame, via a random port on the firewall. *)
+let add_nat_and_forward_ipv4 t frame =
+  add_nat_rule_and_transmit t frame
+    (Nat_rewrite.make_nat_entry t.Router.nat frame t.Router.my_uplink_ip)
+    "added NAT entry: %s:%d -> firewall:%d -> %d:%s"
+    (fun xl_port 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 xl_port dport (Ipaddr.to_string dst)
+    )
+
+(* Add a NAT rule to redirect this conversation to NetVM instead of us. *)
+let redirect_to_netvm t ~frame ~port =
+  let gw = Ipaddr.V4 t.Router.default_gateway#other_ip in
+  add_nat_rule_and_transmit t frame
+    (fun xl_port ->
+      Nat_rewrite.make_redirect_entry t.Router.nat frame (t.Router.my_uplink_ip, xl_port) (gw, port)
+    )
+    "added NAT redirect %s:%d -> %d:firewall:%d -> %d:NetVM"
+    (fun xl_port 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 dport xl_port port
+    )
+
+(* Handle incoming packets *)
+
+let ipv4_from_client t frame =
+  match Memory_pressure.status () with
+  | `Memory_critical -> (* TODO: should happen before copying and async *)
+      Log.warn "Memory low - dropping packet" Logs.unit;
+      return ()
+  | `Ok ->
+  (* Check for existing NAT entry for this packet *)
+  match translate t frame with
+  | Some frame -> forward_ipv4 t frame  (* Some existing connection or redirect *)
+  | None ->
+  (* No existing NAT entry. Check the firewall rules. *)
+  match classify t frame with
+  | None -> return ()
+  | Some info ->
+  match Rules.from_client info, info.dst with
+  | `Accept, `Client client_link -> transmit ~frame client_link
+  | `Accept, `External -> add_nat_and_forward_ipv4 t frame
+  | `Accept, `Unknown_client ->
+      Log.warn "Dropping packet to unknown client" Logs.unit;
+      return ()
+  | `Accept, (`Firewall_uplink | `Client_gateway) ->
+      Log.warn "Bad rule: firewall can't accept packets" Logs.unit;
+      return ()
+  | `Redirect_to_netvm port, _ -> redirect_to_netvm t ~frame ~port
+  | `Drop reason, _ ->
+      Log.info "Dropped packet (%s)" (fun f -> f reason);
+      return ()
+
+let ipv4_from_netvm t frame =
+  match Memory_pressure.status () with
+  | `Memory_critical -> (* TODO: should happen before copying and async *)
+      Log.warn "Memory low - dropping packet" Logs.unit;
+      return ()
+  | `Ok ->
+  match classify t frame with
+  | None -> return ()
+  | Some info ->
+  match info.src with
+  | `Client _ | `Unknown_client | `Firewall_uplink | `Client_gateway ->
+    Log.warn "Frame from NetVM has internal source IP address!" Logs.unit;
+    return ()
+  | `External ->
+  match translate t frame with
+  | Some frame -> forward_ipv4 t frame
+  | None ->
+  match Rules.from_netvm info with
+  | `Drop reason ->
+      Log.info "Dropped packet (%s)" (fun f -> f reason);
+      return ()

firewall.mli

@@ -0,0 +1,11 @@
+(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
+   See the README file for details. *)
+
+(** Classify IP packets, apply rules and send as appropriate. *)
+
+val ipv4_from_netvm : Router.t -> Cstruct.t -> unit Lwt.t
+(** Handle a frame from the outside world (this module will validate the source IP). *)
+
+val ipv4_from_client : Router.t -> Cstruct.t -> unit Lwt.t
+(** Handle a frame from a client. Caller must check the source IP matches the client's
+    before calling this. *)

nat_rules.ml

@@ -1,57 +0,0 @@
-(* 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 ()

packet.ml

@@ -0,0 +1,21 @@
+(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
+   See the README file for details. *)
+
+open Utils
+
+type port = int
+
+type ports = {
+  sport : port; (* Source port *)
+  dport : port; (* Destination *)
+}
+
+type host = 
+  [ `Client of client_link | `Unknown_client | `Client_gateway | `Firewall_uplink | `External ]
+
+type info = {
+  frame : Cstruct.t;
+  src : host;
+  dst : host;
+  proto : [ `UDP of ports | `TCP of ports | `ICMP | `Unknown ];
+}

router.ml

@@ -6,19 +6,22 @@ open Utils
 let src = Logs.Src.create "router" ~doc:"Router"
 module Log = (val Logs.src_log src : Logs.LOG)
 
+(* The routing table *)
+
 type t = {
   client_eth : Client_eth.t;
+  nat : Nat_lookup.t;
   default_gateway : interface;
+  my_uplink_ip : Ipaddr.t;
 }
 
-let create ~client_eth ~default_gateway = { client_eth; default_gateway }
+let create ~client_eth ~default_gateway ~my_uplink_ip =
-
+  let nat = Nat_lookup.empty () in
-let client_eth t = t.client_eth
+  { client_eth; nat; default_gateway; my_uplink_ip }
 
 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_eth.prefix t.client_eth) then (
     match Client_eth.lookup t.client_eth dst_ip with
     | Some client_link -> Some (client_link :> interface)
@@ -31,12 +34,7 @@ let target t buf =
 let add_client t = Client_eth.add_client t.client_eth
 let remove_client t = Client_eth.remove_client t.client_eth
 
-let forward_ipv4 router buf =
+let classify t ip =
-  match Memory_pressure.status () with
+  let (===) a b = (Ipaddr.compare a b = 0) in
-  | `Memory_critical -> (* TODO: should happen before copying and async *)
+  if ip === t.my_uplink_ip then `Firewall_uplink
-      Log.warn "Memory low - dropping packet" Logs.unit;
+  else (Client_eth.classify t.client_eth ip :> Packet.host)
-      return ()
-  | `Ok ->
-  match target router buf with
-  | Some iface -> iface#writev [buf]
-  | None -> return ()

router.mli

@@ -5,17 +5,22 @@
 
 open Utils
 
-type t
+type t = private {
+  client_eth : Client_eth.t;
+  nat : Nat_lookup.t;
+  default_gateway : interface;
+  my_uplink_ip : Ipaddr.t;
+}
 (** A routing table. *)
 
 val create :
   client_eth:Client_eth.t ->
   default_gateway:interface ->
+  my_uplink_ip:Ipaddr.t ->
   t
-(** [create ~client_eth ~default_gateway] is a new routing table that routes packets outside
+(** [create ~client_eth ~default_gateway ~my_uplink_ip] is a new routing table
-    of [client_eth] to [default_gateway]. *)
+    that routes packets outside of [client_eth] to [default_gateway], changing their
-
+    source address to [my_uplink_ip] for NAT. *)
-val client_eth : t -> Client_eth.t
 
 val target : t -> Cstruct.t -> interface option
 (** [target t packet] is the interface to which [packet] (an IP packet) should be routed. *)
@@ -26,5 +31,4 @@ val add_client : t -> client_link -> unit
 
 val remove_client : t -> client_link -> unit
 
-val forward_ipv4 : t -> Cstruct.t -> unit Lwt.t
+val classify : t -> Ipaddr.t -> Packet.host
-(** [forward_ipv4 t packet] sends the packet to [target t packet]. *)

rules.ml

@@ -0,0 +1,23 @@
+(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
+   See the README file for details. *)
+
+(** Put your firewall rules here. *)
+
+open Packet
+
+(* OCaml normally warns if you don't match all fields, but that's OK here. *)
+[@@@ocaml.warning "-9"]
+
+(** Decide what to do with a packet from a client VM.
+    Note: If the packet matched an existing NAT rule then this isn't called. *)
+let from_client = function
+  | { dst = `External } -> `Accept
+  | { dst = `Client_gateway; proto = `UDP { dport = 53 } } -> `Redirect_to_netvm 53
+  | { dst = (`Client_gateway | `Firewall_uplink) } -> `Drop "packet addressed to firewall itself"
+  | { dst = `Client _ } -> `Drop "prevent communication between client VMs"
+  | { dst = `Unknown_client } -> `Drop "target client not running"
+
+(** Decide what to do with a packet received from the outside world.
+    Note: If the packet matched an existing NAT rule then this isn't called. *)
+let from_netvm = function
+  | _ -> `Drop "drop by default"

unikernel.ml

@@ -37,7 +37,8 @@ module Main (Clock : V1.CLOCK) = struct
     (* Set up routing between networks and hosts *)
     let router = Router.create
       ~client_eth
-      ~default_gateway:(Uplink.interface uplink) in
+      ~default_gateway:(Uplink.interface uplink)
+      ~my_uplink_ip:(Ipaddr.V4 config.Dao.uplink_our_ip) in
     (* Handle packets from both networks *)
     Lwt.join [
       Client_net.listen router;

uplink.ml

@@ -19,35 +19,24 @@ module Make(Clock : V1.CLOCK) = struct
     arp : Arp.t;
     interface : interface;
     my_ip : Ipaddr.t;
-    nat_table : Nat_lookup.t;
   }
 
-  class netvm_iface eth my_ip mac nat_table = object
+  class netvm_iface eth mac netvm_ip : interface = object
     method my_mac = Eth.mac eth
+    method other_ip = netvm_ip
     method writev ip =
       mac >>= fun dst ->
       let eth_hdr = eth_header_ipv4 ~src:(Eth.mac eth) ~dst in
-      match Nat_rules.nat my_ip nat_table Nat_rewrite.Source (Cstruct.concat (eth_hdr :: ip)) with
+      Eth.writev eth (eth_hdr :: ip)
-      | None -> return ()
-      | Some frame -> Eth.writev eth (fixup_checksums frame)
   end
 
-  let unnat t router frame _ip =
-    match Nat_rules.nat t.my_ip t.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
-        Router.forward_ipv4 router (Cstruct.shift frame Wire_structs.sizeof_ethernet)
-
   let listen t router =
     Netif.listen t.net (fun frame ->
       (* Handle one Ethernet frame from NetVM *)
       Eth.input t.eth
         ~arpv4:(Arp.input t.arp)
-        ~ipv4:(unnat t router frame)
+        ~ipv4:(fun _ip -> Firewall.ipv4_from_netvm router frame)
-        ~ipv6:(fun _buf -> return ())
+        ~ipv6:(fun _ip -> return ())
         frame
     )
 
@@ -67,7 +56,6 @@ module Make(Clock : V1.CLOCK) = struct
       | `Timeout -> failwith "ARP timeout getting MAC of our NetVM"
       | `Ok netvm_mac -> netvm_mac in
     let my_ip = Ipaddr.V4 ip in
-    let nat_table = Nat_lookup.empty () in
+    let interface = new netvm_iface eth netvm_mac config.Dao.uplink_netvm_ip in
-    let interface = new netvm_iface eth my_ip netvm_mac nat_table in
+    return { net; eth; arp; interface; my_ip }
-    return { net; eth; arp; interface; my_ip; nat_table }
 end

utils.ml

@@ -22,13 +22,13 @@ module IntMap = Map.Make(Int)
 class type interface = object
   method my_mac : Macaddr.t
   method writev : Cstruct.t list -> unit Lwt.t
+  method other_ip : Ipaddr.V4.t
 end
 
 (** An Ethernet interface connected to a clientVM. *)
 class type client_link = object
   inherit interface
-  method client_ip : Ipaddr.V4.t
+  method other_mac : Macaddr.t
-  method client_mac : Macaddr.t
 end
 
 (** An Ethernet header from [src]'s MAC address to [dst]'s with an IPv4 payload. *)