diff --git a/CHANGES.md b/CHANGES.md index 6143c5c..5550cdc 100644 --- a/CHANGES.md +++ b/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) diff --git a/Dockerfile b/Dockerfile index 58cdeae..564f56e 100644 --- a/Dockerfile +++ b/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 diff --git a/build-with-docker.sh b/build-with-docker.sh index 9a312a2..e3ddce7 100755 --- a/build-with-docker.sh +++ b/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)" diff --git a/config.ml b/config.ml index 5d3c532..314172f 100644 --- a/config.ml +++ b/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"; diff --git a/dao.ml b/dao.ml index 1ef5517..1c3785e 100644 --- a/dao.ml +++ b/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 diff --git a/fw_utils.ml b/fw_utils.ml index 3d547af..ffb58dc 100644 --- a/fw_utils.ml +++ b/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 diff --git a/memory_pressure.ml b/memory_pressure.ml index 629ecda..2e9e95a 100644 --- a/memory_pressure.ml +++ b/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 diff --git a/my_dns.ml b/my_dns.ml index 35fbb8d..372c29a 100644 --- a/my_dns.ml +++ b/my_dns.ml @@ -5,11 +5,14 @@ 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 @@ -17,12 +20,26 @@ module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) (Time : Mirage_ 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 diff --git a/my_nat.ml b/my_nat.ml index 209a562..1e86c2d 100644 --- a/my_nat.ml +++ b/my_nat.ml @@ -1,8 +1,6 @@ (* Copyright (C) 2015, Thomas Leonard 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 diff --git a/uplink.mli b/uplink.mli index 0052d75..f6edaaf 100644 --- a/uplink.mli +++ b/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