From 29ddbea03d4f7614d9d5ee2842626f245e7efde6 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 14 Sep 2022 09:42:35 +0200 Subject: [PATCH 1/6] update opam repository to mirage-qubes 0.9.3 release --- Dockerfile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Dockerfile b/Dockerfile index e4aa533..cf6a662 100644 --- a/Dockerfile +++ b/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 From 050c4706e3c2c3705dcf29cf072b72c0f3f91540 Mon Sep 17 00:00:00 2001 From: palainp Date: Fri, 2 Sep 2022 14:27:43 +0200 Subject: [PATCH 2/6] remove gui code, not needed anymore in Qubes 4.1 --- unikernel.ml | 20 +------------------- 1 file changed, 1 insertion(+), 19 deletions(-) diff --git a/unikernel.ml b/unikernel.ml index f4e65fe..6f06efd 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -22,29 +22,11 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_tim 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 *) From 5fdcaae7e84c33c55f17c4be19ea4772c6cfdc3d Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 30 Aug 2022 16:47:27 +0200 Subject: [PATCH 3/6] firewall rule: remove DNS rule (was only needed in Qubes 3) --- rules.ml | 4 ---- 1 file changed, 4 deletions(-) diff --git a/rules.ml b/rules.ml index a70127c..f72d6c0 100644 --- a/rules.ml +++ b/rules.ml @@ -96,10 +96,6 @@ let translate_accepted_packets dns_client packet = (** 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 = match packet with - | { dst = `Firewall; transport_header = `UDP header; _ } -> - 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 From c643f977009c9bd842262a17f8628272aaee1a33 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 7 Sep 2022 16:53:45 +0200 Subject: [PATCH 4/6] in rules, instead of hardcoding IPv4 addresses of name servers, use those present in QubesDB --- client_net.ml | 16 ++++++++-------- client_net.mli | 4 ++-- dao.ml | 10 +++++++--- dao.mli | 1 + firewall.ml | 4 ++-- firewall.mli | 2 +- rules.ml | 28 +++++++++++----------------- unikernel.ml | 9 +++++---- 8 files changed, 37 insertions(+), 37 deletions(-) diff --git a/client_net.ml b/client_net.ml index fc501df..84a1401 100644 --- a/client_net.ml +++ b/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 ) diff --git a/client_net.mli b/client_net.mli index 192fc29..e6254a6 100644 --- a/client_net.mli +++ b/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 -(** [listen get_timestamp resolver db router] is a thread that watches for clients being added to and + Ipaddr.V4.t list -> Qubes.DB.t -> Router.t -> 'a Lwt.t +(** [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. *) diff --git a/dao.ml b/dao.ml index 241a90f..1ef5517 100644 --- a/dao.ml +++ b/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 "@[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); - { uplink_netvm_ip; uplink_our_ip; clients_our_ip ; dns } + Ipaddr.V4.pp 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 = diff --git a/dao.mli b/dao.mli index be6ebb9..2b3d97a 100644 --- a/dao.mli +++ b/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 diff --git a/firewall.ml b/firewall.ml index aecc383..44e6c9b 100644 --- a/firewall.ml +++ b/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 diff --git a/firewall.mli b/firewall.mli index 0141d94..c26cfbe 100644 --- a/firewall.mli +++ b/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. *) diff --git a/rules.ml b/rules.ml index f72d6c0..9210b47 100644 --- a/rules.ml +++ b/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,35 +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 = - classify_client_packet dns_client packet >|= function +let translate_accepted_packets dns_client dns_servers packet = + 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 = `External _ ; _ } | { dst = `NetVM; _ } -> translate_accepted_packets dns_client packet + | { dst = `External _ ; _ } | { dst = `NetVM; _ } -> translate_accepted_packets dns_client dns_servers 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 *) diff --git a/unikernel.ml b/unikernel.ml index 6f06efd..02cb5a3 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -13,12 +13,12 @@ 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 ] @@ -63,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 (); From 9b1b30aa2b45961da406de8a66b16db75b20ba98 Mon Sep 17 00:00:00 2001 From: palainp Date: Mon, 5 Sep 2022 10:01:15 +0200 Subject: [PATCH 5/6] trigger the GC earlier (at < 50% free space) print memory usage every 10 minutes --- build-with-docker.sh | 2 +- memory_pressure.ml | 20 ++++++++++++++++++-- 2 files changed, 19 insertions(+), 3 deletions(-) diff --git a/build-with-docker.sh b/build-with-docker.sh index 821821d..4601514 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: 588e921b9d78a99f6f49d468a7b68284c50dabeba95698648ea52e99b381723b" +echo "SHA2 last known: f77d17444edf299c64f12a62b6a9e2f598d166caf1bb7582dae4cab46f1dcb6d" echo "(hashes should match for released versions)" diff --git a/memory_pressure.ml b/memory_pressure.ml index 665ae14..3b14f4b 100644 --- a/memory_pressure.ml +++ b/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 ) From 6521b1474ca91be30ad4d19db55facee64820a0e Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 14 Sep 2022 10:18:11 +0200 Subject: [PATCH 6/6] update sha256 --- build-with-docker.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/build-with-docker.sh b/build-with-docker.sh index 4601514..0b6e016 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: f77d17444edf299c64f12a62b6a9e2f598d166caf1bb7582dae4cab46f1dcb6d" +echo "SHA2 last known: d0ec19d5b392509955edccf100852bcc9c0e05bf31f1ec25c9cc9c9e74c3b7bf" echo "(hashes should match for released versions)"