apply rules to incoming traffic (but...)

...we try to read them before they've been written to QubesDB, so we
think there aren't any.  To get useful results, we'll need to either
delay the rule read, or implement a proper watcher for the firewall
rules using the QubesDB watch interface.

client_net.ml

@@ -31,6 +31,7 @@ class client_iface eth ~domid ~gateway_ip ~client_ip client_mac rules : client_l
   object
     val queue = FrameQ.create (Ipaddr.V4.to_string client_ip)
     val rules = rules
+    method get_rules = rules
     method my_mac = ClientEth.mac eth
     method other_mac = client_mac
     method my_ip = gateway_ip
@@ -103,7 +104,8 @@ let add_vif { Dao.ClientVif.domid; device_id } ~client_ip ~router ~cleanup_tasks
 (** A new client VM has been found in XenStore. Find its interface and connect to it. *)
 let add_client ~router vif client_ip rules =
   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 and %d firewall rules"
+               Dao.ClientVif.pp vif Ipaddr.V4.pp client_ip (List.length rules));
   Lwt.async (fun () ->
       Lwt.catch (fun () ->
           add_vif vif ~client_ip ~router ~cleanup_tasks rules
@@ -138,6 +140,7 @@ let listen qubesDB router =
     new_set |> Dao.VifMap.iter (fun key (ip_addr, rules) ->
       if not (Dao.VifMap.mem key !clients) then (
         let cleanup = add_client ~router key ip_addr rules in
+        Log.debug (fun f -> f "client %a arrived with %d rules" Dao.ClientVif.pp key (List.length rules));
         clients := !clients |> Dao.VifMap.add key cleanup
       )
     )

dao.ml

@@ -36,20 +36,32 @@ let directory ~handle dir =
 
 let read_rules qubesDB client_ip =
   let root = "/qubes-firewall/" ^ (Ipaddr.V4.to_string client_ip) ^ "/" in
-  let rec get_rule n l =
+  let rec get_rule n l : (Pf_qubes.Parse_qubes.rule list, string) result =
     let pattern = root ^ Printf.sprintf "%04d" n in
-    Log.info (fun f -> f "reading %s" pattern);
+    Log.debug (fun f -> f "reading %s" pattern);
     match Qubes.DB.read qubesDB pattern with
     | None -> 
-      Log.info (fun f -> f "rule %d was empty " n);
+      Log.debug (fun f -> f "rule %d does not exist; won't look for more" n);
-      List.rev l
+      Ok (List.rev l)
     | Some rule ->
-      Log.info (fun f -> f "rule %d: %s" n rule);
+      Log.debug (fun f -> f "rule %d: %s" n rule);
       match Pf_qubes.Parse_qubes.parse_qubes ~number:n rule with
-      | Error e -> (* TODOOOOOOO!! Traffic should be dropped!!*) l
+      | Error e -> Log.warn (fun f -> f "Error parsing rule %d: %s" n e); Error e
-      | Ok rule -> get_rule (n+1) (rule :: l)
+      | Ok rule ->
+        Log.debug (fun f -> f "parsed rule: %a" Pf_qubes.Parse_qubes.pp_rule rule);
+        get_rule (n+1) (rule :: l)
   in
-  get_rule 0 []
+  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 = [];
+                             icmp_type = None;
+                             number = 0;})]
 
 let vifs qubesDB ~handle domid =
   match String.to_int domid with
@@ -131,7 +143,4 @@ let read_network_config qubesDB =
   in
   aux (DB.bindings qubesDB)
 
-let read_fw_rules qubesDB domid =
-  []
-
 let set_iptables_error db = Qubes.DB.write db "/qubes-iptables-error"

dao.mli

@@ -30,6 +30,4 @@ 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 read_fw_rules: Qubes.DB.t -> int -> Pf_qubes.Parse_qubes.rule list
-
 val set_iptables_error : Qubes.DB.t -> string -> unit Lwt.t

firewall.ml

@@ -50,17 +50,6 @@ let forward_ipv4 t packet =
 
 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)
-  | (`Client_gateway | `Firewall_uplink | `NetVM) as x -> x
-
 (* NAT *)
 
 let translate t packet =
@@ -97,7 +86,9 @@ let apply_rules t (rules : ('a, 'b) Packet.t -> Packet.action) ~dst (annotated_p
   | `Accept, (`Firewall_uplink | `Client_gateway) ->
       Log.warn (fun f -> f "Bad rule: firewall can't accept packets %a" Nat_packet.pp packet);
       return ()
-  | `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 Nat_packet.pp packet);
@@ -122,11 +113,7 @@ 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
-  let src = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.src) in
+  match of_mirage_nat_packet ~src:(`Client src) ~dst packet with
-  match of_mirage_nat_packet
-          ~src:(src)
-          ~dst:(resolve_host dst)
-          packet with
   | None -> return ()
   | Some firewall_packet -> apply_rules t Rules.from_client ~dst firewall_packet
 
@@ -137,7 +124,7 @@ 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 Packet.of_mirage_nat_packet ~src ~dst:(resolve_host dst) packet with
+  match Packet.of_mirage_nat_packet ~src ~dst packet with
   | None -> Lwt.return_unit
   | Some _ ->
   match src with

rules.ml

@@ -1,34 +1,19 @@
 (* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
    See the README file for details. *)
 
-(** Put your firewall rules in this file. *)
+(** Enforce firewall rules from QubesDB. *)
 
-open Packet   (* Allow us to use definitions in packet.ml *)
+open Packet
+module Q = Pf_qubes.Parse_qubes
+
+let src = Logs.Src.create "rules" ~doc:"Firewall rules"
+module Log = (val Logs.src_log src : Logs.LOG)
 
 let dns_port = 53
 
-(* List your AppVM IP addresses here if you want to match on them in the rules below.
-   Any client not listed here will appear as [`Client `Unknown]. *)
-let clients = [
-  (*
-  "10.137.0.12", `Dev;
-  "10.137.0.14", `Untrusted;
-  *)
-]
-
-(* List your external (non-AppVM) IP addresses here if you want to match on them in the rules below.
-   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. *)
 [@@@ocaml.warning "-9"]
 
-module Q = Pf_qubes.Parse_qubes
-
 (* we want to replace this list with a structure including rules from QubesDB.
    we need:
    1) code for reading the rules (we have some for noticing new clients: dao.ml)
@@ -40,19 +25,11 @@ module Q = Pf_qubes.Parse_qubes
    - initially we can set them up with a list, and then look for faster/better/clearer structures later
    4) code for applying the rules to incoming traffic (below, already in this file)
    *)
-let dummy_rules =
-  Pf_qubes.Parse_qubes.([{ action = Drop ;
-    proto = None ;
-    specialtarget = None ;
-    dst = `any ;
-    dstports = [] ;
-    icmp_type = None ;
-    number = 0 ;
-   }])
 
 (* Does the packet match our rules? *)
-let classify_client_packet (packet : ([`Client of _], _) Packet.t) (client_link : Fw_utils.client_link) : Packet.action =
+let classify_client_packet (packet : ([`Client of Fw_utils.client_link], _) Packet.t)  : Packet.action =
   let matches_port dstports (port : int) =
+    List.length dstports = 0 ||
     List.exists (fun (Q.Range_inclusive (min, max)) -> (min <= port && port <= max)) dstports
   in
   let matches_proto rule packet = match rule.Pf_qubes.Parse_qubes.proto with
@@ -74,15 +51,25 @@ let classify_client_packet (packet : ([`Client of _], _) Packet.t) (client_link
     | `hosts subnet -> 
       Ipaddr.Prefix.mem (V4 packet.ipv4_header.Ipv4_packet.dst) subnet
   in
-  let action = List.fold_left (fun found rule -> match found with 
+  let (`Client client_link) = packet.src in
-      | Some action -> Some action 
+  Log.debug (fun f -> f "checking %d rules for a match" (List.length client_link#get_rules));
-      | None -> if matches_proto rule packet && matches_dest rule packet then Some rule.action else None) None client_link#get_rules
+  List.find_opt (fun rule ->
-  in
+      if not (matches_proto rule packet) then begin
-  match action with
+        Log.debug (fun f -> f "rule %d is not a match - proto" rule.Q.number);
-  | None -> `Drop "No matching rule"
+        false
-  | Some Accept -> `Accept
+      end else if not (matches_dest rule packet) then begin
-  | Some Drop -> `Drop "Drop rule matched"
+        Log.debug (fun f -> f "rule %d is not a match - dest" rule.Q.number);
-
+        false
+      end else begin
+        Log.debug (fun f -> f "rule %d is a match" rule.Q.number);
+        true
+      end) client_link#get_rules |> function
+  | None -> `Drop "No matching rule; assuming default drop"
+  | Some {Q.action = Accept; number; _} ->
+    Log.debug (fun f -> f "allowing packet matching rule %d" number);
+    `Accept
+  | Some {Q.action = Drop; number; _} ->
+    `Drop (Printf.sprintf "rule %d explicitly drops this packet" number)
 
 (** This function decides what to do with a packet from a client VM.
 
@@ -94,28 +81,19 @@ let classify_client_packet (packet : ([`Client of _], _) Packet.t) (client_link
     Note: If the packet matched an existing NAT rule then this isn't called. *)
 let from_client (packet : ([`Client of Fw_utils.client_link], _) Packet.t) : Packet.action =
   match packet with
-  (* Examples (add your own rules here):
+  | { dst = (`External _ | `NetVM) } -> begin
-
+    (* see whether this traffic is allowed *)
-     1. Allows Dev to send SSH packets to Untrusted.
+    match classify_client_packet packet with
-        Note: responses are not covered by this!
+    | `Accept -> `NAT
-     2. Allows Untrusted to reply to Dev.
+    | `Drop s -> `Drop s
-     3. Blocks an external site.
+  end
-
-     In all cases, make sure you've added the VM name to [clients] or [externals] above, or it won't
-     match anything! *)
-  (*
-  | { src = `Client `Dev; dst = `Client `Untrusted; proto = `TCP { dport = 22 } } -> `Accept
-  | { 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 = `Client_gateway; transport_header = `UDP header; _ } ->
+    (* TODO: this is where we should implement specialtarget dns rules? *)
     if header.dst_port = dns_port
     then `NAT_to (`NetVM, dns_port)
     else `Drop "packet addressed to client gateway"
   | { dst = (`Client_gateway | `Firewall_uplink) } -> `Drop "packet addressed to firewall itself"
-  | { dst = `Client client_link } -> classify_client_packet packet client_link
+  | { dst = `Client _ } -> classify_client_packet packet
 
 (** 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. *)

test/test.sh

@@ -76,7 +76,7 @@ fi
 
 echo "We're gonna set up a unikernel for the mirage-fw-test qube"
 cd ..
-mirage configure -t xen && \
+mirage configure -t xen -l "*:debug" && \
 make depend && \
 make
 if [ $? -ne 0 ]; then