Merge pull request #163 from hannesm/next

Next release: 0.8.3

CHANGES.md

@@ -1,3 +1,23 @@
+### 0.8.3 (2022-11-11)
+
+- Fix "DNS issues", a firewall ruleset with a domain name lead to 100% CPU usage
+  (reported by fiftyfourthparallel on
+  https://forum.qubes-os.org/t/mirage-firewall-0-8-2-broken-new-users-should-install-0-8-1/14566,
+  re-reported by @palainp in #158, fixed by @hannesm in mirage/mirage-nat#48
+  (release 3.0.1)) - underlying issue was a wrong definition of `is_port_free`
+  (since 3.0.0, used since mirage-qubes-firewall 0.8.2).
+- Fix "crash on downstream vm start", after more than 64 client VMs have been
+  connected and disconnected with the qubes-mirage-firewall (reported by @xaki23
+  in #155, fixed by @hannesm in #161) - underlying issue was a leak of xenstore
+  watchers and a hard limit in xen on the amount of watchers
+- Fix "detach netvm fails" (reported by @rootnoob in #157, fixed by @palainp
+  in mirage/mirage-net-xen#105 (release 2.1.2)) - underlying issue was that the
+  network interface state was never set to closed, but directly removed
+- Fix potential DoS in handling DNS replies (#162 @hannesm)
+- Avoid potential forever loop in My_nat.free_udp_port (#159 @hannesm)
+- Assorted code removals (#161 @hannesm)
+- Update to dns 6.4.0 changes (#154, @hannesm)
+
 ### 0.8.2 (2022-10-12)
 
 - Advise to use 32 MB memory, which is sufficient (#150, @palainp)

Dockerfile

@@ -11,9 +11,9 @@ 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 7b89f6e5c24cf4076252e71abcbbe4d205705627 && opam update
+RUN cd /home/opam/opam-repository && git fetch origin master && git reset --hard 685eb4efcebfa671660e55d76dea017f00fed4d9 && opam update
 
-RUN opam install -y mirage opam-monorepo
+RUN opam install -y mirage opam-monorepo ocaml-solo5
 RUN mkdir /home/opam/qubes-mirage-firewall
 ADD config.ml /home/opam/qubes-mirage-firewall/config.ml
 WORKDIR /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: 88fdd86993dfbd2e2c4a4d502c350bef091d7831405cf983aebe85f936799f2d"
+echo "SHA2 last known: f499b2379c62917ac32854be63f201e6b90466e645e54dea51e376baccdf26ab"
 echo "(hashes should match for released versions)"

config.ml

@@ -24,11 +24,11 @@ let main =
       package ~min:"2.3.0" ~sublibs:["mirage"] "arp";
       package ~min:"3.0.0" "ethernet";
       package "shared-memory-ring" ~min:"3.0.0";
-      package "netchannel" ~min:"1.11.0";
+      package ~min:"2.1.2" "netchannel";
       package "mirage-net-xen";
       package "ipaddr" ~min:"5.2.0";
       package "mirage-qubes" ~min:"0.9.1";
-      package "mirage-nat" ~min:"3.0.0";
+      package ~min:"3.0.1" "mirage-nat";
       package "mirage-logs";
       package "mirage-xen" ~min:"8.0.0";
       package ~min:"6.4.0" "dns-client";

dao.ml

@@ -65,43 +65,44 @@ let read_rules rules client_ip =
                              icmp_type = None;
                              number = 0;})]
 
-let vifs ~handle domid =
+let vifs client domid =
   match String.to_int domid with
   | None -> Log.err (fun f -> f "Invalid domid %S" domid); Lwt.return []
   | Some domid ->
     let path = Printf.sprintf "backend/vif/%d" domid in
-    directory ~handle path >>=
-    Lwt_list.filter_map_p (fun device_id ->
-        match String.to_int device_id with
-        | None -> Log.err (fun f -> f "Invalid device ID %S for domid %d" device_id domid); Lwt.return_none
-        | Some device_id ->
-        let vif = { ClientVif.domid; device_id } in
-        Lwt.try_bind
-          (fun () -> Xen_os.Xs.read handle (Printf.sprintf "%s/%d/ip" path device_id))
-          (fun client_ip ->
-             let client_ip' = match String.cuts ~sep:" " client_ip with
-               | [] -> Log.err (fun m -> m "unexpected empty list"); ""
-               | [ ip ] -> ip
-               | ip::rest ->
-                 Log.warn (fun m -> m "ignoring IPs %s from %a, we support one IP per client"
-                             (String.concat ~sep:" " rest) ClientVif.pp vif);
-                 ip
-             in
-             match Ipaddr.V4.of_string client_ip' with
-             | Ok ip -> Lwt.return (Some (vif, ip))
-             | Error `Msg msg  ->
-               Log.err (fun f -> f "Error parsing IP address of %a from %s: %s"
-                          ClientVif.pp vif client_ip msg);
-               Lwt.return None
-          )
-          (function
-            | Xs_protocol.Enoent _ -> Lwt.return None
-            | ex ->
-              Log.err (fun f -> f "Error getting IP address of %a: %s"
-                          ClientVif.pp vif (Printexc.to_string ex));
-              Lwt.return None
-          )
-      )
+    Xen_os.Xs.immediate client (fun handle ->
+        directory ~handle path >>=
+        Lwt_list.filter_map_p (fun device_id ->
+            match String.to_int device_id with
+            | None -> Log.err (fun f -> f "Invalid device ID %S for domid %d" device_id domid); Lwt.return_none
+            | Some device_id ->
+              let vif = { ClientVif.domid; device_id } in
+              Lwt.try_bind
+                (fun () -> Xen_os.Xs.read handle (Printf.sprintf "%s/%d/ip" path device_id))
+                (fun client_ip ->
+                   let client_ip' = match String.cuts ~sep:" " client_ip with
+                     | [] -> Log.err (fun m -> m "unexpected empty list"); ""
+                     | [ ip ] -> ip
+                     | ip::rest ->
+                       Log.warn (fun m -> m "ignoring IPs %s from %a, we support one IP per client"
+                                    (String.concat ~sep:" " rest) ClientVif.pp vif);
+                       ip
+                   in
+                   match Ipaddr.V4.of_string client_ip' with
+                   | Ok ip -> Lwt.return (Some (vif, ip))
+                   | Error `Msg msg  ->
+                     Log.err (fun f -> f "Error parsing IP address of %a from %s: %s"
+                                 ClientVif.pp vif client_ip msg);
+                     Lwt.return None
+                )
+                (function
+                  | Xs_protocol.Enoent _ -> Lwt.return None
+                  | ex ->
+                    Log.err (fun f -> f "Error getting IP address of %a: %s"
+                                ClientVif.pp vif (Printexc.to_string ex));
+                    Lwt.return None
+                )
+          ))
 
 let watch_clients fn =
   Xen_os.Xs.make () >>= fun xs ->
@@ -114,7 +115,8 @@ let watch_clients fn =
         | Xs_protocol.Enoent _ -> Lwt.return []
         | ex -> Lwt.fail ex)
     end >>= fun items ->
-    Lwt_list.map_p (vifs ~handle) items >>= fun items ->
+    Xen_os.Xs.make () >>= fun xs ->
+    Lwt_list.map_p (vifs xs) items >>= fun items ->
     fn (List.concat items |> VifMap.of_list);
     (* Wait for further updates *)
     Lwt.fail Xs_protocol.Eagain

fw_utils.ml

@@ -10,14 +10,6 @@ module IpMap = struct
     with Not_found -> None
 end
 
-module Int = struct
-  type t = int
-  let compare (a:t) (b:t) = compare a b
-end
-
-module IntSet = Set.Make(Int)
-module IntMap = Map.Make(Int)
-
 (** An Ethernet interface. *)
 class type interface = object
   method my_mac : Macaddr.t

memory_pressure.ml

@@ -36,21 +36,6 @@ 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

my_dns.ml

@@ -5,24 +5,41 @@ module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) (Time : Mirage_
   type io_addr = Ipaddr.V4.t * int
   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
 
+  module IM = Map.Make(Int)
+
   type t = {
     protocol : Dns.proto ;
     nameserver : io_addr ;
     stack : stack ;
     timeout_ns : int64 ;
+    mutable requests : Cstruct.t Lwt_condition.t IM.t ;
   }
   type context = t
 
   let nameservers { protocol ; nameserver ; _ } = protocol, [ nameserver ]
   let rng = R.generate ?g:None
   let clock = C.elapsed_ns
 
+  let rec read t =
+    let _, _, answer = t.stack in
+    Lwt_mvar.take answer >>= fun (_, data) ->
+    if Cstruct.length data > 2 then begin
+      match IM.find_opt (Cstruct.BE.get_uint16 data 0) t.requests with
+      | Some cond -> Lwt_condition.broadcast cond data
+      | None -> ()
+    end;
+    read t
+
   let create ?nameservers ~timeout stack =
     let protocol, nameserver = match nameservers with
       | None | Some (_, []) -> invalid_arg "no nameserver found"
       | Some (proto, ns :: _) -> proto, ns
     in
-    { protocol ; nameserver ; stack ; timeout_ns = timeout }
+    let t =
+      { protocol ; nameserver ; stack ; timeout_ns = timeout ; requests = IM.empty }
+    in
+    Lwt.async (fun () -> read t);
+    t
 
   let with_timeout timeout_ns f =
     let timeout = Time.sleep_ns timeout_ns >|= fun () -> Error (`Msg "DNS request timeout") in
@@ -32,16 +49,19 @@ module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) (Time : Mirage_
 
   let send_recv (ctx : context) buf : (Cstruct.t, [> `Msg of string ]) result Lwt.t =
     let open Router in
-    let open My_nat in
     let dst, dst_port = ctx.nameserver in
-    let router, send_udp, answer = ctx.stack in
+    let router, send_udp, _ = ctx.stack in
     let src_port, evict =
       My_nat.free_udp_port router.nat ~src:router.uplink#my_ip ~dst ~dst_port:53
     in
+    let id = Cstruct.BE.get_uint16 buf 0 in
     with_timeout ctx.timeout_ns
-      ((send_udp ~src_port ~dst ~dst_port buf >|= Rresult.R.open_error_msg) >>= function
-        | Ok () -> (Lwt_mvar.take answer >|= fun (_, dns_response) -> Ok dns_response)
-        | Error _ as e -> Lwt.return e) >|= fun result ->
+      (let cond = Lwt_condition.create () in
+       ctx.requests <- IM.add id cond ctx.requests;
+       (send_udp ~src_port ~dst ~dst_port buf >|= Rresult.R.open_error_msg) >>= function
+       | Ok () -> Lwt_condition.wait cond >|= fun dns_response -> Ok dns_response
+       | Error _ as e -> Lwt.return e) >|= fun result ->
+    ctx.requests <- IM.remove id ctx.requests;
     evict ();
     result
 

my_nat.ml

@@ -1,8 +1,6 @@
 (* Copyright (C) 2015, Thomas Leonard <[email protected]>
    See the README file for details. *)
 
-open Lwt.Infix
-
 let src = Logs.Src.create "my-nat" ~doc:"NAT shim"
 module Log = (val Logs.src_log src : Logs.LOG)
 
@@ -46,22 +44,25 @@ let pick_free_port t proto =
   go 10
 
 let free_udp_port t ~src ~dst ~dst_port =
-  let rec go () =
-    let src_port =
-      Option.value ~default:t.last_resort_port (pick_free_port t `Udp)
-    in
-    if Nat.is_port_free t.table `Udp ~src ~dst ~src_port ~dst_port then begin
-      let remove =
-        if src_port <> t.last_resort_port then begin
-          t.udp_dns <- S.add src_port t.udp_dns;
-          (fun () -> t.udp_dns <- S.remove src_port t.udp_dns)
-        end else Fun.id
+  let rec go retries =
+    if retries = 0 then
+      t.last_resort_port, Fun.id
+    else
+      let src_port =
+        Option.value ~default:t.last_resort_port (pick_free_port t `Udp)
       in
-      src_port, remove
-    end else
-      go ()
+      if Nat.is_port_free t.table `Udp ~src ~dst ~src_port ~dst_port then begin
+        let remove =
+          if src_port <> t.last_resort_port then begin
+            t.udp_dns <- S.add src_port t.udp_dns;
+            (fun () -> t.udp_dns <- S.remove src_port t.udp_dns)
+          end else Fun.id
+        in
+        src_port, remove
+      end else
+        go (retries - 1)
   in
-  go ()
+  go 10
 
 let dns_port t port = S.mem port t.udp_dns || port = t.last_resort_port
 

uplink.mli

@@ -5,7 +5,6 @@
 
 open Fw_utils
 
-[@@@ocaml.warning "-67"]
 module Make (R: Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_time.S) : sig
   type t