Merge pull request #149 from hannesm/next

Next release

Dockerfile

@@ -11,7 +11,7 @@ RUN sudo ln -sf /usr/bin/opam-2.1 /usr/bin/opam
 # 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 /home/opam/opam-repository && git fetch origin master && git reset --hard f904585098b809001380caada4b7426c112d086c && opam update
+RUN cd /home/opam/opam-repository && git fetch origin master && git reset --hard 632ef7fd6add02a7789f896751c51b408dca0373 && opam update
 
 RUN opam install -y mirage opam-monorepo
 RUN mkdir /home/opam/qubes-mirage-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 ./dist/qubes-firewall.xen)"
-echo "SHA2 last known: 588e921b9d78a99f6f49d468a7b68284c50dabeba95698648ea52e99b381723b"
+echo "SHA2 last known: d0ec19d5b392509955edccf100852bcc9c0e05bf31f1ec25c9cc9c9e74c3b7bf"
 echo "(hashes should match for released versions)"

client_net.ml

@@ -59,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 dns_client packet =
+let input_ipv4 get_ts cache ~iface ~router dns_client dns_servers packet =
   let cache', r = Nat_packet.of_ipv4_packet !cache ~now:(get_ts ()) packet in
   cache := cache';
   match r with
@@ -70,7 +70,7 @@ let input_ipv4 get_ts cache ~iface ~router dns_client 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 dns_client router ~src:iface packet
+    if src = iface#other_ip then Firewall.ipv4_from_client dns_client dns_servers 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);
@@ -78,7 +78,7 @@ let input_ipv4 get_ts cache ~iface ~router dns_client packet =
     )
 
 (** 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 } dns_client ~client_ip ~router ~cleanup_tasks qubesDB =
+let add_vif get_ts { Dao.ClientVif.domid; device_id } dns_client dns_servers ~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 ->
@@ -122,7 +122,7 @@ let add_vif get_ts { Dao.ClientVif.domid; device_id } dns_client ~client_ip ~rou
           | 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 dns_client payload
+              | `IPv4 -> input_ipv4 get_ts fragment_cache ~iface ~router dns_client dns_servers payload
               | `IPv6 -> Lwt.return_unit (* TODO: oh no! *)
         )
         >|= or_raise "Listen on client interface" Netback.pp_error)
@@ -132,13 +132,13 @@ let add_vif get_ts { Dao.ClientVif.domid; device_id } dns_client ~client_ip ~rou
   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 dns_client ~router vif client_ip qubesDB =
+let add_client get_ts dns_client dns_servers ~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);
   Lwt.async (fun () ->
       Lwt.catch (fun () ->
-          add_vif get_ts vif dns_client ~client_ip ~router ~cleanup_tasks qubesDB
+          add_vif get_ts vif dns_client dns_servers ~client_ip ~router ~cleanup_tasks qubesDB
         )
         (fun ex ->
            Log.warn (fun f -> f "Error with client %a: %s"
@@ -149,7 +149,7 @@ let add_client get_ts dns_client ~router vif client_ip qubesDB =
   cleanup_tasks
 
 (** Watch XenStore for notifications of new clients. *)
-let listen get_ts dns_client qubesDB router =
+let listen get_ts dns_client dns_servers qubesDB router =
   Dao.watch_clients (fun new_set ->
     (* Check for removed clients *)
     !clients |> Dao.VifMap.iter (fun key cleanup ->
@@ -162,7 +162,7 @@ let listen get_ts dns_client qubesDB 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 dns_client ~router key ip_addr qubesDB in
+        let cleanup = add_client get_ts dns_client dns_servers ~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

@@ -5,8 +5,8 @@
 
 val listen : (unit -> int64) ->
   ([ `host ] Domain_name.t -> (int32 * Ipaddr.V4.Set.t, [> `Msg of string ]) result Lwt.t) ->
-  Qubes.DB.t -> Router.t -> 'a Lwt.t
+  Ipaddr.V4.t list -> Qubes.DB.t -> Router.t -> 'a Lwt.t
-(** [listen get_timestamp resolver db router] is a thread that watches for clients being added to and
+(** [listen get_timestamp resolver dns_servers db router] is a thread that watches for clients being added to and
     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. *)

dao.ml

@@ -126,6 +126,7 @@ type network_config = {
 
   clients_our_ip : Ipaddr.V4.t;        (* The IP address of our interface to our client VMs (their gateway) *)
   dns : Ipaddr.V4.t;
+  dns2 : Ipaddr.V4.t;
 }
 
 exception Missing_key of string
@@ -139,16 +140,19 @@ let try_read_network_config db =
   let uplink_netvm_ip = get "/qubes-gateway" |> Ipaddr.V4.of_string_exn in
   let clients_our_ip = get "/qubes-netvm-gateway" |> Ipaddr.V4.of_string_exn in
   let dns = get "/qubes-primary-dns" |> Ipaddr.V4.of_string_exn in
+  let dns2 = get "/qubes-secondary-dns" |> Ipaddr.V4.of_string_exn in
   Log.info (fun f -> f "@[<v2>Got network configuration from QubesDB:@,\
                         NetVM IP on uplink network: %a@,\
                         Our IP on uplink network:   %a@,\
                         Our IP on client networks:  %a@,\
-                        DNS resolver:               %a@]"
+                        DNS primary resolver:       %a@,\
+                        DNS secondary resolver:     %a@]"
                Ipaddr.V4.pp uplink_netvm_ip
                Ipaddr.V4.pp uplink_our_ip
                Ipaddr.V4.pp clients_our_ip
-               Ipaddr.V4.pp dns);
+               Ipaddr.V4.pp dns
-  { uplink_netvm_ip; uplink_our_ip; clients_our_ip ; dns }
+               Ipaddr.V4.pp dns2);
+  { uplink_netvm_ip; uplink_our_ip; clients_our_ip ; dns ; dns2 }
 
 let read_network_config qubesDB =
   let rec aux bindings =

dao.mli

@@ -25,6 +25,7 @@ type network_config = {
 
   clients_our_ip : Ipaddr.V4.t;        (* The IP address of our interface to our client VMs (their gateway) *)
   dns : Ipaddr.V4.t;
+  dns2 : Ipaddr.V4.t;
 }
 
 val read_network_config : Qubes.DB.t -> network_config Lwt.t

firewall.ml

@@ -91,7 +91,7 @@ let handle_low_memory t =
       `Memory_critical
   | `Ok -> Lwt.return `Ok
 
-let ipv4_from_client resolver t ~src packet =
+let ipv4_from_client resolver dns_servers t ~src packet =
   handle_low_memory t >>= function
   | `Memory_critical -> Lwt.return_unit
   | `Ok ->
@@ -104,7 +104,7 @@ let ipv4_from_client resolver t ~src packet =
   let dst = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in
   match of_mirage_nat_packet ~src:(`Client src) ~dst packet with
   | None -> Lwt.return_unit
-  | Some firewall_packet -> apply_rules t (Rules.from_client resolver) ~dst firewall_packet
+  | Some firewall_packet -> apply_rules t (Rules.from_client resolver dns_servers) ~dst firewall_packet
 
 let ipv4_from_netvm t packet =
   handle_low_memory t >>= function

firewall.mli

@@ -8,6 +8,6 @@ val ipv4_from_netvm : Router.t -> 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 * Ipaddr.V4.Set.t, [> `Msg of string ]) result Lwt.t) ->
-  Router.t -> src:Fw_utils.client_link -> Nat_packet.t -> unit Lwt.t
+  Ipaddr.V4.t list -> 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. *)

memory_pressure.ml

@@ -36,19 +36,35 @@ let report_mem_usage stats =
     )
   )
 
+let print_mem_usage =
+  let rec aux () =
+    let stats = Xen_os.Memory.quick_stat () in
+    let { Xen_os.Memory.free_words; heap_words; _ } = stats in
+    let mem_total = heap_words * wordsize_in_bytes in
+    let mem_free = free_words * wordsize_in_bytes in
+    Log.info (fun f -> f "Memory usage: free %a / %a (%.2f %%)"
+      Fmt.bi_byte_size mem_free
+      Fmt.bi_byte_size mem_total
+      (fraction_free stats *. 100.0));
+    Xen_os.Time.sleep_ns (Duration.of_f 600.0) >>= fun () ->
+    aux ()
+  in
+  aux ()
+
 let init () =
   Gc.full_major ();
   let stats = Xen_os.Memory.quick_stat () in
+  print_mem_usage ;
   report_mem_usage stats
 
 let status () =
   let stats = Xen_os.Memory.quick_stat () in
-  if fraction_free stats > 0.4 then `Ok
+  if fraction_free stats > 0.5 then `Ok
   else (
     Gc.full_major ();
     Xen_os.Memory.trim ();
     let stats = Xen_os.Memory.quick_stat () in
     report_mem_usage stats;
-    if fraction_free stats < 0.4 then `Memory_critical
+    if fraction_free stats < 0.6 then `Memory_critical
     else `Ok
   )

rules.ml

@@ -10,12 +10,6 @@ module Q = Pf_qubes.Parse_qubes
 let src = Logs.Src.create "rules" ~doc:"Firewall rules"
 module Log = (val Logs.src_log src : Logs.LOG)
 
-(* the upstream NetVM will redirect TCP and UDP port 53 traffic with
-   these destination IPs to its upstream nameserver. *)
-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
 
 module Classifier = struct
@@ -24,9 +18,9 @@ module Classifier = struct
     | None -> true
     | Some (Q.Range_inclusive (min, max)) -> min <= port && port <= max
 
-  let matches_proto rule packet = match rule.Q.proto, rule.Q.specialtarget with
+  let matches_proto rule dns_servers packet = match rule.Q.proto, rule.Q.specialtarget with
     | None, None -> true
-    | None, Some `dns when List.mem packet.ipv4_header.Ipv4_packet.dst default_dns_servers -> begin
+    | None, Some `dns when List.mem packet.ipv4_header.Ipv4_packet.dst 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
@@ -70,39 +64,35 @@ module Classifier = struct
 
 end
 
-let find_first_match dns_client packet acc rule =
+let find_first_match dns_client dns_servers packet acc rule =
   match acc with
   | `No_match ->
-    if Classifier.matches_proto rule packet
+    if Classifier.matches_proto rule dns_servers packet
     then Classifier.matches_dest dns_client rule packet
     else Lwt.return `No_match
   | q -> Lwt.return q
 
 (* Does the packet match our rules? *)
-let classify_client_packet dns_client (packet : ([`Client of Fw_utils.client_link], _) Packet.t)  =
+let classify_client_packet dns_client dns_servers (packet : ([`Client of Fw_utils.client_link], _) Packet.t)  =
   let (`Client client_link) = packet.src in
   let rules = client_link#get_rules in
-  Lwt_list.fold_left_s (find_first_match dns_client packet) `No_match rules >|= function
+  Lwt_list.fold_left_s (find_first_match dns_client dns_servers packet) `No_match rules >|= function
   | `No_match -> `Drop "No matching rule; assuming default drop"
   | `Match {Q.action = Q.Accept; _} -> `Accept
   | `Match ({Q.action = Q.Drop; _} as rule) ->
     `Drop (Format.asprintf "rule number %a explicitly drops this packet" Q.pp_rule rule)
 
-let translate_accepted_packets dns_client packet =
+let translate_accepted_packets dns_client dns_servers packet =
-  classify_client_packet dns_client packet >|= function
+  classify_client_packet dns_client dns_servers packet >|= function
   | `Accept -> `NAT
   | `Drop s -> `Drop s
 
 (** Packets from the private interface that don't match any NAT table entry are being checked against the fw rules here *)
-let from_client dns_client (packet : ([`Client of Fw_utils.client_link], _) Packet.t) : Packet.action Lwt.t =
+let from_client dns_client dns_servers (packet : ([`Client of Fw_utils.client_link], _) Packet.t) : Packet.action Lwt.t =
   match packet with
-  | { dst = `Firewall; transport_header = `UDP header; _ } ->
+  | { dst = `External _ ; _ } | { dst = `NetVM; _ } -> translate_accepted_packets dns_client dns_servers packet
-    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
+  | { dst = `Client _ ; _ } -> classify_client_packet dns_client dns_servers packet
   | _ -> Lwt.return @@ `Drop "could not classify packet"
 
 (** Packets from the outside world that don't match any NAT table entry are being dropped by default *)

unikernel.ml

@@ -13,38 +13,20 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_tim
   module Dns_client = Dns_client.Make(Dns_transport)
 
   (* Set up networking and listen for incoming packets. *)
-  let network dns_client dns_responses uplink qubesDB router =
+  let network dns_client dns_responses dns_servers uplink qubesDB router =
     (* Report success *)
     Dao.set_iptables_error qubesDB "" >>= fun () ->
     (* Handle packets from both networks *)
     Lwt.choose [
-      Client_net.listen Clock.elapsed_ns dns_client qubesDB router;
+      Client_net.listen Clock.elapsed_ns dns_client dns_servers qubesDB 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.
-     If the other end dies, don't let it take us with it (can happen on logout). *)
-  let watch_gui gui =
-    Lwt.async (fun () ->
-      Lwt.try_bind
-        (fun () ->
-           gui >>= fun gui ->
-           Log.info (fun f -> f "GUI agent connected");
-           GUI.listen gui ()
-        )
-        (fun `Cant_happen -> assert false)
-        (fun ex ->
-          Log.warn (fun f -> f "GUI thread failed: %s" (Printexc.to_string ex));
-          Lwt.return_unit
-        )
-    )
-
   (* Main unikernel entry point (called from auto-generated main.ml). *)
   let start _random _clock _time =
     let start_time = Clock.elapsed_ns () in
-    (* Start qrexec agent, GUI agent and QubesDB agent in parallel *)
+    (* Start qrexec 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 *)
@@ -81,10 +63,11 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_tim
 
     let send_dns_query = Uplink.send_dns_client_query uplink in
     let dns_mvar = Lwt_mvar.create_empty () in
-    let nameservers = `Udp, [ config.Dao.dns, 53 ] in
+    let nameservers = `Udp, [ config.Dao.dns, 53 ; config.Dao.dns2, 53 ] in
     let dns_client = Dns_client.create ~nameservers (router, send_dns_query, dns_mvar) in
 
-    let net_listener = network (Dns_client.getaddrinfo dns_client Dns.Rr_map.A) dns_mvar uplink qubesDB router in
+    let dns_servers = [ config.Dao.dns ; config.Dao.dns2 ] in
+    let net_listener = network (Dns_client.getaddrinfo dns_client Dns.Rr_map.A) dns_mvar dns_servers uplink qubesDB router in
 
     (* Report memory usage to XenStore *)
     Memory_pressure.init ();