From c11f245d643ee5b5ee2d530009123b589f7ca7b5 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Sun, 26 Jun 2016 12:04:47 +0100 Subject: [PATCH 001/281] Cope with writing a frame failing If a client disconnects suddenly then we may get an error trying to map its grant to send the frame. Fixes #8. --- firewall.ml | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/firewall.ml b/firewall.ml index 97ce185..4b98302 100644 --- a/firewall.ml +++ b/firewall.ml @@ -16,7 +16,14 @@ let transmit ~frame iface = cases. *) let frame = fixup_checksums frame |> Cstruct.concat in let packet = Cstruct.shift frame Wire_structs.sizeof_ethernet in - iface#writev [packet] + Lwt.catch + (fun () -> iface#writev [packet]) + (fun ex -> + Log.warn (fun f -> f "Failed to write packet to %a: %s" + Ipaddr.V4.pp_hum iface#other_ip + (Printexc.to_string ex)); + Lwt.return () + ) let forward_ipv4 t frame = let packet = Cstruct.shift frame Wire_structs.sizeof_ethernet in From a7001a70d2f1f929323b7b53101b1638b60a6bc0 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Sun, 25 Sep 2016 14:38:17 +0100 Subject: [PATCH 002/281] Allow clients to have any IP address We previously assumed that Qubes would always give clients IP addresses on a particular network. However, it is not required to do this and in fact uses a different network for disposable VMs. With this change: - We no longer reject clients with unknown IP addresses - The `Unknown_client` classification is gone; we have no way to tell the difference between a client that isn't connected and an external address. - We now consider every client to be on a point-to-point link and do not answer ARP requests on behalf of other clients. Clients should assume their netmask is 255.255.255.255 (and ignore /qubes-netmask). This is a partial fix for #9. It allows disposable VMs to connect to the firewall but for some reason they don't process any frames we send them (we get their ARP requests but they don't get our replies). Taking eth0 down in the disp VM, then bringing it back up (and re-adding the routes) allows it to work. --- _tags | 1 - client_eth.ml | 19 +++++++++---------- client_eth.mli | 24 ++++++++++++------------ dao.ml | 8 +------- dao.mli | 1 - firewall.ml | 5 +---- packet.ml | 2 +- router.ml | 11 +++-------- rules.ml | 1 - unikernel.ml | 5 +---- 10 files changed, 28 insertions(+), 49 deletions(-) diff --git a/_tags b/_tags index 69adb29..7441bd2 100644 --- a/_tags +++ b/_tags @@ -1,3 +1,2 @@ not : warn(A-4), strict_sequence : package(cstruct.syntax) -true: -syntax(camlp4o) diff --git a/client_eth.ml b/client_eth.ml index af0f299..d027134 100644 --- a/client_eth.ml +++ b/client_eth.ml @@ -1,32 +1,28 @@ -(* Copyright (C) 2015, Thomas Leonard +(* Copyright (C) 2016, Thomas Leonard See the README file for details. *) open Utils -let src = Logs.Src.create "client_eth" ~doc:"Ethernet for NetVM clients" +let src = Logs.Src.create "client_eth" ~doc:"Ethernet networks for NetVM clients" module Log = (val Logs.src_log src : Logs.LOG) type t = { mutable iface_of_ip : client_link IpMap.t; - prefix : Ipaddr.V4.Prefix.t; client_gw : Ipaddr.V4.t; (* The IP that clients are given as their default gateway. *) } type host = [ `Client of client_link - | `Unknown_client of Ipaddr.t | `Client_gateway | `External of Ipaddr.t ] -let create ~prefix ~client_gw = - { iface_of_ip = IpMap.empty; client_gw; prefix } +let create ~client_gw = + { iface_of_ip = IpMap.empty; client_gw } -let prefix t = t.prefix let client_gw t = t.client_gw let add_client t iface = let ip = iface#other_ip in - assert (Ipaddr.V4.Prefix.mem ip t.prefix); (* TODO: Should probably wait for the previous client to disappear. *) (* assert (not (IpMap.mem ip t.iface_of_ip)); *) t.iface_of_ip <- t.iface_of_ip |> IpMap.add ip iface @@ -45,13 +41,11 @@ let classify t ip = if ip4 = t.client_gw then `Client_gateway else match lookup t ip4 with | Some client_link -> `Client client_link - | None when Ipaddr.V4.Prefix.mem ip4 t.prefix -> `Unknown_client ip | None -> `External ip let resolve t : host -> Ipaddr.t = function | `Client client_link -> Ipaddr.V4 client_link#other_ip | `Client_gateway -> Ipaddr.V4 t.client_gw - | `Unknown_client addr | `External addr -> addr module ARP = struct @@ -62,9 +56,14 @@ module ARP = struct let lookup t ip = if ip = t.net.client_gw then Some t.client_link#my_mac + else None + (* We're now treating client networks as point-to-point links, + so we no longer respond on behalf of other clients. *) + (* else match IpMap.find ip t.net.iface_of_ip with | Some client_iface -> Some client_iface#other_mac | None -> None + *) let create ~net client_link = {net; client_link} diff --git a/client_eth.mli b/client_eth.mli index 45203ae..cd8ccfe 100644 --- a/client_eth.mli +++ b/client_eth.mli @@ -1,34 +1,36 @@ -(* Copyright (C) 2015, Thomas Leonard +(* Copyright (C) 2016, Thomas Leonard See the README file for details. *) -(** The ethernet network our client AppVMs are on. *) +(** The ethernet networks connecting us to our client AppVMs. + Note: each AppVM is on a point-to-point link, each link being considered to be a separate Ethernet network. *) open Utils type t -(** A network for client AppVMs to join. *) +(** A collection of clients. *) type host = [ `Client of client_link - | `Unknown_client of Ipaddr.t | `Client_gateway | `External of Ipaddr.t ] +(* Note: Qubes does not allow us to distinguish between an external address and a + disconnected client. + See: https://github.com/talex5/qubes-mirage-firewall/issues/9#issuecomment-246956850 *) -val create : prefix:Ipaddr.V4.Prefix.t -> client_gw:Ipaddr.V4.t -> t -(** [create ~prefix ~client_gw] is a network of client machines. - Their IP addresses all start with [prefix] and they are configured to - use [client_gw] as their default gateway. *) +val create : client_gw:Ipaddr.V4.t -> t +(** [create ~client_gw] is a network of client machines. + Qubes will have configured the client machines to use [client_gw] as their default gateway. *) val add_client : t -> client_link -> unit val remove_client : t -> client_link -> unit -val prefix : t -> Ipaddr.V4.Prefix.t val client_gw : t -> Ipaddr.V4.t val classify : t -> Ipaddr.t -> host val resolve : t -> host -> Ipaddr.t val lookup : t -> Ipaddr.V4.t -> client_link option +(** [lookup t addr] is the client with IP address [addr], if connected. *) module ARP : sig (** We already know the correct mapping of IP addresses to MAC addresses, so we never @@ -40,9 +42,7 @@ module ARP : sig val create : net:t -> client_link -> arp (** [create ~net client_link] is an ARP responder for [client_link]. - It answers on behalf of other clients in [net] (but not for the client - itself, since the client might be trying to check that its own address is - free). It also answers for the client's gateway address. *) + It answers only for the client's gateway address. *) val input : arp -> Cstruct.t -> Cstruct.t option (** Process one ethernet frame containing an ARP message. diff --git a/dao.ml b/dao.ml index 972d2e9..f0ab65b 100644 --- a/dao.ml +++ b/dao.ml @@ -44,7 +44,6 @@ type network_config = { uplink_netvm_ip : Ipaddr.V4.t; (* The IP address of NetVM (our gateway) *) uplink_our_ip : Ipaddr.V4.t; (* The IP address of our interface to NetVM *) - clients_prefix : Ipaddr.V4.Prefix.t; (* The network connecting our client VMs to us *) clients_our_ip : Ipaddr.V4.t; (* The IP address of our interface to our client VMs (their gateway) *) } @@ -56,12 +55,7 @@ let read_network_config qubesDB = | Some value -> value in let uplink_our_ip = get "/qubes-ip" |> Ipaddr.V4.of_string_exn in let uplink_netvm_ip = get "/qubes-gateway" |> Ipaddr.V4.of_string_exn in - let clients_prefix = - (* This is oddly named: seems to be the network we provide to our clients *) - let client_network = get "/qubes-netvm-network" |> Ipaddr.V4.of_string_exn in - let client_netmask = get "/qubes-netvm-netmask" |> Ipaddr.V4.of_string_exn in - Ipaddr.V4.Prefix.of_netmask client_netmask client_network in let clients_our_ip = get "/qubes-netvm-gateway" |> Ipaddr.V4.of_string_exn in - { uplink_netvm_ip; uplink_our_ip; clients_prefix; clients_our_ip } + { uplink_netvm_ip; uplink_our_ip; clients_our_ip } let set_iptables_error db = Qubes.DB.write db "/qubes-iptables-error" diff --git a/dao.mli b/dao.mli index adf036a..c0f2862 100644 --- a/dao.mli +++ b/dao.mli @@ -22,7 +22,6 @@ type network_config = { uplink_netvm_ip : Ipaddr.V4.t; (* The IP address of NetVM (our gateway) *) uplink_our_ip : Ipaddr.V4.t; (* The IP address of our interface to NetVM *) - clients_prefix : Ipaddr.V4.Prefix.t; (* The network connecting our client VMs to us *) clients_our_ip : Ipaddr.V4.t; (* The IP address of our interface to our client VMs (their gateway) *) } diff --git a/firewall.ml b/firewall.ml index 4b98302..cdfd977 100644 --- a/firewall.ml +++ b/firewall.ml @@ -155,9 +155,6 @@ let apply_rules t rules info = match rules info, info.dst with | `Accept, `Client client_link -> transmit ~frame client_link | `Accept, (`External _ | `NetVM) -> transmit ~frame t.Router.uplink - | `Accept, `Unknown_client _ -> - Log.warn (fun f -> f "Dropping packet to unknown client %a" pp_packet info); - return () | `Accept, (`Firewall_uplink | `Client_gateway) -> Log.warn (fun f -> f "Bad rule: firewall can't accept packets %a" pp_packet info); return () @@ -196,7 +193,7 @@ let ipv4_from_netvm t frame = | None -> return () | Some info -> match info.src with - | `Client _ | `Unknown_client _ | `Firewall_uplink | `Client_gateway -> + | `Client _ | `Firewall_uplink | `Client_gateway -> Log.warn (fun f -> f "Frame from NetVM has internal source IP address! %a" pp_packet info); return () | `External _ | `NetVM -> diff --git a/packet.ml b/packet.ml index bf9f062..a359e16 100644 --- a/packet.ml +++ b/packet.ml @@ -11,7 +11,7 @@ type ports = { } type host = - [ `Client of client_link | `Unknown_client of Ipaddr.t | `Client_gateway | `Firewall_uplink | `NetVM | `External of Ipaddr.t ] + [ `Client of client_link | `Client_gateway | `Firewall_uplink | `NetVM | `External of Ipaddr.t ] type info = { frame : Cstruct.t; diff --git a/router.ml b/router.ml index e86d38b..8e1dc44 100644 --- a/router.ml +++ b/router.ml @@ -21,14 +21,9 @@ let create ~client_eth ~uplink = let target t buf = let open Wire_structs.Ipv4_wire in let dst_ip = get_ipv4_dst buf |> Ipaddr.V4.of_int32 in - if Ipaddr.V4.Prefix.mem dst_ip (Client_eth.prefix t.client_eth) then ( - match Client_eth.lookup t.client_eth dst_ip with - | Some client_link -> Some (client_link :> interface) - | None -> - Log.warn (fun f -> f "Packet to unknown internal client %a - dropping" - Ipaddr.V4.pp_hum dst_ip); - None - ) else Some t.uplink + match Client_eth.lookup t.client_eth dst_ip with + | Some client_link -> Some (client_link :> interface) + | None -> Some t.uplink let add_client t = Client_eth.add_client t.client_eth let remove_client t = Client_eth.remove_client t.client_eth diff --git a/rules.ml b/rules.ml index a2e86ae..7e62790 100644 --- a/rules.ml +++ b/rules.ml @@ -32,7 +32,6 @@ let from_client = function | { dst = `Client_gateway; proto = `UDP { dport = 53 } } -> `NAT_to (`NetVM, 53) | { dst = (`Client_gateway | `Firewall_uplink) } -> `Drop "packet addressed to firewall itself" | { dst = `Client _ } -> `Drop "prevent communication between client VMs" - | { dst = `Unknown_client _ } -> `Drop "target client not running" (** 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. *) diff --git a/unikernel.ml b/unikernel.ml index d64274f..e03380b 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -14,16 +14,13 @@ module Main (Clock : V1.CLOCK) = struct let network qubesDB = (* Read configuration from QubesDB *) let config = Dao.read_network_config qubesDB in - Logs.info (fun f -> f "Client (internal) network is %a" - Ipaddr.V4.Prefix.pp_hum config.Dao.clients_prefix); (* Initialise connection to NetVM *) Uplink.connect config >>= fun uplink -> (* Report success *) Dao.set_iptables_error qubesDB "" >>= fun () -> (* Set up client-side networking *) let client_eth = Client_eth.create - ~client_gw:config.Dao.clients_our_ip - ~prefix:config.Dao.clients_prefix in + ~client_gw:config.Dao.clients_our_ip in (* Set up routing between networks and hosts *) let router = Router.create ~client_eth From 63cbb4bed066a53cc781631532f541e915307182 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Sun, 25 Sep 2016 15:14:16 +0100 Subject: [PATCH 003/281] Ensure that old client has quit before adding new one Not sure if this can happen, but it removes a TODO from the code. --- client_eth.ml | 24 +++++++++++++++++++----- client_eth.mli | 5 ++++- client_net.ml | 2 +- router.mli | 5 ++--- 4 files changed, 26 insertions(+), 10 deletions(-) diff --git a/client_eth.ml b/client_eth.ml index d027134..f30f69c 100644 --- a/client_eth.ml +++ b/client_eth.ml @@ -2,12 +2,14 @@ See the README file for details. *) open Utils +open Lwt.Infix let src = Logs.Src.create "client_eth" ~doc:"Ethernet networks for NetVM clients" module Log = (val Logs.src_log src : Logs.LOG) type t = { mutable iface_of_ip : client_link IpMap.t; + changed : unit Lwt_condition.t; (* Fires when [iface_of_ip] changes. *) client_gw : Ipaddr.V4.t; (* The IP that clients are given as their default gateway. *) } @@ -17,20 +19,32 @@ type host = | `External of Ipaddr.t ] let create ~client_gw = - { iface_of_ip = IpMap.empty; client_gw } + let changed = Lwt_condition.create () in + { iface_of_ip = IpMap.empty; client_gw; changed } let client_gw t = t.client_gw let add_client t iface = let ip = iface#other_ip in - (* TODO: Should probably wait for the previous client to disappear. *) - (* assert (not (IpMap.mem ip t.iface_of_ip)); *) - t.iface_of_ip <- t.iface_of_ip |> IpMap.add ip iface + let rec aux () = + if IpMap.mem ip t.iface_of_ip then ( + (* Wait for old client to disappear before adding one with the same IP address. + Otherwise, its [remove_client] call will remove the new client instead. *) + Log.info (fun f -> f "Waiting for old client %a to go away before accepting new one" Ipaddr.V4.pp_hum ip); + Lwt_condition.wait t.changed >>= aux + ) else ( + t.iface_of_ip <- t.iface_of_ip |> IpMap.add ip iface; + Lwt_condition.broadcast t.changed (); + Lwt.return_unit + ) + in + aux () let remove_client t iface = let ip = iface#other_ip in assert (IpMap.mem ip t.iface_of_ip); - t.iface_of_ip <- t.iface_of_ip |> IpMap.remove ip + t.iface_of_ip <- t.iface_of_ip |> IpMap.remove ip; + Lwt_condition.broadcast t.changed () let lookup t ip = IpMap.find ip t.iface_of_ip diff --git a/client_eth.mli b/client_eth.mli index cd8ccfe..41746d3 100644 --- a/client_eth.mli +++ b/client_eth.mli @@ -21,7 +21,10 @@ val create : client_gw:Ipaddr.V4.t -> t (** [create ~client_gw] is a network of client machines. Qubes will have configured the client machines to use [client_gw] as their default gateway. *) -val add_client : t -> client_link -> unit +val add_client : t -> client_link -> unit Lwt.t +(** [add_client t client] registers a new client. If a client with this IP address is already registered, + it waits for [remove_client] to be called on that before adding the new client and returning. *) + val remove_client : t -> client_link -> unit val client_gw : t -> Ipaddr.V4.t diff --git a/client_net.ml b/client_net.ml index 0c84921..ebb6851 100644 --- a/client_net.ml +++ b/client_net.ml @@ -50,7 +50,7 @@ let add_vif { Dao.domid; device_id; client_ip } ~router ~cleanup_tasks = let client_eth = router.Router.client_eth in let gateway_ip = Client_eth.client_gw client_eth in let iface = new client_iface eth ~gateway_ip ~client_ip client_mac in - Router.add_client router iface; + Router.add_client router iface >>= fun () -> Cleanup.on_cleanup cleanup_tasks (fun () -> Router.remove_client router iface); let fixed_arp = Client_eth.ARP.create ~net:client_eth iface in Netback.listen backend (fun frame -> diff --git a/router.mli b/router.mli index 8743b57..ac743d3 100644 --- a/router.mli +++ b/router.mli @@ -22,9 +22,8 @@ val create : val target : t -> Cstruct.t -> interface option (** [target t packet] is the interface to which [packet] (an IP packet) should be routed. *) -val add_client : t -> client_link -> unit -(** [add_client t iface] adds a rule for routing packets addressed to [iface]. - The client's IP address must be within the [client_eth] passed to [create]. *) +val add_client : t -> client_link -> unit Lwt.t +(** [add_client t iface] adds a rule for routing packets addressed to [iface]. *) val remove_client : t -> client_link -> unit From 9c33da3bfd2d9cf142c20f4c1e5726c0b3274abb Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Sun, 25 Sep 2016 15:25:51 +0100 Subject: [PATCH 004/281] Handle errors writing to client mirage-net-xen would report Netback_shutdown if we tried to write to a client after it had disconnected. Now we just log this and continue. --- client_net.ml | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/client_net.ml b/client_net.ml index ebb6851..5de5fa2 100644 --- a/client_net.ml +++ b/client_net.ml @@ -7,9 +7,19 @@ open Utils module Netback = Netchannel.Backend.Make(Netchannel.Xenstore.Make(OS.Xs)) module ClientEth = Ethif.Make(Netback) -let src = Logs.Src.create "net" ~doc:"Client networking" +let src = Logs.Src.create "client_net" ~doc:"Client networking" module Log = (val Logs.src_log src : Logs.LOG) +let writev eth data = + Lwt.catch + (fun () -> ClientEth.writev eth data) + (fun ex -> + (* Usually Netback_shutdown, because the client disconnected *) + Log.err (fun f -> f "uncaught exception trying to send to client:@\n@[ %a@]@\nException: @[%s@]" + Cstruct.hexdump_pp (Cstruct.concat data) (Printexc.to_string ex)); + Lwt.return () + ) + class client_iface eth ~gateway_ip ~client_ip client_mac : client_link = object val queue = FrameQ.create (Ipaddr.V4.to_string client_ip) method my_mac = ClientEth.mac eth @@ -19,7 +29,7 @@ class client_iface eth ~gateway_ip ~client_ip client_mac : client_link = object method writev ip = FrameQ.send queue (fun () -> let eth_hdr = eth_header_ipv4 ~src:(ClientEth.mac eth) ~dst:client_mac in - ClientEth.writev eth (fixup_checksums (Cstruct.concat (eth_hdr :: ip))) + writev eth (fixup_checksums (Cstruct.concat (eth_hdr :: ip))) ) end @@ -29,7 +39,7 @@ let clients : Cleanup.t IntMap.t ref = ref IntMap.empty let input_arp ~fixed_arp ~eth request = match Client_eth.ARP.input fixed_arp request with | None -> return () - | Some response -> ClientEth.write eth response + | Some response -> writev eth [response] (** Handle an IPv4 packet from the client. *) let input_ipv4 ~client_ip ~router frame packet = From 79092e1463a807b5e4aac335ed7e92ccdb99674f Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Sat, 1 Oct 2016 10:47:19 +0100 Subject: [PATCH 005/281] Avoid using Lwt.join on listening threads Lwt.join only reports an error if *both* threads fail. --- unikernel.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unikernel.ml b/unikernel.ml index e03380b..9e5eba3 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -26,7 +26,7 @@ module Main (Clock : V1.CLOCK) = struct ~client_eth ~uplink:(Uplink.interface uplink) in (* Handle packets from both networks *) - Lwt.join [ + Lwt.choose [ Client_net.listen router; Uplink.listen uplink router ] From 312627e078240a6db64793dcae7411cc93253492 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Sat, 1 Oct 2016 14:42:27 +0100 Subject: [PATCH 006/281] Monitor set of client interfaces, not client domains Qubes does not remove the client directory itself when the domain exits. Combined with 63cbb4bed0, this prevented clients from reconnecting. This may also make it possible to connect clients to the firewall via multiple interfaces, although this doesn't seem useful. --- client_net.ml | 50 ++++++++++++++------------------- dao.ml | 77 ++++++++++++++++++++++++++++++++++++++------------- dao.mli | 27 +++++++++--------- 3 files changed, 92 insertions(+), 62 deletions(-) diff --git a/client_net.ml b/client_net.ml index 5de5fa2..ca39938 100644 --- a/client_net.ml +++ b/client_net.ml @@ -33,7 +33,7 @@ class client_iface eth ~gateway_ip ~client_ip client_mac : client_link = object ) end -let clients : Cleanup.t IntMap.t ref = ref IntMap.empty +let clients : Cleanup.t Dao.VifMap.t ref = ref Dao.VifMap.empty (** Handle an ARP message from the client. *) let input_arp ~fixed_arp ~eth request = @@ -52,7 +52,7 @@ let input_ipv4 ~client_ip ~router frame packet = ) (** Connect to a new client's interface and listen for incoming frames. *) -let add_vif { Dao.domid; device_id; client_ip } ~router ~cleanup_tasks = +let add_vif { Dao.ClientVif.domid; device_id } ~client_ip ~router ~cleanup_tasks = 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 >>= or_fail "Can't make Ethernet device" >>= fun eth -> @@ -75,45 +75,37 @@ let add_vif { Dao.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 domid = +let add_client ~router vif client_ip = let cleanup_tasks = Cleanup.create () in - Log.info (fun f -> f "add client domain %d" domid); + Log.info (fun f -> f "add client vif %a" Dao.ClientVif.pp vif); Lwt.async (fun () -> - Lwt.catch (fun () -> - Dao.client_vifs domid >>= function - | [] -> - Log.warn (fun f -> f "Client has no interfaces"); - return () - | vif :: others -> - if others <> [] then Log.warn (fun f -> f "Client has multiple interfaces; using first"); - add_vif vif ~router ~cleanup_tasks - ) - (fun ex -> - Log.warn (fun f -> f "Error connecting client domain %d: %s" - domid (Printexc.to_string ex)); - return () - ) - ); + Lwt.catch (fun () -> + add_vif vif ~client_ip ~router ~cleanup_tasks + ) + (fun ex -> + Log.warn (fun f -> f "Error connecting client %a: %s" + Dao.ClientVif.pp vif (Printexc.to_string ex)); + return () + ) + ); cleanup_tasks (** Watch XenStore for notifications of new clients. *) let listen router = - let backend_vifs = "backend/vif" in - Log.info (fun f -> f "Watching %s" backend_vifs); Dao.watch_clients (fun new_set -> (* Check for removed clients *) - !clients |> IntMap.iter (fun key cleanup -> - if not (IntSet.mem key new_set) then ( - clients := !clients |> IntMap.remove key; - Log.info (fun f -> f "client %d has gone" key); + !clients |> Dao.VifMap.iter (fun key cleanup -> + if not (Dao.VifMap.mem key new_set) then ( + clients := !clients |> Dao.VifMap.remove key; + Log.info (fun f -> f "client %a has gone" Dao.ClientVif.pp key); Cleanup.cleanup cleanup ) ); (* Check for added clients *) - new_set |> IntSet.iter (fun key -> - if not (IntMap.mem key !clients) then ( - let cleanup = add_client ~router key in - clients := !clients |> IntMap.add key cleanup + new_set |> Dao.VifMap.iter (fun key ip_addr -> + if not (Dao.VifMap.mem key !clients) then ( + let cleanup = add_client ~router key ip_addr in + clients := !clients |> Dao.VifMap.add key cleanup ) ) ) diff --git a/dao.ml b/dao.ml index f0ab65b..dd22735 100644 --- a/dao.ml +++ b/dao.ml @@ -4,38 +4,75 @@ open Lwt.Infix open Utils open Qubes +open Astring -type client_vif = { - domid : int; - device_id : int; - client_ip : Ipaddr.V4.t; -} +let src = Logs.Src.create "dao" ~doc:"QubesDB data access" +module Log = (val Logs.src_log src : Logs.LOG) -let client_vifs domid = - let path = Printf.sprintf "backend/vif/%d" domid in - OS.Xs.make () >>= fun xs -> - OS.Xs.immediate xs (fun h -> - OS.Xs.directory h path >>= - Lwt_list.map_p (fun device_id -> - let device_id = int_of_string device_id in - OS.Xs.read h (Printf.sprintf "%s/%d/ip" path device_id) >|= fun client_ip -> - let client_ip = Ipaddr.V4.of_string_exn client_ip in - { domid; device_id; client_ip } - ) - ) +module ClientVif = struct + type t = { + domid : int; + device_id : int; + } + + let pp f { domid; device_id } = Fmt.pf f "{domid=%d;device_id=%d}" domid device_id + + let compare = compare +end +module VifMap = struct + include Map.Make(ClientVif) + let rec of_list = function + | [] -> empty + | (k, v) :: rest -> add k v (of_list rest) + let find key t = + try Some (find key t) + with Not_found -> None +end + +let directory ~handle dir = + OS.Xs.directory handle dir >|= function + | [""] -> [] (* XenStore client bug *) + | items -> items + +let vifs ~handle 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 () -> OS.Xs.read handle (Printf.sprintf "%s/%d/ip" path device_id)) + (fun client_ip -> + let client_ip = Ipaddr.V4.of_string_exn client_ip in + Lwt.return (Some (vif, client_ip)) + ) + (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 = OS.Xs.make () >>= fun xs -> let backend_vifs = "backend/vif" in + Log.info (fun f -> f "Watching %s" backend_vifs); OS.Xs.wait xs (fun handle -> begin Lwt.catch - (fun () -> OS.Xs.directory handle backend_vifs) + (fun () -> directory ~handle backend_vifs) (function | Xs_protocol.Enoent _ -> return [] | ex -> fail ex) end >>= fun items -> - let items = items |> List.fold_left (fun acc key -> IntSet.add (int_of_string key) acc) IntSet.empty in - fn items; + Lwt_list.map_p (vifs ~handle) items >>= fun items -> + fn (List.concat items |> VifMap.of_list); (* Wait for further updates *) fail Xs_protocol.Eagain ) diff --git a/dao.mli b/dao.mli index c0f2862..e1b96c6 100644 --- a/dao.mli +++ b/dao.mli @@ -3,20 +3,21 @@ (** Wrapper for XenStore and QubesDB databases. *) -open Utils +module ClientVif : sig + type t = { + domid : int; + device_id : int; + } + val pp : t Fmt.t +end +module VifMap : sig + include Map.S with type key = ClientVif.t + val find : key -> 'a t -> 'a option +end -type client_vif = { - domid : int; - device_id : int; - client_ip : Ipaddr.V4.t; -} - -val watch_clients : (IntSet.t -> unit) -> 'a Lwt.t -(** [watch_clients fn] calls [fn clients] with the current set of backend client domain IDs - in XenStore, and again each time the set changes. *) - -val client_vifs : int -> client_vif list Lwt.t -(** [client_vif domid] is the list of network interfaces to the client VM [domid]. *) +val watch_clients : (Ipaddr.V4.t VifMap.t -> unit) -> 'a Lwt.t +(** [watch_clients fn] calls [fn clients] with the list of backend clients + in XenStore, and again each time XenStore updates. *) type network_config = { uplink_netvm_ip : Ipaddr.V4.t; (* The IP address of NetVM (our gateway) *) From d6074f2271eb3acd1cbd1538444c4c7929b2dcb1 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Mon, 9 Jan 2017 16:45:16 +0000 Subject: [PATCH 007/281] Add option to build with Docker --- .dockerignore | 2 ++ Dockerfile | 10 ++++++++++ README.md | 18 +++++++++++++++++- build-with-docker.sh | 4 ++++ 4 files changed, 33 insertions(+), 1 deletion(-) create mode 100644 .dockerignore create mode 100644 Dockerfile create mode 100755 build-with-docker.sh diff --git a/.dockerignore b/.dockerignore new file mode 100644 index 0000000..5fde600 --- /dev/null +++ b/.dockerignore @@ -0,0 +1,2 @@ +.git +_build diff --git a/Dockerfile b/Dockerfile new file mode 100644 index 0000000..097b564 --- /dev/null +++ b/Dockerfile @@ -0,0 +1,10 @@ +FROM ocaml/opam:debian-8_ocaml-4.03.0 +RUN sudo apt-get install -y m4 libxen-dev +RUN opam install -y vchan xen-gnt mirage-xen-ocaml mirage-xen-minios io-page mirage-xen mirage +RUN opam pin add -n -y mirage-nat 'https://github.com/talex5/mirage-nat.git#simplify-checksum' +RUN mkdir /home/opam/qubes-mirage-firewall +ADD config.ml /home/opam/qubes-mirage-firewall/config.ml +WORKDIR /home/opam/qubes-mirage-firewall +RUN opam config exec -- mirage configure --xen +CMD opam config exec -- mirage configure --xen --no-opam && \ + opam config exec -- make tar diff --git a/README.md b/README.md index a62ed36..2fc182a 100644 --- a/README.md +++ b/README.md @@ -7,11 +7,25 @@ Note: This firewall *ignores the rules set in the Qubes GUI*. See `rules.ml` for See [A Unikernel Firewall for QubesOS][] for more details. +## Build (with Docker) + +Clone this Git repository and run the `build-with-docker.sh` script: + + sudo yum install docker + sudo systemctl start docker + git clone https://github.com/talex5/qubes-mirage-firewall.git + cd qubes-mirage-firewall + ./build-with-docker.sh + +This took about 10 minutes on my laptop (it will be much quicker if you run it again). + +## Build (without Docker) + To build (tested by creating a fresh Fedora 23 AppVM in Qubes): 1. Install build tools: - sudo yum install git gcc m4 0install patch ncurses-devel + sudo yum install git gcc m4 0install patch ncurses-devel tar bzip2 unzip make which findutils xen-devel mkdir ~/bin 0install add opam http://tools.ocaml.org/opam.xml opam init --comp=4.02.3 @@ -29,6 +43,8 @@ To build (tested by creating a fresh Fedora 23 AppVM in Qubes): mirage configure --xen make +## Deploy + If you want to deploy manually, use `make tar` to create `mirage-firewall.tar.bz2` and unpack this in dom0, inside `/var/lib/qubes/vm-kernels/`. e.g. (if `dev` is the AppVM where you built it): [tal@dom0 ~]$ cd /var/lib/qubes/vm-kernels/ diff --git a/build-with-docker.sh b/build-with-docker.sh new file mode 100755 index 0000000..31f85f4 --- /dev/null +++ b/build-with-docker.sh @@ -0,0 +1,4 @@ +#!/bin/sh +set -eux +docker build -t qubes-mirage-firewall . +docker run --rm -i -v `pwd`:/home/opam/qubes-mirage-firewall qubes-mirage-firewall From 07ff3d61477383860216c69869a1ffee59145e45 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Sat, 28 Jan 2017 13:44:21 +0000 Subject: [PATCH 008/281] Fix opam-repository commit for reproducible builds Also, display the actual and expected SHA hashes after building. --- Dockerfile | 5 +++++ build-with-docker.sh | 6 +++++- 2 files changed, 10 insertions(+), 1 deletion(-) diff --git a/Dockerfile b/Dockerfile index 097b564..9424fc7 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,4 +1,9 @@ FROM ocaml/opam:debian-8_ocaml-4.03.0 + +# Pin last known-good version for reproducible builds. +# Remove this line if you want to test with the latest versions. +RUN cd opam-repository && git reset --hard 0f17b354206c97e729700ce60ddce3789ccb1d52 && opam update + RUN sudo apt-get install -y m4 libxen-dev RUN opam install -y vchan xen-gnt mirage-xen-ocaml mirage-xen-minios io-page mirage-xen mirage RUN opam pin add -n -y mirage-nat 'https://github.com/talex5/mirage-nat.git#simplify-checksum' diff --git a/build-with-docker.sh b/build-with-docker.sh index 31f85f4..d61f13c 100755 --- a/build-with-docker.sh +++ b/build-with-docker.sh @@ -1,4 +1,8 @@ #!/bin/sh -set -eux +set -eu +echo Building Docker image with dependencies.. 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 mir-qubes-firewall.xen)" +echo "SHA2 last known: f0c1a06fc4b02b494c81972dc89419af6cffa73b75839c0e8ee3798d77bf69b3" From 036d92b0ff9236062550836c3e35e48ea37311b5 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Sat, 28 Jan 2017 15:19:05 +0000 Subject: [PATCH 009/281] Update README: you need "sudo docker" by default --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 2fc182a..396f545 100644 --- a/README.md +++ b/README.md @@ -15,7 +15,7 @@ Clone this Git repository and run the `build-with-docker.sh` script: sudo systemctl start docker git clone https://github.com/talex5/qubes-mirage-firewall.git cd qubes-mirage-firewall - ./build-with-docker.sh + sudo ./build-with-docker.sh This took about 10 minutes on my laptop (it will be much quicker if you run it again). From 150208fc722185dbe135294f65e0bf08a5e0737e Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Tue, 31 Jan 2017 09:26:57 +0000 Subject: [PATCH 010/281] Pin Docker base image to a specific hash Requested by Joanna Rutkowska. --- Dockerfile | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/Dockerfile b/Dockerfile index 9424fc7..2182d1e 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,7 +1,12 @@ -FROM ocaml/opam:debian-8_ocaml-4.03.0 +# Pin the base image to a specific hash for maximum reproducibility. +# It will probably still work on newer images, though, unless Debian 8 +# changes some compiler optimisations (unlikely). +#FROM ocaml/opam:debian-8_ocaml-4.03.0 +FROM ocaml/opam@sha256:28efab6a5535a517aa719ba5ac6d2e6fddd4831afaeabf5eee6470717eda9cca # Pin last known-good version for reproducible builds. -# Remove this line if you want to test with the latest versions. +# Remove this line (and the base image pin above) if you want to test with the +# latest versions. RUN cd opam-repository && git reset --hard 0f17b354206c97e729700ce60ddce3789ccb1d52 && opam update RUN sudo apt-get install -y m4 libxen-dev From bb78a726e463267b96de8f285ff422d50be9691a Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Thu, 2 Mar 2017 14:52:55 +0000 Subject: [PATCH 011/281] Mirage 3 support --- .travis.yml | 2 +- Makefile.user | 2 +- README.md | 6 +- client_eth.ml | 108 ++++++++++--------------------- client_eth.mli | 4 +- client_net.ml | 69 ++++++++++++-------- config.ml | 15 +++-- dao.ml | 2 +- firewall.ml | 171 +++++++++++++++++++------------------------------ firewall.mli | 8 +-- fw_utils.ml | 48 ++++++++++++++ my_nat.ml | 139 ++++++++++++++++++++++++++++++++++++++++ my_nat.mli | 19 ++++++ packet.ml | 4 +- router.ml | 22 ++----- router.mli | 12 ++-- unikernel.ml | 29 ++++++--- uplink.ml | 33 +++++----- uplink.mli | 6 +- utils.ml | 65 ------------------- 20 files changed, 423 insertions(+), 341 deletions(-) create mode 100644 fw_utils.ml create mode 100644 my_nat.ml create mode 100644 my_nat.mli delete mode 100644 utils.ml diff --git a/.travis.yml b/.travis.yml index 9842928..e9d1353 100644 --- a/.travis.yml +++ b/.travis.yml @@ -20,4 +20,4 @@ addons: - time - libxen-dev env: - - FORK_USER=talex5 FORK_BRANCH=unikernel OCAML_VERSION=4.02 MIRAGE_BACKEND=xen PINS="mirage-nat:https://github.com/talex5/mirage-nat.git#simplify-checksum" + - OCAML_VERSION=4.04 MIRAGE_BACKEND=xen PINS="mirage-nat:https://github.com/talex5/mirage-nat.git#mirage3" diff --git a/Makefile.user b/Makefile.user index 61ad38e..33335e6 100644 --- a/Makefile.user +++ b/Makefile.user @@ -1,7 +1,7 @@ tar: build rm -rf _build/mirage-firewall mkdir _build/mirage-firewall - cp mir-qubes-firewall.xen _build/mirage-firewall/vmlinuz + cp qubes_firewall.xen _build/mirage-firewall/vmlinuz touch _build/mirage-firewall/modules.img cat /dev/null | gzip > _build/mirage-firewall/initramfs tar cjf mirage-firewall.tar.bz2 -C _build mirage-firewall diff --git a/README.md b/README.md index 396f545..18b0b7e 100644 --- a/README.md +++ b/README.md @@ -21,19 +21,17 @@ This took about 10 minutes on my laptop (it will be much quicker if you run it a ## Build (without Docker) -To build (tested by creating a fresh Fedora 23 AppVM in Qubes): - 1. Install build tools: sudo yum install git gcc m4 0install patch ncurses-devel tar bzip2 unzip make which findutils xen-devel mkdir ~/bin 0install add opam http://tools.ocaml.org/opam.xml - opam init --comp=4.02.3 + opam init --comp=4.04.0 eval `opam config env` 2. Install mirage, pinning a few unreleased features we need: - opam pin add -y mirage-nat 'https://github.com/talex5/mirage-nat.git#simplify-checksum' + opam pin add -y mirage-nat 'https://github.com/talex5/mirage-nat.git#mirage3' opam install mirage 3. Build mirage-firewall: diff --git a/client_eth.ml b/client_eth.ml index f30f69c..751274b 100644 --- a/client_eth.ml +++ b/client_eth.ml @@ -1,7 +1,7 @@ (* Copyright (C) 2016, Thomas Leonard See the README file for details. *) -open Utils +open Fw_utils open Lwt.Infix let src = Logs.Src.create "client_eth" ~doc:"Ethernet networks for NetVM clients" @@ -52,10 +52,10 @@ let classify t ip = match ip with | Ipaddr.V6 _ -> `External ip | Ipaddr.V4 ip4 -> - if ip4 = t.client_gw then `Client_gateway - else match lookup t ip4 with - | Some client_link -> `Client client_link - | None -> `External ip + if ip4 = t.client_gw then `Client_gateway + else match lookup t ip4 with + | Some client_link -> `Client client_link + | None -> `External ip let resolve t : host -> Ipaddr.t = function | `Client client_link -> Ipaddr.V4 client_link#other_ip @@ -71,8 +71,8 @@ module ARP = struct let lookup t ip = if ip = t.net.client_gw then Some t.client_link#my_mac else None - (* We're now treating client networks as point-to-point links, - so we no longer respond on behalf of other clients. *) + (* We're now treating client networks as point-to-point links, + so we no longer respond on behalf of other clients. *) (* else match IpMap.find ip t.net.iface_of_ip with | Some client_iface -> Some client_iface#other_mac @@ -81,84 +81,46 @@ module ARP = struct let create ~net client_link = {net; client_link} - type arp_msg = { - op: [ `Request |`Reply |`Unknown of int ]; - sha: Macaddr.t; - spa: Ipaddr.V4.t; - tha: Macaddr.t; - tpa: Ipaddr.V4.t; - } - - let to_wire arp = - let open Arpv4_wire in - (* Obtain a buffer to write into *) - let buf = Cstruct.create (Wire_structs.sizeof_ethernet + sizeof_arp) in - (* Write the ARP packet *) - let dmac = Macaddr.to_bytes arp.tha in - let smac = Macaddr.to_bytes arp.sha in - let spa = Ipaddr.V4.to_int32 arp.spa in - let tpa = Ipaddr.V4.to_int32 arp.tpa in - let op = - match arp.op with - |`Request -> 1 - |`Reply -> 2 - |`Unknown n -> n - in - Wire_structs.set_ethernet_dst dmac 0 buf; - Wire_structs.set_ethernet_src smac 0 buf; - Wire_structs.set_ethernet_ethertype buf 0x0806; (* ARP *) - let arpbuf = Cstruct.shift buf 14 in - set_arp_htype arpbuf 1; - set_arp_ptype arpbuf 0x0800; (* IPv4 *) - set_arp_hlen arpbuf 6; (* ethernet mac size *) - set_arp_plen arpbuf 4; (* ipv4 size *) - set_arp_op arpbuf op; - set_arp_sha smac 0 arpbuf; - set_arp_spa arpbuf spa; - set_arp_tha dmac 0 arpbuf; - set_arp_tpa arpbuf tpa; - buf - - let input_query t frame = - let open Arpv4_wire in - let req_ipv4 = Ipaddr.V4.of_int32 (get_arp_tpa frame) in + let input_query t arp = + let req_ipv4 = arp.Arpv4_packet.tpa in Log.info (fun f -> f "who-has %s?" (Ipaddr.V4.to_string req_ipv4)); if req_ipv4 = t.client_link#other_ip then ( Log.info (fun f -> f "ignoring request for client's own IP"); None ) else match lookup t req_ipv4 with - | None -> + | None -> Log.info (fun f -> f "unknown address; not responding"); None - | Some req_mac -> + | Some req_mac -> Log.info (fun f -> f "responding to: who-has %s?" (Ipaddr.V4.to_string req_ipv4)); - Some (to_wire { - op = `Reply; - (* The Target Hardware Address and IP are copied from the request *) - tha = Macaddr.of_bytes_exn (copy_arp_sha frame); - tpa = Ipaddr.V4.of_int32 (get_arp_spa frame); - sha = req_mac; - spa = req_ipv4; - }) + let req_spa = arp.Arpv4_packet.spa in + let req_sha = arp.Arpv4_packet.sha in + Some { Arpv4_packet. + op = Arpv4_wire.Reply; + (* The Target Hardware Address and IP are copied from the request *) + tha = req_sha; + tpa = req_spa; + sha = req_mac; + spa = req_ipv4; + } - let input_gratuitous t frame = - let open Arpv4_wire in - let spa = Ipaddr.V4.of_int32 (get_arp_spa frame) in - let sha = Macaddr.of_bytes_exn (copy_arp_sha frame) in + let input_gratuitous t arp = + let spa = arp.Arpv4_packet.spa in + let sha = arp.Arpv4_packet.sha in match lookup t spa with | Some real_mac when Macaddr.compare sha real_mac = 0 -> - Log.info (fun f -> f "client suggests updating %s -> %s (as expected)" - (Ipaddr.V4.to_string spa) (Macaddr.to_string sha)); + Log.info (fun f -> f "client suggests updating %s -> %s (as expected)" + (Ipaddr.V4.to_string spa) (Macaddr.to_string sha)); | Some other_mac -> - Log.warn (fun f -> f "client suggests incorrect update %s -> %s (should be %s)" - (Ipaddr.V4.to_string spa) (Macaddr.to_string sha) (Macaddr.to_string other_mac)); + Log.warn (fun f -> f "client suggests incorrect update %s -> %s (should be %s)" + (Ipaddr.V4.to_string spa) (Macaddr.to_string sha) (Macaddr.to_string other_mac)); | None -> - Log.warn (fun f -> f "client suggests incorrect update %s -> %s (unexpected IP)" - (Ipaddr.V4.to_string spa) (Macaddr.to_string sha)) + Log.warn (fun f -> f "client suggests incorrect update %s -> %s (unexpected IP)" + (Ipaddr.V4.to_string spa) (Macaddr.to_string sha)) - let input t frame = - match Arpv4_wire.get_arp_op frame with - |1 -> input_query t frame - |2 -> input_gratuitous t frame; None - |n -> Log.warn (fun f -> f "unknown message %d - ignored" n); None + let input t arp = + let op = arp.Arpv4_packet.op in + match op with + | Arpv4_wire.Request -> input_query t arp + | Arpv4_wire.Reply -> input_gratuitous t arp; None end diff --git a/client_eth.mli b/client_eth.mli index 41746d3..0851913 100644 --- a/client_eth.mli +++ b/client_eth.mli @@ -4,7 +4,7 @@ (** The ethernet networks connecting us to our client AppVMs. Note: each AppVM is on a point-to-point link, each link being considered to be a separate Ethernet network. *) -open Utils +open Fw_utils type t (** A collection of clients. *) @@ -47,7 +47,7 @@ module ARP : sig (** [create ~net client_link] is an ARP responder for [client_link]. It answers only for the client's gateway address. *) - val input : arp -> Cstruct.t -> Cstruct.t option + val input : arp -> Arpv4_packet.t -> Arpv4_packet.t option (** Process one ethernet frame containing an ARP message. Returns a response frame, if one is needed. *) end diff --git a/client_net.ml b/client_net.ml index ca39938..50f22ea 100644 --- a/client_net.ml +++ b/client_net.ml @@ -2,7 +2,7 @@ See the README file for details. *) open Lwt.Infix -open Utils +open Fw_utils module Netback = Netchannel.Backend.Make(Netchannel.Xenstore.Make(OS.Xs)) module ClientEth = Ethif.Make(Netback) @@ -12,7 +12,13 @@ module Log = (val Logs.src_log src : Logs.LOG) let writev eth data = Lwt.catch - (fun () -> ClientEth.writev eth data) + (fun () -> + ClientEth.writev eth data >|= function + | Ok () -> () + | Error e -> + Log.err (fun f -> f "error trying to send to client:@\n@[ %a@]@\nError: @[%a@]" + Cstruct.hexdump_pp (Cstruct.concat data) ClientEth.pp_error e); + ) (fun ex -> (* Usually Netback_shutdown, because the client disconnected *) Log.err (fun f -> f "uncaught exception trying to send to client:@\n@[ %a@]@\nException: @[%s@]" @@ -26,36 +32,47 @@ class client_iface eth ~gateway_ip ~client_ip client_mac : client_link = object method other_mac = client_mac method my_ip = gateway_ip method other_ip = client_ip - method writev ip = + method writev proto ip = FrameQ.send queue (fun () -> - let eth_hdr = eth_header_ipv4 ~src:(ClientEth.mac eth) ~dst:client_mac in - writev eth (fixup_checksums (Cstruct.concat (eth_hdr :: ip))) + let eth_hdr = eth_header proto ~src:(ClientEth.mac eth) ~dst:client_mac in + writev eth (eth_hdr :: ip) ) end let clients : Cleanup.t Dao.VifMap.t ref = ref Dao.VifMap.empty (** Handle an ARP message from the client. *) -let input_arp ~fixed_arp ~eth request = - match Client_eth.ARP.input fixed_arp request with - | None -> return () - | Some response -> writev eth [response] +let input_arp ~fixed_arp ~iface request = + match Arpv4_packet.Unmarshal.of_cstruct request with + | Error e -> + Log.warn (fun f -> f "ignored unknown ARP message: %a" Arpv4_packet.Unmarshal.pp_error e); + Lwt.return () + | Ok arp -> + match Client_eth.ARP.input fixed_arp arp with + | None -> return () + | Some response -> + iface#writev Ethif_wire.ARP [Arpv4_packet.Marshal.make_cstruct response] (** Handle an IPv4 packet from the client. *) -let input_ipv4 ~client_ip ~router frame packet = - let src = Wire_structs.Ipv4_wire.get_ipv4_src packet |> Ipaddr.V4.of_int32 in - if src = client_ip then Firewall.ipv4_from_client router frame - else ( - Log.warn (fun f -> f "Incorrect source IP %a in IP packet from %a (dropping)" - Ipaddr.V4.pp_hum src Ipaddr.V4.pp_hum client_ip); - return () - ) +let input_ipv4 ~client_ip ~router packet = + match Ipv4_packet.Unmarshal.of_cstruct packet with + | Error e -> + Log.warn (fun f -> f "ignored unknown IPv4 message: %s" e); + Lwt.return () + | Ok (ip, payload) -> + let src = ip.Ipv4_packet.src in + if src = client_ip then Firewall.ipv4_from_client router (ip, payload) + else ( + Log.warn (fun f -> f "Incorrect source IP %a in IP packet from %a (dropping)" + Ipaddr.V4.pp_hum src Ipaddr.V4.pp_hum client_ip); + return () + ) (** Connect to a new client's interface and listen for incoming frames. *) let add_vif { Dao.ClientVif.domid; device_id } ~client_ip ~router ~cleanup_tasks = 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 >>= or_fail "Can't make Ethernet device" >>= fun eth -> + ClientEth.connect backend >>= fun eth -> let client_mac = Netback.mac backend in let client_eth = router.Router.client_eth in let gateway_ip = Client_eth.client_gw client_eth in @@ -64,15 +81,15 @@ let add_vif { Dao.ClientVif.domid; device_id } ~client_ip ~router ~cleanup_tasks Cleanup.on_cleanup cleanup_tasks (fun () -> Router.remove_client router iface); let fixed_arp = Client_eth.ARP.create ~net:client_eth iface in Netback.listen backend (fun frame -> - match Wire_structs.parse_ethernet_frame frame with - | None -> Log.warn (fun f -> f "Invalid Ethernet frame"); return () - | Some (typ, _destination, payload) -> - match typ with - | Some Wire_structs.ARP -> input_arp ~fixed_arp ~eth payload - | Some Wire_structs.IPv4 -> input_ipv4 ~client_ip ~router frame payload - | Some Wire_structs.IPv6 -> return () - | None -> Logs.warn (fun f -> f "Unknown Ethernet type"); Lwt.return_unit + match Ethif_packet.Unmarshal.of_cstruct frame with + | Error err -> Log.warn (fun f -> f "Invalid Ethernet frame: %s" err); return () + | Ok (eth, payload) -> + match eth.Ethif_packet.ethertype with + | Ethif_wire.ARP -> input_arp ~fixed_arp ~iface payload + | Ethif_wire.IPv4 -> input_ipv4 ~client_ip ~router payload + | Ethif_wire.IPv6 -> return () ) + >|= or_raise "Listen on client interface" Netback.pp_error (** A new client VM has been found in XenStore. Find its interface and connect to it. *) let add_client ~router vif client_ip = diff --git a/config.ml b/config.ml index e2be6f3..6ac02db 100644 --- a/config.ml +++ b/config.ml @@ -7,10 +7,17 @@ open Mirage let main = foreign - ~libraries:["mirage-net-xen"; "tcpip.stack-direct"; "tcpip.xen"; "mirage-qubes"; "mirage-nat"; "mirage-logs"] - ~packages:["vchan"; "cstruct"; "tcpip"; "mirage-net-xen"; "mirage-qubes"; "mirage-nat"; "mirage-logs"] - "Unikernel.Main" (clock @-> job) + ~packages:[ + package "vchan"; + package "cstruct"; + package "tcpip" ~sublibs:["stack-direct"; "xen"]; + package "mirage-net-xen"; + package "mirage-qubes"; + package "mirage-nat" ~sublibs:["hashtable"]; + package "mirage-logs"; + ] + "Unikernel.Main" (mclock @-> job) let () = - register "qubes-firewall" [main $ default_clock] + register "qubes-firewall" [main $ default_monotonic_clock] ~argv:no_argv diff --git a/dao.ml b/dao.ml index dd22735..9ce0766 100644 --- a/dao.ml +++ b/dao.ml @@ -2,8 +2,8 @@ See the README file for details. *) open Lwt.Infix -open Utils open Qubes +open Fw_utils open Astring let src = Logs.Src.create "dao" ~doc:"QubesDB data access" diff --git a/firewall.ml b/firewall.ml index cdfd977..226a56c 100644 --- a/firewall.ml +++ b/firewall.ml @@ -1,23 +1,19 @@ (* Copyright (C) 2015, Thomas Leonard See the README file for details. *) -open Utils +open Fw_utils open Packet +open Lwt.Infix let src = Logs.Src.create "firewall" ~doc:"Packet handler" module Log = (val Logs.src_log src : Logs.LOG) (* Transmission *) -let transmit ~frame iface = - (* If packet has been NAT'd then we certainly need to recalculate the checksum, - but even for direct pass-through it might have been received with an invalid - checksum due to checksum offload. For now, recalculate full checksum in all - cases. *) - let frame = fixup_checksums frame |> Cstruct.concat in - let packet = Cstruct.shift frame Wire_structs.sizeof_ethernet in +let transmit (ip, payload) iface = + let packet = Ipv4_packet.Marshal.make_cstruct ~payload ip in Lwt.catch - (fun () -> iface#writev [packet]) + (fun () -> iface#writev Ethif_wire.IPv4 [packet; payload]) (fun ex -> Log.warn (fun f -> f "Failed to write packet to %a: %s" Ipaddr.V4.pp_hum iface#other_ip @@ -25,35 +21,44 @@ let transmit ~frame iface = Lwt.return () ) -let forward_ipv4 t frame = - let packet = Cstruct.shift frame Wire_structs.sizeof_ethernet in - match Router.target t packet with - | Some iface -> transmit ~frame iface +let forward_ipv4 t (ip, packet) = + match Router.target t ip with + | Some iface -> transmit (ip, packet) iface | None -> return () (* Packet classification *) -let ports transport = - let sport, dport = Nat_rewrite.ports_of_transport transport in - { sport; dport } +let classify_tcp trans = + match Tcp.Tcp_packet.Unmarshal.of_cstruct trans with + | Error e -> + Log.info (fun f -> f "Failed to parse TCP packet: %s" e); + `Unknown + | Ok (tcp, _payload) -> + let sport = tcp.Tcp.Tcp_packet.src_port in + let dport = tcp.Tcp.Tcp_packet.dst_port in + `TCP {sport; dport} -let classify t frame = - match Nat_rewrite.layers frame with - | None -> - Log.warn (fun f -> f "Failed to parse frame"); - None - | Some (_eth, ip, transport) -> - let src, dst = Nat_rewrite.addresses_of_ip ip in +let classify_udp trans = + match Udp_packet.Unmarshal.of_cstruct trans with + | Error e -> + Log.info (fun f -> f "Failed to parse UDP packet: %s" e); + `Unknown + | Ok (udp, _payload) -> + let sport = udp.Udp_packet.src_port in + let dport = udp.Udp_packet.dst_port in + `UDP {sport; dport} + +let classify t (ip, transport) = let proto = - match Nat_rewrite.proto_of_ip ip with - | 1 -> `ICMP - | 6 -> `TCP (ports transport) - | 17 -> `UDP (ports transport) - | _ -> `Unknown in + match ip.Ipv4_packet.proto |> Ipv4_packet.Unmarshal.int_to_protocol with + | Some `ICMP -> `ICMP + | Some `TCP -> classify_tcp transport + | Some `UDP -> classify_udp transport + | None -> `Unknown in Some { - frame; - src = Router.classify t src; - dst = Router.classify t dst; + packet = (ip, transport); + src = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.src); + dst = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.dst); proto; } @@ -74,7 +79,7 @@ let pp_proto fmt = function | `ICMP -> Format.pp_print_string fmt "ICMP" | `Unknown -> Format.pp_print_string fmt "UnknownProtocol" -let pp_packet fmt {src; dst; proto; frame = _} = +let pp_packet fmt {src; dst; proto; packet = _} = Format.fprintf fmt "[src=%a dst=%a proto=%a]" pp_host src pp_host dst @@ -82,84 +87,40 @@ let pp_packet fmt {src; dst; proto; frame = _} = (* NAT *) -let translate t frame = - Nat_rewrite.translate t.Router.nat frame - -let random_user_port () = - 1024 + Random.int (0xffff - 1024) - -let rec add_nat_rule_and_transmit ?(retries=100) t frame fn logf = - let xl_port = random_user_port () in - match fn xl_port with - | exception Out_of_memory -> - (* Because hash tables resize in big steps, this can happen even if we have a fair - chunk of free memory. *) - Log.warn (fun f -> f "Out_of_memory adding NAT rule. Dropping NAT table..."); - Router.reset t; - add_nat_rule_and_transmit ~retries:(retries - 1) t frame fn logf - | Nat_rewrite.Overlap when retries < 0 -> return () - | Nat_rewrite.Overlap -> - if retries = 0 then ( - Log.warn (fun f -> f "Failed to find a free port; resetting NAT table"); - Router.reset t; - ); - add_nat_rule_and_transmit ~retries:(retries - 1) t frame fn logf (* Try a different port *) - | Nat_rewrite.Unparseable -> - Log.warn (fun f -> f "Failed to add NAT rule: Unparseable"); - return () - | Nat_rewrite.Ok _ -> - Log.debug (logf xl_port); - match translate t frame with - | Some frame -> forward_ipv4 t frame - | None -> - Log.warn (fun f -> f "No NAT entry, even after adding one!"); - return () +let translate t packet = + My_nat.translate t.Router.nat packet (* Add a NAT rule for the endpoints in this frame, via a random port on the firewall. *) -let add_nat_and_forward_ipv4 t ~frame = +let add_nat_and_forward_ipv4 t packet = let xl_host = Ipaddr.V4 t.Router.uplink#my_ip in - add_nat_rule_and_transmit t frame - (* Note: DO NOT partially apply; [t.nat] may change between calls *) - (fun xl_port -> Nat_rewrite.make_nat_entry t.Router.nat frame xl_host xl_port) - (fun xl_port f -> - match Nat_rewrite.layers frame with - | None -> assert false - | Some (_eth, ip, transport) -> - let src, dst = Nat_rewrite.addresses_of_ip ip in - let sport, dport = Nat_rewrite.ports_of_transport transport in - f "added NAT entry: %s:%d -> firewall:%d -> %d:%s" (Ipaddr.to_string src) sport xl_port dport (Ipaddr.to_string dst) - ) + My_nat.add_nat_rule_and_translate t.Router.nat ~xl_host `Rewrite packet >>= function + | Ok packet -> forward_ipv4 t packet + | Error e -> + Log.warn (fun f -> f "Failed to add NAT rewrite rule: %s" e); + Lwt.return () (* Add a NAT rule to redirect this conversation to [host:port] instead of us. *) -let nat_to t ~frame ~host ~port = +let nat_to t ~host ~port packet = let target = Router.resolve t host in let xl_host = Ipaddr.V4 t.Router.uplink#my_ip in - add_nat_rule_and_transmit t frame - (fun xl_port -> - Nat_rewrite.make_redirect_entry t.Router.nat frame (xl_host, xl_port) (target, port) - ) - (fun xl_port f -> - match Nat_rewrite.layers frame with - | None -> assert false - | Some (_eth, ip, transport) -> - let src, _dst = Nat_rewrite.addresses_of_ip ip in - let sport, dport = Nat_rewrite.ports_of_transport transport in - f "added NAT redirect %s:%d -> %d:firewall:%d -> %d:%a" - (Ipaddr.to_string src) sport dport xl_port port pp_host host - ) + My_nat.add_nat_rule_and_translate t.Router.nat ~xl_host (`Redirect (target, port)) packet >>= function + | Ok packet -> forward_ipv4 t packet + | Error e -> + Log.warn (fun f -> f "Failed to add NAT redirect rule: %s" e); + Lwt.return () (* Handle incoming packets *) let apply_rules t rules info = - let frame = info.frame in + let packet = info.packet in match rules info, info.dst with - | `Accept, `Client client_link -> transmit ~frame client_link - | `Accept, (`External _ | `NetVM) -> transmit ~frame t.Router.uplink + | `Accept, `Client client_link -> transmit packet client_link + | `Accept, (`External _ | `NetVM) -> transmit packet t.Router.uplink | `Accept, (`Firewall_uplink | `Client_gateway) -> Log.warn (fun f -> f "Bad rule: firewall can't accept packets %a" pp_packet info); return () - | `NAT, _ -> add_nat_and_forward_ipv4 t ~frame - | `NAT_to (host, port), _ -> nat_to t ~frame ~host ~port + | `NAT, _ -> 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 pp_packet info); return () @@ -168,28 +129,28 @@ let handle_low_memory t = match Memory_pressure.status () with | `Memory_critical -> (* TODO: should happen before copying and async *) Log.warn (fun f -> f "Memory low - dropping packet and resetting NAT table"); - Router.reset t; + My_nat.reset t.Router.nat >|= fun () -> `Memory_critical - | `Ok -> `Ok + | `Ok -> Lwt.return `Ok -let ipv4_from_client t frame = - match handle_low_memory t with +let ipv4_from_client t (ip, payload) = + handle_low_memory t >>= function | `Memory_critical -> return () | `Ok -> (* Check for existing NAT entry for this packet *) - match translate t frame with + translate t (ip, payload) >>= function | Some frame -> forward_ipv4 t frame (* Some existing connection or redirect *) | None -> (* No existing NAT entry. Check the firewall rules. *) - match classify t frame with + match classify t (ip, payload) with | None -> return () | Some info -> apply_rules t Rules.from_client info -let ipv4_from_netvm t frame = - match handle_low_memory t with +let ipv4_from_netvm t (ip, payload) = + handle_low_memory t >>= function | `Memory_critical -> return () | `Ok -> - match classify t frame with + match classify t (ip, payload) with | None -> return () | Some info -> match info.src with @@ -197,7 +158,7 @@ let ipv4_from_netvm t frame = Log.warn (fun f -> f "Frame from NetVM has internal source IP address! %a" pp_packet info); return () | `External _ | `NetVM -> - match translate t frame with + translate t (ip, payload) >>= function | Some frame -> forward_ipv4 t frame | None -> apply_rules t Rules.from_netvm info diff --git a/firewall.mli b/firewall.mli index a8e5624..3a88270 100644 --- a/firewall.mli +++ b/firewall.mli @@ -3,9 +3,9 @@ (** Classify IP packets, apply rules and send as appropriate. *) -val ipv4_from_netvm : Router.t -> Cstruct.t -> unit Lwt.t -(** Handle a frame from the outside world (this module will validate the source IP). *) +val ipv4_from_netvm : Router.t -> Ipv4_packet.t * Cstruct.t -> unit Lwt.t +(** Handle a packet from the outside world (this module will validate the source IP). *) -val ipv4_from_client : Router.t -> Cstruct.t -> unit Lwt.t -(** Handle a frame from a client. Caller must check the source IP matches the client's +val ipv4_from_client : Router.t -> Ipv4_packet.t * Cstruct.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/fw_utils.ml b/fw_utils.ml new file mode 100644 index 0000000..f4e63e8 --- /dev/null +++ b/fw_utils.ml @@ -0,0 +1,48 @@ +(* Copyright (C) 2015, Thomas Leonard + See the README file for details. *) + +(** General utility functions. *) + +module IpMap = struct + include Map.Make(Ipaddr.V4) + let find x map = + try Some (find x map) + 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 + method writev : Ethif_wire.ethertype -> Cstruct.t list -> unit Lwt.t + method my_ip : Ipaddr.V4.t + method other_ip : Ipaddr.V4.t +end + +(** An Ethernet interface connected to a clientVM. *) +class type client_link = object + inherit interface + method other_mac : Macaddr.t +end + +(** An Ethernet header from [src]'s MAC address to [dst]'s with an IPv4 payload. *) +let eth_header ethertype ~src ~dst = + Ethif_packet.Marshal.make_cstruct { Ethif_packet.source = src; destination = dst; ethertype } + +let error fmt = + let err s = Failure s in + Printf.ksprintf err fmt + +let return = Lwt.return +let fail = Lwt.fail + +let or_raise msg pp = function + | Ok x -> x + | Error e -> failwith (Fmt.strf "%s: %a" msg pp e) diff --git a/my_nat.ml b/my_nat.ml new file mode 100644 index 0000000..ec9d0f2 --- /dev/null +++ b/my_nat.ml @@ -0,0 +1,139 @@ +(* 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) + +type action = [ + | `Rewrite + | `Redirect of Ipaddr.t * int +] + +type packet = Ipv4_packet.t * Cstruct.t + +(* To avoid needing to allocate a new NAT table when we've run out of + memory, pre-allocate the new one ahead of time. *) +type 'a with_standby = { + mutable current :'a; + mutable next : 'a; +} + +type t = Nat : (module Mirage_nat.S with type t = 't and type config = 'c) * 'c * 't with_standby -> t + +let create (type c t) (nat:(module Mirage_nat.S with type config = c and type t = t)) (c:c) = + let (module Nat : Mirage_nat.S with type config = c and type t = t) = nat in + Nat.empty c >>= fun current -> + Nat.empty c >>= fun next -> + let table = { current; next } in + Lwt.return (Nat (nat, c, table)) + +(* Ideally, mirage-nat wouldn't ask us for an ethernet header, since it only + cares about the IP layer anyway. *) +let fake_ipv4_eth = + let dontcare = Macaddr.broadcast in + Fw_utils.eth_header Ethif_wire.IPv4 ~src:dontcare ~dst:dontcare + +let translate (Nat ((module Nat), _, table)) (ip, payload) = + (* XXX: change Nat.translate API *) + let packet = Ipv4_packet.Marshal.make_cstruct ~payload ip in + let frame = Cstruct.concat [ + fake_ipv4_eth; + packet; + payload; + ] in + Nat.translate table.current frame >|= function + | Mirage_nat.Untranslated -> None + | Mirage_nat.Translated _ -> (* XXX: translate mutates frame *) + let packet = Cstruct.shift frame Ethif_wire.sizeof_ethernet in + match Ipv4_packet.Unmarshal.of_cstruct packet with + | Error e -> Log.err (fun f -> f "Translation failed: %s" e); None + | Ok packet -> Some packet + +let random_user_port () = + 1024 + Random.int (0xffff - 1024) + +let reset (Nat ((module Nat), c, table)) = + table.current <- table.next; + (* (at this point, the big old NAT table can be GC'd, so allocating + a new one should be OK) *) + Nat.empty c >|= fun next -> + table.next <- next + +let add_nat_rule_and_translate ((Nat ((module Nat), c, table)) as t) ~xl_host action packet = + let frame = + let (ip, payload) = packet in + Cstruct.concat [ + fake_ipv4_eth; + Ipv4_packet.Marshal.make_cstruct ~payload ip; + payload; + ] in + let apply_action xl_port = + Lwt.try_bind (fun () -> + match action with + | `Rewrite -> + Nat.add_nat table.current frame (xl_host, xl_port) + | `Redirect target -> + Nat.add_redirect table.current frame (xl_host, xl_port) target + ) + (function + | Nat.Ok -> Lwt.return (Ok ()) + | Nat.Overlap -> Lwt.return (Error `Overlap) + | Nat.Unparseable -> Lwt.return (Error `Unparseable) + ) + (function + | Out_of_memory -> Lwt.return (Error `Out_of_memory) + | x -> Lwt.fail x + ) + in + let reset () = + table.current <- table.next; + (* (at this point, the big old NAT table can be GC'd, so allocating + a new one should be OK) *) + Nat.empty c >|= fun next -> + table.next <- next + in + let rec aux ~retries = + let xl_port = random_user_port () in + apply_action xl_port >>= function + | Error `Out_of_memory -> + (* Because hash tables resize in big steps, this can happen even if we have a fair + chunk of free memory. *) + Log.warn (fun f -> f "Out_of_memory adding NAT rule. Dropping NAT table..."); + reset () >>= fun () -> + aux ~retries:(retries - 1) + | Error `Overlap when retries < 0 -> Lwt.return (Error "Too many retries") + | Error `Overlap -> + if retries = 0 then ( + Log.warn (fun f -> f "Failed to find a free port; resetting NAT table"); + reset () >>= fun () -> + aux ~retries:(retries - 1) + ) else ( + aux ~retries:(retries - 1) + ) + | Error `Unparseable -> + Lwt.return (Error "Unparseable by mirage-nat") + | Ok () -> + translate t packet >|= function + | None -> Error "No NAT entry, even after adding one!" + | Some packet -> +(* + Log.debug (fun f -> + match action with + | `Rewrite -> + let (ip, trans) = packet in + let src, dst = Nat_rewrite.addresses_of_ip ip in + let sport, dport = Nat_rewrite.ports_of_transport transport in + f "added NAT entry: %s:%d -> firewall:%d -> %d:%s" (Ipaddr.to_string src) sport xl_port dport (Ipaddr.to_string dst) + | `Redirect -> + let (ip, transport) = packet in + let src, _dst = Nat_rewrite.addresses_of_ip ip in + let sport, dport = Nat_rewrite.ports_of_transport transport in + f "added NAT redirect %s:%d -> %d:firewall:%d -> %d:%a" + (Ipaddr.to_string src) sport dport xl_port port pp_host host + ); +*) + Ok packet + in + aux ~retries:100 diff --git a/my_nat.mli b/my_nat.mli new file mode 100644 index 0000000..cf71dec --- /dev/null +++ b/my_nat.mli @@ -0,0 +1,19 @@ +(* Copyright (C) 2015, Thomas Leonard + See the README file for details. *) + +(* Abstract over NAT interface (todo: remove this) *) + +type t + +type action = [ + | `Rewrite + | `Redirect of Ipaddr.t * int +] + +type packet = Ipv4_packet.t * Cstruct.t + +val create : (module Mirage_nat.S with type t = 'a and type config = 'c) -> 'c -> t Lwt.t +val reset : t -> unit Lwt.t +val translate : t -> packet -> packet option Lwt.t +val add_nat_rule_and_translate : t -> xl_host:Ipaddr.t -> + action -> packet -> (packet, string) result Lwt.t diff --git a/packet.ml b/packet.ml index a359e16..bea2594 100644 --- a/packet.ml +++ b/packet.ml @@ -1,7 +1,7 @@ (* Copyright (C) 2015, Thomas Leonard See the README file for details. *) -open Utils +open Fw_utils type port = int @@ -14,7 +14,7 @@ type host = [ `Client of client_link | `Client_gateway | `Firewall_uplink | `NetVM | `External of Ipaddr.t ] type info = { - frame : Cstruct.t; + packet : Ipv4_packet.t * Cstruct.t; src : host; dst : host; proto : [ `UDP of ports | `TCP of ports | `ICMP | `Unknown ]; diff --git a/router.ml b/router.ml index 8e1dc44..ff5fddc 100644 --- a/router.ml +++ b/router.ml @@ -1,26 +1,21 @@ (* Copyright (C) 2015, Thomas Leonard See the README file for details. *) -open Utils - -let src = Logs.Src.create "router" ~doc:"Router" -module Log = (val Logs.src_log src : Logs.LOG) +open Fw_utils (* The routing table *) type t = { client_eth : Client_eth.t; - mutable nat : Nat_lookup.t; + nat : My_nat.t; uplink : interface; } -let create ~client_eth ~uplink = - let nat = Nat_lookup.empty () in +let create ~client_eth ~uplink ~nat = { client_eth; nat; uplink } let target t buf = - let open Wire_structs.Ipv4_wire in - let dst_ip = get_ipv4_dst buf |> Ipaddr.V4.of_int32 in + let dst_ip = buf.Ipv4_packet.dst in match Client_eth.lookup t.client_eth dst_ip with | Some client_link -> Some (client_link :> interface) | None -> Some t.uplink @@ -37,12 +32,3 @@ let resolve t = function | `Firewall_uplink -> Ipaddr.V4 t.uplink#my_ip | `NetVM -> Ipaddr.V4 t.uplink#other_ip | #Client_eth.host as host -> Client_eth.resolve t.client_eth host - -(* To avoid needing to allocate a new NAT table when we've run out of - memory, pre-allocate the new one ahead of time. *) -let next_nat = ref (Nat_lookup.empty ()) -let reset t = - t.nat <- !next_nat; - (* (at this point, the big old NAT table can be GC'd, so allocating - a new one should be OK) *) - next_nat := Nat_lookup.empty () diff --git a/router.mli b/router.mli index ac743d3..80678fb 100644 --- a/router.mli +++ b/router.mli @@ -3,11 +3,11 @@ (** Routing packets to the right network interface. *) -open Utils +open Fw_utils type t = private { client_eth : Client_eth.t; - mutable nat : Nat_lookup.t; + nat : My_nat.t; uplink : interface; } (** A routing table. *) @@ -15,12 +15,13 @@ type t = private { val create : client_eth:Client_eth.t -> uplink:interface -> + nat:My_nat.t -> t (** [create ~client_eth ~uplink] is a new routing table that routes packets outside of [client_eth] via [uplink]. *) -val target : t -> Cstruct.t -> interface option -(** [target t packet] is the interface to which [packet] (an IP packet) should be routed. *) +val target : t -> Ipv4_packet.t -> interface option +(** [target t packet] is the interface to which [packet] should be routed. *) val add_client : t -> client_link -> unit Lwt.t (** [add_client t iface] adds a rule for routing packets addressed to [iface]. *) @@ -29,6 +30,3 @@ val remove_client : t -> client_link -> unit val classify : t -> Ipaddr.t -> Packet.host val resolve : t -> Packet.host -> Ipaddr.t - -val reset : t -> unit -(** Clear the NAT table (to free memory). *) diff --git a/unikernel.ml b/unikernel.ml index 9e5eba3..3189bb0 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -7,15 +7,16 @@ open Qubes let src = Logs.Src.create "unikernel" ~doc:"Main unikernel code" module Log = (val Logs.src_log src : Logs.LOG) -module Main (Clock : V1.CLOCK) = struct +module Main (Clock : Mirage_clock_lwt.MCLOCK) = struct module Uplink = Uplink.Make(Clock) + module Nat = Mirage_nat_hashtable.Make(Clock)(OS.Time) (* Set up networking and listen for incoming packets. *) - let network qubesDB = + let network ~clock nat qubesDB = (* Read configuration from QubesDB *) let config = Dao.read_network_config qubesDB in (* Initialise connection to NetVM *) - Uplink.connect config >>= fun uplink -> + Uplink.connect ~clock config >>= fun uplink -> (* Report success *) Dao.set_iptables_error qubesDB "" >>= fun () -> (* Set up client-side networking *) @@ -24,7 +25,9 @@ module Main (Clock : V1.CLOCK) = struct (* Set up routing between networks and hosts *) let router = Router.create ~client_eth - ~uplink:(Uplink.interface uplink) in + ~uplink:(Uplink.interface uplink) + ~nat + in (* Handle packets from both networks *) Lwt.choose [ Client_net.listen router; @@ -45,8 +48,8 @@ module Main (Clock : V1.CLOCK) = struct ) (* Main unikernel entry point (called from auto-generated main.ml). *) - let start () = - let start_time = Clock.time () in + let start clock = + let start_time = Clock.elapsed_ns clock in (* Start qrexec agent, GUI agent and QubesDB agent in parallel *) let qrexec = RExec.connect ~domid:0 () in let gui = GUI.connect ~domid:0 () in @@ -57,18 +60,24 @@ module Main (Clock : V1.CLOCK) = struct gui >>= fun gui -> watch_gui gui; qubesDB >>= fun qubesDB -> - Log.info (fun f -> f "agents connected in %.3f s (CPU time used since boot: %.3f s)" - (Clock.time () -. start_time) (Sys.time ())); + let startup_time = + let (-) = Int64.sub in + let time_in_ns = Clock.elapsed_ns clock - start_time in + Int64.to_float time_in_ns /. 1e9 + in + Log.info (fun f -> f "Qubes agents connected in %.3f s (CPU time used since boot: %.3f s)" + startup_time (Sys.time ())); (* Watch for shutdown requests from Qubes *) let shutdown_rq = OS.Lifecycle.await_shutdown_request () >>= fun (`Poweroff | `Reboot) -> return () in (* Set up networking *) - let net_listener = network qubesDB in + My_nat.create (module Nat) clock >>= fun nat -> + let net_listener = network ~clock nat qubesDB in (* Report memory usage to XenStore *) Memory_pressure.init (); (* Run until something fails or we get a shutdown request. *) Lwt.choose [agent_listener; net_listener; shutdown_rq] >>= fun () -> (* Give the console daemon time to show any final log messages. *) - OS.Time.sleep 1.0 + OS.Time.sleep_ns (1.0 *. 1e9 |> Int64.of_float) end diff --git a/uplink.ml b/uplink.ml index 711b5f5..0dfe79c 100644 --- a/uplink.ml +++ b/uplink.ml @@ -2,16 +2,15 @@ See the README file for details. *) open Lwt.Infix -open Utils +open Fw_utils module Eth = Ethif.Make(Netif) let src = Logs.Src.create "uplink" ~doc:"Network connection to NetVM" module Log = (val Logs.src_log src : Logs.LOG) -module Make(Clock : V1.CLOCK) = struct +module Make(Clock : Mirage_clock_lwt.MCLOCK) = struct module Arp = Arpv4.Make(Eth)(Clock)(OS.Time) - module IPv4 = Ipv4.Make(Eth)(Arp) type t = { net : Netif.t; @@ -25,11 +24,11 @@ module Make(Clock : V1.CLOCK) = struct method my_mac = Eth.mac eth method my_ip = my_ip method other_ip = other_ip - method writev ip = + method writev ethertype payload = FrameQ.send queue (fun () -> mac >>= fun dst -> - let eth_hdr = eth_header_ipv4 ~src:(Eth.mac eth) ~dst in - Eth.writev eth (eth_hdr :: ip) + let eth_hdr = eth_header ethertype ~src:(Eth.mac eth) ~dst in + Eth.writev eth (eth_hdr :: payload) >|= or_raise "Write to uplink" Eth.pp_error ) end @@ -38,22 +37,26 @@ module Make(Clock : V1.CLOCK) = struct (* Handle one Ethernet frame from NetVM *) Eth.input t.eth ~arpv4:(Arp.input t.arp) - ~ipv4:(fun _ip -> Firewall.ipv4_from_netvm router frame) + ~ipv4:(fun ip -> + match Ipv4_packet.Unmarshal.of_cstruct ip with + | Error e -> Log.warn (fun f -> f "Bad IPv4 packet from uplink: %s" e); Lwt.return () + | Ok packet -> Firewall.ipv4_from_netvm router packet + ) ~ipv6:(fun _ip -> return ()) frame - ) + ) >|= or_raise "Uplink listen loop" Netif.pp_error let interface t = t.interface - let connect config = + let connect ~clock config = let ip = config.Dao.uplink_our_ip in - Netif.connect "0" >>= or_fail "Can't connect uplink device" >>= fun net -> - Eth.connect net >>= or_fail "Can't make Ethernet device for tap" >>= fun eth -> - Arp.connect eth >>= or_fail "Can't add ARP" >>= fun arp -> + Netif.connect "0" >>= fun net -> + Eth.connect net >>= fun eth -> + Arp.connect eth clock >>= fun arp -> Arp.add_ip arp ip >>= fun () -> - let netvm_mac = Arp.query arp config.Dao.uplink_netvm_ip >|= function - | `Timeout -> failwith "ARP timeout getting MAC of our NetVM" - | `Ok netvm_mac -> netvm_mac in + let netvm_mac = + Arp.query arp config.Dao.uplink_netvm_ip + >|= or_raise "Getting MAC of our NetVM" Arp.pp_error in let interface = new netvm_iface eth netvm_mac ~my_ip:ip ~other_ip:config.Dao.uplink_netvm_ip in diff --git a/uplink.mli b/uplink.mli index 156e91f..6e2f5f4 100644 --- a/uplink.mli +++ b/uplink.mli @@ -3,12 +3,12 @@ (** The link from us to NetVM (and, through that, to the outside world). *) -open Utils +open Fw_utils -module Make(Clock : V1.CLOCK) : sig +module Make(Clock : Mirage_clock_lwt.MCLOCK) : sig type t - val connect : Dao.network_config -> t Lwt.t + val connect : clock:Clock.t -> Dao.network_config -> t Lwt.t (** Connect to our NetVM (gateway). *) val interface : t -> interface diff --git a/utils.ml b/utils.ml deleted file mode 100644 index 13d512a..0000000 --- a/utils.ml +++ /dev/null @@ -1,65 +0,0 @@ -(* Copyright (C) 2015, Thomas Leonard - See the README file for details. *) - -(** General utility functions. *) - -module IpMap = struct - include Map.Make(Ipaddr.V4) - let find x map = - try Some (find x map) - 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 - method writev : Cstruct.t list -> unit Lwt.t - method my_ip : Ipaddr.V4.t - method other_ip : Ipaddr.V4.t -end - -(** An Ethernet interface connected to a clientVM. *) -class type client_link = object - inherit interface - method other_mac : Macaddr.t -end - -(** An Ethernet header from [src]'s MAC address to [dst]'s with an IPv4 payload. *) -let eth_header_ipv4 ~src ~dst = - let open Wire_structs in - let frame = Cstruct.create sizeof_ethernet in - frame |> set_ethernet_src (Macaddr.to_bytes src) 0; - frame |> set_ethernet_dst (Macaddr.to_bytes dst) 0; - set_ethernet_ethertype frame (ethertype_to_int IPv4); - frame - -(** Recalculate checksums after modifying packets. - Note that frames often arrive with invalid checksums due to checksum offload. - For now, we always calculate valid checksums for out-bound frames. *) -let fixup_checksums frame = - match Nat_rewrite.layers frame with - | None -> raise (Invalid_argument "NAT transformation rendered packet unparseable") - | Some (ether, ip, tx) -> - let (just_headers, higherlevel_data) = - Nat_rewrite.recalculate_transport_checksum (ether, ip, tx) - in - [just_headers; higherlevel_data] - -let error fmt = - let err s = Failure s in - Printf.ksprintf err fmt - -let return = Lwt.return -let fail = Lwt.fail - -let or_fail msg = function - | `Ok x -> return x - | `Error _ -> fail (Failure msg) From b4079ac8619c58354cc25132f7e55556de0645b8 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Sun, 5 Mar 2017 16:31:04 +0000 Subject: [PATCH 012/281] Update to new mirage-nat API --- .travis.yml | 2 +- Dockerfile | 11 ++++---- README.md | 3 ++- build-with-docker.sh | 4 +-- client_net.ml | 11 ++++---- firewall.ml | 61 +++++++++++++++----------------------------- firewall.mli | 4 +-- my_nat.ml | 30 ++++------------------ my_nat.mli | 6 ++--- packet.ml | 2 +- uplink.ml | 25 ++++++++++-------- 11 files changed, 62 insertions(+), 97 deletions(-) diff --git a/.travis.yml b/.travis.yml index e9d1353..6ef81aa 100644 --- a/.travis.yml +++ b/.travis.yml @@ -20,4 +20,4 @@ addons: - time - libxen-dev env: - - OCAML_VERSION=4.04 MIRAGE_BACKEND=xen PINS="mirage-nat:https://github.com/talex5/mirage-nat.git#mirage3" + - OCAML_VERSION=4.04 MIRAGE_BACKEND=xen PINS="mirage-nat:https://github.com/talex5/mirage-nat.git#cleanup" diff --git a/Dockerfile b/Dockerfile index 2182d1e..4c8b436 100644 --- a/Dockerfile +++ b/Dockerfile @@ -2,19 +2,20 @@ # It will probably still work on newer images, though, unless Debian 8 # changes some compiler optimisations (unlikely). #FROM ocaml/opam:debian-8_ocaml-4.03.0 -FROM ocaml/opam@sha256:28efab6a5535a517aa719ba5ac6d2e6fddd4831afaeabf5eee6470717eda9cca +FROM ocaml/opam@sha256:72ebf516fca7a9464db2136f2dcf2a58d09547669b60f3643a8329768febaed6 # 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 opam-repository && git reset --hard 0f17b354206c97e729700ce60ddce3789ccb1d52 && opam update +RUN cd opam-repository && git reset --hard 8f4d15eae94dfe6f70a66a7572a21a0c60d9f4f4 && opam update RUN sudo apt-get install -y m4 libxen-dev RUN opam install -y vchan xen-gnt mirage-xen-ocaml mirage-xen-minios io-page mirage-xen mirage -RUN opam pin add -n -y mirage-nat 'https://github.com/talex5/mirage-nat.git#simplify-checksum' +RUN opam pin add -n -y tcpip 'https://github.com/talex5/mirage-tcpip.git#fix-length-checks' +RUN opam pin add -n -y mirage-nat 'https://github.com/talex5/mirage-nat.git#cleanup' RUN mkdir /home/opam/qubes-mirage-firewall ADD config.ml /home/opam/qubes-mirage-firewall/config.ml WORKDIR /home/opam/qubes-mirage-firewall -RUN opam config exec -- mirage configure --xen -CMD opam config exec -- mirage configure --xen --no-opam && \ +RUN opam config exec -- mirage configure -t xen && make depend +CMD opam config exec -- mirage configure -t xen && \ opam config exec -- make tar diff --git a/README.md b/README.md index 18b0b7e..7e24e99 100644 --- a/README.md +++ b/README.md @@ -31,7 +31,8 @@ This took about 10 minutes on my laptop (it will be much quicker if you run it a 2. Install mirage, pinning a few unreleased features we need: - opam pin add -y mirage-nat 'https://github.com/talex5/mirage-nat.git#mirage3' + opam pin add -n -y tcpip 'https://github.com/talex5/mirage-tcpip.git#fix-length-checks' + opam pin add -y mirage-nat 'https://github.com/talex5/mirage-nat.git#cleanup' opam install mirage 3. Build mirage-firewall: diff --git a/build-with-docker.sh b/build-with-docker.sh index d61f13c..f004471 100755 --- a/build-with-docker.sh +++ b/build-with-docker.sh @@ -4,5 +4,5 @@ echo Building Docker image with dependencies.. 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 mir-qubes-firewall.xen)" -echo "SHA2 last known: f0c1a06fc4b02b494c81972dc89419af6cffa73b75839c0e8ee3798d77bf69b3" +echo "SHA2 of build: $(sha256sum qubes_firewall.xen)" +echo "SHA2 last known: 45b82182341237ca9e754636f771ef3f4c93824212d1a76520a8a79bbee18668" diff --git a/client_net.ml b/client_net.ml index 50f22ea..7148011 100644 --- a/client_net.ml +++ b/client_net.ml @@ -45,7 +45,7 @@ let clients : Cleanup.t Dao.VifMap.t ref = ref Dao.VifMap.empty let input_arp ~fixed_arp ~iface request = match Arpv4_packet.Unmarshal.of_cstruct request with | Error e -> - Log.warn (fun f -> f "ignored unknown ARP message: %a" Arpv4_packet.Unmarshal.pp_error e); + Log.warn (fun f -> f "Ignored unknown ARP message: %a" Arpv4_packet.Unmarshal.pp_error e); Lwt.return () | Ok arp -> match Client_eth.ARP.input fixed_arp arp with @@ -55,13 +55,14 @@ let input_arp ~fixed_arp ~iface request = (** Handle an IPv4 packet from the client. *) let input_ipv4 ~client_ip ~router packet = - match Ipv4_packet.Unmarshal.of_cstruct packet with + match Nat_packet.of_ipv4_packet packet with | Error e -> - Log.warn (fun f -> f "ignored unknown IPv4 message: %s" e); + Log.warn (fun f -> f "Ignored unknown IPv4 message: %a" Nat_packet.pp_error e); Lwt.return () - | Ok (ip, payload) -> + | Ok packet -> + let `IPv4 (ip, _) = packet in let src = ip.Ipv4_packet.src in - if src = client_ip then Firewall.ipv4_from_client router (ip, payload) + if src = client_ip then Firewall.ipv4_from_client router packet else ( Log.warn (fun f -> f "Incorrect source IP %a in IP packet from %a (dropping)" Ipaddr.V4.pp_hum src Ipaddr.V4.pp_hum client_ip); diff --git a/firewall.ml b/firewall.ml index 226a56c..350eecf 100644 --- a/firewall.ml +++ b/firewall.ml @@ -10,10 +10,10 @@ module Log = (val Logs.src_log src : Logs.LOG) (* Transmission *) -let transmit (ip, payload) iface = - let packet = Ipv4_packet.Marshal.make_cstruct ~payload ip in +let transmit_ipv4 packet iface = + let headers, payload = Nat_packet.make_headers_cstruct packet in Lwt.catch - (fun () -> iface#writev Ethif_wire.IPv4 [packet; payload]) + (fun () -> iface#writev Ethif_wire.IPv4 [headers; payload]) (fun ex -> Log.warn (fun f -> f "Failed to write packet to %a: %s" Ipaddr.V4.pp_hum iface#other_ip @@ -21,42 +21,23 @@ let transmit (ip, payload) iface = Lwt.return () ) -let forward_ipv4 t (ip, packet) = +let forward_ipv4 t packet = + let `IPv4 (ip, _) = packet in match Router.target t ip with - | Some iface -> transmit (ip, packet) iface + | Some iface -> transmit_ipv4 packet iface | None -> return () (* Packet classification *) -let classify_tcp trans = - match Tcp.Tcp_packet.Unmarshal.of_cstruct trans with - | Error e -> - Log.info (fun f -> f "Failed to parse TCP packet: %s" e); - `Unknown - | Ok (tcp, _payload) -> - let sport = tcp.Tcp.Tcp_packet.src_port in - let dport = tcp.Tcp.Tcp_packet.dst_port in - `TCP {sport; dport} - -let classify_udp trans = - match Udp_packet.Unmarshal.of_cstruct trans with - | Error e -> - Log.info (fun f -> f "Failed to parse UDP packet: %s" e); - `Unknown - | Ok (udp, _payload) -> - let sport = udp.Udp_packet.src_port in - let dport = udp.Udp_packet.dst_port in - `UDP {sport; dport} - -let classify t (ip, transport) = +let classify t packet = + let `IPv4 (ip, transport) = packet in let proto = - match ip.Ipv4_packet.proto |> Ipv4_packet.Unmarshal.int_to_protocol with - | Some `ICMP -> `ICMP - | Some `TCP -> classify_tcp transport - | Some `UDP -> classify_udp transport - | None -> `Unknown in + match transport with + | `TCP ({Tcp.Tcp_packet.src_port; dst_port; _}, _) -> `TCP {sport = src_port; dport = dst_port} + | `UDP ({Udp_packet.src_port; dst_port; _}, _) -> `UDP {sport = src_port; dport = dst_port} + in Some { - packet = (ip, transport); + packet; src = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.src); dst = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.dst); proto; @@ -114,8 +95,8 @@ let nat_to t ~host ~port packet = let apply_rules t rules info = let packet = info.packet in match rules info, info.dst with - | `Accept, `Client client_link -> transmit packet client_link - | `Accept, (`External _ | `NetVM) -> transmit packet t.Router.uplink + | `Accept, `Client client_link -> transmit_ipv4 packet client_link + | `Accept, (`External _ | `NetVM) -> transmit_ipv4 packet t.Router.uplink | `Accept, (`Firewall_uplink | `Client_gateway) -> Log.warn (fun f -> f "Bad rule: firewall can't accept packets %a" pp_packet info); return () @@ -133,24 +114,24 @@ let handle_low_memory t = `Memory_critical | `Ok -> Lwt.return `Ok -let ipv4_from_client t (ip, payload) = +let ipv4_from_client t packet = handle_low_memory t >>= function | `Memory_critical -> return () | `Ok -> (* Check for existing NAT entry for this packet *) - translate t (ip, payload) >>= function + translate t packet >>= function | Some frame -> forward_ipv4 t frame (* Some existing connection or redirect *) | None -> (* No existing NAT entry. Check the firewall rules. *) - match classify t (ip, payload) with + match classify t packet with | None -> return () | Some info -> apply_rules t Rules.from_client info -let ipv4_from_netvm t (ip, payload) = +let ipv4_from_netvm t packet = handle_low_memory t >>= function | `Memory_critical -> return () | `Ok -> - match classify t (ip, payload) with + match classify t packet with | None -> return () | Some info -> match info.src with @@ -158,7 +139,7 @@ let ipv4_from_netvm t (ip, payload) = Log.warn (fun f -> f "Frame from NetVM has internal source IP address! %a" pp_packet info); return () | `External _ | `NetVM -> - translate t (ip, payload) >>= function + translate t packet >>= function | Some frame -> forward_ipv4 t frame | None -> apply_rules t Rules.from_netvm info diff --git a/firewall.mli b/firewall.mli index 3a88270..3909ee0 100644 --- a/firewall.mli +++ b/firewall.mli @@ -3,9 +3,9 @@ (** Classify IP packets, apply rules and send as appropriate. *) -val ipv4_from_netvm : Router.t -> Ipv4_packet.t * Cstruct.t -> unit Lwt.t +val ipv4_from_netvm : Router.t -> Nat_packet.t -> unit Lwt.t (** Handle a packet from the outside world (this module will validate the source IP). *) -val ipv4_from_client : Router.t -> Ipv4_packet.t * Cstruct.t -> unit Lwt.t +val ipv4_from_client : Router.t -> 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/my_nat.ml b/my_nat.ml index ec9d0f2..8d81258 100644 --- a/my_nat.ml +++ b/my_nat.ml @@ -11,8 +11,6 @@ type action = [ | `Redirect of Ipaddr.t * int ] -type packet = Ipv4_packet.t * Cstruct.t - (* To avoid needing to allocate a new NAT table when we've run out of memory, pre-allocate the new one ahead of time. *) type 'a with_standby = { @@ -35,21 +33,10 @@ let fake_ipv4_eth = let dontcare = Macaddr.broadcast in Fw_utils.eth_header Ethif_wire.IPv4 ~src:dontcare ~dst:dontcare -let translate (Nat ((module Nat), _, table)) (ip, payload) = - (* XXX: change Nat.translate API *) - let packet = Ipv4_packet.Marshal.make_cstruct ~payload ip in - let frame = Cstruct.concat [ - fake_ipv4_eth; - packet; - payload; - ] in - Nat.translate table.current frame >|= function +let translate (Nat ((module Nat), _, table)) packet = + Nat.translate table.current packet >|= function | Mirage_nat.Untranslated -> None - | Mirage_nat.Translated _ -> (* XXX: translate mutates frame *) - let packet = Cstruct.shift frame Ethif_wire.sizeof_ethernet in - match Ipv4_packet.Unmarshal.of_cstruct packet with - | Error e -> Log.err (fun f -> f "Translation failed: %s" e); None - | Ok packet -> Some packet + | Mirage_nat.Translated packet -> Some packet let random_user_port () = 1024 + Random.int (0xffff - 1024) @@ -62,20 +49,13 @@ let reset (Nat ((module Nat), c, table)) = table.next <- next let add_nat_rule_and_translate ((Nat ((module Nat), c, table)) as t) ~xl_host action packet = - let frame = - let (ip, payload) = packet in - Cstruct.concat [ - fake_ipv4_eth; - Ipv4_packet.Marshal.make_cstruct ~payload ip; - payload; - ] in let apply_action xl_port = Lwt.try_bind (fun () -> match action with | `Rewrite -> - Nat.add_nat table.current frame (xl_host, xl_port) + Nat.add_nat table.current packet (xl_host, xl_port) | `Redirect target -> - Nat.add_redirect table.current frame (xl_host, xl_port) target + Nat.add_redirect table.current packet (xl_host, xl_port) target ) (function | Nat.Ok -> Lwt.return (Ok ()) diff --git a/my_nat.mli b/my_nat.mli index cf71dec..ac6e0f9 100644 --- a/my_nat.mli +++ b/my_nat.mli @@ -10,10 +10,8 @@ type action = [ | `Redirect of Ipaddr.t * int ] -type packet = Ipv4_packet.t * Cstruct.t - val create : (module Mirage_nat.S with type t = 'a and type config = 'c) -> 'c -> t Lwt.t val reset : t -> unit Lwt.t -val translate : t -> packet -> packet option Lwt.t +val translate : t -> Nat_packet.t -> Nat_packet.t option Lwt.t val add_nat_rule_and_translate : t -> xl_host:Ipaddr.t -> - action -> packet -> (packet, string) result Lwt.t + action -> Nat_packet.t -> (Nat_packet.t, string) result Lwt.t diff --git a/packet.ml b/packet.ml index bea2594..a9fa4e7 100644 --- a/packet.ml +++ b/packet.ml @@ -14,7 +14,7 @@ type host = [ `Client of client_link | `Client_gateway | `Firewall_uplink | `NetVM | `External of Ipaddr.t ] type info = { - packet : Ipv4_packet.t * Cstruct.t; + packet : Nat_packet.t; src : host; dst : host; proto : [ `UDP of ports | `TCP of ports | `ICMP | `Unknown ]; diff --git a/uplink.ml b/uplink.ml index 0dfe79c..ff7e718 100644 --- a/uplink.ml +++ b/uplink.ml @@ -34,17 +34,20 @@ module Make(Clock : Mirage_clock_lwt.MCLOCK) = struct let listen t router = Netif.listen t.net (fun frame -> - (* Handle one Ethernet frame from NetVM *) - Eth.input t.eth - ~arpv4:(Arp.input t.arp) - ~ipv4:(fun ip -> - match Ipv4_packet.Unmarshal.of_cstruct ip with - | Error e -> Log.warn (fun f -> f "Bad IPv4 packet from uplink: %s" e); Lwt.return () - | Ok packet -> Firewall.ipv4_from_netvm router packet - ) - ~ipv6:(fun _ip -> return ()) - frame - ) >|= or_raise "Uplink listen loop" Netif.pp_error + (* Handle one Ethernet frame from NetVM *) + Eth.input t.eth + ~arpv4:(Arp.input t.arp) + ~ipv4:(fun ip -> + match Nat_packet.of_ipv4_packet ip with + | Error e -> + Log.warn (fun f -> f "Ignored unknown IPv4 message from uplink: %a" Nat_packet.pp_error e); + Lwt.return () + | Ok packet -> + Firewall.ipv4_from_netvm router packet + ) + ~ipv6:(fun _ip -> return ()) + frame + ) >|= or_raise "Uplink listen loop" Netif.pp_error let interface t = t.interface From e070044fefcd43d6024099bf27794bfe474bec31 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Mon, 6 Mar 2017 14:30:41 +0000 Subject: [PATCH 013/281] Add extra logging --- client_net.ml | 5 +++++ firewall.ml | 20 +++++++++++++++----- my_nat.ml | 6 ------ uplink.ml | 5 +++++ 4 files changed, 25 insertions(+), 11 deletions(-) diff --git a/client_net.ml b/client_net.ml index 7148011..e7bc744 100644 --- a/client_net.ml +++ b/client_net.ml @@ -83,6 +83,11 @@ let add_vif { Dao.ClientVif.domid; device_id } ~client_ip ~router ~cleanup_tasks let fixed_arp = Client_eth.ARP.create ~net:client_eth iface in Netback.listen backend (fun frame -> match Ethif_packet.Unmarshal.of_cstruct frame with + | exception ex -> + Log.err (fun f -> f "Error unmarshalling ethernet frame from client: %s@.%a" (Printexc.to_string ex) + Cstruct.hexdump_pp frame + ); + Lwt.return_unit | Error err -> Log.warn (fun f -> f "Invalid Ethernet frame: %s" err); return () | Ok (eth, payload) -> match eth.Ethif_packet.ethertype with diff --git a/firewall.ml b/firewall.ml index 350eecf..623c071 100644 --- a/firewall.ml +++ b/firewall.ml @@ -11,13 +11,23 @@ module Log = (val Logs.src_log src : Logs.LOG) (* Transmission *) let transmit_ipv4 packet iface = - let headers, payload = Nat_packet.make_headers_cstruct packet in Lwt.catch - (fun () -> iface#writev Ethif_wire.IPv4 [headers; payload]) + (fun () -> + let transport = Nat_packet.to_cstruct packet in + Lwt.catch + (fun () -> iface#writev Ethif_wire.IPv4 transport) + (fun ex -> + Log.warn (fun f -> f "Failed to write packet to %a: %s" + Ipaddr.V4.pp_hum iface#other_ip + (Printexc.to_string ex)); + Lwt.return () + ) + ) (fun ex -> - Log.warn (fun f -> f "Failed to write packet to %a: %s" - Ipaddr.V4.pp_hum iface#other_ip - (Printexc.to_string ex)); + Log.err (fun f -> f "Exception in transmit_ipv4: %s for:@.%a" + (Printexc.to_string ex) + Nat_packet.pp packet + ); Lwt.return () ) diff --git a/my_nat.ml b/my_nat.ml index 8d81258..665e703 100644 --- a/my_nat.ml +++ b/my_nat.ml @@ -27,12 +27,6 @@ let create (type c t) (nat:(module Mirage_nat.S with type config = c and type t let table = { current; next } in Lwt.return (Nat (nat, c, table)) -(* Ideally, mirage-nat wouldn't ask us for an ethernet header, since it only - cares about the IP layer anyway. *) -let fake_ipv4_eth = - let dontcare = Macaddr.broadcast in - Fw_utils.eth_header Ethif_wire.IPv4 ~src:dontcare ~dst:dontcare - let translate (Nat ((module Nat), _, table)) packet = Nat.translate table.current packet >|= function | Mirage_nat.Untranslated -> None diff --git a/uplink.ml b/uplink.ml index ff7e718..5735418 100644 --- a/uplink.ml +++ b/uplink.ml @@ -39,6 +39,11 @@ module Make(Clock : Mirage_clock_lwt.MCLOCK) = struct ~arpv4:(Arp.input t.arp) ~ipv4:(fun ip -> match Nat_packet.of_ipv4_packet ip with + | exception ex -> + Log.err (fun f -> f "Error unmarshalling ethernet frame from uplink: %s@.%a" (Printexc.to_string ex) + Cstruct.hexdump_pp frame + ); + Lwt.return_unit | Error e -> Log.warn (fun f -> f "Ignored unknown IPv4 message from uplink: %a" Nat_packet.pp_error e); Lwt.return () From 15fb063137ce2e9b70d7f6136589adbc2599d418 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Mon, 6 Mar 2017 14:31:26 +0000 Subject: [PATCH 014/281] Pin tcpip --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 6ef81aa..e46684f 100644 --- a/.travis.yml +++ b/.travis.yml @@ -20,4 +20,4 @@ addons: - time - libxen-dev env: - - OCAML_VERSION=4.04 MIRAGE_BACKEND=xen PINS="mirage-nat:https://github.com/talex5/mirage-nat.git#cleanup" + - OCAML_VERSION=4.04 MIRAGE_BACKEND=xen PINS="mirage-nat:https://github.com/talex5/mirage-nat.git#cleanup tcpip:https://github.com/talex5/mirage-tcpip.git#fix-length-checks" From ac711f4eee40b7c817baf7136295a4d0106e0e50 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Tue, 7 Mar 2017 10:02:54 +0000 Subject: [PATCH 015/281] Add ICMP ping support --- firewall.ml | 1 + my_nat.ml | 25 ++++++++++--------------- 2 files changed, 11 insertions(+), 15 deletions(-) diff --git a/firewall.ml b/firewall.ml index 623c071..341f103 100644 --- a/firewall.ml +++ b/firewall.ml @@ -45,6 +45,7 @@ let classify t packet = match transport with | `TCP ({Tcp.Tcp_packet.src_port; dst_port; _}, _) -> `TCP {sport = src_port; dport = dst_port} | `UDP ({Udp_packet.src_port; dst_port; _}, _) -> `UDP {sport = src_port; dport = dst_port} + | `ICMP _ -> `ICMP in Some { packet; diff --git a/my_nat.ml b/my_nat.ml index 665e703..4d15111 100644 --- a/my_nat.ml +++ b/my_nat.ml @@ -29,8 +29,8 @@ let create (type c t) (nat:(module Mirage_nat.S with type config = c and type t let translate (Nat ((module Nat), _, table)) packet = Nat.translate table.current packet >|= function - | Mirage_nat.Untranslated -> None - | Mirage_nat.Translated packet -> Some packet + | Error `Untranslated -> None + | Ok packet -> Some packet let random_user_port () = 1024 + Random.int (0xffff - 1024) @@ -44,17 +44,12 @@ let reset (Nat ((module Nat), c, table)) = let add_nat_rule_and_translate ((Nat ((module Nat), c, table)) as t) ~xl_host action packet = let apply_action xl_port = - Lwt.try_bind (fun () -> - match action with - | `Rewrite -> - Nat.add_nat table.current packet (xl_host, xl_port) - | `Redirect target -> - Nat.add_redirect table.current packet (xl_host, xl_port) target - ) - (function - | Nat.Ok -> Lwt.return (Ok ()) - | Nat.Overlap -> Lwt.return (Error `Overlap) - | Nat.Unparseable -> Lwt.return (Error `Unparseable) + Lwt.catch (fun () -> + match action with + | `Rewrite -> + Nat.add_nat table.current packet (xl_host, xl_port) + | `Redirect target -> + Nat.add_redirect table.current packet (xl_host, xl_port) target ) (function | Out_of_memory -> Lwt.return (Error `Out_of_memory) @@ -86,8 +81,8 @@ let add_nat_rule_and_translate ((Nat ((module Nat), c, table)) as t) ~xl_host ac ) else ( aux ~retries:(retries - 1) ) - | Error `Unparseable -> - Lwt.return (Error "Unparseable by mirage-nat") + | Error `Cannot_NAT -> + Lwt.return (Error "Cannot NAT this packet") | Ok () -> translate t packet >|= function | None -> Error "No NAT entry, even after adding one!" From 6f8d83f82875eb07561a47f45de178d7b5abc924 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Tue, 7 Mar 2017 16:06:18 +0000 Subject: [PATCH 016/281] Use new Nat.reset function to clear the table --- my_nat.ml | 63 +++++++++++----------------------------------------- my_nat.mli | 2 +- unikernel.ml | 2 +- 3 files changed, 15 insertions(+), 52 deletions(-) diff --git a/my_nat.ml b/my_nat.ml index 4d15111..6cdcae1 100644 --- a/my_nat.ml +++ b/my_nat.ml @@ -11,58 +11,37 @@ type action = [ | `Redirect of Ipaddr.t * int ] -(* To avoid needing to allocate a new NAT table when we've run out of - memory, pre-allocate the new one ahead of time. *) -type 'a with_standby = { - mutable current :'a; - mutable next : 'a; -} +type t = Nat : (module Mirage_nat.S with type t = 't) * 't -> t -type t = Nat : (module Mirage_nat.S with type t = 't and type config = 'c) * 'c * 't with_standby -> t +let create (type t) (nat:(module Mirage_nat.S with type t = t)) (table:t) = + let (module Nat : Mirage_nat.S with type t = t) = nat in + Nat (nat, table) -let create (type c t) (nat:(module Mirage_nat.S with type config = c and type t = t)) (c:c) = - let (module Nat : Mirage_nat.S with type config = c and type t = t) = nat in - Nat.empty c >>= fun current -> - Nat.empty c >>= fun next -> - let table = { current; next } in - Lwt.return (Nat (nat, c, table)) - -let translate (Nat ((module Nat), _, table)) packet = - Nat.translate table.current packet >|= function +let translate (Nat ((module Nat), table)) packet = + Nat.translate table packet >|= function | Error `Untranslated -> None | Ok packet -> Some packet let random_user_port () = 1024 + Random.int (0xffff - 1024) -let reset (Nat ((module Nat), c, table)) = - table.current <- table.next; - (* (at this point, the big old NAT table can be GC'd, so allocating - a new one should be OK) *) - Nat.empty c >|= fun next -> - table.next <- next +let reset (Nat ((module Nat), table)) = + Nat.reset table -let add_nat_rule_and_translate ((Nat ((module Nat), c, table)) as t) ~xl_host action packet = +let add_nat_rule_and_translate ((Nat ((module Nat), table)) as t) ~xl_host action packet = let apply_action xl_port = Lwt.catch (fun () -> match action with | `Rewrite -> - Nat.add_nat table.current packet (xl_host, xl_port) + Nat.add_nat table packet (xl_host, xl_port) | `Redirect target -> - Nat.add_redirect table.current packet (xl_host, xl_port) target + Nat.add_redirect table packet (xl_host, xl_port) target ) (function | Out_of_memory -> Lwt.return (Error `Out_of_memory) | x -> Lwt.fail x ) in - let reset () = - table.current <- table.next; - (* (at this point, the big old NAT table can be GC'd, so allocating - a new one should be OK) *) - Nat.empty c >|= fun next -> - table.next <- next - in let rec aux ~retries = let xl_port = random_user_port () in apply_action xl_port >>= function @@ -70,13 +49,13 @@ let add_nat_rule_and_translate ((Nat ((module Nat), c, table)) as t) ~xl_host ac (* Because hash tables resize in big steps, this can happen even if we have a fair chunk of free memory. *) Log.warn (fun f -> f "Out_of_memory adding NAT rule. Dropping NAT table..."); - reset () >>= fun () -> + Nat.reset table >>= fun () -> aux ~retries:(retries - 1) | Error `Overlap when retries < 0 -> Lwt.return (Error "Too many retries") | Error `Overlap -> if retries = 0 then ( Log.warn (fun f -> f "Failed to find a free port; resetting NAT table"); - reset () >>= fun () -> + Nat.reset table >>= fun () -> aux ~retries:(retries - 1) ) else ( aux ~retries:(retries - 1) @@ -87,22 +66,6 @@ let add_nat_rule_and_translate ((Nat ((module Nat), c, table)) as t) ~xl_host ac translate t packet >|= function | None -> Error "No NAT entry, even after adding one!" | Some packet -> -(* - Log.debug (fun f -> - match action with - | `Rewrite -> - let (ip, trans) = packet in - let src, dst = Nat_rewrite.addresses_of_ip ip in - let sport, dport = Nat_rewrite.ports_of_transport transport in - f "added NAT entry: %s:%d -> firewall:%d -> %d:%s" (Ipaddr.to_string src) sport xl_port dport (Ipaddr.to_string dst) - | `Redirect -> - let (ip, transport) = packet in - let src, _dst = Nat_rewrite.addresses_of_ip ip in - let sport, dport = Nat_rewrite.ports_of_transport transport in - f "added NAT redirect %s:%d -> %d:firewall:%d -> %d:%a" - (Ipaddr.to_string src) sport dport xl_port port pp_host host - ); -*) Ok packet in aux ~retries:100 diff --git a/my_nat.mli b/my_nat.mli index ac6e0f9..7ff5b88 100644 --- a/my_nat.mli +++ b/my_nat.mli @@ -10,7 +10,7 @@ type action = [ | `Redirect of Ipaddr.t * int ] -val create : (module Mirage_nat.S with type t = 'a and type config = 'c) -> 'c -> t Lwt.t +val create : (module Mirage_nat.S with type t = 'a) -> 'a -> t val reset : t -> unit Lwt.t val translate : t -> Nat_packet.t -> Nat_packet.t option Lwt.t val add_nat_rule_and_translate : t -> xl_host:Ipaddr.t -> diff --git a/unikernel.ml b/unikernel.ml index 3189bb0..f0368a7 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -72,7 +72,7 @@ module Main (Clock : Mirage_clock_lwt.MCLOCK) = struct OS.Lifecycle.await_shutdown_request () >>= fun (`Poweroff | `Reboot) -> return () in (* Set up networking *) - My_nat.create (module Nat) clock >>= fun nat -> + Nat.empty clock >|= My_nat.create (module Nat) >>= fun nat -> let net_listener = network ~clock nat qubesDB in (* Report memory usage to XenStore *) Memory_pressure.init (); From 0ef60ae76789ea3b8144b744d0e14a35512a381d Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Fri, 10 Mar 2017 16:09:36 +0000 Subject: [PATCH 017/281] Update to new mirage-nat API --- firewall.ml | 20 +++++++++++--------- my_nat.ml | 45 ++++++++++++++++++++++++++------------------- my_nat.mli | 8 ++++---- unikernel.ml | 4 ++-- 4 files changed, 43 insertions(+), 34 deletions(-) diff --git a/firewall.ml b/firewall.ml index 341f103..f0d29ef 100644 --- a/firewall.ml +++ b/firewall.ml @@ -84,8 +84,8 @@ let translate t packet = (* Add a NAT rule for the endpoints in this frame, via a random port on the firewall. *) let add_nat_and_forward_ipv4 t packet = - let xl_host = Ipaddr.V4 t.Router.uplink#my_ip in - My_nat.add_nat_rule_and_translate t.Router.nat ~xl_host `Rewrite packet >>= function + let xl_host = t.Router.uplink#my_ip in + My_nat.add_nat_rule_and_translate t.Router.nat ~xl_host `NAT packet >>= function | Ok packet -> forward_ipv4 t packet | Error e -> Log.warn (fun f -> f "Failed to add NAT rewrite rule: %s" e); @@ -93,13 +93,15 @@ let add_nat_and_forward_ipv4 t packet = (* Add a NAT rule to redirect this conversation to [host:port] instead of us. *) let nat_to t ~host ~port packet = - let target = Router.resolve t host in - let xl_host = Ipaddr.V4 t.Router.uplink#my_ip in - My_nat.add_nat_rule_and_translate t.Router.nat ~xl_host (`Redirect (target, port)) packet >>= function - | Ok packet -> forward_ipv4 t packet - | Error e -> - Log.warn (fun f -> f "Failed to add NAT redirect rule: %s" e); - Lwt.return () + match Router.resolve t host with + | Ipaddr.V6 _ -> Log.warn (fun f -> f "Cannot NAT with IPv6"); Lwt.return () + | Ipaddr.V4 target -> + let xl_host = t.Router.uplink#my_ip in + My_nat.add_nat_rule_and_translate t.Router.nat ~xl_host (`Redirect (target, port)) packet >>= function + | Ok packet -> forward_ipv4 t packet + | Error e -> + Log.warn (fun f -> f "Failed to add NAT redirect rule: %s" e); + Lwt.return () (* Handle incoming packets *) diff --git a/my_nat.ml b/my_nat.ml index 6cdcae1..be9b57b 100644 --- a/my_nat.ml +++ b/my_nat.ml @@ -7,35 +7,42 @@ let src = Logs.Src.create "my-nat" ~doc:"NAT shim" module Log = (val Logs.src_log src : Logs.LOG) type action = [ - | `Rewrite - | `Redirect of Ipaddr.t * int + | `NAT + | `Redirect of Mirage_nat.endpoint ] -type t = Nat : (module Mirage_nat.S with type t = 't) * 't -> t +module Nat = Mirage_nat_hashtable -let create (type t) (nat:(module Mirage_nat.S with type t = t)) (table:t) = - let (module Nat : Mirage_nat.S with type t = t) = nat in - Nat (nat, table) +type t = { + table : Nat.t; + get_time : unit -> Mirage_nat.time; +} -let translate (Nat ((module Nat), table)) packet = - Nat.translate table packet >|= function - | Error `Untranslated -> None +let create ~get_time = + Nat.empty () >|= fun table -> + { get_time; table } + +let translate t packet = + Nat.translate t.table packet >|= function + | Error (`Untranslated | `TTL_exceeded as e) -> + Log.debug (fun f -> f "Failed to NAT %a: %a" + Nat_packet.pp packet + Mirage_nat.pp_error e + ); + None | Ok packet -> Some packet let random_user_port () = 1024 + Random.int (0xffff - 1024) -let reset (Nat ((module Nat), table)) = - Nat.reset table +let reset t = + Nat.reset t.table -let add_nat_rule_and_translate ((Nat ((module Nat), table)) as t) ~xl_host action packet = +let add_nat_rule_and_translate t ~xl_host action packet = + let now = t.get_time () in let apply_action xl_port = Lwt.catch (fun () -> - match action with - | `Rewrite -> - Nat.add_nat table packet (xl_host, xl_port) - | `Redirect target -> - Nat.add_redirect table packet (xl_host, xl_port) target + Nat.add t.table ~now packet (xl_host, xl_port) action ) (function | Out_of_memory -> Lwt.return (Error `Out_of_memory) @@ -49,13 +56,13 @@ let add_nat_rule_and_translate ((Nat ((module Nat), table)) as t) ~xl_host actio (* Because hash tables resize in big steps, this can happen even if we have a fair chunk of free memory. *) Log.warn (fun f -> f "Out_of_memory adding NAT rule. Dropping NAT table..."); - Nat.reset table >>= fun () -> + Nat.reset t.table >>= fun () -> aux ~retries:(retries - 1) | Error `Overlap when retries < 0 -> Lwt.return (Error "Too many retries") | Error `Overlap -> if retries = 0 then ( Log.warn (fun f -> f "Failed to find a free port; resetting NAT table"); - Nat.reset table >>= fun () -> + Nat.reset t.table >>= fun () -> aux ~retries:(retries - 1) ) else ( aux ~retries:(retries - 1) diff --git a/my_nat.mli b/my_nat.mli index 7ff5b88..6761b73 100644 --- a/my_nat.mli +++ b/my_nat.mli @@ -6,12 +6,12 @@ type t type action = [ - | `Rewrite - | `Redirect of Ipaddr.t * int + | `NAT + | `Redirect of Mirage_nat.endpoint ] -val create : (module Mirage_nat.S with type t = 'a) -> 'a -> t +val create : get_time:(unit -> Mirage_nat.time) -> t Lwt.t val reset : t -> unit Lwt.t val translate : t -> Nat_packet.t -> Nat_packet.t option Lwt.t -val add_nat_rule_and_translate : t -> xl_host:Ipaddr.t -> +val add_nat_rule_and_translate : t -> xl_host:Ipaddr.V4.t -> action -> Nat_packet.t -> (Nat_packet.t, string) result Lwt.t diff --git a/unikernel.ml b/unikernel.ml index f0368a7..5cf69f9 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -9,7 +9,6 @@ module Log = (val Logs.src_log src : Logs.LOG) module Main (Clock : Mirage_clock_lwt.MCLOCK) = struct module Uplink = Uplink.Make(Clock) - module Nat = Mirage_nat_hashtable.Make(Clock)(OS.Time) (* Set up networking and listen for incoming packets. *) let network ~clock nat qubesDB = @@ -72,7 +71,8 @@ module Main (Clock : Mirage_clock_lwt.MCLOCK) = struct OS.Lifecycle.await_shutdown_request () >>= fun (`Poweroff | `Reboot) -> return () in (* Set up networking *) - Nat.empty clock >|= My_nat.create (module Nat) >>= fun nat -> + let get_time () = Clock.elapsed_ns clock in + My_nat.create ~get_time >>= fun nat -> let net_listener = network ~clock nat qubesDB in (* Report memory usage to XenStore *) Memory_pressure.init (); From 75dd8503c5ddb3bb6824e12be4fb15489673adf9 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Wed, 15 Mar 2017 08:56:24 +0000 Subject: [PATCH 018/281] Use LRU cache to prevent out-of-memory errors --- README.md | 4 ++-- config.ml | 10 ++++++++++ my_nat.ml | 41 ++++++++++++++++++++++------------------- my_nat.mli | 2 +- unikernel.ml | 3 ++- 5 files changed, 37 insertions(+), 23 deletions(-) diff --git a/README.md b/README.md index 7e24e99..a819a00 100644 --- a/README.md +++ b/README.md @@ -31,8 +31,8 @@ This took about 10 minutes on my laptop (it will be much quicker if you run it a 2. Install mirage, pinning a few unreleased features we need: - opam pin add -n -y tcpip 'https://github.com/talex5/mirage-tcpip.git#fix-length-checks' - opam pin add -y mirage-nat 'https://github.com/talex5/mirage-nat.git#cleanup' + opam pin add -n -y tcpip.3.0.0 'https://github.com/talex5/mirage-tcpip.git#fix-length-checks' + opam pin add -y mirage-nat 'https://github.com/talex5/mirage-nat.git#lru' opam install mirage 3. Build mirage-firewall: diff --git a/config.ml b/config.ml index 6ac02db..37207aa 100644 --- a/config.ml +++ b/config.ml @@ -5,8 +5,18 @@ open Mirage +let table_size = + let open Functoria_key in + let info = Arg.info + ~doc:"The number of NAT entries to allocate." + ~docv:"ENTRIES" ["nat-table-size"] + in + let key = Arg.opt ~stage:`Both Arg.int 5_000 info in + create "nat_table_size" key + let main = foreign + ~keys:[Functoria_key.abstract table_size] ~packages:[ package "vchan"; package "cstruct"; diff --git a/my_nat.ml b/my_nat.ml index be9b57b..fa995b1 100644 --- a/my_nat.ml +++ b/my_nat.ml @@ -18,8 +18,10 @@ type t = { get_time : unit -> Mirage_nat.time; } -let create ~get_time = - Nat.empty () >|= fun table -> +let create ~get_time ~max_entries = + let tcp_size = 7 * max_entries / 8 in + let udp_size = max_entries - tcp_size in + Nat.empty ~tcp_size ~udp_size ~icmp_size:100 >|= fun table -> { get_time; table } let translate t packet = @@ -53,26 +55,27 @@ let add_nat_rule_and_translate t ~xl_host action packet = let xl_port = random_user_port () in apply_action xl_port >>= function | Error `Out_of_memory -> - (* Because hash tables resize in big steps, this can happen even if we have a fair - chunk of free memory. *) - Log.warn (fun f -> f "Out_of_memory adding NAT rule. Dropping NAT table..."); - Nat.reset t.table >>= fun () -> - aux ~retries:(retries - 1) + (* Because hash tables resize in big steps, this can happen even if we have a fair + chunk of free memory. *) + Log.warn (fun f -> f "Out_of_memory adding NAT rule. Dropping NAT table..."); + Nat.reset t.table >>= fun () -> + aux ~retries:(retries - 1) | Error `Overlap when retries < 0 -> Lwt.return (Error "Too many retries") | Error `Overlap -> - if retries = 0 then ( - Log.warn (fun f -> f "Failed to find a free port; resetting NAT table"); - Nat.reset t.table >>= fun () -> - aux ~retries:(retries - 1) - ) else ( - aux ~retries:(retries - 1) - ) + if retries = 0 then ( + Log.warn (fun f -> f "Failed to find a free port; resetting NAT table"); + Nat.reset t.table >>= fun () -> + aux ~retries:(retries - 1) + ) else ( + aux ~retries:(retries - 1) + ) | Error `Cannot_NAT -> - Lwt.return (Error "Cannot NAT this packet") + Lwt.return (Error "Cannot NAT this packet") | Ok () -> - translate t packet >|= function - | None -> Error "No NAT entry, even after adding one!" - | Some packet -> - Ok packet + Log.debug (fun f -> f "Updated NAT table: %a" Nat.pp_summary t.table); + translate t packet >|= function + | None -> Error "No NAT entry, even after adding one!" + | Some packet -> + Ok packet in aux ~retries:100 diff --git a/my_nat.mli b/my_nat.mli index 6761b73..770eaa0 100644 --- a/my_nat.mli +++ b/my_nat.mli @@ -10,7 +10,7 @@ type action = [ | `Redirect of Mirage_nat.endpoint ] -val create : get_time:(unit -> Mirage_nat.time) -> t Lwt.t +val create : get_time:(unit -> Mirage_nat.time) -> max_entries:int -> t Lwt.t val reset : t -> unit Lwt.t val translate : t -> Nat_packet.t -> Nat_packet.t option Lwt.t val add_nat_rule_and_translate : t -> xl_host:Ipaddr.V4.t -> diff --git a/unikernel.ml b/unikernel.ml index 5cf69f9..e35d1d1 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -72,7 +72,8 @@ module Main (Clock : Mirage_clock_lwt.MCLOCK) = struct return () in (* Set up networking *) let get_time () = Clock.elapsed_ns clock in - My_nat.create ~get_time >>= fun nat -> + let max_entries = Key_gen.nat_table_size () in + My_nat.create ~get_time ~max_entries >>= fun nat -> let net_listener = network ~clock nat qubesDB in (* Report memory usage to XenStore *) Memory_pressure.init (); From 630304500fef32eab4d71ba9613371d917d536d4 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Sat, 18 Mar 2017 10:20:26 +0000 Subject: [PATCH 019/281] Update build for Mirage 3 --- .travis.yml | 2 +- Dockerfile | 7 +++---- build-with-docker.sh | 2 +- config.ml | 4 ++-- 4 files changed, 7 insertions(+), 8 deletions(-) diff --git a/.travis.yml b/.travis.yml index e46684f..ba4e918 100644 --- a/.travis.yml +++ b/.travis.yml @@ -20,4 +20,4 @@ addons: - time - libxen-dev env: - - OCAML_VERSION=4.04 MIRAGE_BACKEND=xen PINS="mirage-nat:https://github.com/talex5/mirage-nat.git#cleanup tcpip:https://github.com/talex5/mirage-tcpip.git#fix-length-checks" + - FORK_USER=talex5 FORK_BRANCH=unikernel OCAML_VERSION=4.04 MIRAGE_BACKEND=xen PINS="mirage-nat:https://github.com/talex5/mirage-nat.git#lru" diff --git a/Dockerfile b/Dockerfile index 4c8b436..479eac0 100644 --- a/Dockerfile +++ b/Dockerfile @@ -2,17 +2,16 @@ # It will probably still work on newer images, though, unless Debian 8 # changes some compiler optimisations (unlikely). #FROM ocaml/opam:debian-8_ocaml-4.03.0 -FROM ocaml/opam@sha256:72ebf516fca7a9464db2136f2dcf2a58d09547669b60f3643a8329768febaed6 +FROM ocaml/opam@sha256:48c025a4ec2e6ff6dcb4c14f8cae0f332a090fa1ed677170912c4a48627778ab # 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 opam-repository && git reset --hard 8f4d15eae94dfe6f70a66a7572a21a0c60d9f4f4 && opam update +RUN cd opam-repository && git reset --hard a51e30ffcec63836014a5bd2408203ec02e4c7af && opam update RUN sudo apt-get install -y m4 libxen-dev RUN opam install -y vchan xen-gnt mirage-xen-ocaml mirage-xen-minios io-page mirage-xen mirage -RUN opam pin add -n -y tcpip 'https://github.com/talex5/mirage-tcpip.git#fix-length-checks' -RUN opam pin add -n -y mirage-nat 'https://github.com/talex5/mirage-nat.git#cleanup' +RUN opam pin add -n -y mirage-nat 'https://github.com/talex5/mirage-nat.git#lru' 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 f004471..4823c77 100755 --- a/build-with-docker.sh +++ b/build-with-docker.sh @@ -5,4 +5,4 @@ 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 qubes_firewall.xen)" -echo "SHA2 last known: 45b82182341237ca9e754636f771ef3f4c93824212d1a76520a8a79bbee18668" +echo "SHA2 last known: 4b24bab81f9c1b14bafabd9725428456c4d6eaff0ef5cefd032a59b9f4021693" diff --git a/config.ml b/config.ml index 37207aa..0b4cf79 100644 --- a/config.ml +++ b/config.ml @@ -1,4 +1,4 @@ -(* Copyright (C) 2015, Thomas Leonard +(* Copyright (C) 2017, Thomas Leonard See the README file for details. *) (** Configuration for the "mirage" tool. *) @@ -20,7 +20,7 @@ let main = ~packages:[ package "vchan"; package "cstruct"; - package "tcpip" ~sublibs:["stack-direct"; "xen"]; + package "tcpip" ~sublibs:["stack-direct"; "xen"] ~min:"3.1.0"; package "mirage-net-xen"; package "mirage-qubes"; package "mirage-nat" ~sublibs:["hashtable"]; From 5158853c30982448aada620fdea250a2e1f1e4c9 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Sat, 18 Mar 2017 11:29:55 +0000 Subject: [PATCH 020/281] Update README --- README.md | 54 +++++++++++++++++++++++------------------------------- 1 file changed, 23 insertions(+), 31 deletions(-) diff --git a/README.md b/README.md index a819a00..3982cd0 100644 --- a/README.md +++ b/README.md @@ -31,7 +31,6 @@ This took about 10 minutes on my laptop (it will be much quicker if you run it a 2. Install mirage, pinning a few unreleased features we need: - opam pin add -n -y tcpip.3.0.0 'https://github.com/talex5/mirage-tcpip.git#fix-length-checks' opam pin add -y mirage-nat 'https://github.com/talex5/mirage-nat.git#lru' opam install mirage @@ -39,7 +38,7 @@ This took about 10 minutes on my laptop (it will be much quicker if you run it a git clone https://github.com/talex5/qubes-mirage-firewall.git cd qubes-mirage-firewall - mirage configure --xen + mirage configure -t xen make ## Deploy @@ -53,9 +52,9 @@ The tarball contains `vmlinuz`, which is the unikernel itself, plus a couple of For development, use the [test-mirage][] scripts to deploy the unikernel (`mir-qubes-firewall.xen`) from your development AppVM. e.g. - $ test-mirage mir-firewall.xen mirage-firewall + $ test-mirage qubes_firewall.xen mirage-firewall Waiting for 'Ready'... OK - Uploading 'mir-qubes-firewall.xen' (4843304 bytes) to "mirage-firewall" + Uploading 'qubes_firewall.xen' (5901080 bytes) to "mirage-firewall" Waiting for 'Booting'... OK --> Loading the VM (type = ProxyVM)... --> Starting Qubes DB... @@ -72,38 +71,31 @@ For development, use the [test-mirage][] scripts to deploy the unikernel (`mir-q MirageOS booting... Initialising timer interface Initialising console ... done. - Netif: add resume hook gnttab_stubs.c: initialised mini-os gntmap - 2015-12-30 10:04.42: INF [qubes.rexec] waiting for client... - 2015-12-30 10:04.42: INF [qubes.gui] waiting for client... - 2015-12-30 10:04.42: INF [qubes.db] connecting to server... - 2015-12-30 10:04.42: INF [qubes.db] connected - 2015-12-30 10:04.42: INF [qubes.rexec] client connected, using protocol version 2 - 2015-12-30 10:04.42: INF [qubes.db] got update: "/qubes-keyboard" = "xkb_keymap {\n\txkb_keycodes { include \"evdev+aliases(qwerty)\"\t};\n\txkb_types { include \"complete\"\t};\n\txkb_compat { include \"complete\"\t};\n\txkb_symbols { include \"pc+gb+inet(evdev)\"\t};\n\txkb_geometry { include \"pc(pc104)\"\t};\n};" - 2015-12-30 10:04.42: INF [qubes.gui] client connected (screen size: 6720x2160) - 2015-12-30 10:04.42: INF [unikernel] agents connected in 0.052 s (CPU time used since boot: 0.007 s) - Netif.connect 0 - Netfront.create: id=0 domid=1 - sg:true gso_tcpv4:true rx_copy:true rx_flip:false smart_poll:false - MAC: 00:16:3e:5e:6c:0b - ARP: sending gratuitous from 10.137.1.13 - 2015-12-30 10:04.42: INF [application] Client (internal) network is 10.137.3.0/24 - ARP: transmitting probe -> 10.137.1.1 - 2015-12-30 10:04.42: INF [net] Watching backend/vif - 2015-12-30 10:04.42: INF [qubes.rexec] Execute "user:QUBESRPC qubes.SetMonitorLayout dom0\000" - 2015-12-30 10:04.42: WRN [command] << Unknown command "QUBESRPC qubes.SetMonitorLayout dom0" - 2015-12-30 10:04.42: INF [qubes.rexec] Execute "root:QUBESRPC qubes.WaitForSession none\000" - 2015-12-30 10:04.42: WRN [command] << Unknown command "QUBESRPC qubes.WaitForSession none" - 2015-12-30 10:04.42: INF [qubes.db] got update: "/qubes-netvm-domid" = "1" - ARP: retrying 10.137.1.1 (n=1) - ARP: transmitting probe -> 10.137.1.1 - ARP: updating 10.137.1.1 -> fe:ff:ff:ff:ff:ff - + 2017-03-18 11:32:37 -00:00: INF [qubes.rexec] waiting for client... + 2017-03-18 11:32:37 -00:00: INF [qubes.gui] waiting for client... + 2017-03-18 11:32:37 -00:00: INF [qubes.db] connecting to server... + 2017-03-18 11:32:37 -00:00: INF [qubes.db] connected + 2017-03-18 11:32:37 -00:00: INF [qubes.rexec] client connected, using protocol version 2 + 2017-03-18 11:32:37 -00:00: INF [qubes.db] got update: "/qubes-keyboard" = "xkb_keymap {\n\txkb_keycodes { include \"evdev+aliases(qwerty)\"\t};\n\txkb_types { include \"complete\"\t};\n\txkb_compat { include \"complete\"\t};\n\txkb_symbols { include \"pc+gb+inet(evdev)\"\t};\n\txkb_geometry { include \"pc(pc105)\"\t};\n};" + 2017-03-18 11:32:37 -00:00: INF [qubes.gui] client connected (screen size: 6720x2160) + 2017-03-18 11:32:37 -00:00: INF [unikernel] Qubes agents connected in 0.095 s (CPU time used since boot: 0.008 s) + 2017-03-18 11:32:37 -00:00: INF [net-xen:frontend] connect 0 + 2017-03-18 11:32:37 -00:00: INF [memory_pressure] Writing meminfo: free 6584 / 17504 kB (37.61 %) + Note: cannot write Xen 'control' directory + 2017-03-18 11:32:37 -00:00: INF [net-xen:frontend] create: id=0 domid=1 + 2017-03-18 11:32:37 -00:00: INF [net-xen:frontend] sg:true gso_tcpv4:true rx_copy:true rx_flip:false smart_poll:false + 2017-03-18 11:32:37 -00:00: INF [net-xen:frontend] MAC: 00:16:3e:5e:6c:11 + 2017-03-18 11:32:37 -00:00: WRN [command] << Unknown command "QUBESRPC qubes.SetMonitorLayout dom0" + 2017-03-18 11:32:38 -00:00: INF [ethif] Connected Ethernet interface 00:16:3e:5e:6c:11 + 2017-03-18 11:32:38 -00:00: INF [arpv4] Connected arpv4 device on 00:16:3e:5e:6c:11 + 2017-03-18 11:32:38 -00:00: INF [dao] Watching backend/vif + 2017-03-18 11:32:38 -00:00: INF [qubes.db] got update: "/qubes-netvm-domid" = "1" # LICENSE -Copyright (c) 2015, Thomas Leonard +Copyright (c) 2017, Thomas Leonard All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: From 583366b22bf78be060bf3ab7be353bc7a3479f79 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Sat, 18 Mar 2017 17:59:06 +0000 Subject: [PATCH 021/281] Remove non-Docker build instructions Fedora 24 doesn't work with opam (because the current binary release of aspcud's clasp binary segfaults, which opam reports as `External solver failed with inconsistent return value.`). --- README.md | 25 +++---------------------- 1 file changed, 3 insertions(+), 22 deletions(-) diff --git a/README.md b/README.md index 3982cd0..4da31f4 100644 --- a/README.md +++ b/README.md @@ -7,7 +7,7 @@ Note: This firewall *ignores the rules set in the Qubes GUI*. See `rules.ml` for See [A Unikernel Firewall for QubesOS][] for more details. -## Build (with Docker) +## Build Clone this Git repository and run the `build-with-docker.sh` script: @@ -19,27 +19,8 @@ Clone this Git repository and run the `build-with-docker.sh` script: This took about 10 minutes on my laptop (it will be much quicker if you run it again). -## Build (without Docker) - -1. Install build tools: - - sudo yum install git gcc m4 0install patch ncurses-devel tar bzip2 unzip make which findutils xen-devel - mkdir ~/bin - 0install add opam http://tools.ocaml.org/opam.xml - opam init --comp=4.04.0 - eval `opam config env` - -2. Install mirage, pinning a few unreleased features we need: - - opam pin add -y mirage-nat 'https://github.com/talex5/mirage-nat.git#lru' - opam install mirage - -3. Build mirage-firewall: - - git clone https://github.com/talex5/qubes-mirage-firewall.git - cd qubes-mirage-firewall - mirage configure -t xen - make +You can also build without Docker, as for any normal Mirage unikernel; +see [the Mirage installation instructions](https://mirage.io/wiki/install) for details. ## Deploy From 78f25ea2c5b79b6ebdb83810adc8676c804e0a44 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Mon, 27 Mar 2017 13:45:06 +0100 Subject: [PATCH 022/281] Fix build instructions No need to run `make tar` manually now. --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 4da31f4..9bf0e00 100644 --- a/README.md +++ b/README.md @@ -24,7 +24,7 @@ see [the Mirage installation instructions](https://mirage.io/wiki/install) for d ## Deploy -If you want to deploy manually, use `make tar` to create `mirage-firewall.tar.bz2` and unpack this in dom0, inside `/var/lib/qubes/vm-kernels/`. e.g. (if `dev` is the AppVM where you built it): +If you want to deploy manually, unpack `mirage-firewall.tar.bz2` in dom0, inside `/var/lib/qubes/vm-kernels/`. e.g. (if `dev` is the AppVM where you built it): [tal@dom0 ~]$ cd /var/lib/qubes/vm-kernels/ [tal@dom0 vm-kernels]$ qvm-run -p dev 'cat qubes-mirage-firewall/mirage-firewall.tar.bz2' | tar xjf - From f4df389713bf8bad65834bbbe693d5d07a729106 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Fri, 7 Apr 2017 13:07:07 +0100 Subject: [PATCH 023/281] Add more detailed installation instructions --- README.md | 18 ++++++++++++++++-- 1 file changed, 16 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index 9bf0e00..1448f20 100644 --- a/README.md +++ b/README.md @@ -26,10 +26,24 @@ see [the Mirage installation instructions](https://mirage.io/wiki/install) for d If you want to deploy manually, unpack `mirage-firewall.tar.bz2` in dom0, inside `/var/lib/qubes/vm-kernels/`. e.g. (if `dev` is the AppVM where you built it): - [tal@dom0 ~]$ cd /var/lib/qubes/vm-kernels/ - [tal@dom0 vm-kernels]$ qvm-run -p dev 'cat qubes-mirage-firewall/mirage-firewall.tar.bz2' | tar xjf - + [tal@dom0 ~]$ cd /var/lib/qubes/vm-kernels/ + [tal@dom0 vm-kernels]$ qvm-run -p dev 'cat qubes-mirage-firewall/mirage-firewall.tar.bz2' | tar xjf - The tarball contains `vmlinuz`, which is the unikernel itself, plus a couple of dummy files that Qubes requires. +To configure your new firewall using the Qubes Manager GUI: + +- Create a new ProxyVM named `mirage-firewall` to run the unikernel. +- You can use any template, and make it standalone or not. It doesn’t matter, since we don’t use the hard disk. +- Set the type to `ProxyVM`. +- Select `sys-net` for networking (not `sys-firewall`). +- Click `OK` to create the VM. +- Go to the VM settings, and look in the `Advanced` tab: + - Set the kernel to `mirage-firewall`. + - Turn off memory balancing and set the memory to 20 MB or so (you might have to fight a bit with the Qubes GUI to get it this low). + - Set VCPUs (number of virtual CPUs) to 1. + +You can run `mirage-firewall` alongside your existing `sys-firewall` and you can choose which AppVMs use which firewall using the GUI. +To configure an AppVM to use it, go to the app VM's settings in the GUI and change its `NetVM` from `default (sys-firewall)` to `mirage-firewall`. Alternatively, you can configure `mirage-firewall` to be your default firewall VM. For development, use the [test-mirage][] scripts to deploy the unikernel (`mir-qubes-firewall.xen`) from your development AppVM. e.g. From 445b1711cbc3e27e0b81ad826b37435478d443b0 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Sat, 8 Apr 2017 13:12:38 +0100 Subject: [PATCH 024/281] Show the packet when failing to add a NAT rule The previous message was just: WRN [firewall] Failed to add NAT rewrite rule: Cannot NAT this packet --- firewall.ml | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) diff --git a/firewall.ml b/firewall.ml index f0d29ef..337c5c8 100644 --- a/firewall.ml +++ b/firewall.ml @@ -77,6 +77,17 @@ let pp_packet fmt {src; dst; proto; packet = _} = pp_host dst pp_proto proto +let pp_transport_headers f = function + | `ICMP (h, _) -> Icmpv4_packet.pp f h + | `TCP (h, _) -> Tcp.Tcp_packet.pp f h + | `UDP (h, _) -> Udp_packet.pp f h + +let pp_header f = function + | `IPv4 (ip, transport) -> + Fmt.pf f "%a %a" + Ipv4_packet.pp ip + pp_transport_headers transport + (* NAT *) let translate t packet = @@ -88,7 +99,7 @@ let add_nat_and_forward_ipv4 t packet = My_nat.add_nat_rule_and_translate t.Router.nat ~xl_host `NAT packet >>= function | Ok packet -> forward_ipv4 t packet | Error e -> - Log.warn (fun f -> f "Failed to add NAT rewrite rule: %s" e); + Log.warn (fun f -> f "Failed to add NAT rewrite rule: %s (%a)" e pp_header packet); Lwt.return () (* Add a NAT rule to redirect this conversation to [host:port] instead of us. *) @@ -100,7 +111,7 @@ let nat_to t ~host ~port packet = My_nat.add_nat_rule_and_translate t.Router.nat ~xl_host (`Redirect (target, port)) packet >>= function | Ok packet -> forward_ipv4 t packet | Error e -> - Log.warn (fun f -> f "Failed to add NAT redirect rule: %s" e); + Log.warn (fun f -> f "Failed to add NAT redirect rule: %s (%a)" e pp_header packet); Lwt.return () (* Handle incoming packets *) From e55c304160e61296ea32bfa36733600c15e85d2c Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Sat, 29 Apr 2017 11:42:31 +0100 Subject: [PATCH 025/281] Drop frames if the xmit queue gets too long With lots of VMs updating, the firewall quit with: 2017-04-23 20:47:52 -00:00: INF [frameQ] Queue length for 10.137.3.11: incr to 474 2017-04-23 20:47:52 -00:00: INF [memory_pressure] Writing meminfo: free 2648 / 17504 kB (15.13 %) [...] Fatal error: out of memory. The firewall will now drop frames when more than 10 are queued (note that queuing only starts once the network driver's transmit buffer is already full). --- frameQ.ml | 31 +++++++++++++++++++------------ frameQ.mli | 2 +- 2 files changed, 20 insertions(+), 13 deletions(-) diff --git a/frameQ.ml b/frameQ.ml index bea4cf2..b6b7ed1 100644 --- a/frameQ.ml +++ b/frameQ.ml @@ -10,16 +10,23 @@ type t = { } let create name = { name; items = 0 } - + +(* Note: the queue is only used if we already filled the transmit buffer. *) +let max_qlen = 10 + let send q fn = - (* TODO: drop if queue too long *) - let sent = fn () in - if Lwt.state sent = Lwt.Sleep then ( - q.items <- q.items + 1; - Log.info (fun f -> f "Queue length for %s: incr to %d" q.name q.items); - Lwt.on_termination sent (fun () -> - q.items <- q.items - 1; - Log.info (fun f -> f "Queue length for %s: decr to %d" q.name q.items); - ) - ); - sent + if q.items = max_qlen then ( + Log.warn (fun f -> f "Maximim queue length exceeded for %s: dropping frame" q.name); + Lwt.return_unit + ) else ( + let sent = fn () in + if Lwt.state sent = Lwt.Sleep then ( + q.items <- q.items + 1; + Log.info (fun f -> f "Queue length for %s: incr to %d" q.name q.items); + Lwt.on_termination sent (fun () -> + q.items <- q.items - 1; + Log.info (fun f -> f "Queue length for %s: decr to %d" q.name q.items); + ) + ); + sent + ) diff --git a/frameQ.mli b/frameQ.mli index de72211..f11e1ae 100644 --- a/frameQ.mli +++ b/frameQ.mli @@ -8,7 +8,7 @@ type t val create : string -> t (** [create name] is a new empty queue. [name] is used in log messages. *) -val send : t -> (unit -> 'a Lwt.t) -> 'a Lwt.t +val send : t -> (unit -> unit Lwt.t) -> unit Lwt.t (** [send t fn] checks that the queue isn't overloaded and calls [fn ()] if it's OK. The item is considered to be queued until the result of [fn] has resolved. In the case of mirage-net-xen's [writev], this happens when the frame has been From 794ca35d234b454ef438c9f8d14856f897180703 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Tue, 12 Sep 2017 16:57:01 +0100 Subject: [PATCH 026/281] Update Dockerfile to use newer Debian base image Was failing with ``` E: Failed to fetch http://security.debian.org/pool/updates/main/x/xen/libxenstore3.0_4.4.1-9+deb8u8_amd64.deb 404 Not Found [IP: 212.211.132.32 80] ``` --- Dockerfile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Dockerfile b/Dockerfile index 479eac0..e04f6d1 100644 --- a/Dockerfile +++ b/Dockerfile @@ -2,7 +2,7 @@ # It will probably still work on newer images, though, unless Debian 8 # changes some compiler optimisations (unlikely). #FROM ocaml/opam:debian-8_ocaml-4.03.0 -FROM ocaml/opam@sha256:48c025a4ec2e6ff6dcb4c14f8cae0f332a090fa1ed677170912c4a48627778ab +FROM ocaml/opam@sha256:66f9d402ab6dc00c47d2ee3195ab247f9c1c8e7e774197f4fa6ea2a290a3ebbc # Pin last known-good version for reproducible builds. # Remove this line (and the base image pin above) if you want to test with the From d61c2312c12a8f8e82e13ddca866cb788893aecd Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Tue, 12 Sep 2017 18:05:55 +0100 Subject: [PATCH 027/281] Fix Travis --- .travis.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index ba4e918..4a58a64 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,5 +1,5 @@ language: c -install: wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-mirage.sh +install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-mirage.sh script: bash -ex .travis-mirage.sh sudo: required dist: trusty @@ -20,4 +20,4 @@ addons: - time - libxen-dev env: - - FORK_USER=talex5 FORK_BRANCH=unikernel OCAML_VERSION=4.04 MIRAGE_BACKEND=xen PINS="mirage-nat:https://github.com/talex5/mirage-nat.git#lru" + - OCAML_VERSION=4.04 MIRAGE_BACKEND=xen PINS="mirage-nat:https://github.com/talex5/mirage-nat.git#lru" From 997d538a93f3c3effe0bd5cabfb7b1f877eb6e0b Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Sun, 15 Oct 2017 14:35:03 +0100 Subject: [PATCH 028/281] Use released mirage-nat 1.0 --- .travis.yml | 2 +- Dockerfile | 9 ++++----- config.ml | 4 ++-- my_nat.ml | 2 +- 4 files changed, 8 insertions(+), 9 deletions(-) diff --git a/.travis.yml b/.travis.yml index 4a58a64..1325706 100644 --- a/.travis.yml +++ b/.travis.yml @@ -20,4 +20,4 @@ addons: - time - libxen-dev env: - - OCAML_VERSION=4.04 MIRAGE_BACKEND=xen PINS="mirage-nat:https://github.com/talex5/mirage-nat.git#lru" + - OCAML_VERSION=4.04 MIRAGE_BACKEND=xen diff --git a/Dockerfile b/Dockerfile index e04f6d1..e971234 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,17 +1,16 @@ # Pin the base image to a specific hash for maximum reproducibility. # It will probably still work on newer images, though, unless Debian 8 # changes some compiler optimisations (unlikely). -#FROM ocaml/opam:debian-8_ocaml-4.03.0 -FROM ocaml/opam@sha256:66f9d402ab6dc00c47d2ee3195ab247f9c1c8e7e774197f4fa6ea2a290a3ebbc +#FROM ocaml/opam:debian-8_ocaml-4.04.2 +FROM ocaml/opam@sha256:17a527319b850bdaf6759386a566dd088a053758b6d0603712dbcb10ad62f86c # 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 opam-repository && git reset --hard a51e30ffcec63836014a5bd2408203ec02e4c7af && opam update +RUN cd opam-repository && git fetch origin && git reset --hard ad6348231fa14e1d9df724db908a1b7fe07d3ab9 && opam update RUN sudo apt-get install -y m4 libxen-dev -RUN opam install -y vchan xen-gnt mirage-xen-ocaml mirage-xen-minios io-page mirage-xen mirage -RUN opam pin add -n -y mirage-nat 'https://github.com/talex5/mirage-nat.git#lru' +RUN opam install -y vchan xen-gnt mirage-xen-ocaml mirage-xen-minios io-page mirage-xen mirage mirage-nat 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/config.ml b/config.ml index 0b4cf79..0a73b48 100644 --- a/config.ml +++ b/config.ml @@ -20,10 +20,10 @@ let main = ~packages:[ package "vchan"; package "cstruct"; - package "tcpip" ~sublibs:["stack-direct"; "xen"] ~min:"3.1.0"; + package "tcpip" ~sublibs:["stack-direct"; "xen"; "arpv4"] ~min:"3.1.0"; package "mirage-net-xen"; package "mirage-qubes"; - package "mirage-nat" ~sublibs:["hashtable"]; + package "mirage-nat"; package "mirage-logs"; ] "Unikernel.Main" (mclock @-> job) diff --git a/my_nat.ml b/my_nat.ml index fa995b1..bfaf702 100644 --- a/my_nat.ml +++ b/my_nat.ml @@ -11,7 +11,7 @@ type action = [ | `Redirect of Mirage_nat.endpoint ] -module Nat = Mirage_nat_hashtable +module Nat = Mirage_nat_lru type t = { table : Nat.t; From b114e569f23db06bb9624d6f74ae9b4fe2542c2c Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Thu, 9 Nov 2017 15:20:55 +0000 Subject: [PATCH 029/281] Use Git master for shared-memory-ring and netchannel This adds support for HVM and disposable domains. Also, update the suggested RAM allocation slightly as 20 MB can be too small with lots of VMs. --- Dockerfile | 9 ++++++--- README.md | 2 +- build-with-docker.sh | 2 +- client_net.ml | 2 +- 4 files changed, 9 insertions(+), 6 deletions(-) diff --git a/Dockerfile b/Dockerfile index e971234..e3cf30c 100644 --- a/Dockerfile +++ b/Dockerfile @@ -2,15 +2,18 @@ # It will probably still work on newer images, though, unless Debian 8 # changes some compiler optimisations (unlikely). #FROM ocaml/opam:debian-8_ocaml-4.04.2 -FROM ocaml/opam@sha256:17a527319b850bdaf6759386a566dd088a053758b6d0603712dbcb10ad62f86c +FROM ocaml/opam@sha256:17143ad95a2e944758fd9de6ee831e9af98367455cd273b17139c38dcb032f09 # 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 opam-repository && git fetch origin && git reset --hard ad6348231fa14e1d9df724db908a1b7fe07d3ab9 && opam update +RUN cd opam-repository && git reset --hard 26fc7c2d5eb5041b7348e28e8300d376a1c31a62 && opam update RUN sudo apt-get install -y m4 libxen-dev -RUN opam install -y vchan xen-gnt mirage-xen-ocaml mirage-xen-minios io-page mirage-xen mirage mirage-nat +# TODO: remove this once the new versions are released (smr>2.0.1 and mnx>1.7.1) +RUN opam pin add -yn --dev netchannel +RUN opam pin add -yn --dev shared-memory-ring +RUN opam install -y vchan xen-gnt mirage-xen-ocaml mirage-xen-minios io-page mirage-xen mirage mirage-nat mirage-qubes 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/README.md b/README.md index 1448f20..6b90ac3 100644 --- a/README.md +++ b/README.md @@ -39,7 +39,7 @@ To configure your new firewall using the Qubes Manager GUI: - Click `OK` to create the VM. - Go to the VM settings, and look in the `Advanced` tab: - Set the kernel to `mirage-firewall`. - - Turn off memory balancing and set the memory to 20 MB or so (you might have to fight a bit with the Qubes GUI to get it this low). + - Turn off memory balancing and set the memory to 32 MB or so (you might have to fight a bit with the Qubes GUI to get it this low). - Set VCPUs (number of virtual CPUs) to 1. You can run `mirage-firewall` alongside your existing `sys-firewall` and you can choose which AppVMs use which firewall using the GUI. diff --git a/build-with-docker.sh b/build-with-docker.sh index 4823c77..11be5c0 100755 --- a/build-with-docker.sh +++ b/build-with-docker.sh @@ -5,4 +5,4 @@ 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 qubes_firewall.xen)" -echo "SHA2 last known: 4b24bab81f9c1b14bafabd9725428456c4d6eaff0ef5cefd032a59b9f4021693" +echo "SHA2 last known: 2cad66c4b83817cdd1650f174586fd4daab7b7c271abd62844de6e6a17200750" diff --git a/client_net.ml b/client_net.ml index e7bc744..995b5f5 100644 --- a/client_net.ml +++ b/client_net.ml @@ -106,7 +106,7 @@ let add_client ~router vif client_ip = add_vif vif ~client_ip ~router ~cleanup_tasks ) (fun ex -> - Log.warn (fun f -> f "Error connecting client %a: %s" + Log.warn (fun f -> f "Error with client %a: %s" Dao.ClientVif.pp vif (Printexc.to_string ex)); return () ) From f4a978b13c44335151bb7c0aa4b5be0e136669b0 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Thu, 9 Nov 2017 17:31:02 +0000 Subject: [PATCH 030/281] Update Travis to test with Docker --- .dockerignore | 2 ++ .travis.yml | 25 +++++-------------------- 2 files changed, 7 insertions(+), 20 deletions(-) diff --git a/.dockerignore b/.dockerignore index 5fde600..85fe546 100644 --- a/.dockerignore +++ b/.dockerignore @@ -1,2 +1,4 @@ .git _build +*.xen +*.bz2 diff --git a/.travis.yml b/.travis.yml index 1325706..fb11f9a 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,23 +1,8 @@ language: c -install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-mirage.sh -script: bash -ex .travis-mirage.sh +script: + - echo 'ADD . /home/opam/qubes-mirage-firewall' >> Dockerfile + - echo 'RUN sudo chown -R opam /home/opam/qubes-mirage-firewall' >> Dockerfile + - docker build -t qubes-mirage-firewall . + - docker run --rm -i qubes-mirage-firewall sudo: required dist: trusty -addons: - apt: - sources: - - avsm - packages: - - ocaml - - ocaml-base - - ocaml-native-compilers - - ocaml-compiler-libs - - ocaml-interp - - ocaml-base-nox - - ocaml-nox - - camlp4 - - camlp4-extra - - time - - libxen-dev -env: - - OCAML_VERSION=4.04 MIRAGE_BACKEND=xen From aca156f21b8e255165b99c5fd8fd53ee6137a1ba Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Tue, 14 Nov 2017 12:35:33 +0000 Subject: [PATCH 031/281] Update to released shared-memory-ring --- Dockerfile | 5 ++--- config.ml | 1 + 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/Dockerfile b/Dockerfile index e3cf30c..211f42e 100644 --- a/Dockerfile +++ b/Dockerfile @@ -7,12 +7,11 @@ FROM ocaml/opam@sha256:17143ad95a2e944758fd9de6ee831e9af98367455cd273b17139c38dc # 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 opam-repository && git reset --hard 26fc7c2d5eb5041b7348e28e8300d376a1c31a62 && opam update +RUN cd opam-repository && git fetch origin && git reset --hard 67ab04a9a142da70935c9fdf919bf09b517499c9 && opam update RUN sudo apt-get install -y m4 libxen-dev -# TODO: remove this once the new versions are released (smr>2.0.1 and mnx>1.7.1) +# TODO: remove this once the new versions are released (mnx>1.7.1) RUN opam pin add -yn --dev netchannel -RUN opam pin add -yn --dev shared-memory-ring RUN opam install -y vchan xen-gnt mirage-xen-ocaml mirage-xen-minios io-page mirage-xen mirage mirage-nat mirage-qubes RUN mkdir /home/opam/qubes-mirage-firewall ADD config.ml /home/opam/qubes-mirage-firewall/config.ml diff --git a/config.ml b/config.ml index 0a73b48..8fb088e 100644 --- a/config.ml +++ b/config.ml @@ -21,6 +21,7 @@ let main = package "vchan"; package "cstruct"; package "tcpip" ~sublibs:["stack-direct"; "xen"; "arpv4"] ~min:"3.1.0"; + package "shared-memory-ring" ~min:"3.0.0"; package "mirage-net-xen"; package "mirage-qubes"; package "mirage-nat"; From 6e6ff755ebf7337c1f39bafebbc50c63a8de30af Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Sat, 16 Dec 2017 12:37:42 +0000 Subject: [PATCH 032/281] Update to newly released version of netchannel --- Dockerfile | 4 +--- build-with-docker.sh | 2 +- config.ml | 3 ++- 3 files changed, 4 insertions(+), 5 deletions(-) diff --git a/Dockerfile b/Dockerfile index 211f42e..a680fc2 100644 --- a/Dockerfile +++ b/Dockerfile @@ -7,11 +7,9 @@ FROM ocaml/opam@sha256:17143ad95a2e944758fd9de6ee831e9af98367455cd273b17139c38dc # 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 opam-repository && git fetch origin && git reset --hard 67ab04a9a142da70935c9fdf919bf09b517499c9 && opam update +RUN cd opam-repository && git fetch origin && git reset --hard eb49e10ee78f36c660a1f57aea45f7a6ed932460 && opam update RUN sudo apt-get install -y m4 libxen-dev -# TODO: remove this once the new versions are released (mnx>1.7.1) -RUN opam pin add -yn --dev netchannel RUN opam install -y vchan xen-gnt mirage-xen-ocaml mirage-xen-minios io-page mirage-xen mirage mirage-nat mirage-qubes RUN mkdir /home/opam/qubes-mirage-firewall ADD config.ml /home/opam/qubes-mirage-firewall/config.ml diff --git a/build-with-docker.sh b/build-with-docker.sh index 11be5c0..c7858c0 100755 --- a/build-with-docker.sh +++ b/build-with-docker.sh @@ -5,4 +5,4 @@ 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 qubes_firewall.xen)" -echo "SHA2 last known: 2cad66c4b83817cdd1650f174586fd4daab7b7c271abd62844de6e6a17200750" +echo "SHA2 last known: dc0e1e614e113b4e0d4fbd71e90d0489b3fc26a64cd1fbd0df8a56499dfa9a45" diff --git a/config.ml b/config.ml index 8fb088e..3f112fb 100644 --- a/config.ml +++ b/config.ml @@ -22,7 +22,8 @@ let main = package "cstruct"; package "tcpip" ~sublibs:["stack-direct"; "xen"; "arpv4"] ~min:"3.1.0"; package "shared-memory-ring" ~min:"3.0.0"; - package "mirage-net-xen"; + package "netchannel" ~min:"1.8.0"; + package "mirage-net-xen" ~min:"1.7.1"; package "mirage-qubes"; package "mirage-nat"; package "mirage-logs"; From b77d91cb20e07566b4397dcbc654f6431d7392fd Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Sat, 6 Jan 2018 12:09:26 +0000 Subject: [PATCH 033/281] Add installation instructions for Qubes 4 --- README.md | 53 +++++++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 47 insertions(+), 6 deletions(-) diff --git a/README.md b/README.md index 6b90ac3..961393f 100644 --- a/README.md +++ b/README.md @@ -7,7 +7,12 @@ Note: This firewall *ignores the rules set in the Qubes GUI*. See `rules.ml` for See [A Unikernel Firewall for QubesOS][] for more details. -## Build + +## Binary releases + +Pre-built binaries are available from the [releases page][]. + +## Build from source Clone this Git repository and run the `build-with-docker.sh` script: @@ -30,7 +35,10 @@ If you want to deploy manually, unpack `mirage-firewall.tar.bz2` in dom0, inside [tal@dom0 vm-kernels]$ qvm-run -p dev 'cat qubes-mirage-firewall/mirage-firewall.tar.bz2' | tar xjf - The tarball contains `vmlinuz`, which is the unikernel itself, plus a couple of dummy files that Qubes requires. -To configure your new firewall using the Qubes Manager GUI: + +### Qubes 3 + +To configure your new firewall using the Qubes 3 Manager GUI: - Create a new ProxyVM named `mirage-firewall` to run the unikernel. - You can use any template, and make it standalone or not. It doesn’t matter, since we don’t use the hard disk. @@ -42,10 +50,42 @@ To configure your new firewall using the Qubes Manager GUI: - Turn off memory balancing and set the memory to 32 MB or so (you might have to fight a bit with the Qubes GUI to get it this low). - Set VCPUs (number of virtual CPUs) to 1. -You can run `mirage-firewall` alongside your existing `sys-firewall` and you can choose which AppVMs use which firewall using the GUI. -To configure an AppVM to use it, go to the app VM's settings in the GUI and change its `NetVM` from `default (sys-firewall)` to `mirage-firewall`. Alternatively, you can configure `mirage-firewall` to be your default firewall VM. +### Qubes 4 -For development, use the [test-mirage][] scripts to deploy the unikernel (`mir-qubes-firewall.xen`) from your development AppVM. e.g. +Run this command in dom0 to create a `mirage-firewall` VM using the `mirage-firewall` kernel you added above: + +``` +qvm-create \ + --property kernel=mirage-firewall \ + --property kernelopts=None \ + --property memory=32 \ + --property maxmem=32 \ + --property netvm=sys-net \ + --property provides_network=True \ + --property vcpus=1 \ + --property virt_mode=pv \ + --label=green \ + --class StandaloneVM \ + mirage-firewall +``` + +### Configure AppVMs to use it + +You can run `mirage-firewall` alongside your existing `sys-firewall` and you can choose which AppVMs use which firewall using the GUI. +To configure an AppVM to use it, go to the app VM's settings in the GUI and change its `NetVM` from `default (sys-firewall)` to `mirage-firewall`. + +You can also configure it by running this command in dom0 (replace `my-app-vm` with the AppVM's name): + +``` +qvm-prefs --set my-app-vm netvm mirage-firewall +``` + +Alternatively, you can configure `mirage-firewall` to be your default firewall VM. + +### Easy deployment for developers + +For development, use the [test-mirage][] scripts to deploy the unikernel (`qubes_firewall.xen`) from your development AppVM. +This takes a little more setting up the first time, but will be much quicker after that. e.g. $ test-mirage qubes_firewall.xen mirage-firewall Waiting for 'Ready'... OK @@ -90,7 +130,7 @@ For development, use the [test-mirage][] scripts to deploy the unikernel (`mir-q # LICENSE -Copyright (c) 2017, Thomas Leonard +Copyright (c) 2018, Thomas Leonard All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: @@ -105,3 +145,4 @@ gg [test-mirage]: https://github.com/talex5/qubes-test-mirage [mirage-qubes]: https://github.com/talex5/mirage-qubes [A Unikernel Firewall for QubesOS]: http://roscidus.com/blog/blog/2016/01/01/a-unikernel-firewall-for-qubesos/ +[releases page]: https://github.com/talex5/qubes-mirage-firewall/releases From 78e219da8cf5413b5f12b354b0cd46c7635dc324 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Sat, 3 Nov 2018 17:25:40 +0000 Subject: [PATCH 034/281] Update Debian base image in Docker build Had stopped working: Err http://security.debian.org/ jessie/updates/main libxenstore3.0 amd64 4.4.1-9+deb8u10 404 Not Found [IP: 128.61.240.73 80] Updated from Debian 8 to Debian 9, and from opam to opam2. --- Dockerfile | 10 +++++----- build-with-docker.sh | 2 +- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/Dockerfile b/Dockerfile index a680fc2..a6b1c52 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,15 +1,15 @@ # Pin the base image to a specific hash for maximum reproducibility. -# It will probably still work on newer images, though, unless Debian 8 +# It will probably still work on newer images, though, unless Debian # changes some compiler optimisations (unlikely). -#FROM ocaml/opam:debian-8_ocaml-4.04.2 -FROM ocaml/opam@sha256:17143ad95a2e944758fd9de6ee831e9af98367455cd273b17139c38dcb032f09 +#FROM ocaml/opam2:debian-9-ocaml-4.04 +FROM ocaml/opam2@sha256:feebac4b6f9df9ed52ca1fe7266335cb9fdfffbdc0f6ba4f5e8603ece7e8b096 # 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 opam-repository && git fetch origin && git reset --hard eb49e10ee78f36c660a1f57aea45f7a6ed932460 && opam update +RUN git fetch origin && git reset --hard 1fa4c078f5b145bd4a455eb0a5559f761d0a94c0 && opam update -RUN sudo apt-get install -y m4 libxen-dev +RUN sudo apt-get install -y m4 libxen-dev pkg-config RUN opam install -y vchan xen-gnt mirage-xen-ocaml mirage-xen-minios io-page mirage-xen mirage mirage-nat mirage-qubes RUN mkdir /home/opam/qubes-mirage-firewall ADD config.ml /home/opam/qubes-mirage-firewall/config.ml diff --git a/build-with-docker.sh b/build-with-docker.sh index c7858c0..76b6a97 100755 --- a/build-with-docker.sh +++ b/build-with-docker.sh @@ -5,4 +5,4 @@ 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 qubes_firewall.xen)" -echo "SHA2 last known: dc0e1e614e113b4e0d4fbd71e90d0489b3fc26a64cd1fbd0df8a56499dfa9a45" +echo "SHA2 last known: dbc245bc425537082e64cf4b4822ce300ddeab10a272a009881e0bd22e06455a" From 0d0159b56fe9ae9fc745805b38b89e1c8994ef3b Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Sun, 4 Nov 2018 14:33:47 +0000 Subject: [PATCH 035/281] Update build instructions for latest Fedora `yum` no longer exists. Also, show how to create a symlink for /var/lib/docker on build VMs that aren't standalone. Reported by xaki23. --- README.md | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index 961393f..02dc576 100644 --- a/README.md +++ b/README.md @@ -16,13 +16,16 @@ Pre-built binaries are available from the [releases page][]. Clone this Git repository and run the `build-with-docker.sh` script: - sudo yum install docker + sudo ln -s /var/lib/docker /home/user/docker + sudo dnf install docker sudo systemctl start docker git clone https://github.com/talex5/qubes-mirage-firewall.git cd qubes-mirage-firewall sudo ./build-with-docker.sh This took about 10 minutes on my laptop (it will be much quicker if you run it again). +The symlink step at the start isn't needed if your build VM is standalone. +It gives Docker more disk space and avoids losing the Docker image cache when you reboot the Qube. You can also build without Docker, as for any normal Mirage unikernel; see [the Mirage installation instructions](https://mirage.io/wiki/install) for details. From 184d320a8fe8e6e4f63730c3a9d2020ce492ba7c Mon Sep 17 00:00:00 2001 From: xaki23 Date: Fri, 30 Nov 2018 00:08:26 +0100 Subject: [PATCH 036/281] add stub makefile for qubes-builder --- Makefile.builder | 8 ++++++++ 1 file changed, 8 insertions(+) create mode 100644 Makefile.builder diff --git a/Makefile.builder b/Makefile.builder new file mode 100644 index 0000000..7ad9df1 --- /dev/null +++ b/Makefile.builder @@ -0,0 +1,8 @@ +MIRAGE_KERNEL_NAME = qubes_firewall.xen +#SOURCE_BUILD_DEP := ssh-agent-build-dep +OCAML_VERSION ?= 4.05.0 + +#ssh-agent-build-dep: +# opam pin -y add angstrom https://github.com/reynir/angstrom.git#no-c-blit +# opam pin -y add ssh-agent https://github.com/reynir/ocaml-ssh-agent.git + From d849a09a2505188c0c97c8f83696b4e9c7232db4 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Thu, 10 Jan 2019 12:39:39 +0000 Subject: [PATCH 037/281] Don't wait for GUI before attaching client VMs If the firewall is restarted while AppVMs are connected, qubesd tries to reconnect them before starting the GUI agent. However, the firewall was waiting for the GUI agent to connect before handling the connections. This led to a 10s delay on restart for each client VM. Reported by xaki23. --- unikernel.ml | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/unikernel.ml b/unikernel.ml index e35d1d1..4a63403 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -34,11 +34,15 @@ module Main (Clock : Mirage_clock_lwt.MCLOCK) = struct ] (* 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 log out). *) + 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.listen gui) + (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)); @@ -51,21 +55,18 @@ module Main (Clock : Mirage_clock_lwt.MCLOCK) = struct let start_time = Clock.elapsed_ns clock in (* Start qrexec agent, GUI agent and QubesDB agent in parallel *) let qrexec = RExec.connect ~domid:0 () in - let gui = GUI.connect ~domid:0 () in + GUI.connect ~domid:0 () |> watch_gui; let qubesDB = DB.connect ~domid:0 () in (* Wait for clients to connect *) qrexec >>= fun qrexec -> let agent_listener = RExec.listen qrexec Command.handler in - gui >>= fun gui -> - watch_gui gui; qubesDB >>= fun qubesDB -> let startup_time = let (-) = Int64.sub in let time_in_ns = Clock.elapsed_ns clock - start_time in Int64.to_float time_in_ns /. 1e9 in - Log.info (fun f -> f "Qubes agents connected in %.3f s (CPU time used since boot: %.3f s)" - startup_time (Sys.time ())); + Log.info (fun f -> f "QubesDB and qrexec agents connected in %.3f s" startup_time); (* Watch for shutdown requests from Qubes *) let shutdown_rq = OS.Lifecycle.await_shutdown_request () >>= fun (`Poweroff | `Reboot) -> From ef09eb50ac883b6df000ff1a90138ecebc09a5a4 Mon Sep 17 00:00:00 2001 From: Ahmed Al-Sudani Date: Wed, 16 Jan 2019 14:17:09 -0500 Subject: [PATCH 038/281] Update last known build hash --- 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 76b6a97..bdada12 100755 --- a/build-with-docker.sh +++ b/build-with-docker.sh @@ -5,4 +5,4 @@ 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 qubes_firewall.xen)" -echo "SHA2 last known: dbc245bc425537082e64cf4b4822ce300ddeab10a272a009881e0bd22e06455a" +echo "SHA2 last known: 3605a97fbdb9e699a9ceb9e43def8a3cdd04e5cefb48b5824df8f55e7f949203" From 4526375a1915e34d763da5306f0793bd021fb312 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Sat, 19 Jan 2019 10:32:27 +0000 Subject: [PATCH 039/281] Note that Git versions might have different hashes --- build-with-docker.sh | 1 + 1 file changed, 1 insertion(+) diff --git a/build-with-docker.sh b/build-with-docker.sh index bdada12..7ba6fa6 100755 --- a/build-with-docker.sh +++ b/build-with-docker.sh @@ -6,3 +6,4 @@ echo Building Firewall... docker run --rm -i -v `pwd`:/home/opam/qubes-mirage-firewall qubes-mirage-firewall echo "SHA2 of build: $(sha256sum qubes_firewall.xen)" echo "SHA2 last known: 3605a97fbdb9e699a9ceb9e43def8a3cdd04e5cefb48b5824df8f55e7f949203" +echo "(hashes should match for released versions)" From 2edb0886507beef9b7f0c6935bafccc4e9a67136 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Fri, 1 Feb 2019 09:25:29 +0000 Subject: [PATCH 040/281] Update to latest Debian and opam Reported by Honzoo. --- Dockerfile | 6 +++--- README.md | 3 +++ build-with-docker.sh | 2 +- client_eth.ml | 2 +- client_net.ml | 2 +- config.ml | 2 ++ firewall.ml | 8 ++++---- 7 files changed, 15 insertions(+), 10 deletions(-) diff --git a/Dockerfile b/Dockerfile index a6b1c52..6b277c2 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,13 +1,13 @@ # Pin the base image to a specific hash for maximum reproducibility. # It will probably still work on newer images, though, unless Debian # changes some compiler optimisations (unlikely). -#FROM ocaml/opam2:debian-9-ocaml-4.04 -FROM ocaml/opam2@sha256:feebac4b6f9df9ed52ca1fe7266335cb9fdfffbdc0f6ba4f5e8603ece7e8b096 +#FROM ocaml/opam2:debian-9-ocaml-4.07 +FROM ocaml/opam2@sha256:5ff7e5a1d4ab951dcc26cca7834fa57dce8bb08d1d27ba67a0e51071c2197599 # 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 git fetch origin && git reset --hard 1fa4c078f5b145bd4a455eb0a5559f761d0a94c0 && opam update +RUN git fetch origin && git reset --hard 95448cbb9fad7515e104222f92b3d1e0bee70ede && opam update RUN sudo apt-get install -y m4 libxen-dev pkg-config RUN opam install -y vchan xen-gnt mirage-xen-ocaml mirage-xen-minios io-page mirage-xen mirage mirage-nat mirage-qubes diff --git a/README.md b/README.md index 02dc576..b63222a 100644 --- a/README.md +++ b/README.md @@ -27,6 +27,9 @@ This took about 10 minutes on my laptop (it will be much quicker if you run it a The symlink step at the start isn't needed if your build VM is standalone. It gives Docker more disk space and avoids losing the Docker image cache when you reboot the Qube. +Note: the object files are stored in the `_build` directory to speed up incremental builds. +If you change the dependencies, you will need to delete this directory before rebuilding. + You can also build without Docker, as for any normal Mirage unikernel; see [the Mirage installation instructions](https://mirage.io/wiki/install) for details. diff --git a/build-with-docker.sh b/build-with-docker.sh index 7ba6fa6..8836e95 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 qubes_firewall.xen)" -echo "SHA2 last known: 3605a97fbdb9e699a9ceb9e43def8a3cdd04e5cefb48b5824df8f55e7f949203" +echo "SHA2 last known: 21bd3e48dbca42ea5327a4fc6e27f9fe1f35f97e65864fff64e7a7675191148c" echo "(hashes should match for released versions)" diff --git a/client_eth.ml b/client_eth.ml index 751274b..e8e20c1 100644 --- a/client_eth.ml +++ b/client_eth.ml @@ -30,7 +30,7 @@ let add_client t iface = if IpMap.mem ip t.iface_of_ip then ( (* Wait for old client to disappear before adding one with the same IP address. Otherwise, its [remove_client] call will remove the new client instead. *) - Log.info (fun f -> f "Waiting for old client %a to go away before accepting new one" Ipaddr.V4.pp_hum ip); + Log.info (fun f -> f "Waiting for old client %a to go away before accepting new one" Ipaddr.V4.pp ip); Lwt_condition.wait t.changed >>= aux ) else ( t.iface_of_ip <- t.iface_of_ip |> IpMap.add ip iface; diff --git a/client_net.ml b/client_net.ml index 995b5f5..4b906e7 100644 --- a/client_net.ml +++ b/client_net.ml @@ -65,7 +65,7 @@ let input_ipv4 ~client_ip ~router packet = if src = client_ip then Firewall.ipv4_from_client router packet else ( Log.warn (fun f -> f "Incorrect source IP %a in IP packet from %a (dropping)" - Ipaddr.V4.pp_hum src Ipaddr.V4.pp_hum client_ip); + Ipaddr.V4.pp src Ipaddr.V4.pp client_ip); return () ) diff --git a/config.ml b/config.ml index 3f112fb..c115c1b 100644 --- a/config.ml +++ b/config.ml @@ -20,10 +20,12 @@ let main = ~packages:[ package "vchan"; package "cstruct"; + package "astring"; package "tcpip" ~sublibs:["stack-direct"; "xen"; "arpv4"] ~min:"3.1.0"; package "shared-memory-ring" ~min:"3.0.0"; package "netchannel" ~min:"1.8.0"; package "mirage-net-xen" ~min:"1.7.1"; + package "ipaddr" ~min:"3.0.0"; package "mirage-qubes"; package "mirage-nat"; package "mirage-logs"; diff --git a/firewall.ml b/firewall.ml index 337c5c8..98f5b21 100644 --- a/firewall.ml +++ b/firewall.ml @@ -18,7 +18,7 @@ let transmit_ipv4 packet iface = (fun () -> iface#writev Ethif_wire.IPv4 transport) (fun ex -> Log.warn (fun f -> f "Failed to write packet to %a: %s" - Ipaddr.V4.pp_hum iface#other_ip + Ipaddr.V4.pp iface#other_ip (Printexc.to_string ex)); Lwt.return () ) @@ -58,10 +58,10 @@ let pp_ports fmt {sport; dport} = Format.fprintf fmt "sport=%d dport=%d" sport dport let pp_host fmt = function - | `Client c -> Ipaddr.V4.pp_hum fmt (c#other_ip) - | `Unknown_client ip -> Format.fprintf fmt "unknown-client(%a)" Ipaddr.pp_hum ip + | `Client c -> Ipaddr.V4.pp fmt (c#other_ip) + | `Unknown_client ip -> Format.fprintf fmt "unknown-client(%a)" Ipaddr.pp ip | `NetVM -> Format.pp_print_string fmt "net-vm" - | `External ip -> Format.fprintf fmt "external(%a)" Ipaddr.pp_hum ip + | `External ip -> Format.fprintf fmt "external(%a)" Ipaddr.pp ip | `Firewall_uplink -> Format.pp_print_string fmt "firewall(uplink)" | `Client_gateway -> Format.pp_print_string fmt "firewall(client-gw)" From ab88d413c483ac05e72db9e18421c6244a1ea653 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Tue, 26 Feb 2019 16:57:40 +0000 Subject: [PATCH 041/281] Update links from talex5 to mirage --- README.md | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/README.md b/README.md index b63222a..cb084ad 100644 --- a/README.md +++ b/README.md @@ -19,7 +19,7 @@ Clone this Git repository and run the `build-with-docker.sh` script: sudo ln -s /var/lib/docker /home/user/docker sudo dnf install docker sudo systemctl start docker - git clone https://github.com/talex5/qubes-mirage-firewall.git + git clone https://github.com/mirage/qubes-mirage-firewall.git cd qubes-mirage-firewall sudo ./build-with-docker.sh @@ -149,6 +149,6 @@ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND gg [test-mirage]: https://github.com/talex5/qubes-test-mirage -[mirage-qubes]: https://github.com/talex5/mirage-qubes +[mirage-qubes]: https://github.com/mirage/mirage-qubes [A Unikernel Firewall for QubesOS]: http://roscidus.com/blog/blog/2016/01/01/a-unikernel-firewall-for-qubesos/ -[releases page]: https://github.com/talex5/qubes-mirage-firewall/releases +[releases page]: https://github.com/mirage/qubes-mirage-firewall/releases From 04bea6e9baf4f449252dd7d9730ab54301c70e14 Mon Sep 17 00:00:00 2001 From: xaki23 Date: Wed, 6 Mar 2019 23:43:49 +0100 Subject: [PATCH 042/281] update ocaml version (from 4.05 to 4.07), pin-down mirage version (to 3.4, 3.5 is current) --- Makefile.builder | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/Makefile.builder b/Makefile.builder index 7ad9df1..b41efd6 100644 --- a/Makefile.builder +++ b/Makefile.builder @@ -1,8 +1,8 @@ MIRAGE_KERNEL_NAME = qubes_firewall.xen -#SOURCE_BUILD_DEP := ssh-agent-build-dep -OCAML_VERSION ?= 4.05.0 +SOURCE_BUILD_DEP := mfw-build-dep +OCAML_VERSION ?= 4.07.1 -#ssh-agent-build-dep: -# opam pin -y add angstrom https://github.com/reynir/angstrom.git#no-c-blit +mfw-build-dep: + opam pin -y add mirage 3.4.0 # opam pin -y add ssh-agent https://github.com/reynir/ocaml-ssh-agent.git From d7cd4e29619432a0dff2cf83cc32b9a5e987c736 Mon Sep 17 00:00:00 2001 From: Mindy Date: Sun, 17 Mar 2019 17:42:05 -0500 Subject: [PATCH 043/281] typo fix --- frameQ.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/frameQ.ml b/frameQ.ml index b6b7ed1..390ac7a 100644 --- a/frameQ.ml +++ b/frameQ.ml @@ -16,7 +16,7 @@ let max_qlen = 10 let send q fn = if q.items = max_qlen then ( - Log.warn (fun f -> f "Maximim queue length exceeded for %s: dropping frame" q.name); + Log.warn (fun f -> f "Maximum queue length exceeded for %s: dropping frame" q.name); Lwt.return_unit ) else ( let sent = fn () in From 0852aa0f437848128f7f9b7b4f2589b5f579317c Mon Sep 17 00:00:00 2001 From: Mindy Date: Sun, 17 Mar 2019 16:32:17 -0500 Subject: [PATCH 044/281] use tcpip 3.7, ethernet, arp, mirage-nat 1.1.0 --- client_eth.ml | 36 +++++++++++++++++------------------- client_eth.mli | 2 +- client_net.ml | 37 ++++++++++++++++++------------------- config.ml | 8 ++++++-- firewall.ml | 15 ++++++++++++--- fw_utils.ml | 4 ++-- uplink.ml | 15 +++++++-------- 7 files changed, 63 insertions(+), 54 deletions(-) diff --git a/client_eth.ml b/client_eth.ml index e8e20c1..019e459 100644 --- a/client_eth.ml +++ b/client_eth.ml @@ -82,7 +82,7 @@ module ARP = struct let create ~net client_link = {net; client_link} let input_query t arp = - let req_ipv4 = arp.Arpv4_packet.tpa in + let req_ipv4 = arp.Arp_packet.target_ip in Log.info (fun f -> f "who-has %s?" (Ipaddr.V4.to_string req_ipv4)); if req_ipv4 = t.client_link#other_ip then ( Log.info (fun f -> f "ignoring request for client's own IP"); @@ -93,34 +93,32 @@ module ARP = struct None | Some req_mac -> Log.info (fun f -> f "responding to: who-has %s?" (Ipaddr.V4.to_string req_ipv4)); - let req_spa = arp.Arpv4_packet.spa in - let req_sha = arp.Arpv4_packet.sha in - Some { Arpv4_packet. - op = Arpv4_wire.Reply; + Some { Arp_packet. + operation = Arp_packet.Reply; (* The Target Hardware Address and IP are copied from the request *) - tha = req_sha; - tpa = req_spa; - sha = req_mac; - spa = req_ipv4; + target_ip = arp.Arp_packet.source_ip; + target_mac = arp.Arp_packet.source_mac; + source_ip = req_ipv4; + source_mac = req_mac; } let input_gratuitous t arp = - let spa = arp.Arpv4_packet.spa in - let sha = arp.Arpv4_packet.sha in - match lookup t spa with - | Some real_mac when Macaddr.compare sha real_mac = 0 -> + let source_ip = arp.Arp_packet.source_ip in + let source_mac = arp.Arp_packet.source_mac in + match lookup t source_ip with + | Some real_mac when Macaddr.compare source_mac real_mac = 0 -> Log.info (fun f -> f "client suggests updating %s -> %s (as expected)" - (Ipaddr.V4.to_string spa) (Macaddr.to_string sha)); + (Ipaddr.V4.to_string source_ip) (Macaddr.to_string source_mac)); | Some other_mac -> Log.warn (fun f -> f "client suggests incorrect update %s -> %s (should be %s)" - (Ipaddr.V4.to_string spa) (Macaddr.to_string sha) (Macaddr.to_string other_mac)); + (Ipaddr.V4.to_string source_ip) (Macaddr.to_string source_mac) (Macaddr.to_string other_mac)); | None -> Log.warn (fun f -> f "client suggests incorrect update %s -> %s (unexpected IP)" - (Ipaddr.V4.to_string spa) (Macaddr.to_string sha)) + (Ipaddr.V4.to_string source_ip) (Macaddr.to_string source_mac)) let input t arp = - let op = arp.Arpv4_packet.op in + let op = arp.Arp_packet.operation in match op with - | Arpv4_wire.Request -> input_query t arp - | Arpv4_wire.Reply -> input_gratuitous t arp; None + | Arp_packet.Request -> input_query t arp + | Arp_packet.Reply -> input_gratuitous t arp; None end diff --git a/client_eth.mli b/client_eth.mli index 0851913..952e970 100644 --- a/client_eth.mli +++ b/client_eth.mli @@ -47,7 +47,7 @@ module ARP : sig (** [create ~net client_link] is an ARP responder for [client_link]. It answers only for the client's gateway address. *) - val input : arp -> Arpv4_packet.t -> Arpv4_packet.t option + val input : arp -> Arp_packet.t -> Arp_packet.t option (** Process one ethernet frame containing an ARP message. Returns a response frame, if one is needed. *) end diff --git a/client_net.ml b/client_net.ml index 4b906e7..01a27f6 100644 --- a/client_net.ml +++ b/client_net.ml @@ -5,24 +5,24 @@ open Lwt.Infix open Fw_utils module Netback = Netchannel.Backend.Make(Netchannel.Xenstore.Make(OS.Xs)) -module ClientEth = Ethif.Make(Netback) +module ClientEth = Ethernet.Make(Netback) let src = Logs.Src.create "client_net" ~doc:"Client networking" module Log = (val Logs.src_log src : Logs.LOG) -let writev eth data = +let writev eth dst proto fillfn = Lwt.catch (fun () -> - ClientEth.writev eth data >|= function + ClientEth.write eth dst proto fillfn >|= function | Ok () -> () | Error e -> - Log.err (fun f -> f "error trying to send to client:@\n@[ %a@]@\nError: @[%a@]" - Cstruct.hexdump_pp (Cstruct.concat data) ClientEth.pp_error e); + Log.err (fun f -> f "error trying to send to client: @[%a@]" + ClientEth.pp_error e); ) (fun ex -> (* Usually Netback_shutdown, because the client disconnected *) - Log.err (fun f -> f "uncaught exception trying to send to client:@\n@[ %a@]@\nException: @[%s@]" - Cstruct.hexdump_pp (Cstruct.concat data) (Printexc.to_string ex)); + Log.err (fun f -> f "uncaught exception trying to send to client: @[%s@]" + (Printexc.to_string ex)); Lwt.return () ) @@ -32,10 +32,9 @@ class client_iface eth ~gateway_ip ~client_ip client_mac : client_link = object method other_mac = client_mac method my_ip = gateway_ip method other_ip = client_ip - method writev proto ip = + method writev proto fillfn = FrameQ.send queue (fun () -> - let eth_hdr = eth_header proto ~src:(ClientEth.mac eth) ~dst:client_mac in - writev eth (eth_hdr :: ip) + writev eth client_mac proto fillfn ) end @@ -43,15 +42,15 @@ let clients : Cleanup.t Dao.VifMap.t ref = ref Dao.VifMap.empty (** Handle an ARP message from the client. *) let input_arp ~fixed_arp ~iface request = - match Arpv4_packet.Unmarshal.of_cstruct request with + match Arp_packet.decode request with | Error e -> - Log.warn (fun f -> f "Ignored unknown ARP message: %a" Arpv4_packet.Unmarshal.pp_error e); + Log.warn (fun f -> f "Ignored unknown ARP message: %a" Arp_packet.pp_error e); Lwt.return () | Ok arp -> match Client_eth.ARP.input fixed_arp arp with | None -> return () | Some response -> - iface#writev Ethif_wire.ARP [Arpv4_packet.Marshal.make_cstruct response] + iface#writev `ARP (fun b -> Arp_packet.encode_into response b; Arp_packet.size) (** Handle an IPv4 packet from the client. *) let input_ipv4 ~client_ip ~router packet = @@ -81,8 +80,8 @@ let add_vif { Dao.ClientVif.domid; device_id } ~client_ip ~router ~cleanup_tasks Router.add_client router iface >>= fun () -> Cleanup.on_cleanup cleanup_tasks (fun () -> Router.remove_client router iface); let fixed_arp = Client_eth.ARP.create ~net:client_eth iface in - Netback.listen backend (fun frame -> - match Ethif_packet.Unmarshal.of_cstruct frame with + Netback.listen backend ~header_size:14 (fun frame -> + match Ethernet_packet.Unmarshal.of_cstruct frame with | exception ex -> Log.err (fun f -> f "Error unmarshalling ethernet frame from client: %s@.%a" (Printexc.to_string ex) Cstruct.hexdump_pp frame @@ -90,10 +89,10 @@ let add_vif { Dao.ClientVif.domid; device_id } ~client_ip ~router ~cleanup_tasks Lwt.return_unit | Error err -> Log.warn (fun f -> f "Invalid Ethernet frame: %s" err); return () | Ok (eth, payload) -> - match eth.Ethif_packet.ethertype with - | Ethif_wire.ARP -> input_arp ~fixed_arp ~iface payload - | Ethif_wire.IPv4 -> input_ipv4 ~client_ip ~router payload - | Ethif_wire.IPv6 -> return () + match eth.Ethernet_packet.ethertype with + | `ARP -> input_arp ~fixed_arp ~iface payload + | `IPv4 -> input_ipv4 ~client_ip ~router payload + | `IPv6 -> return () (* TODO: oh no! *) ) >|= or_raise "Listen on client interface" Netback.pp_error diff --git a/config.ml b/config.ml index c115c1b..d0f702a 100644 --- a/config.ml +++ b/config.ml @@ -21,13 +21,17 @@ let main = package "vchan"; package "cstruct"; package "astring"; - package "tcpip" ~sublibs:["stack-direct"; "xen"; "arpv4"] ~min:"3.1.0"; + package "tcpip" ~min:"3.7.0"; + package "arp"; + package "arp-mirage"; + package "ethernet"; + package "mirage-protocols"; package "shared-memory-ring" ~min:"3.0.0"; package "netchannel" ~min:"1.8.0"; package "mirage-net-xen" ~min:"1.7.1"; package "ipaddr" ~min:"3.0.0"; package "mirage-qubes"; - package "mirage-nat"; + package "mirage-nat" ~min:"1.1.0"; package "mirage-logs"; ] "Unikernel.Main" (mclock @-> job) diff --git a/firewall.ml b/firewall.ml index 98f5b21..39254d3 100644 --- a/firewall.ml +++ b/firewall.ml @@ -13,9 +13,18 @@ module Log = (val Logs.src_log src : Logs.LOG) let transmit_ipv4 packet iface = Lwt.catch (fun () -> - let transport = Nat_packet.to_cstruct packet in Lwt.catch - (fun () -> iface#writev Ethif_wire.IPv4 transport) + (fun () -> + iface#writev `IPv4 (fun b -> + match Nat_packet.into_cstruct packet b with + | Error e -> + Log.warn (fun f -> f "Failed to write packet to %a: %a" + Ipaddr.V4.pp iface#other_ip + Nat_packet.pp_error e); + 0 + | Ok n -> n + ) + ) (fun ex -> Log.warn (fun f -> f "Failed to write packet to %a: %s" Ipaddr.V4.pp iface#other_ip @@ -35,7 +44,7 @@ let forward_ipv4 t packet = let `IPv4 (ip, _) = packet in match Router.target t ip with | Some iface -> transmit_ipv4 packet iface - | None -> return () + | None -> Lwt.return_unit (* Packet classification *) diff --git a/fw_utils.ml b/fw_utils.ml index f4e63e8..65a769f 100644 --- a/fw_utils.ml +++ b/fw_utils.ml @@ -21,7 +21,7 @@ module IntMap = Map.Make(Int) (** An Ethernet interface. *) class type interface = object method my_mac : Macaddr.t - method writev : Ethif_wire.ethertype -> Cstruct.t list -> unit Lwt.t + method writev : Mirage_protocols.Ethernet.proto -> (Cstruct.t -> int) -> unit Lwt.t method my_ip : Ipaddr.V4.t method other_ip : Ipaddr.V4.t end @@ -34,7 +34,7 @@ end (** An Ethernet header from [src]'s MAC address to [dst]'s with an IPv4 payload. *) let eth_header ethertype ~src ~dst = - Ethif_packet.Marshal.make_cstruct { Ethif_packet.source = src; destination = dst; ethertype } + Ethernet_packet.Marshal.make_cstruct { Ethernet_packet.source = src; destination = dst; ethertype } let error fmt = let err s = Failure s in diff --git a/uplink.ml b/uplink.ml index 5735418..7579292 100644 --- a/uplink.ml +++ b/uplink.ml @@ -4,13 +4,13 @@ open Lwt.Infix open Fw_utils -module Eth = Ethif.Make(Netif) +module Eth = Ethernet.Make(Netif) let src = Logs.Src.create "uplink" ~doc:"Network connection to NetVM" module Log = (val Logs.src_log src : Logs.LOG) module Make(Clock : Mirage_clock_lwt.MCLOCK) = struct - module Arp = Arpv4.Make(Eth)(Clock)(OS.Time) + module Arp = Arp.Make(Eth)(OS.Time) type t = { net : Netif.t; @@ -24,16 +24,15 @@ module Make(Clock : Mirage_clock_lwt.MCLOCK) = struct method my_mac = Eth.mac eth method my_ip = my_ip method other_ip = other_ip - method writev ethertype payload = + method writev ethertype fillfn = FrameQ.send queue (fun () -> mac >>= fun dst -> - let eth_hdr = eth_header ethertype ~src:(Eth.mac eth) ~dst in - Eth.writev eth (eth_hdr :: payload) >|= or_raise "Write to uplink" Eth.pp_error + Eth.write eth dst ethertype fillfn >|= or_raise "Write to uplink" Eth.pp_error ) end let listen t router = - Netif.listen t.net (fun frame -> + Netif.listen t.net ~header_size:14 (fun frame -> (* Handle one Ethernet frame from NetVM *) Eth.input t.eth ~arpv4:(Arp.input t.arp) @@ -56,11 +55,11 @@ module Make(Clock : Mirage_clock_lwt.MCLOCK) = struct let interface t = t.interface - let connect ~clock config = + let connect ~clock:_ config = let ip = config.Dao.uplink_our_ip in Netif.connect "0" >>= fun net -> Eth.connect net >>= fun eth -> - Arp.connect eth clock >>= fun arp -> + Arp.connect eth >>= fun arp -> Arp.add_ip arp ip >>= fun () -> let netvm_mac = Arp.query arp config.Dao.uplink_netvm_ip From 7f99973a02b1799efae05cb2385208ee68544683 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Sun, 24 Mar 2019 13:13:11 +0000 Subject: [PATCH 045/281] Update Docker build for Mirage 3.5 --- Dockerfile | 4 ++-- build-with-docker.sh | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/Dockerfile b/Dockerfile index 6b277c2..e8c8c74 100644 --- a/Dockerfile +++ b/Dockerfile @@ -2,12 +2,12 @@ # It will probably still work on newer images, though, unless Debian # changes some compiler optimisations (unlikely). #FROM ocaml/opam2:debian-9-ocaml-4.07 -FROM ocaml/opam2@sha256:5ff7e5a1d4ab951dcc26cca7834fa57dce8bb08d1d27ba67a0e51071c2197599 +FROM ocaml/opam2@sha256:f7125924dd6632099ff98b2505536fe5f5c36bf0beb24779431bb62be5748562 # 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 git fetch origin && git reset --hard 95448cbb9fad7515e104222f92b3d1e0bee70ede && opam update +RUN git fetch origin && git reset --hard 55e835f197d5a6961ff9b22eb5bbcb5a17f13e65 && opam update RUN sudo apt-get install -y m4 libxen-dev pkg-config RUN opam install -y vchan xen-gnt mirage-xen-ocaml mirage-xen-minios io-page mirage-xen mirage mirage-nat mirage-qubes diff --git a/build-with-docker.sh b/build-with-docker.sh index 8836e95..2f895e6 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 qubes_firewall.xen)" -echo "SHA2 last known: 21bd3e48dbca42ea5327a4fc6e27f9fe1f35f97e65864fff64e7a7675191148c" +echo "SHA2 last known: addeb78681d73ee44df328ca059f6f15b8b7bbdff38a3de5363229cdf3da2eda" echo "(hashes should match for released versions)" From 3553a7aa93e8341d19d9d46206ff53e286a5439f Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 24 Mar 2019 14:29:21 +0100 Subject: [PATCH 046/281] use Ethernet_wire.sizeof_ethernet instead of a magic '14' --- client_net.ml | 2 +- uplink.ml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/client_net.ml b/client_net.ml index 01a27f6..95b51c4 100644 --- a/client_net.ml +++ b/client_net.ml @@ -80,7 +80,7 @@ let add_vif { Dao.ClientVif.domid; device_id } ~client_ip ~router ~cleanup_tasks Router.add_client router iface >>= fun () -> Cleanup.on_cleanup cleanup_tasks (fun () -> Router.remove_client router iface); let fixed_arp = Client_eth.ARP.create ~net:client_eth iface in - Netback.listen backend ~header_size:14 (fun frame -> + Netback.listen backend ~header_size:Ethernet_wire.sizeof_ethernet (fun frame -> match Ethernet_packet.Unmarshal.of_cstruct frame with | exception ex -> Log.err (fun f -> f "Error unmarshalling ethernet frame from client: %s@.%a" (Printexc.to_string ex) diff --git a/uplink.ml b/uplink.ml index 7579292..06d4df3 100644 --- a/uplink.ml +++ b/uplink.ml @@ -32,7 +32,7 @@ module Make(Clock : Mirage_clock_lwt.MCLOCK) = struct end let listen t router = - Netif.listen t.net ~header_size:14 (fun frame -> + Netif.listen t.net ~header_size:Ethernet_wire.sizeof_ethernet (fun frame -> (* Handle one Ethernet frame from NetVM *) Eth.input t.eth ~arpv4:(Arp.input t.arp) From cb7078633e98113d2e09e7e063ca091860e9cc00 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Wed, 3 Apr 2019 12:32:13 +0100 Subject: [PATCH 047/281] Update dependencies Remove pin on mirage 3.4 - it should now be working with the latest release. --- Dockerfile | 2 +- Makefile.builder | 6 ------ build-with-docker.sh | 2 +- config.ml | 6 +++--- 4 files changed, 5 insertions(+), 11 deletions(-) diff --git a/Dockerfile b/Dockerfile index e8c8c74..72e2516 100644 --- a/Dockerfile +++ b/Dockerfile @@ -7,7 +7,7 @@ FROM ocaml/opam2@sha256:f7125924dd6632099ff98b2505536fe5f5c36bf0beb24779431bb62b # 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 git fetch origin && git reset --hard 55e835f197d5a6961ff9b22eb5bbcb5a17f13e65 && opam update +RUN git fetch origin && git reset --hard c261c4ee9c1ef032af93483913b60f674d4acdb2 && opam update RUN sudo apt-get install -y m4 libxen-dev pkg-config RUN opam install -y vchan xen-gnt mirage-xen-ocaml mirage-xen-minios io-page mirage-xen mirage mirage-nat mirage-qubes diff --git a/Makefile.builder b/Makefile.builder index b41efd6..098463d 100644 --- a/Makefile.builder +++ b/Makefile.builder @@ -1,8 +1,2 @@ MIRAGE_KERNEL_NAME = qubes_firewall.xen -SOURCE_BUILD_DEP := mfw-build-dep OCAML_VERSION ?= 4.07.1 - -mfw-build-dep: - opam pin -y add mirage 3.4.0 -# opam pin -y add ssh-agent https://github.com/reynir/ocaml-ssh-agent.git - diff --git a/build-with-docker.sh b/build-with-docker.sh index 2f895e6..2570b28 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 qubes_firewall.xen)" -echo "SHA2 last known: addeb78681d73ee44df328ca059f6f15b8b7bbdff38a3de5363229cdf3da2eda" +echo "SHA2 last known: 1f72adad30cbd4f8315983240bd150811084cb93d360c14740fadb36394c7aa8" echo "(hashes should match for released versions)" diff --git a/config.ml b/config.ml index d0f702a..f7d5169 100644 --- a/config.ml +++ b/config.ml @@ -18,7 +18,7 @@ let main = foreign ~keys:[Functoria_key.abstract table_size] ~packages:[ - package "vchan"; + package "vchan" ~min:"4.0.2"; package "cstruct"; package "astring"; package "tcpip" ~min:"3.7.0"; @@ -27,8 +27,8 @@ let main = package "ethernet"; package "mirage-protocols"; package "shared-memory-ring" ~min:"3.0.0"; - package "netchannel" ~min:"1.8.0"; - package "mirage-net-xen" ~min:"1.7.1"; + package "netchannel" ~min:"1.10.2"; + package "mirage-net-xen"; package "ipaddr" ~min:"3.0.0"; package "mirage-qubes"; package "mirage-nat" ~min:"1.1.0"; From bd7babeda0d5ff507f4e3226b0a0cba05b5a1847 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Thu, 4 Apr 2019 11:04:09 +0100 Subject: [PATCH 048/281] Remove Qubes 3 instructions from README See https://www.qubes-os.org/news/2019/03/28/qubes-3-2-has-reached-eol/ --- README.md | 18 ++---------------- 1 file changed, 2 insertions(+), 16 deletions(-) diff --git a/README.md b/README.md index cb084ad..3c3195b 100644 --- a/README.md +++ b/README.md @@ -42,22 +42,6 @@ If you want to deploy manually, unpack `mirage-firewall.tar.bz2` in dom0, inside The tarball contains `vmlinuz`, which is the unikernel itself, plus a couple of dummy files that Qubes requires. -### Qubes 3 - -To configure your new firewall using the Qubes 3 Manager GUI: - -- Create a new ProxyVM named `mirage-firewall` to run the unikernel. -- You can use any template, and make it standalone or not. It doesn’t matter, since we don’t use the hard disk. -- Set the type to `ProxyVM`. -- Select `sys-net` for networking (not `sys-firewall`). -- Click `OK` to create the VM. -- Go to the VM settings, and look in the `Advanced` tab: - - Set the kernel to `mirage-firewall`. - - Turn off memory balancing and set the memory to 32 MB or so (you might have to fight a bit with the Qubes GUI to get it this low). - - Set VCPUs (number of virtual CPUs) to 1. - -### Qubes 4 - Run this command in dom0 to create a `mirage-firewall` VM using the `mirage-firewall` kernel you added above: ``` @@ -75,6 +59,8 @@ qvm-create \ mirage-firewall ``` +To upgrade from an earlier release, just overwrite `/var/lib/qubes/vm-kernels/mirage-firewall/vmlinuz` with the new version and restart the firewall VM. + ### Configure AppVMs to use it You can run `mirage-firewall` alongside your existing `sys-firewall` and you can choose which AppVMs use which firewall using the GUI. From 74479c792ee29fa6a4dc459825f513625f096616 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Fri, 5 Apr 2019 09:37:02 +0100 Subject: [PATCH 049/281] Use source date in .tar.bz2 archive All files are now added using the date the build-with-docker script was last changed. Since this includes the hash of the result, it should be up-to-date. This ensures that rebuilding the archive doesn't change it in any way. Reported-by: Holger Levsen --- Makefile.user | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Makefile.user b/Makefile.user index 33335e6..da810cd 100644 --- a/Makefile.user +++ b/Makefile.user @@ -3,5 +3,5 @@ tar: build mkdir _build/mirage-firewall cp qubes_firewall.xen _build/mirage-firewall/vmlinuz touch _build/mirage-firewall/modules.img - cat /dev/null | gzip > _build/mirage-firewall/initramfs - tar cjf mirage-firewall.tar.bz2 -C _build mirage-firewall + cat /dev/null | gzip -n > _build/mirage-firewall/initramfs + tar cjf mirage-firewall.tar.bz2 -C _build --mtime=./build-with-docker.sh mirage-firewall From 06511e076f8114fec17f36cc4aa849715d121792 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Mon, 8 Apr 2019 10:34:30 +0100 Subject: [PATCH 050/281] Add patch to cmdliner for reproducible build See https://github.com/dbuenzli/cmdliner/pull/106 --- Dockerfile | 1 + build-with-docker.sh | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/Dockerfile b/Dockerfile index 72e2516..4558a7e 100644 --- a/Dockerfile +++ b/Dockerfile @@ -10,6 +10,7 @@ FROM ocaml/opam2@sha256:f7125924dd6632099ff98b2505536fe5f5c36bf0beb24779431bb62b RUN git fetch origin && git reset --hard c261c4ee9c1ef032af93483913b60f674d4acdb2 && opam update RUN sudo apt-get install -y m4 libxen-dev pkg-config +RUN opam pin add -yn cmdliner 'https://github.com/talex5/cmdliner.git#repro-builds' RUN opam install -y vchan xen-gnt mirage-xen-ocaml mirage-xen-minios io-page mirage-xen mirage mirage-nat mirage-qubes RUN mkdir /home/opam/qubes-mirage-firewall ADD config.ml /home/opam/qubes-mirage-firewall/config.ml diff --git a/build-with-docker.sh b/build-with-docker.sh index 2570b28..3f6c59c 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 qubes_firewall.xen)" -echo "SHA2 last known: 1f72adad30cbd4f8315983240bd150811084cb93d360c14740fadb36394c7aa8" +echo "SHA2 last known: ce9a16b6f5ce0123f289b3586492f9f4b921f6e788f8e333784545807bb1b0f2" echo "(hashes should match for released versions)" From 5958cfed97dc33669db640279fb41c22580a1662 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Mon, 8 Apr 2019 10:23:34 +0100 Subject: [PATCH 051/281] Clarify how to build from source --- README.md | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index 3c3195b..3dc4d72 100644 --- a/README.md +++ b/README.md @@ -14,6 +14,7 @@ Pre-built binaries are available from the [releases page][]. ## Build from source +Create a new Fedora-29 AppVM (or reuse an existing one). Open a terminal. Clone this Git repository and run the `build-with-docker.sh` script: sudo ln -s /var/lib/docker /home/user/docker @@ -30,9 +31,19 @@ It gives Docker more disk space and avoids losing the Docker image cache when yo Note: the object files are stored in the `_build` directory to speed up incremental builds. If you change the dependencies, you will need to delete this directory before rebuilding. +If you want to build on Debian, follow the instructions at [docker.com][debian-docker] to get Docker and then run `sudo ./build-with-docker.sh` as above. + +It's OK to install the Docker package in a template VM if you want it to remain +after a reboot, but the build of the firewall itself should be done in a regular AppVM. + You can also build without Docker, as for any normal Mirage unikernel; see [the Mirage installation instructions](https://mirage.io/wiki/install) for details. +The Docker build fixes the versions of the libraries it uses, ensuring that you will get +exactly the same binary that is in the release. If you build without Docker, it will build +against the latest versions instead (and the hash will therefore probably not match). +However, it should still work fine. + ## Deploy If you want to deploy manually, unpack `mirage-firewall.tar.bz2` in dom0, inside `/var/lib/qubes/vm-kernels/`. e.g. (if `dev` is the AppVM where you built it): @@ -122,7 +133,7 @@ This takes a little more setting up the first time, but will be much quicker aft # LICENSE -Copyright (c) 2018, Thomas Leonard +Copyright (c) 2019, Thomas Leonard All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: @@ -138,3 +149,4 @@ gg [mirage-qubes]: https://github.com/mirage/mirage-qubes [A Unikernel Firewall for QubesOS]: http://roscidus.com/blog/blog/2016/01/01/a-unikernel-firewall-for-qubesos/ [releases page]: https://github.com/mirage/qubes-mirage-firewall/releases +[debian-docker]: https://docs.docker.com/install/linux/docker-ce/debian/#install-using-the-repository From 45eef49c95048d5112257b8056c780f97ca58eb5 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Tue, 16 Apr 2019 18:05:08 +0100 Subject: [PATCH 052/281] Upgrade to latest mirage-nat to fix ICMP Now ping and traceroute should work. --- Dockerfile | 4 ++-- build-with-docker.sh | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/Dockerfile b/Dockerfile index 4558a7e..b2abb28 100644 --- a/Dockerfile +++ b/Dockerfile @@ -7,11 +7,11 @@ FROM ocaml/opam2@sha256:f7125924dd6632099ff98b2505536fe5f5c36bf0beb24779431bb62b # 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 git fetch origin && git reset --hard c261c4ee9c1ef032af93483913b60f674d4acdb2 && opam update +RUN git fetch origin && git reset --hard e77756e92274790668ed1f6f998d66fa2e744fb6 && opam update RUN sudo apt-get install -y m4 libxen-dev pkg-config RUN opam pin add -yn cmdliner 'https://github.com/talex5/cmdliner.git#repro-builds' -RUN opam install -y vchan xen-gnt mirage-xen-ocaml mirage-xen-minios io-page mirage-xen mirage mirage-nat mirage-qubes +RUN opam install -y vchan mirage-xen-ocaml mirage-xen-minios io-page mirage-xen mirage mirage-nat mirage-qubes 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 3f6c59c..1389a8d 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 qubes_firewall.xen)" -echo "SHA2 last known: ce9a16b6f5ce0123f289b3586492f9f4b921f6e788f8e333784545807bb1b0f2" +echo "SHA2 last known: 765cf16c2e85feb7e5dfd3e409a3013c91c2b07f5680ed9f4e487e27213f1355" echo "(hashes should match for released versions)" From eb14f7e777ca56fa7d5f42c502a7e2c9987fd579 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Fri, 26 Apr 2019 12:38:36 +0100 Subject: [PATCH 053/281] Link to security advisories from README Also, link from binary installation to deployment section. --- README.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/README.md b/README.md index 3dc4d72..bfbef5f 100644 --- a/README.md +++ b/README.md @@ -11,6 +11,7 @@ See [A Unikernel Firewall for QubesOS][] for more details. ## Binary releases Pre-built binaries are available from the [releases page][]. +See the [Deploy](#deploy) section below for installation instructions. ## Build from source @@ -130,6 +131,9 @@ This takes a little more setting up the first time, but will be much quicker aft 2017-03-18 11:32:38 -00:00: INF [dao] Watching backend/vif 2017-03-18 11:32:38 -00:00: INF [qubes.db] got update: "/qubes-netvm-domid" = "1" +# Security advisories + +See [issues tagged "security"](https://github.com/mirage/qubes-mirage-firewall/issues?utf8=%E2%9C%93&q=label%3Asecurity+) for security advisories affecting the firewall. # LICENSE From c7fc54af02621284489069ad91fd648f12cefdec Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Sun, 28 Apr 2019 16:06:03 +0100 Subject: [PATCH 054/281] Wait if dom0 is slow to set the network configuration Sometimes we boot before dom0 has put the network settings in QubesDB. If that happens, log a message, wait until the database changes, and retry. --- dao.ml | 24 +++++++++++++++++++++--- dao.mli | 4 +++- unikernel.ml | 2 +- 3 files changed, 25 insertions(+), 5 deletions(-) diff --git a/dao.ml b/dao.ml index 9ce0766..a68cc64 100644 --- a/dao.ml +++ b/dao.ml @@ -84,15 +84,33 @@ type network_config = { clients_our_ip : Ipaddr.V4.t; (* The IP address of our interface to our client VMs (their gateway) *) } +exception Missing_key of string + (* TODO: /qubes-secondary-dns *) -let read_network_config qubesDB = +let try_read_network_config db = let get name = - match DB.read qubesDB name with - | None -> raise (error "QubesDB key %S not present" name) + match DB.KeyMap.find_opt name db with + | None -> raise (Missing_key name) | Some value -> value in let uplink_our_ip = get "/qubes-ip" |> Ipaddr.V4.of_string_exn in 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 + 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@]" + Ipaddr.V4.pp uplink_netvm_ip + Ipaddr.V4.pp uplink_our_ip + Ipaddr.V4.pp clients_our_ip); { uplink_netvm_ip; uplink_our_ip; clients_our_ip } +let read_network_config qubesDB = + let rec aux bindings = + try Lwt.return (try_read_network_config bindings) + with Missing_key key -> + Log.warn (fun f -> f "QubesDB key %S not (yet) present; waiting for QubesDB to change..." key); + DB.after qubesDB bindings >>= aux + in + aux (DB.bindings qubesDB) + let set_iptables_error db = Qubes.DB.write db "/qubes-iptables-error" diff --git a/dao.mli b/dao.mli index e1b96c6..b1f56b6 100644 --- a/dao.mli +++ b/dao.mli @@ -26,6 +26,8 @@ type network_config = { clients_our_ip : Ipaddr.V4.t; (* The IP address of our interface to our client VMs (their gateway) *) } -val read_network_config : Qubes.DB.t -> network_config +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 set_iptables_error : Qubes.DB.t -> string -> unit Lwt.t diff --git a/unikernel.ml b/unikernel.ml index 4a63403..84cac6d 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -13,7 +13,7 @@ module Main (Clock : Mirage_clock_lwt.MCLOCK) = struct (* Set up networking and listen for incoming packets. *) let network ~clock nat qubesDB = (* Read configuration from QubesDB *) - let config = Dao.read_network_config qubesDB in + Dao.read_network_config qubesDB >>= fun config -> (* Initialise connection to NetVM *) Uplink.connect ~clock config >>= fun uplink -> (* Report success *) From 9d2723a08ad0cfef3dd081232491ea7cc49cf11d Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Sun, 28 Apr 2019 16:10:02 +0100 Subject: [PATCH 055/281] Require mirage-nat >= 1.2.0 for ICMP support --- config.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config.ml b/config.ml index f7d5169..50de8ab 100644 --- a/config.ml +++ b/config.ml @@ -31,7 +31,7 @@ let main = package "mirage-net-xen"; package "ipaddr" ~min:"3.0.0"; package "mirage-qubes"; - package "mirage-nat" ~min:"1.1.0"; + package "mirage-nat" ~min:"1.2.0"; package "mirage-logs"; ] "Unikernel.Main" (mclock @-> job) From 0a4dd7413ca52bcf942ca2806734530fcb366a3d Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Wed, 1 May 2019 10:05:14 +0100 Subject: [PATCH 056/281] Force backend MAC to fe:ff:ff:ff:ff:ff to fix HVM clients Xen appears to configure the same MAC address for both the frontend and backend in XenStore. e.g. [tal@dom0 ~]$ xenstore-ls /local/domain/3/backend/vif/19/0 frontend = "/local/domain/19/device/vif/0" mac = "00:16:3e:5e:6c:00" [...] [tal@dom0 ~]$ xenstore-ls /local/domain/19/device/vif/0 mac = "00:16:3e:5e:6c:00" This works if the client uses just a simple ethernet device, but fails if it connects via a bridge. HVM domains have an associated stub domain running qemu, which provides an emulated network device. The stub domain uses a bridge to connect qemu's interface with eth0, and this didn't work. Force the use of the fixed version of mirage-net-xen, which no longer uses XenStore to get the backend MAC, and provides a new function to get the frontend one. --- Dockerfile | 2 +- client_net.ml | 2 +- config.ml | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/Dockerfile b/Dockerfile index b2abb28..1cbe558 100644 --- a/Dockerfile +++ b/Dockerfile @@ -7,7 +7,7 @@ FROM ocaml/opam2@sha256:f7125924dd6632099ff98b2505536fe5f5c36bf0beb24779431bb62b # 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 git fetch origin && git reset --hard e77756e92274790668ed1f6f998d66fa2e744fb6 && opam update +RUN git fetch origin && git reset --hard d1b2a1cbc28d43926b37e61f46fc403b48ab9c23 && opam update RUN sudo apt-get install -y m4 libxen-dev pkg-config RUN opam pin add -yn cmdliner 'https://github.com/talex5/cmdliner.git#repro-builds' diff --git a/client_net.ml b/client_net.ml index 95b51c4..636198a 100644 --- a/client_net.ml +++ b/client_net.ml @@ -73,7 +73,7 @@ let add_vif { Dao.ClientVif.domid; device_id } ~client_ip ~router ~cleanup_tasks 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 -> - let client_mac = Netback.mac backend in + let client_mac = Netback.frontend_mac backend in let client_eth = router.Router.client_eth in let gateway_ip = Client_eth.client_gw client_eth in let iface = new client_iface eth ~gateway_ip ~client_ip client_mac in diff --git a/config.ml b/config.ml index 50de8ab..4171927 100644 --- a/config.ml +++ b/config.ml @@ -27,7 +27,7 @@ let main = package "ethernet"; package "mirage-protocols"; package "shared-memory-ring" ~min:"3.0.0"; - package "netchannel" ~min:"1.10.2"; + package "netchannel" ~min:"1.11.0" ~pin:"git+https://github.com/mirage/mirage-net-xen.git"; package "mirage-net-xen"; package "ipaddr" ~min:"3.0.0"; package "mirage-qubes"; From 8b4cc6f5a9e896491c35a2eebe5f6677d4e39875 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Mon, 6 May 2019 09:54:35 +0100 Subject: [PATCH 057/281] Improve logging --- client_eth.ml | 25 ++++++++++++++----------- client_net.ml | 29 ++++++++++++++++------------- fw_utils.ml | 1 + 3 files changed, 31 insertions(+), 24 deletions(-) diff --git a/client_eth.ml b/client_eth.ml index 019e459..345552a 100644 --- a/client_eth.ml +++ b/client_eth.ml @@ -27,16 +27,16 @@ let client_gw t = t.client_gw let add_client t iface = let ip = iface#other_ip in let rec aux () = - if IpMap.mem ip t.iface_of_ip then ( + match IpMap.find ip t.iface_of_ip with + | Some old -> (* Wait for old client to disappear before adding one with the same IP address. Otherwise, its [remove_client] call will remove the new client instead. *) - Log.info (fun f -> f "Waiting for old client %a to go away before accepting new one" Ipaddr.V4.pp ip); + Log.info (fun f -> f ~header:iface#log_header "Waiting for old client %s to go away before accepting new one" old#log_header); Lwt_condition.wait t.changed >>= aux - ) else ( + | None -> t.iface_of_ip <- t.iface_of_ip |> IpMap.add ip iface; Lwt_condition.broadcast t.changed (); Lwt.return_unit - ) in aux () @@ -83,16 +83,18 @@ module ARP = struct let input_query t arp = let req_ipv4 = arp.Arp_packet.target_ip in - Log.info (fun f -> f "who-has %s?" (Ipaddr.V4.to_string req_ipv4)); + let pf (f : ?header:string -> ?tags:_ -> _) fmt = + f ~header:t.client_link#log_header ("who-has %a? " ^^ fmt) Ipaddr.V4.pp req_ipv4 + in if req_ipv4 = t.client_link#other_ip then ( - Log.info (fun f -> f "ignoring request for client's own IP"); + Log.info (fun f -> pf f "ignoring request for client's own IP"); None ) else match lookup t req_ipv4 with | None -> - Log.info (fun f -> f "unknown address; not responding"); + Log.info (fun f -> pf f "unknown address; not responding"); None | Some req_mac -> - Log.info (fun f -> f "responding to: who-has %s?" (Ipaddr.V4.to_string req_ipv4)); + Log.info (fun f -> pf f "responding with %a" Macaddr.pp req_mac); Some { Arp_packet. operation = Arp_packet.Reply; (* The Target Hardware Address and IP are copied from the request *) @@ -105,15 +107,16 @@ module ARP = struct let input_gratuitous t arp = let source_ip = arp.Arp_packet.source_ip in let source_mac = arp.Arp_packet.source_mac in + let header = t.client_link#log_header in match lookup t source_ip with | Some real_mac when Macaddr.compare source_mac real_mac = 0 -> - Log.info (fun f -> f "client suggests updating %s -> %s (as expected)" + Log.info (fun f -> f ~header "client suggests updating %s -> %s (as expected)" (Ipaddr.V4.to_string source_ip) (Macaddr.to_string source_mac)); | Some other_mac -> - Log.warn (fun f -> f "client suggests incorrect update %s -> %s (should be %s)" + Log.warn (fun f -> f ~header "client suggests incorrect update %s -> %s (should be %s)" (Ipaddr.V4.to_string source_ip) (Macaddr.to_string source_mac) (Macaddr.to_string other_mac)); | None -> - Log.warn (fun f -> f "client suggests incorrect update %s -> %s (unexpected IP)" + Log.warn (fun f -> f ~header "client suggests incorrect update %s -> %s (unexpected IP)" (Ipaddr.V4.to_string source_ip) (Macaddr.to_string source_mac)) let input t arp = diff --git a/client_net.ml b/client_net.ml index 636198a..0649567 100644 --- a/client_net.ml +++ b/client_net.ml @@ -26,17 +26,20 @@ let writev eth dst proto fillfn = Lwt.return () ) -class client_iface eth ~gateway_ip ~client_ip client_mac : client_link = object - val queue = FrameQ.create (Ipaddr.V4.to_string client_ip) - method my_mac = ClientEth.mac eth - method other_mac = client_mac - method my_ip = gateway_ip - method other_ip = client_ip - method writev proto fillfn = - FrameQ.send queue (fun () -> - writev eth client_mac proto fillfn - ) -end +class client_iface eth ~domid ~gateway_ip ~client_ip client_mac : client_link = + let log_header = Fmt.strf "dom%d:%a" domid Ipaddr.V4.pp client_ip in + object + val queue = FrameQ.create (Ipaddr.V4.to_string client_ip) + method my_mac = ClientEth.mac eth + method other_mac = client_mac + method my_ip = gateway_ip + method other_ip = client_ip + method writev proto fillfn = + FrameQ.send queue (fun () -> + writev eth client_mac proto fillfn + ) + method log_header = log_header + end let clients : Cleanup.t Dao.VifMap.t ref = ref Dao.VifMap.empty @@ -76,7 +79,7 @@ let add_vif { Dao.ClientVif.domid; device_id } ~client_ip ~router ~cleanup_tasks let client_mac = Netback.frontend_mac backend in let client_eth = router.Router.client_eth in let gateway_ip = Client_eth.client_gw client_eth in - let iface = new client_iface eth ~gateway_ip ~client_ip client_mac in + let iface = new client_iface eth ~domid ~gateway_ip ~client_ip client_mac in Router.add_client router iface >>= fun () -> Cleanup.on_cleanup cleanup_tasks (fun () -> Router.remove_client router iface); let fixed_arp = Client_eth.ARP.create ~net:client_eth iface in @@ -99,7 +102,7 @@ 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 = let cleanup_tasks = Cleanup.create () in - Log.info (fun f -> f "add client vif %a" Dao.ClientVif.pp vif); + 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 vif ~client_ip ~router ~cleanup_tasks diff --git a/fw_utils.ml b/fw_utils.ml index 65a769f..c034e72 100644 --- a/fw_utils.ml +++ b/fw_utils.ml @@ -30,6 +30,7 @@ end class type client_link = object inherit interface method other_mac : Macaddr.t + method log_header : string (* For log messages *) end (** An Ethernet header from [src]'s MAC address to [dst]'s with an IPv4 payload. *) From d7b376d3730bc9dae82a359906ab4f8fb44a5d59 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Sun, 5 May 2019 17:26:56 +0100 Subject: [PATCH 058/281] Respond to ARP requests for *.*.*.1 This is a work-around to get DHCP working with HVM domains. See: https://github.com/QubesOS/qubes-issues/issues/5022 --- build-with-docker.sh | 2 +- client_eth.ml | 6 +++++- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/build-with-docker.sh b/build-with-docker.sh index 1389a8d..d14c057 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 qubes_firewall.xen)" -echo "SHA2 last known: 765cf16c2e85feb7e5dfd3e409a3013c91c2b07f5680ed9f4e487e27213f1355" +echo "SHA2 last known: dbf7460fa628bea5d132a96fe7ba2cd832e3d9da7005ae74f6a124957f4848ea" echo "(hashes should match for released versions)" diff --git a/client_eth.ml b/client_eth.ml index 345552a..a65325c 100644 --- a/client_eth.ml +++ b/client_eth.ml @@ -70,7 +70,11 @@ module ARP = struct let lookup t ip = if ip = t.net.client_gw then Some t.client_link#my_mac - else None + else if (Ipaddr.V4.to_bytes ip).[3] = '\x01' then ( + Log.info (fun f -> f ~header:t.client_link#log_header + "Request for %a is invalid, but pretending it's me (see Qubes issue #5022)" Ipaddr.V4.pp ip); + Some t.client_link#my_mac + ) else None (* We're now treating client networks as point-to-point links, so we no longer respond on behalf of other clients. *) (* From acf46b423185a5faad5c95700bf17a24ca127358 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Thu, 11 Apr 2019 12:25:19 +0100 Subject: [PATCH 059/281] Allow naming hosts and add examples to rules.ml Previously we passed in the interface, from which it was possible (but a little difficult) to extract the IP address and compare with some predefined ones. Now, we allow the user to list IP addresses and named tags for them, which can be matched on easily. Added example rules showing how to block access to an external service or allow SSH between AppVMs. Requested at https://groups.google.com/d/msg/qubes-users/BnL0nZGpJOE/61HOBg1rCgAJ. --- firewall.ml | 14 +++++++++++++- packet.ml | 12 +++++++++--- rules.ml | 26 +++++++++++++++++++++++++- 3 files changed, 47 insertions(+), 5 deletions(-) diff --git a/firewall.ml b/firewall.ml index 39254d3..0e38d45 100644 --- a/firewall.ml +++ b/firewall.ml @@ -125,9 +125,21 @@ let nat_to t ~host ~port packet = (* Handle incoming packets *) +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_host = function + | `Client c -> `Client (try List.assoc (Ipaddr.V4 c#other_ip) clients with Not_found -> `Unknown) + | `External ip -> `External (try List.assoc ip externals with Not_found -> `Unknown) + | (`Client_gateway | `Firewall_uplink | `NetVM) as x -> x + let apply_rules t rules info = let packet = info.packet in - match rules info, info.dst with + let resolved_info = { info with src = resolve_host info.src; + dst = resolve_host info.dst } in + match rules resolved_info, info.dst with | `Accept, `Client client_link -> transmit_ipv4 packet client_link | `Accept, (`External _ | `NetVM) -> transmit_ipv4 packet t.Router.uplink | `Accept, (`Firewall_uplink | `Client_gateway) -> diff --git a/packet.ml b/packet.ml index a9fa4e7..607fd37 100644 --- a/packet.ml +++ b/packet.ml @@ -13,9 +13,15 @@ type ports = { type host = [ `Client of client_link | `Client_gateway | `Firewall_uplink | `NetVM | `External of Ipaddr.t ] -type info = { +(* Note: 'a is either [host], or the result of applying [Rules.clients] and [Rules.externals] to a host. *) +type 'a info = { packet : Nat_packet.t; - src : host; - dst : host; + src : 'a; + dst : 'a; proto : [ `UDP of ports | `TCP of ports | `ICMP | `Unknown ]; } + +(* The first message in a TCP connection has SYN set and ACK clear. *) +let is_tcp_start = function + | `IPv4 (_ip, `TCP (hdr, _body)) -> Tcp.Tcp_packet.(hdr.syn && not hdr.ack) + | _ -> false diff --git a/rules.ml b/rules.ml index 7e62790..7980469 100644 --- a/rules.ml +++ b/rules.ml @@ -25,13 +25,37 @@ open Packet - [`Drop reason] drop the packet and log the reason. *) +(* 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; + *) +] + (** Decide what to do with a packet from a client VM. Note: If the packet matched an existing NAT rule then this isn't called. *) let from_client = function + (* Examples (add your own rules here): *) + (* + | { src = `Client `Dev; dst = `Client `Untrusted; proto = `TCP { dport = 22 } } -> `Accept + | { src = `Client _; dst = `Client _; proto = `TCP _; packet } + when not (is_tcp_start packet) -> `Accept + | { dst = `External `GoogleDNS } -> `Drop "block Google DNS" + *) | { dst = (`External _ | `NetVM) } -> `NAT | { dst = `Client_gateway; proto = `UDP { dport = 53 } } -> `NAT_to (`NetVM, 53) | { dst = (`Client_gateway | `Firewall_uplink) } -> `Drop "packet addressed to firewall itself" - | { dst = `Client _ } -> `Drop "prevent communication between client VMs" + | { dst = `Client _ } -> `Drop "prevent communication between client VMs by default" (** 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. *) From 189a7363680c2f0075a4c730d493f5321f04c122 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Wed, 17 Apr 2019 10:26:32 +0100 Subject: [PATCH 060/281] Add some types to the rules Before, we inferred the types from rules.ml and then the compiler checked that it was consistent with what firewall.ml expected. If it wasn't it reported the problem as being with firewall.ml, which could be confusing to users. --- packet.ml | 11 +++++++++++ rules.ml | 23 ++++------------------- 2 files changed, 15 insertions(+), 19 deletions(-) diff --git a/packet.ml b/packet.ml index 607fd37..97f1feb 100644 --- a/packet.ml +++ b/packet.ml @@ -25,3 +25,14 @@ type 'a info = { let is_tcp_start = function | `IPv4 (_ip, `TCP (hdr, _body)) -> Tcp.Tcp_packet.(hdr.syn && not hdr.ack) | _ -> false + +(* The possible actions we can take for a packet: *) +type action = [ + | `Accept (* Send the packet to its destination. *) + | `NAT (* Rewrite the packet's source field so packet appears to + have come from the firewall, via an unused port. + Also, add NAT rules so related packets will be translated accordingly. *) + | `NAT_to of host * port (* As for [`NAT], but also rewrite the packet's + destination fields so it will be sent to [host:port]. *) + | `Drop of string (* Drop the packet and log the given reason. *) +] diff --git a/rules.ml b/rules.ml index 7980469..352c98b 100644 --- a/rules.ml +++ b/rules.ml @@ -8,23 +8,6 @@ open Packet (* OCaml normally warns if you don't match all fields, but that's OK here. *) [@@@ocaml.warning "-9"] -(** {2 Actions} - - The possible actions are: - - - [`Accept] : Send the packet to its destination. - - - [`NAT] : Rewrite the packet's source field so packet appears to - have come from the firewall, via an unused port. - Also, add NAT rules so related packets will be translated accordingly. - - - [`NAT_to (host, port)] : - As for [`NAT], but also rewrite the packet's destination fields so it - will be sent to [host:port]. - - - [`Drop reason] drop the packet and log the reason. -*) - (* 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 = [ @@ -44,7 +27,8 @@ let externals = [ (** Decide what to do with a packet from a client VM. Note: If the packet matched an existing NAT rule then this isn't called. *) -let from_client = function +let from_client (info : _ info) : action = + match info with (* Examples (add your own rules here): *) (* | { src = `Client `Dev; dst = `Client `Untrusted; proto = `TCP { dport = 22 } } -> `Accept @@ -59,5 +43,6 @@ let from_client = function (** 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. *) -let from_netvm = function +let from_netvm (info : _ info) : action = + match info with | _ -> `Drop "drop by default" From b60d098e96b2b713589d51748cc06e387f92519c Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Wed, 17 Apr 2019 11:03:17 +0100 Subject: [PATCH 061/281] Give exact types for Packet.src Before, the packet passed to rules.ml could have any host as its src. Now, `from_client` knows that `src` must be a `Client`, and `from_netvm` knows that `src` is `External` or `NetVM`. --- client_net.ml | 8 +++--- firewall.ml | 67 +++++++++++++++++++++++++++++---------------------- firewall.mli | 2 +- packet.ml | 7 +++--- rules.ml | 33 ++++++++++++++++++------- 5 files changed, 70 insertions(+), 47 deletions(-) diff --git a/client_net.ml b/client_net.ml index 0649567..68fe6d3 100644 --- a/client_net.ml +++ b/client_net.ml @@ -56,7 +56,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 ~client_ip ~router packet = +let input_ipv4 ~iface ~router packet = match Nat_packet.of_ipv4_packet packet with | Error e -> Log.warn (fun f -> f "Ignored unknown IPv4 message: %a" Nat_packet.pp_error e); @@ -64,10 +64,10 @@ let input_ipv4 ~client_ip ~router packet = | Ok packet -> let `IPv4 (ip, _) = packet in let src = ip.Ipv4_packet.src in - if src = client_ip then Firewall.ipv4_from_client router packet + if src = iface#other_ip then Firewall.ipv4_from_client 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 client_ip); + Ipaddr.V4.pp src Ipaddr.V4.pp iface#other_ip); return () ) @@ -94,7 +94,7 @@ let add_vif { Dao.ClientVif.domid; device_id } ~client_ip ~router ~cleanup_tasks | Ok (eth, payload) -> match eth.Ethernet_packet.ethertype with | `ARP -> input_arp ~fixed_arp ~iface payload - | `IPv4 -> input_ipv4 ~client_ip ~router payload + | `IPv4 -> input_ipv4 ~iface ~router payload | `IPv6 -> return () (* TODO: oh no! *) ) >|= or_raise "Listen on client interface" Netback.pp_error diff --git a/firewall.ml b/firewall.ml index 0e38d45..cbb47b7 100644 --- a/firewall.ml +++ b/firewall.ml @@ -48,8 +48,21 @@ let forward_ipv4 t packet = (* Packet classification *) -let classify t packet = - let `IPv4 (ip, transport) = packet in +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 + +let classify ~src ~dst packet = + let `IPv4 (_ip, transport) = packet in let proto = match transport with | `TCP ({Tcp.Tcp_packet.src_port; dst_port; _}, _) -> `TCP {sport = src_port; dport = dst_port} @@ -58,8 +71,8 @@ let classify t packet = in Some { packet; - src = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.src); - dst = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.dst); + src; + dst; proto; } @@ -80,7 +93,10 @@ let pp_proto fmt = function | `ICMP -> Format.pp_print_string fmt "ICMP" | `Unknown -> Format.pp_print_string fmt "UnknownProtocol" -let pp_packet fmt {src; dst; proto; packet = _} = +let pp_packet t fmt {src = _; dst = _; proto; 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 Format.fprintf fmt "[src=%a dst=%a proto=%a]" pp_host src pp_host dst @@ -125,30 +141,18 @@ let nat_to t ~host ~port packet = (* Handle incoming packets *) -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_host = function - | `Client c -> `Client (try List.assoc (Ipaddr.V4 c#other_ip) clients with Not_found -> `Unknown) - | `External ip -> `External (try List.assoc ip externals with Not_found -> `Unknown) - | (`Client_gateway | `Firewall_uplink | `NetVM) as x -> x - -let apply_rules t rules info = +let apply_rules t rules ~dst info = let packet = info.packet in - let resolved_info = { info with src = resolve_host info.src; - dst = resolve_host info.dst } in - match rules resolved_info, info.dst with + match rules info, dst with | `Accept, `Client client_link -> transmit_ipv4 packet client_link | `Accept, (`External _ | `NetVM) -> transmit_ipv4 packet t.Router.uplink | `Accept, (`Firewall_uplink | `Client_gateway) -> - Log.warn (fun f -> f "Bad rule: firewall can't accept packets %a" pp_packet info); + Log.warn (fun f -> f "Bad rule: firewall can't accept packets %a" (pp_packet t) info); return () | `NAT, _ -> 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 pp_packet info); + Log.info (fun f -> f "Dropped packet (%s) %a" reason (pp_packet t) info); return () let handle_low_memory t = @@ -159,7 +163,7 @@ let handle_low_memory t = `Memory_critical | `Ok -> Lwt.return `Ok -let ipv4_from_client t packet = +let ipv4_from_client t ~src packet = handle_low_memory t >>= function | `Memory_critical -> return () | `Ok -> @@ -168,23 +172,28 @@ let ipv4_from_client t packet = | Some frame -> forward_ipv4 t frame (* Some existing connection or redirect *) | None -> (* No existing NAT entry. Check the firewall rules. *) - match classify t packet with + let `IPv4 (ip, _transport) = packet in + let dst = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in + match classify ~src:(resolve_client src) ~dst:(resolve_host dst) packet with | None -> return () - | Some info -> apply_rules t Rules.from_client info + | Some info -> apply_rules t Rules.from_client ~dst info let ipv4_from_netvm t packet = handle_low_memory t >>= function | `Memory_critical -> return () | `Ok -> - match classify t packet with + 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 classify ~src ~dst:(resolve_host dst) packet with | None -> return () | Some info -> - match info.src with + match src with | `Client _ | `Firewall_uplink | `Client_gateway -> - Log.warn (fun f -> f "Frame from NetVM has internal source IP address! %a" pp_packet info); + Log.warn (fun f -> f "Frame from NetVM has internal source IP address! %a" (pp_packet t) info); return () - | `External _ | `NetVM -> + | `External _ | `NetVM as src -> translate t packet >>= function | Some frame -> forward_ipv4 t frame | None -> - apply_rules t Rules.from_netvm info + apply_rules t Rules.from_netvm ~dst { info with src } diff --git a/firewall.mli b/firewall.mli index 3909ee0..9900f56 100644 --- a/firewall.mli +++ b/firewall.mli @@ -6,6 +6,6 @@ val ipv4_from_netvm : Router.t -> Nat_packet.t -> unit Lwt.t (** Handle a packet from the outside world (this module will validate the source IP). *) -val ipv4_from_client : Router.t -> Nat_packet.t -> unit Lwt.t +val ipv4_from_client : 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/packet.ml b/packet.ml index 97f1feb..d9b49bb 100644 --- a/packet.ml +++ b/packet.ml @@ -13,11 +13,10 @@ type ports = { type host = [ `Client of client_link | `Client_gateway | `Firewall_uplink | `NetVM | `External of Ipaddr.t ] -(* Note: 'a is either [host], or the result of applying [Rules.clients] and [Rules.externals] to a host. *) -type 'a info = { +type ('src, 'dst) info = { packet : Nat_packet.t; - src : 'a; - dst : 'a; + src : 'src; + dst : 'dst; proto : [ `UDP of ports | `TCP of ports | `ICMP | `Unknown ]; } diff --git a/rules.ml b/rules.ml index 352c98b..f8f253d 100644 --- a/rules.ml +++ b/rules.ml @@ -1,12 +1,9 @@ (* Copyright (C) 2015, Thomas Leonard See the README file for details. *) -(** Put your firewall rules here. *) +(** Put your firewall rules in this file. *) -open Packet - -(* OCaml normally warns if you don't match all fields, but that's OK here. *) -[@@@ocaml.warning "-9"] +open Packet (* Allow us to use definitions in packet.ml *) (* 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]. *) @@ -25,11 +22,29 @@ let externals = [ *) ] -(** Decide what to do with a packet from a client VM. +(* OCaml normally warns if you don't match all fields, but that's OK here. *) +[@@@ocaml.warning "-9"] + +(** This function decides what to do with a packet from a client VM. + + It takes as input an argument [info] (of type [Packet.info]) describing the + packet, and returns an action (of type [Packet.action]) to perform. + + See packet.ml for the definitions of [info] and [action]. + Note: If the packet matched an existing NAT rule then this isn't called. *) -let from_client (info : _ info) : action = +let from_client (info : ([`Client of _], _) Packet.info) : Packet.action = match info with - (* Examples (add your own rules here): *) + (* Examples (add your own rules here): + + 1. Allows Dev to send SSH packets to Untrusted. + Note: responses are not covered by this! + 2. Allows clients to continue existing TCP connections with other clients. + This allows responses to SSH packets from the previous rule. + 3. Blocks an external site. + + 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 _; dst = `Client _; proto = `TCP _; packet } @@ -43,6 +58,6 @@ let from_client (info : _ info) : action = (** 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. *) -let from_netvm (info : _ info) : action = +let from_netvm (info : ([`NetVM | `External of _], _) Packet.info) : Packet.action = match info with | _ -> `Drop "drop by default" From eec1e985e5ed1209979d799ad9ffe4b125f602ed Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Fri, 3 May 2019 10:45:15 +0100 Subject: [PATCH 062/281] Add overview of the main components of the firewall --- .gitignore | 2 +- README.md | 23 +++++++ diagrams/Makefile | 6 ++ diagrams/components.svg | 149 ++++++++++++++++++++++++++++++++++++++++ diagrams/components.txt | 20 ++++++ 5 files changed, 199 insertions(+), 1 deletion(-) create mode 100644 diagrams/Makefile create mode 100644 diagrams/components.svg create mode 100644 diagrams/components.txt diff --git a/.gitignore b/.gitignore index f5cd959..bd2f111 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,4 @@ -Makefile +/Makefile _build/ log key_gen.ml diff --git a/README.md b/README.md index bfbef5f..960e568 100644 --- a/README.md +++ b/README.md @@ -86,6 +86,29 @@ qvm-prefs --set my-app-vm netvm mirage-firewall Alternatively, you can configure `mirage-firewall` to be your default firewall VM. +### Components + +This diagram show the main components (each box corresponds to a source `.ml` file with the same name): + +

+ +

+ +Ethernet frames arrives from client qubes (such as `work` or `personal`) or from `sys-net`. +Internet (IP) packets are sent to `firewall`, which consults `rules` to decide what to do with the packet. +If it should be sent on, it uses `router` to send it to the chosen destination. +`client_net` watches the XenStore database provided by dom0 +to find out when clients need to be added or removed. + +The boot process: + +- `config.ml` describes the libraries used and static configuration settings (NAT table size). + The `mirage` tool uses this to generate `main.ml`. +- `main.ml` initialises the drivers selected by `config.ml` + and calls the `start` function in `unikernel.ml`. +- `unikernel.ml` connects the Qubes agents, sets up the networking components, + and then waits for a shutdown request. + ### Easy deployment for developers For development, use the [test-mirage][] scripts to deploy the unikernel (`qubes_firewall.xen`) from your development AppVM. diff --git a/diagrams/Makefile b/diagrams/Makefile new file mode 100644 index 0000000..a6fbc5f --- /dev/null +++ b/diagrams/Makefile @@ -0,0 +1,6 @@ +# Requires https://github.com/blampe/goat + +all: components.svg + +%.svg: %.txt + goat $^ > $@ diff --git a/diagrams/components.svg b/diagrams/components.svg new file mode 100644 index 0000000..1e996b1 --- /dev/null +++ b/diagrams/components.svg @@ -0,0 +1,149 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +l +y +s +t +k +r +u +l +n +_ +r +i +e +l +o +n +k +n +o +o +e +e +e +l +s +t +( +f +p +i +i +o +w +t +u +n +- +a +o +X +S +r +m +u +c +r +] +e +r +i +n +s +t +e +k +s +w +e +. +n +e +l +r +s +e +s +r +l +[ +. +p +n +t +o +o +c +h +. +c +t +m +a +e +r +d +0 +) + + diff --git a/diagrams/components.txt b/diagrams/components.txt new file mode 100644 index 0000000..62e4f9e --- /dev/null +++ b/diagrams/components.txt @@ -0,0 +1,20 @@ + +----------+ + | rules | + +----------+ + ^ + |checks + | + +------------+ +-----+----+ + work <---->| +---->| firewall |<--------. + | | +-----+----+ | + | | | +----+---+ + [...] <---->| client_net | | | uplink |<----> sys-net + | | v +--------+ + | | +----------+ ^ +personal <---->| |<----+ router +---------' + +------+-----+ +----------+ + | + |monitors + v + XenStore + (dom0) From e15fc8c219d2b38aa4b16e9eb2e6224455355903 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Fri, 3 May 2019 11:12:58 +0100 Subject: [PATCH 063/281] Make example rule more restrictive In the (commented-out) example rules, instead of allowing any client to continue a TCP flow with any other client, just allow Untrusted to reply to Dev. This is all that is needed to make the SSH example work. --- rules.ml | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/rules.ml b/rules.ml index f8f253d..3959d14 100644 --- a/rules.ml +++ b/rules.ml @@ -39,15 +39,14 @@ let from_client (info : ([`Client of _], _) Packet.info) : Packet.action = 1. Allows Dev to send SSH packets to Untrusted. Note: responses are not covered by this! - 2. Allows clients to continue existing TCP connections with other clients. - This allows responses to SSH packets from the previous rule. + 2. Allows Untrusted to reply to Dev. 3. Blocks an external site. 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 _; dst = `Client _; proto = `TCP _; packet } + | { src = `Client `Untrusted; dst = `Client `Dev; proto = `TCP _; packet } when not (is_tcp_start packet) -> `Accept | { dst = `External `GoogleDNS } -> `Drop "block Google DNS" *) From 691c4ae745c80d24132c0c2d67c39db66fafb26f Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Mon, 6 May 2019 10:37:24 +0100 Subject: [PATCH 064/281] Update build hash --- 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 d14c057..7345ca5 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 qubes_firewall.xen)" -echo "SHA2 last known: dbf7460fa628bea5d132a96fe7ba2cd832e3d9da7005ae74f6a124957f4848ea" +echo "SHA2 last known: 888cfd66e54c14da75be2bc4272efdb74c2ec8f9f144979f508a09410121482e" echo "(hashes should match for released versions)" From 672c82c43c44a24d31a0bf43988104fdce618a00 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Thu, 16 May 2019 19:18:31 +0100 Subject: [PATCH 065/281] Combine Client_gateway and Firewall_uplink Before, we used Client_gateway for the IP address of the firewall on the client network and Firewall_uplink for its address on the uplink network. However, Qubes 4 uses the same IP address for both, so we can't separate these any longer, and there doesn't seem to be any advantage to keeping them separate anyway. --- build-with-docker.sh | 2 +- client_eth.ml | 6 +++--- client_eth.mli | 2 +- firewall.ml | 9 ++++----- packet.ml | 2 +- router.ml | 4 ++-- rules.ml | 4 ++-- 7 files changed, 14 insertions(+), 15 deletions(-) diff --git a/build-with-docker.sh b/build-with-docker.sh index 7345ca5..701c686 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 qubes_firewall.xen)" -echo "SHA2 last known: 888cfd66e54c14da75be2bc4272efdb74c2ec8f9f144979f508a09410121482e" +echo "SHA2 last known: 5ee982b12fb3964e7d9e32ca74ce377ec068b3bbef2b6c86c131f8bb422a3134" echo "(hashes should match for released versions)" diff --git a/client_eth.ml b/client_eth.ml index a65325c..3aa3a8a 100644 --- a/client_eth.ml +++ b/client_eth.ml @@ -15,7 +15,7 @@ type t = { type host = [ `Client of client_link - | `Client_gateway + | `Firewall | `External of Ipaddr.t ] let create ~client_gw = @@ -52,14 +52,14 @@ let classify t ip = match ip with | Ipaddr.V6 _ -> `External ip | Ipaddr.V4 ip4 -> - if ip4 = t.client_gw then `Client_gateway + if ip4 = t.client_gw then `Firewall else match lookup t ip4 with | Some client_link -> `Client client_link | None -> `External ip let resolve t : host -> Ipaddr.t = function | `Client client_link -> Ipaddr.V4 client_link#other_ip - | `Client_gateway -> Ipaddr.V4 t.client_gw + | `Firewall -> Ipaddr.V4 t.client_gw | `External addr -> addr module ARP = struct diff --git a/client_eth.mli b/client_eth.mli index 952e970..2bbb672 100644 --- a/client_eth.mli +++ b/client_eth.mli @@ -11,7 +11,7 @@ type t type host = [ `Client of client_link - | `Client_gateway + | `Firewall | `External of Ipaddr.t ] (* Note: Qubes does not allow us to distinguish between an external address and a disconnected client. diff --git a/firewall.ml b/firewall.ml index cbb47b7..77656d2 100644 --- a/firewall.ml +++ b/firewall.ml @@ -59,7 +59,7 @@ let resolve_client client = 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 + | (`Firewall | `NetVM) as x -> x let classify ~src ~dst packet = let `IPv4 (_ip, transport) = packet in @@ -84,8 +84,7 @@ let pp_host fmt = function | `Unknown_client ip -> Format.fprintf fmt "unknown-client(%a)" Ipaddr.pp ip | `NetVM -> Format.pp_print_string fmt "net-vm" | `External ip -> Format.fprintf fmt "external(%a)" Ipaddr.pp ip - | `Firewall_uplink -> Format.pp_print_string fmt "firewall(uplink)" - | `Client_gateway -> Format.pp_print_string fmt "firewall(client-gw)" + | `Firewall -> Format.pp_print_string fmt "firewall" let pp_proto fmt = function | `UDP ports -> Format.fprintf fmt "UDP(%a)" pp_ports ports @@ -146,7 +145,7 @@ let apply_rules t rules ~dst info = match rules info, dst with | `Accept, `Client client_link -> transmit_ipv4 packet client_link | `Accept, (`External _ | `NetVM) -> transmit_ipv4 packet t.Router.uplink - | `Accept, (`Firewall_uplink | `Client_gateway) -> + | `Accept, `Firewall -> Log.warn (fun f -> f "Bad rule: firewall can't accept packets %a" (pp_packet t) info); return () | `NAT, _ -> add_nat_and_forward_ipv4 t packet @@ -189,7 +188,7 @@ let ipv4_from_netvm t packet = | None -> return () | Some info -> match src with - | `Client _ | `Firewall_uplink | `Client_gateway -> + | `Client _ | `Firewall -> Log.warn (fun f -> f "Frame from NetVM has internal source IP address! %a" (pp_packet t) info); return () | `External _ | `NetVM as src -> diff --git a/packet.ml b/packet.ml index d9b49bb..7838a6b 100644 --- a/packet.ml +++ b/packet.ml @@ -11,7 +11,7 @@ type ports = { } type host = - [ `Client of client_link | `Client_gateway | `Firewall_uplink | `NetVM | `External of Ipaddr.t ] + [ `Client of client_link | `Firewall | `NetVM | `External of Ipaddr.t ] type ('src, 'dst) info = { packet : Nat_packet.t; diff --git a/router.ml b/router.ml index ff5fddc..4d7ed90 100644 --- a/router.ml +++ b/router.ml @@ -24,11 +24,11 @@ let add_client t = Client_eth.add_client t.client_eth let remove_client t = Client_eth.remove_client t.client_eth let classify t ip = - if ip = Ipaddr.V4 t.uplink#my_ip then `Firewall_uplink + if ip = Ipaddr.V4 t.uplink#my_ip then `Firewall else if ip = Ipaddr.V4 t.uplink#other_ip then `NetVM else (Client_eth.classify t.client_eth ip :> Packet.host) let resolve t = function - | `Firewall_uplink -> Ipaddr.V4 t.uplink#my_ip + | `Firewall -> Ipaddr.V4 t.uplink#my_ip | `NetVM -> Ipaddr.V4 t.uplink#other_ip | #Client_eth.host as host -> Client_eth.resolve t.client_eth host diff --git a/rules.ml b/rules.ml index 3959d14..ec0c1c3 100644 --- a/rules.ml +++ b/rules.ml @@ -51,8 +51,8 @@ let from_client (info : ([`Client of _], _) Packet.info) : Packet.action = | { dst = `External `GoogleDNS } -> `Drop "block Google DNS" *) | { dst = (`External _ | `NetVM) } -> `NAT - | { dst = `Client_gateway; proto = `UDP { dport = 53 } } -> `NAT_to (`NetVM, 53) - | { dst = (`Client_gateway | `Firewall_uplink) } -> `Drop "packet addressed to firewall itself" + | { dst = `Firewall; proto = `UDP { dport = 53 } } -> `NAT_to (`NetVM, 53) + | { dst = `Firewall } -> `Drop "packet addressed to firewall itself" | { dst = `Client _ } -> `Drop "prevent communication between client VMs by default" (** Decide what to do with a packet received from the outside world. From ee97d67c844e9b6483b4bc360ce65283031c3f43 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Tue, 28 May 2019 21:04:31 +0100 Subject: [PATCH 066/281] Add CHANGELOG Older entries are imported from the release notes. The 0.6 ones are from the Git commits. --- CHANGES.md | 212 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 212 insertions(+) create mode 100644 CHANGES.md diff --git a/CHANGES.md b/CHANGES.md new file mode 100644 index 0000000..7fde759 --- /dev/null +++ b/CHANGES.md @@ -0,0 +1,212 @@ +### 0.6 + +Changes to rules language: + +- Allow naming hosts (@talex5, #54). + Previously, we passed in the interface, from which it was possible (but a + little difficult) to extract the IP address and compare with some predefined + ones. Now, we allow the user to list IP addresses and named tags for them, + which can be matched on easily. + +- Add some types to the rules (@talex5, #54). + Before, we inferred the types from `rules.ml` and then the compiler checked that + it was consistent with what `firewall.ml` expected. If it wasn't then it + reported the problem as being with `firewall.ml`, which could be confusing to + users. + +- Give exact types for `Packet.src` (@talex5, #54). + Before, the packet passed to `rules.ml` could have any host as its `src`. + Now, `from_client` knows that `src` must be a `Client`, + and `from_netvm` knows that `src` is `External` or `NetVM`. + +- Combine `Client_gateway` and `Firewall_uplink` (@talex5, #65). + Before, we used `Client_gateway` for the IP address of the firewall on the client network + and `Firewall_uplink` for its address on the uplink network. + However, Qubes 4 uses the same IP address for both, so we can't separate these any longer, + and there doesn't seem to be any advantage to keeping them separate anyway. + +Bug fixes: + +- Upgrade to latest mirage-nat to fix ICMP (@yomimono, @linse, #55). + Now ping and traceroute should work. Reported by @xaki23. + +- Respond to ARP requests for `*.*.*.1` (@talex5, #61). + This is a work-around to get DHCP working with HVM domains. + Reported by @cgchinicz. + See: https://github.com/QubesOS/qubes-issues/issues/5022 + +- Force backend MAC to `fe:ff:ff:ff:ff:ff` to fix HVM clients (@talex5, #61). + Xen appears to configure the same MAC address for both the frontend and + backend in XenStore. This works if the client uses just a simple ethernet + device, but fails if it connects via a bridge. HVM domains have an associated + stub domain running qemu, which provides an emulated network device. The stub + domain uses a bridge to connect qemu's interface with eth0, and this didn't + work. Force the use of the fixed version of mirage-net-xen, which no longer + uses XenStore to get the backend MAC, and provides a new function to get the + frontend one. + +- Wait if dom0 is slow to set the network configuration (@talex5, #60). + Sometimes we boot before dom0 has put the network settings in QubesDB. + If that happens, log a message, wait until the database changes, and retry. + +Reproducible builds: + +- Add patch to cmdliner for reproducible build (@talex5, #52). + See https://github.com/dbuenzli/cmdliner/pull/106 + +- Use source date in .tar.bz2 archive (@talex5, #49). + All files are now added using the date the `build-with-docker` script was last changed. + Since this includes the hash of the result, it should be up-to-date. + This ensures that rebuilding the archive doesn't change it in any way. + Reported by Holger Levsen. + +Documentation changes: + +- Added example rules showing how to block access to an external service or + allow SSH between AppVMs (@talex5, #54). Requested at + https://groups.google.com/d/msg/qubes-users/BnL0nZGpJOE/61HOBg1rCgAJ. + +- Add overview of the main components of the firewall in the README (@talex5, #54). + +- Link to security advisories from README (@talex5, #58). + +- Clarify how to build from source (@talex5, #51). + +- Remove Qubes 3 instructions (@talex5, #48). + See https://www.qubes-os.org/news/2019/03/28/qubes-3-2-has-reached-eol/ + +### 0.5 + +- Update to the latest mirage-net-xen, mirage-nat and tcpip libraries (@yomimono, @talex5, #45, #47). + In iperf benchmarks between a client VM and sys-net, this more than doubled the reported bandwidth! + +- Don't wait for the Qubes GUI daemon to connect before attaching client VMs (@talex5, #38). + If the firewall is restarted while AppVMs are connected, qubesd tries to + reconnect them before starting the GUI agent. However, the firewall was + waiting for the GUI agent to connect before handling the connections. This + led to a 10s delay on restart for each client VM. Reported by @xaki23. + +- Add stub makefile for qubes-builder (@xaki23, #37). + +- Update build instructions for latest Fedora (@talex5, #36). `yum` no longer exists. + Also, show how to create a symlink for `/var/lib/docker` on build VMs that aren't standalone. + Reported by @xaki23. + +- Add installation instructions for Qubes 4 (@yomimono, @reynir, @talex5, #27). + +- Use `Ethernet_wire.sizeof_ethernet` instead of a magic `14` (@hannesm, #46). + +### 0.4 + +- Add support for HVM guests (needed for Qubes 4). + +- Add support for disposable VMs. + +- Drop frames if an interface's queue gets too long. + +- Show the packet when failing to add a NAT rule. The previous message was + just: `WRN [firewall] Failed to add NAT rewrite rule: Cannot NAT this packet` + +### 0.3 + +- Add support for NAT of ICMP queries (e.g. pings) and errors (e.g. "Host unreachable"). + Before, these packets would be dropped. + +- Use an LRU cache to avoid running out of memory and needing to reset the table. + Should avoid any more out-of-memory bugs. + +- Pass around parsed packets rather than raw ethernet frames. + +- Pin Docker base image to a specific hash. Requested by Joanna Rutkowska. + +- Update for Mirage 3. + +- Remove non-Docker build instructions. Fedora 24 doesn't work with opam + (because the current binary release of aspcud's clasp binary segfaults, which + opam reports as `External solver failed with inconsistent return value.`). + +### 0.2 + +Build: + +- Add option to build with Docker. This fixes opam-repository to a known commit + for reproducible builds. It also displays the actual and expected SHA hashes + after building. + +Bug fixes: + +- Updated README: the build also requires "patch". Reported by William Waites. +- Monitor set of client interfaces, not client domains. Qubes does not remove + the client directory itself when the domain exits. This prevented clients + from reconnecting. This may also make it possible to connect clients to the + firewall via multiple interfaces, although this doesn't seem useful. +- Handle errors writing to client. mirage-net-xen would report `Netback_shutdown` + if we tried to write to a client after it had disconnected. Now we just log + this and continue. +- Ensure that old client has quit before adding new one. Not sure if this can + happen, but it removes a TODO from the code. +- Allow clients to have any IP address. We previously assumed that Qubes would + always give clients IP addresses on a particular network. However, it is not + required to do this and in fact uses a different network for disposable VMs. + With this change: + - We no longer reject clients with unknown IP addresses. + - The `Unknown_client` classification is gone; we have no way to tell the + difference between a client that isn't connected and an external address. + - We now consider every client to be on a point-to-point link and do not + answer ARP requests on behalf of other clients. Clients should assume their + netmask is `255.255.255.255` (and ignore `/qubes-netmask`). This allows + disposable VMs to connect to the firewall but for some reason they don't + process any frames we send them (we get their ARP requests but they don't + get our replies). Taking eth0 down in the disp VM, then bringing it back up + (and re-adding the routes) allows it to work. +- Cope with writing a frame failing. If a client disconnects suddenly then we + may get an error trying to map its grant to send the frame. +- Survive death of our GUId connection to dom0. We don't need the GUI anyway. +- Handle `Out_of_memory` adding NAT entries. Because hash tables resize in big + steps, this can happen even if we have a fair chunk of free memory. +- Calculate checksums even for `Accept` action. If packet has been NAT'd then we + certainly need to recalculate the checksum, but even for direct pass-through + it might have been received with an invalid checksum due to checksum offload. + For now, recalculate full checksum in all cases. +- Log correct destination for redirected packets. Before, we always said it was + going to "NetVM". +- If we can't find a free port, reset the NAT table. +- Reset NAT table if memory gets low. + +Other changes: + +- Report current memory use to XenStore. +- Reduce logging verbosity. +- Avoid using `Lwt.join` on listening threads. + `Lwt.join` only reports an error if _both_ threads fail. +- Keep track of transmit queue lengths. Log if we have to wait to send a frame. +- Use mirage-logs library for log reporter. +- Respond to `WaitForSession` commands (we're always ready!). +- Log `SetDateTime` messages from dom0 (we still don't actually update our clock, + though). + +Updates for upstream library changes: + +- Updates for mirage 2.9.0. + - Use new name for uplink device (`0`, not `tap0`). + - Don't configure logging - mirage does that for us now. +- Remove tcpip pin. The 2.7.0 release has the checksum feature we need. +- Remove mirage-xen pin. mirage-xen 2.4.0 has been released with the required + features (also fixes indentation problem reported by @cfcs). +- Add ncurses-dev to required yum packages. The ocamlfind package has started + listing this as a required dependency for some reason, although it appears + not to need it. Reported by cyrinux. +- Add work-around for Qubes passing Linux kernel arguments. With the new + Functoria release of Mirage, these unrecognised arguments prevented the + unikernel from booting. See: https://github.com/mirage/mirage/issues/493 +- Remove mirage-logs pin. Now available from the main repository. +- Remove mirage-qubes pin. + mirage-qubes 0.2 has been released, and supports the latests Logs API. +- Remove mirage-net-xen pin. + Version 1.5 has now been released, and includes netback support. +- Update to new Logs API. +- Remove pin for mirage-clock-xen. New version has been released now. + +### 0.1 + +Initial release. From de7d05ebfa6dad7be7aa17f34870f24d53b6f743 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Wed, 29 May 2019 08:37:31 +0100 Subject: [PATCH 067/281] Fix typos in docs --- CHANGES.md | 2 +- README.md | 1 - 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 7fde759..6284c3e 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -19,7 +19,7 @@ Changes to rules language: Now, `from_client` knows that `src` must be a `Client`, and `from_netvm` knows that `src` is `External` or `NetVM`. -- Combine `Client_gateway` and `Firewall_uplink` (@talex5, #65). +- Combine `Client_gateway` and `Firewall_uplink` (@talex5, #64). Before, we used `Client_gateway` for the IP address of the firewall on the client network and `Firewall_uplink` for its address on the uplink network. However, Qubes 4 uses the same IP address for both, so we can't separate these any longer, diff --git a/README.md b/README.md index 960e568..33a22a1 100644 --- a/README.md +++ b/README.md @@ -170,7 +170,6 @@ Redistribution and use in source and binary forms, with or without modification, 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -gg [test-mirage]: https://github.com/talex5/qubes-test-mirage [mirage-qubes]: https://github.com/mirage/mirage-qubes From 3ab7284a6413043f5e40c592b2907954b126a661 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Wed, 29 May 2019 15:22:15 +0100 Subject: [PATCH 068/281] Note that mirage-firewall cannot be used as UpdateVM Reported at: https://groups.google.com/forum/#!topic/qubes-users/YPFtbwyoUjc --- README.md | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/README.md b/README.md index 960e568..97b8122 100644 --- a/README.md +++ b/README.md @@ -86,6 +86,14 @@ qvm-prefs --set my-app-vm netvm mirage-firewall Alternatively, you can configure `mirage-firewall` to be your default firewall VM. +Note that by default dom0 uses sys-firewall as its "UpdateVM" (a proxy for downloading updates). +mirage-firewall cannot be used for this, but any Linux VM should be fine. +https://www.qubes-os.org/doc/software-update-dom0/ says: + +> The role of UpdateVM can be assigned to any VM in the Qubes VM Manager, and +> there are no significant security implications in this choice. By default, +> this role is assigned to the firewallvm. + ### Components This diagram show the main components (each box corresponds to a source `.ml` file with the same name): From 0a4b01a8410e8d8c357cf6ce9e3f65f6c422f02b Mon Sep 17 00:00:00 2001 From: jaseg Date: Fri, 31 May 2019 12:50:33 +0900 Subject: [PATCH 069/281] Fix ln(1) call in build instructions The arguments were backwards. [```ln``` takes the link target first, then the link name](https://linux.die.net/man/1/ln). --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 0c8aaae..9cd73d7 100644 --- a/README.md +++ b/README.md @@ -18,7 +18,7 @@ See the [Deploy](#deploy) section below for installation instructions. Create a new Fedora-29 AppVM (or reuse an existing one). Open a terminal. Clone this Git repository and run the `build-with-docker.sh` script: - sudo ln -s /var/lib/docker /home/user/docker + sudo ln -s /home/user/docker /var/lib/docker sudo dnf install docker sudo systemctl start docker git clone https://github.com/mirage/qubes-mirage-firewall.git From d36ecf96af37154ca050b0de2e1c445f41f603a2 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Sat, 15 Jun 2019 12:48:01 +0100 Subject: [PATCH 070/281] Remove cmdliner pin as 1.0.4 is now released Reverts 06511e076f --- Dockerfile | 5 ++--- build-with-docker.sh | 2 +- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/Dockerfile b/Dockerfile index 1cbe558..41ad029 100644 --- a/Dockerfile +++ b/Dockerfile @@ -2,15 +2,14 @@ # It will probably still work on newer images, though, unless Debian # changes some compiler optimisations (unlikely). #FROM ocaml/opam2:debian-9-ocaml-4.07 -FROM ocaml/opam2@sha256:f7125924dd6632099ff98b2505536fe5f5c36bf0beb24779431bb62be5748562 +FROM ocaml/opam2@sha256:74fb6e30a95e1569db755b3c061970a8270dfc281c4e69bffe2cf9905d356b38 # 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 git fetch origin && git reset --hard d1b2a1cbc28d43926b37e61f46fc403b48ab9c23 && opam update +RUN git fetch origin && git reset --hard d28fedaa8a077a429bd7bd79cbc19eb90e01c040 && opam update RUN sudo apt-get install -y m4 libxen-dev pkg-config -RUN opam pin add -yn cmdliner 'https://github.com/talex5/cmdliner.git#repro-builds' RUN opam install -y vchan mirage-xen-ocaml mirage-xen-minios io-page mirage-xen mirage mirage-nat mirage-qubes RUN mkdir /home/opam/qubes-mirage-firewall ADD config.ml /home/opam/qubes-mirage-firewall/config.ml diff --git a/build-with-docker.sh b/build-with-docker.sh index 701c686..b484c2f 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 qubes_firewall.xen)" -echo "SHA2 last known: 5ee982b12fb3964e7d9e32ca74ce377ec068b3bbef2b6c86c131f8bb422a3134" +echo "SHA2 last known: b4758e0911acd25c278c5d4bb9feb05daccb5e3d6c3692b5e2274b098971e1b8" echo "(hashes should match for released versions)" From f9856a3605ff326520e01c3a26783f0465bed164 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Sat, 22 Jun 2019 14:53:25 +0100 Subject: [PATCH 071/281] Remove netchannel pin Version 1.11.0 has been released now, and the current trunk doesn't build without updating other things. The error was: File "lib/xenstore.ml", line 165, characters 19-34: Error: The module OS is an alias for module Os_xen, which is missing ocamlopt lib/.netchannel.objs/native/netchannel__Backend.{cmx,o} (exit 2) (cd _build/default && /home/opam/.opam/4.07/bin/ocamlopt.opt -w -40 -g -I lib/.netchannel.objs/byte -I lib/.netchannel.objs/native -I /home/opam/.opam/4.07/lib/base/caml -I /home/opam/.opam/4.07/lib/bigarray-compat -I /home/opam/.opam/4.07/lib/bytes -I /home/opam/.opam/4.07/lib/cstruct -I /home/opam/.opam/4.07/lib/fmt -I /home/opam/.opam/4.07/lib/io-page -I /home/opam/.opam/4.07/lib/io-page-x[...] File "lib/backend.ml", line 23, characters 16-29: Error: The module OS is an alias for module Os_xen, which is missing Reported by ronpunz in https://groups.google.com/forum/#!topic/qubes-users/PsYUXvypPDs --- build-with-docker.sh | 2 +- config.ml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/build-with-docker.sh b/build-with-docker.sh index b484c2f..ad8d3b7 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 qubes_firewall.xen)" -echo "SHA2 last known: b4758e0911acd25c278c5d4bb9feb05daccb5e3d6c3692b5e2274b098971e1b8" +echo "SHA2 last known: 9f7d064a194be07301173389a4414266cd5d7ef935b16ed29a978a33cb92884c" echo "(hashes should match for released versions)" diff --git a/config.ml b/config.ml index 4171927..c27223a 100644 --- a/config.ml +++ b/config.ml @@ -27,7 +27,7 @@ let main = package "ethernet"; package "mirage-protocols"; package "shared-memory-ring" ~min:"3.0.0"; - package "netchannel" ~min:"1.11.0" ~pin:"git+https://github.com/mirage/mirage-net-xen.git"; + package "netchannel" ~min:"1.11.0"; package "mirage-net-xen"; package "ipaddr" ~min:"3.0.0"; package "mirage-qubes"; From cb6d03d83d2d7b1e204c9a36ab7210c35c74a1ec Mon Sep 17 00:00:00 2001 From: xaki23 Date: Sun, 28 Jul 2019 13:07:09 +0200 Subject: [PATCH 072/281] Use OCaml 4.08.0 for qubes-builder builds (was 4.07.1) --- Makefile.builder | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile.builder b/Makefile.builder index 098463d..146392e 100644 --- a/Makefile.builder +++ b/Makefile.builder @@ -1,2 +1,2 @@ MIRAGE_KERNEL_NAME = qubes_firewall.xen -OCAML_VERSION ?= 4.07.1 +OCAML_VERSION ?= 4.08.0 From 16231e2e524a53284490346961fc26b11059fe22 Mon Sep 17 00:00:00 2001 From: xaki23 Date: Sun, 28 Jul 2019 13:08:15 +0200 Subject: [PATCH 073/281] Adjust to ipaddr-4.0.0 renaming _bytes to _octets --- Dockerfile | 2 +- build-with-docker.sh | 2 +- client_eth.ml | 2 +- config.ml | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/Dockerfile b/Dockerfile index 41ad029..7544cdb 100644 --- a/Dockerfile +++ b/Dockerfile @@ -7,7 +7,7 @@ FROM ocaml/opam2@sha256:74fb6e30a95e1569db755b3c061970a8270dfc281c4e69bffe2cf990 # 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 git fetch origin && git reset --hard d28fedaa8a077a429bd7bd79cbc19eb90e01c040 && opam update +RUN git fetch origin && git reset --hard 3389beb33b37da54c9f5a41f19291883dfb59bfb && opam update RUN sudo apt-get install -y m4 libxen-dev pkg-config RUN opam install -y vchan mirage-xen-ocaml mirage-xen-minios io-page mirage-xen mirage mirage-nat mirage-qubes diff --git a/build-with-docker.sh b/build-with-docker.sh index ad8d3b7..82a6fab 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 qubes_firewall.xen)" -echo "SHA2 last known: 9f7d064a194be07301173389a4414266cd5d7ef935b16ed29a978a33cb92884c" +echo "SHA2 last known: 5707d97d78eb54cad9bade5322c197d8b3706335aa277ccad31fceac564f3319" echo "(hashes should match for released versions)" diff --git a/client_eth.ml b/client_eth.ml index 3aa3a8a..10c84d1 100644 --- a/client_eth.ml +++ b/client_eth.ml @@ -70,7 +70,7 @@ module ARP = struct let lookup t ip = if ip = t.net.client_gw then Some t.client_link#my_mac - else if (Ipaddr.V4.to_bytes ip).[3] = '\x01' then ( + else if (Ipaddr.V4.to_octets ip).[3] = '\x01' then ( Log.info (fun f -> f ~header:t.client_link#log_header "Request for %a is invalid, but pretending it's me (see Qubes issue #5022)" Ipaddr.V4.pp ip); Some t.client_link#my_mac diff --git a/config.ml b/config.ml index c27223a..ef85b1a 100644 --- a/config.ml +++ b/config.ml @@ -29,7 +29,7 @@ let main = package "shared-memory-ring" ~min:"3.0.0"; package "netchannel" ~min:"1.11.0"; package "mirage-net-xen"; - package "ipaddr" ~min:"3.0.0"; + package "ipaddr" ~min:"4.0.0"; package "mirage-qubes"; package "mirage-nat" ~min:"1.2.0"; package "mirage-logs"; From 8b411db75145131a11a42a1b662f6de7ae27184d Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Sun, 28 Jul 2019 16:49:16 +0100 Subject: [PATCH 074/281] Removed some hard-coded installs from Dockerfile There's no advantage to installing these manually, and with the current version of mirage they had to be downgraded again in the next step. --- Dockerfile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Dockerfile b/Dockerfile index 7544cdb..5929b79 100644 --- a/Dockerfile +++ b/Dockerfile @@ -10,7 +10,7 @@ FROM ocaml/opam2@sha256:74fb6e30a95e1569db755b3c061970a8270dfc281c4e69bffe2cf990 RUN git fetch origin && git reset --hard 3389beb33b37da54c9f5a41f19291883dfb59bfb && opam update RUN sudo apt-get install -y m4 libxen-dev pkg-config -RUN opam install -y vchan mirage-xen-ocaml mirage-xen-minios io-page mirage-xen mirage mirage-nat mirage-qubes +RUN opam install -y mirage lwt RUN mkdir /home/opam/qubes-mirage-firewall ADD config.ml /home/opam/qubes-mirage-firewall/config.ml WORKDIR /home/opam/qubes-mirage-firewall From ce29c09f0f543e2eed02fe55355fd17197027e40 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Sun, 28 Jul 2019 17:01:23 +0100 Subject: [PATCH 075/281] Show final sha256 checksum in Travis output --- .travis.yml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index fb11f9a..77b3499 100644 --- a/.travis.yml +++ b/.travis.yml @@ -3,6 +3,8 @@ script: - echo 'ADD . /home/opam/qubes-mirage-firewall' >> Dockerfile - echo 'RUN sudo chown -R opam /home/opam/qubes-mirage-firewall' >> Dockerfile - docker build -t qubes-mirage-firewall . - - docker run --rm -i qubes-mirage-firewall + - docker run --name build -i qubes-mirage-firewall + - docker cp build:/home/opam/qubes-mirage-firewall/qubes_firewall.xen . + - sha256sum qubes_firewall.xen sudo: required dist: trusty From cac3e53be120fe03cfafe3a221b797bb8fa47a2b Mon Sep 17 00:00:00 2001 From: xaki23 Date: Sun, 28 Jul 2019 13:33:43 +0200 Subject: [PATCH 076/281] README: create the symlink-redirected docker dir Otherwise, installing the docker package removes the dangling symlink. --- README.md | 1 + 1 file changed, 1 insertion(+) diff --git a/README.md b/README.md index 9cd73d7..7722ff9 100644 --- a/README.md +++ b/README.md @@ -18,6 +18,7 @@ See the [Deploy](#deploy) section below for installation instructions. Create a new Fedora-29 AppVM (or reuse an existing one). Open a terminal. Clone this Git repository and run the `build-with-docker.sh` script: + mkdir /home/user/docker sudo ln -s /home/user/docker /var/lib/docker sudo dnf install docker sudo systemctl start docker From 3fefba21a78327d243092d3236b19fbf28383bf1 Mon Sep 17 00:00:00 2001 From: xaki23 Date: Sun, 25 Aug 2019 18:12:17 +0200 Subject: [PATCH 077/281] bump OCAML_VERSION to 4.08.1 --- Makefile.builder | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile.builder b/Makefile.builder index 146392e..8a6355b 100644 --- a/Makefile.builder +++ b/Makefile.builder @@ -1,2 +1,2 @@ MIRAGE_KERNEL_NAME = qubes_firewall.xen -OCAML_VERSION ?= 4.08.0 +OCAML_VERSION ?= 4.08.1 From bc7706cc97531aaf1f4dd0291a26c2307f32d647 Mon Sep 17 00:00:00 2001 From: xaki23 Date: Sun, 25 Aug 2019 18:12:59 +0200 Subject: [PATCH 078/281] rename things for newer mirage-xen versions --- client_net.ml | 2 +- dao.ml | 8 ++++---- memory_pressure.ml | 10 +++++----- 3 files changed, 10 insertions(+), 10 deletions(-) diff --git a/client_net.ml b/client_net.ml index 68fe6d3..df436be 100644 --- a/client_net.ml +++ b/client_net.ml @@ -4,7 +4,7 @@ open Lwt.Infix open Fw_utils -module Netback = Netchannel.Backend.Make(Netchannel.Xenstore.Make(OS.Xs)) +module Netback = Netchannel.Backend.Make(Netchannel.Xenstore.Make(Os_xen.Xs)) module ClientEth = Ethernet.Make(Netback) let src = Logs.Src.create "client_net" ~doc:"Client networking" diff --git a/dao.ml b/dao.ml index a68cc64..55d901e 100644 --- a/dao.ml +++ b/dao.ml @@ -30,7 +30,7 @@ module VifMap = struct end let directory ~handle dir = - OS.Xs.directory handle dir >|= function + Os_xen.Xs.directory handle dir >|= function | [""] -> [] (* XenStore client bug *) | items -> items @@ -46,7 +46,7 @@ let vifs ~handle domid = | Some device_id -> let vif = { ClientVif.domid; device_id } in Lwt.try_bind - (fun () -> OS.Xs.read handle (Printf.sprintf "%s/%d/ip" path device_id)) + (fun () -> Os_xen.Xs.read handle (Printf.sprintf "%s/%d/ip" path device_id)) (fun client_ip -> let client_ip = Ipaddr.V4.of_string_exn client_ip in Lwt.return (Some (vif, client_ip)) @@ -61,10 +61,10 @@ let vifs ~handle domid = ) let watch_clients fn = - OS.Xs.make () >>= fun xs -> + Os_xen.Xs.make () >>= fun xs -> let backend_vifs = "backend/vif" in Log.info (fun f -> f "Watching %s" backend_vifs); - OS.Xs.wait xs (fun handle -> + Os_xen.Xs.wait xs (fun handle -> begin Lwt.catch (fun () -> directory ~handle backend_vifs) (function diff --git a/memory_pressure.ml b/memory_pressure.ml index ed5b7e5..92271da 100644 --- a/memory_pressure.ml +++ b/memory_pressure.ml @@ -6,7 +6,7 @@ open Lwt let src = Logs.Src.create "memory_pressure" ~doc:"Memory pressure monitor" module Log = (val Logs.src_log src : Logs.LOG) -let total_pages = OS.MM.Heap_pages.total () +let total_pages = Os_xen.MM.Heap_pages.total () let pagesize_kb = Io_page.page_size / 1024 let meminfo ~used = @@ -23,7 +23,7 @@ let meminfo ~used = let report_mem_usage used = Lwt.async (fun () -> - let open OS in + let open Os_xen in Xs.make () >>= fun xs -> Xs.immediate xs (fun h -> Xs.write h "memory/meminfo" (meminfo ~used) @@ -32,16 +32,16 @@ let report_mem_usage used = let init () = Gc.full_major (); - let used = OS.MM.Heap_pages.used () in + let used = Os_xen.MM.Heap_pages.used () in report_mem_usage used let status () = - let used = OS.MM.Heap_pages.used () |> float_of_int in + let used = Os_xen.MM.Heap_pages.used () |> float_of_int in let frac = used /. float_of_int total_pages in if frac < 0.9 then `Ok else ( Gc.full_major (); - let used = OS.MM.Heap_pages.used () in + let used = Os_xen.MM.Heap_pages.used () in report_mem_usage used; let frac = float_of_int used /. float_of_int total_pages in if frac > 0.9 then `Memory_critical From 49195ed5e18128792f239b500768107ef5e557c2 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Sun, 25 Aug 2019 18:41:09 +0100 Subject: [PATCH 079/281] Update Docker build for new mirage-xen Also, switched to the experimental new OCurrent images, as they are much smaller: - Before: 1 GB (ocaml/opam2:debian-10-ocaml-4.08) - Now: 309 MB (ocurrent/opam:alpine-3.10-ocaml-4.08) --- .dockerignore | 3 +++ Dockerfile | 9 ++++----- build-with-docker.sh | 2 +- config.ml | 1 + 4 files changed, 9 insertions(+), 6 deletions(-) diff --git a/.dockerignore b/.dockerignore index 85fe546..72eb1df 100644 --- a/.dockerignore +++ b/.dockerignore @@ -2,3 +2,6 @@ _build *.xen *.bz2 +*.tar.bz2 +*.tgz +mirage-firewall-bin* diff --git a/Dockerfile b/Dockerfile index 5929b79..ba15257 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,16 +1,15 @@ # Pin the base image to a specific hash for maximum reproducibility. # It will probably still work on newer images, though, unless Debian # changes some compiler optimisations (unlikely). -#FROM ocaml/opam2:debian-9-ocaml-4.07 -FROM ocaml/opam2@sha256:74fb6e30a95e1569db755b3c061970a8270dfc281c4e69bffe2cf9905d356b38 +#FROM ocurrent/opam:alpine-3.10-ocaml-4.08 +FROM ocurrent/opam@sha256:4cf6f8a427e7f65a250cd5dbc9f5069e8f8213467376af5136bf67a21d39d6ec # 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 git fetch origin && git reset --hard 3389beb33b37da54c9f5a41f19291883dfb59bfb && opam update +RUN cd ~/opam-repository && git fetch origin master && git reset --hard a83bd077e4e54c41b0664a2e1618670d57b7c79d && opam update -RUN sudo apt-get install -y m4 libxen-dev pkg-config -RUN opam install -y mirage lwt +RUN opam depext -i -y mirage lwt 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 82a6fab..01555ba 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 qubes_firewall.xen)" -echo "SHA2 last known: 5707d97d78eb54cad9bade5322c197d8b3706335aa277ccad31fceac564f3319" +echo "SHA2 last known: 3cf9358df911c7bc5a28846087c5359e5b550e5d0c6cf342a6e1c90545518ac6" echo "(hashes should match for released versions)" diff --git a/config.ml b/config.ml index ef85b1a..55d8c42 100644 --- a/config.ml +++ b/config.ml @@ -33,6 +33,7 @@ let main = package "mirage-qubes"; package "mirage-nat" ~min:"1.2.0"; package "mirage-logs"; + package "mirage-xen" ~min:"4.0.0"; ] "Unikernel.Main" (mclock @-> job) From 930d209cdb09ec670ad3f28bde15d595c8553c95 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Sun, 17 Nov 2019 14:25:42 +0000 Subject: [PATCH 080/281] Fix build - A new ocaml-migrate-parsetree.1.4.0 was released, replacing the old 1.4.0 with new code. This was rejected by the checksum test. Fixed by updating to the latest opam-repository. See: https://github.com/ocaml/opam-repository/pull/15294 - The latest opam-repository pulls in mirage 3.7, which doesn't work (`No available version of mirage-clock satisfies the constraints`), so pin the previous mirage 3.5.2 version instead. - Mirage now generates `.merlin`, so remove it from Git. --- .gitignore | 1 + .merlin | 3 --- Dockerfile | 6 +++--- build-with-docker.sh | 2 +- 4 files changed, 5 insertions(+), 7 deletions(-) delete mode 100644 .merlin diff --git a/.gitignore b/.gitignore index bd2f111..280a547 100644 --- a/.gitignore +++ b/.gitignore @@ -7,3 +7,4 @@ main.native mir-qubes-test qubes-firewall.xl.in qubes-firewall_libvirt.xml +.merlin diff --git a/.merlin b/.merlin deleted file mode 100644 index 2b4d411..0000000 --- a/.merlin +++ /dev/null @@ -1,3 +0,0 @@ -S . -B _build -PKG vchan.xen lwt mirage mirage-net-xen tcpip mirage-nat diff --git a/Dockerfile b/Dockerfile index ba15257..c6ef858 100644 --- a/Dockerfile +++ b/Dockerfile @@ -2,14 +2,14 @@ # It will probably still work on newer images, though, unless Debian # changes some compiler optimisations (unlikely). #FROM ocurrent/opam:alpine-3.10-ocaml-4.08 -FROM ocurrent/opam@sha256:4cf6f8a427e7f65a250cd5dbc9f5069e8f8213467376af5136bf67a21d39d6ec +FROM ocurrent/opam@sha256:3f3ce7e577a94942c7f9c63cbdd1ecbfe0ea793f581f69047f3155967bba36f6 # 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 ~/opam-repository && git fetch origin master && git reset --hard a83bd077e4e54c41b0664a2e1618670d57b7c79d && opam update +RUN cd ~/opam-repository && git fetch origin master && git reset --hard 5eed470abc5c7991e448c9653698c03d6ea146d1 && opam update -RUN opam depext -i -y mirage lwt +RUN opam depext -i -y mirage.3.5.2 lwt 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 01555ba..31dd331 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 qubes_firewall.xen)" -echo "SHA2 last known: 3cf9358df911c7bc5a28846087c5359e5b550e5d0c6cf342a6e1c90545518ac6" +echo "SHA2 last known: cae3c66d38a50671f694cd529062c538592438b95935d707b97d80b57fbfc186" echo "(hashes should match for released versions)" From 315fe4681e52c9b327942d06e93c9e11001fb656 Mon Sep 17 00:00:00 2001 From: Snowy Marmot Date: Wed, 27 Nov 2019 16:01:58 +0000 Subject: [PATCH 081/281] Note that AppVM Size may need to increase Add note that AppVM used to build from source may need a private image larger than the default 2048MB. --- README.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/README.md b/README.md index 7722ff9..9bd1fef 100644 --- a/README.md +++ b/README.md @@ -16,6 +16,9 @@ See the [Deploy](#deploy) section below for installation instructions. ## Build from source Create a new Fedora-29 AppVM (or reuse an existing one). Open a terminal. +Note that you may need more than the default 2GB (2048MB) of storage in the private +image of the AppVM, so you may need to increase the size in the Qube's Settings. + Clone this Git repository and run the `build-with-docker.sh` script: mkdir /home/user/docker From dad1f6a723d2ea7ad54db566f30d6896997ea314 Mon Sep 17 00:00:00 2001 From: Snowy Marmot Date: Sat, 14 Dec 2019 00:24:55 +0000 Subject: [PATCH 082/281] Update per review Update with suggested wording per talex5 --- README.md | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/README.md b/README.md index 9bd1fef..6556705 100644 --- a/README.md +++ b/README.md @@ -15,9 +15,8 @@ See the [Deploy](#deploy) section below for installation instructions. ## Build from source -Create a new Fedora-29 AppVM (or reuse an existing one). Open a terminal. -Note that you may need more than the default 2GB (2048MB) of storage in the private -image of the AppVM, so you may need to increase the size in the Qube's Settings. + +Create a new Fedora-30 AppVM (or reuse an existing one). In the Qube's Settings (Basic / Disk storage), increase the private storage max size from the default 2048 MiB to 4096 MiB. Open a terminal. Clone this Git repository and run the `build-with-docker.sh` script: From 43656be181b8fb6660dca6075c3ba3e3eb2fe7f8 Mon Sep 17 00:00:00 2001 From: xaki23 Date: Fri, 27 Dec 2019 23:19:35 +0100 Subject: [PATCH 083/281] pin mirage to 3.5.2 for qubes-builder builds --- Makefile.builder | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/Makefile.builder b/Makefile.builder index 8a6355b..23827af 100644 --- a/Makefile.builder +++ b/Makefile.builder @@ -1,2 +1,7 @@ MIRAGE_KERNEL_NAME = qubes_firewall.xen OCAML_VERSION ?= 4.08.1 +SOURCE_BUILD_DEP := firewall-build-dep + +firewall-build-dep: + opam pin -y add mirage 3.5.2 + From c66ee54a9fe24e1ffb05261e3b7cef3d9883ffc9 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sat, 11 Jan 2020 14:34:25 +0100 Subject: [PATCH 084/281] revert bc7706cc97531aaf1f4dd0291a26c2307f32d647, mirage-xen since 5.0.0 reverted the split of OS into Os_xen --- client_net.ml | 2 +- config.ml | 2 +- dao.ml | 8 ++++---- memory_pressure.ml | 10 +++++----- 4 files changed, 11 insertions(+), 11 deletions(-) diff --git a/client_net.ml b/client_net.ml index df436be..68fe6d3 100644 --- a/client_net.ml +++ b/client_net.ml @@ -4,7 +4,7 @@ open Lwt.Infix open Fw_utils -module Netback = Netchannel.Backend.Make(Netchannel.Xenstore.Make(Os_xen.Xs)) +module Netback = Netchannel.Backend.Make(Netchannel.Xenstore.Make(OS.Xs)) module ClientEth = Ethernet.Make(Netback) let src = Logs.Src.create "client_net" ~doc:"Client networking" diff --git a/config.ml b/config.ml index 55d8c42..ae4f8f4 100644 --- a/config.ml +++ b/config.ml @@ -33,7 +33,7 @@ let main = package "mirage-qubes"; package "mirage-nat" ~min:"1.2.0"; package "mirage-logs"; - package "mirage-xen" ~min:"4.0.0"; + package "mirage-xen" ~min:"5.0.0"; ] "Unikernel.Main" (mclock @-> job) diff --git a/dao.ml b/dao.ml index 55d901e..a68cc64 100644 --- a/dao.ml +++ b/dao.ml @@ -30,7 +30,7 @@ module VifMap = struct end let directory ~handle dir = - Os_xen.Xs.directory handle dir >|= function + OS.Xs.directory handle dir >|= function | [""] -> [] (* XenStore client bug *) | items -> items @@ -46,7 +46,7 @@ let vifs ~handle domid = | Some device_id -> let vif = { ClientVif.domid; device_id } in Lwt.try_bind - (fun () -> Os_xen.Xs.read handle (Printf.sprintf "%s/%d/ip" path device_id)) + (fun () -> OS.Xs.read handle (Printf.sprintf "%s/%d/ip" path device_id)) (fun client_ip -> let client_ip = Ipaddr.V4.of_string_exn client_ip in Lwt.return (Some (vif, client_ip)) @@ -61,10 +61,10 @@ let vifs ~handle domid = ) let watch_clients fn = - Os_xen.Xs.make () >>= fun xs -> + OS.Xs.make () >>= fun xs -> let backend_vifs = "backend/vif" in Log.info (fun f -> f "Watching %s" backend_vifs); - Os_xen.Xs.wait xs (fun handle -> + OS.Xs.wait xs (fun handle -> begin Lwt.catch (fun () -> directory ~handle backend_vifs) (function diff --git a/memory_pressure.ml b/memory_pressure.ml index 92271da..ed5b7e5 100644 --- a/memory_pressure.ml +++ b/memory_pressure.ml @@ -6,7 +6,7 @@ open Lwt let src = Logs.Src.create "memory_pressure" ~doc:"Memory pressure monitor" module Log = (val Logs.src_log src : Logs.LOG) -let total_pages = Os_xen.MM.Heap_pages.total () +let total_pages = OS.MM.Heap_pages.total () let pagesize_kb = Io_page.page_size / 1024 let meminfo ~used = @@ -23,7 +23,7 @@ let meminfo ~used = let report_mem_usage used = Lwt.async (fun () -> - let open Os_xen in + let open OS in Xs.make () >>= fun xs -> Xs.immediate xs (fun h -> Xs.write h "memory/meminfo" (meminfo ~used) @@ -32,16 +32,16 @@ let report_mem_usage used = let init () = Gc.full_major (); - let used = Os_xen.MM.Heap_pages.used () in + let used = OS.MM.Heap_pages.used () in report_mem_usage used let status () = - let used = Os_xen.MM.Heap_pages.used () |> float_of_int in + let used = OS.MM.Heap_pages.used () |> float_of_int in let frac = used /. float_of_int total_pages in if frac < 0.9 then `Ok else ( Gc.full_major (); - let used = Os_xen.MM.Heap_pages.used () in + let used = OS.MM.Heap_pages.used () in report_mem_usage used; let frac = float_of_int used /. float_of_int total_pages in if frac > 0.9 then `Memory_critical From 0f476c4d7b99b13527bdb9b6270cec9a9bd2fc13 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sat, 11 Jan 2020 15:36:02 +0100 Subject: [PATCH 085/281] mirage-nat 2.0.0 and mirage-qubes 0.8.0 compatibility --- client_net.ml | 20 +++++++++++--------- client_net.mli | 10 +++++----- firewall.ml | 9 ++++++--- my_nat.ml | 8 +++----- my_nat.mli | 2 +- unikernel.ml | 21 ++++++++++----------- uplink.ml | 13 ++++++++----- uplink.mli | 4 ++-- 8 files changed, 46 insertions(+), 41 deletions(-) diff --git a/client_net.ml b/client_net.ml index 68fe6d3..5cd819d 100644 --- a/client_net.ml +++ b/client_net.ml @@ -56,12 +56,13 @@ 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 ~iface ~router packet = - match Nat_packet.of_ipv4_packet packet with +let input_ipv4 get_ts cache ~iface ~router packet = + match Nat_packet.of_ipv4_packet cache ~now:(get_ts ()) packet with | Error e -> Log.warn (fun f -> f "Ignored unknown IPv4 message: %a" Nat_packet.pp_error e); Lwt.return () - | Ok packet -> + | Ok None -> Lwt.return () + | 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 router ~src:iface packet @@ -72,7 +73,7 @@ let input_ipv4 ~iface ~router packet = ) (** Connect to a new client's interface and listen for incoming frames. *) -let add_vif { Dao.ClientVif.domid; device_id } ~client_ip ~router ~cleanup_tasks = +let add_vif get_ts { Dao.ClientVif.domid; device_id } ~client_ip ~router ~cleanup_tasks = 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 -> @@ -83,6 +84,7 @@ let add_vif { Dao.ClientVif.domid; device_id } ~client_ip ~router ~cleanup_tasks Router.add_client router iface >>= fun () -> Cleanup.on_cleanup cleanup_tasks (fun () -> Router.remove_client router iface); let fixed_arp = Client_eth.ARP.create ~net:client_eth iface in + let fragment_cache = Fragments.Cache.create (256 * 1024) in Netback.listen backend ~header_size:Ethernet_wire.sizeof_ethernet (fun frame -> match Ethernet_packet.Unmarshal.of_cstruct frame with | exception ex -> @@ -94,18 +96,18 @@ let add_vif { Dao.ClientVif.domid; device_id } ~client_ip ~router ~cleanup_tasks | Ok (eth, payload) -> match eth.Ethernet_packet.ethertype with | `ARP -> input_arp ~fixed_arp ~iface payload - | `IPv4 -> input_ipv4 ~iface ~router payload + | `IPv4 -> input_ipv4 get_ts fragment_cache ~iface ~router payload | `IPv6 -> return () (* TODO: oh no! *) ) >|= or_raise "Listen on client interface" Netback.pp_error (** A new client VM has been found in XenStore. Find its interface and connect to it. *) -let add_client ~router vif client_ip = +let add_client get_ts ~router vif client_ip = 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 vif ~client_ip ~router ~cleanup_tasks + add_vif get_ts vif ~client_ip ~router ~cleanup_tasks ) (fun ex -> Log.warn (fun f -> f "Error with client %a: %s" @@ -116,7 +118,7 @@ let add_client ~router vif client_ip = cleanup_tasks (** Watch XenStore for notifications of new clients. *) -let listen router = +let listen get_ts router = Dao.watch_clients (fun new_set -> (* Check for removed clients *) !clients |> Dao.VifMap.iter (fun key cleanup -> @@ -129,7 +131,7 @@ let listen 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 ~router key ip_addr in + let cleanup = add_client get_ts ~router key ip_addr in clients := !clients |> Dao.VifMap.add key cleanup ) ) diff --git a/client_net.mli b/client_net.mli index 7bc2660..97ebd68 100644 --- a/client_net.mli +++ b/client_net.mli @@ -3,8 +3,8 @@ (** Handling client VMs. *) -val listen : Router.t -> 'a Lwt.t -(** [listen 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. *) +val listen : (unit -> int64) -> Router.t -> 'a Lwt.t +(** [listen get_timestamp 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/firewall.ml b/firewall.ml index 77656d2..beaa948 100644 --- a/firewall.ml +++ b/firewall.ml @@ -15,6 +15,7 @@ let transmit_ipv4 packet iface = (fun () -> Lwt.catch (fun () -> + let fragments = ref [] in iface#writev `IPv4 (fun b -> match Nat_packet.into_cstruct packet b with | Error e -> @@ -22,9 +23,11 @@ let transmit_ipv4 packet iface = Ipaddr.V4.pp iface#other_ip Nat_packet.pp_error e); 0 - | Ok n -> n - ) - ) + | Ok (n, frags) -> fragments := frags ; n) >>= fun () -> + Lwt_list.iter_s (fun f -> + let size = Cstruct.len f in + iface#writev `IPv4 (fun b -> Cstruct.blit f 0 b 0 size ; size)) + !fragments) (fun ex -> Log.warn (fun f -> f "Failed to write packet to %a: %s" Ipaddr.V4.pp iface#other_ip diff --git a/my_nat.ml b/my_nat.ml index bfaf702..02a4b5a 100644 --- a/my_nat.ml +++ b/my_nat.ml @@ -15,14 +15,13 @@ module Nat = Mirage_nat_lru type t = { table : Nat.t; - get_time : unit -> Mirage_nat.time; } -let create ~get_time ~max_entries = +let create ~max_entries = let tcp_size = 7 * max_entries / 8 in let udp_size = max_entries - tcp_size in Nat.empty ~tcp_size ~udp_size ~icmp_size:100 >|= fun table -> - { get_time; table } + { table } let translate t packet = Nat.translate t.table packet >|= function @@ -41,10 +40,9 @@ let reset t = Nat.reset t.table let add_nat_rule_and_translate t ~xl_host action packet = - let now = t.get_time () in let apply_action xl_port = Lwt.catch (fun () -> - Nat.add t.table ~now packet (xl_host, xl_port) action + Nat.add t.table packet (xl_host, xl_port) action ) (function | Out_of_memory -> Lwt.return (Error `Out_of_memory) diff --git a/my_nat.mli b/my_nat.mli index 770eaa0..cdc5eda 100644 --- a/my_nat.mli +++ b/my_nat.mli @@ -10,7 +10,7 @@ type action = [ | `Redirect of Mirage_nat.endpoint ] -val create : get_time:(unit -> Mirage_nat.time) -> max_entries:int -> t Lwt.t +val create : max_entries:int -> t Lwt.t val reset : t -> unit Lwt.t val translate : t -> Nat_packet.t -> Nat_packet.t option Lwt.t val add_nat_rule_and_translate : t -> xl_host:Ipaddr.V4.t -> diff --git a/unikernel.ml b/unikernel.ml index 84cac6d..25e4739 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -11,11 +11,11 @@ module Main (Clock : Mirage_clock_lwt.MCLOCK) = struct module Uplink = Uplink.Make(Clock) (* Set up networking and listen for incoming packets. *) - let network ~clock nat qubesDB = + let network nat qubesDB = (* Read configuration from QubesDB *) Dao.read_network_config qubesDB >>= fun config -> (* Initialise connection to NetVM *) - Uplink.connect ~clock config >>= fun uplink -> + Uplink.connect config >>= fun uplink -> (* Report success *) Dao.set_iptables_error qubesDB "" >>= fun () -> (* Set up client-side networking *) @@ -29,8 +29,8 @@ module Main (Clock : Mirage_clock_lwt.MCLOCK) = struct in (* Handle packets from both networks *) Lwt.choose [ - Client_net.listen router; - Uplink.listen uplink router + Client_net.listen Clock.elapsed_ns router; + Uplink.listen uplink Clock.elapsed_ns router ] (* We don't use the GUI, but it's interesting to keep an eye on it. @@ -41,7 +41,7 @@ module Main (Clock : Mirage_clock_lwt.MCLOCK) = struct (fun () -> gui >>= fun gui -> Log.info (fun f -> f "GUI agent connected"); - GUI.listen gui + GUI.listen gui () ) (fun `Cant_happen -> assert false) (fun ex -> @@ -51,8 +51,8 @@ module Main (Clock : Mirage_clock_lwt.MCLOCK) = struct ) (* Main unikernel entry point (called from auto-generated main.ml). *) - let start clock = - let start_time = Clock.elapsed_ns clock in + let start _clock = + let start_time = Clock.elapsed_ns () in (* Start qrexec agent, GUI agent and QubesDB agent in parallel *) let qrexec = RExec.connect ~domid:0 () in GUI.connect ~domid:0 () |> watch_gui; @@ -63,7 +63,7 @@ module Main (Clock : Mirage_clock_lwt.MCLOCK) = struct qubesDB >>= fun qubesDB -> let startup_time = let (-) = Int64.sub in - let time_in_ns = Clock.elapsed_ns clock - start_time in + let time_in_ns = Clock.elapsed_ns () - start_time in Int64.to_float time_in_ns /. 1e9 in Log.info (fun f -> f "QubesDB and qrexec agents connected in %.3f s" startup_time); @@ -72,10 +72,9 @@ module Main (Clock : Mirage_clock_lwt.MCLOCK) = struct OS.Lifecycle.await_shutdown_request () >>= fun (`Poweroff | `Reboot) -> return () in (* Set up networking *) - let get_time () = Clock.elapsed_ns clock in let max_entries = Key_gen.nat_table_size () in - My_nat.create ~get_time ~max_entries >>= fun nat -> - let net_listener = network ~clock nat qubesDB in + My_nat.create ~max_entries >>= fun nat -> + let net_listener = network nat qubesDB in (* Report memory usage to XenStore *) Memory_pressure.init (); (* Run until something fails or we get a shutdown request. *) diff --git a/uplink.ml b/uplink.ml index 06d4df3..92b46a6 100644 --- a/uplink.ml +++ b/uplink.ml @@ -17,6 +17,7 @@ module Make(Clock : Mirage_clock_lwt.MCLOCK) = struct eth : Eth.t; arp : Arp.t; interface : interface; + fragments : Fragments.Cache.t; } class netvm_iface eth mac ~my_ip ~other_ip : interface = object @@ -31,13 +32,13 @@ module Make(Clock : Mirage_clock_lwt.MCLOCK) = struct ) end - let listen t router = + let listen t get_ts router = Netif.listen t.net ~header_size:Ethernet_wire.sizeof_ethernet (fun frame -> (* Handle one Ethernet frame from NetVM *) Eth.input t.eth ~arpv4:(Arp.input t.arp) ~ipv4:(fun ip -> - match Nat_packet.of_ipv4_packet ip with + match Nat_packet.of_ipv4_packet t.fragments ~now:(get_ts ()) ip with | exception ex -> Log.err (fun f -> f "Error unmarshalling ethernet frame from uplink: %s@.%a" (Printexc.to_string ex) Cstruct.hexdump_pp frame @@ -46,7 +47,8 @@ module Make(Clock : Mirage_clock_lwt.MCLOCK) = struct | Error e -> Log.warn (fun f -> f "Ignored unknown IPv4 message from uplink: %a" Nat_packet.pp_error e); Lwt.return () - | Ok packet -> + | Ok None -> Lwt.return_unit + | Ok (Some packet) -> Firewall.ipv4_from_netvm router packet ) ~ipv6:(fun _ip -> return ()) @@ -55,7 +57,7 @@ module Make(Clock : Mirage_clock_lwt.MCLOCK) = struct let interface t = t.interface - let connect ~clock:_ config = + let connect config = let ip = config.Dao.uplink_our_ip in Netif.connect "0" >>= fun net -> Eth.connect net >>= fun eth -> @@ -67,5 +69,6 @@ module Make(Clock : Mirage_clock_lwt.MCLOCK) = struct let interface = new netvm_iface eth netvm_mac ~my_ip:ip ~other_ip:config.Dao.uplink_netvm_ip in - return { net; eth; arp; interface } + let fragments = Fragments.Cache.create (256 * 1024) in + return { net; eth; arp; interface ; fragments } end diff --git a/uplink.mli b/uplink.mli index 6e2f5f4..14fbd86 100644 --- a/uplink.mli +++ b/uplink.mli @@ -8,12 +8,12 @@ open Fw_utils module Make(Clock : Mirage_clock_lwt.MCLOCK) : sig type t - val connect : clock:Clock.t -> Dao.network_config -> t Lwt.t + val connect : Dao.network_config -> t Lwt.t (** Connect to our NetVM (gateway). *) val interface : t -> interface (** The network interface to NetVM. *) - val listen : t -> Router.t -> unit Lwt.t + val listen : t -> (unit -> int64) -> Router.t -> unit Lwt.t (** Handle incoming frames from NetVM. *) end From 3fc418e80cafc8b6cc6f137e613d5f04b23aa825 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sat, 11 Jan 2020 15:39:20 +0100 Subject: [PATCH 086/281] qualify all return with Lwt, use Lwt.return_unit where possible --- client_net.ml | 18 +++++++++--------- config.ml | 4 ++-- dao.ml | 7 +++---- firewall.ml | 25 ++++++++++++------------- fw_utils.ml | 3 --- unikernel.ml | 4 ++-- uplink.ml | 6 +++--- 7 files changed, 31 insertions(+), 36 deletions(-) diff --git a/client_net.ml b/client_net.ml index 5cd819d..4665aa1 100644 --- a/client_net.ml +++ b/client_net.ml @@ -23,7 +23,7 @@ let writev eth dst proto fillfn = (* Usually Netback_shutdown, because the client disconnected *) Log.err (fun f -> f "uncaught exception trying to send to client: @[%s@]" (Printexc.to_string ex)); - Lwt.return () + Lwt.return_unit ) class client_iface eth ~domid ~gateway_ip ~client_ip client_mac : client_link = @@ -48,10 +48,10 @@ let input_arp ~fixed_arp ~iface request = match Arp_packet.decode request with | Error e -> Log.warn (fun f -> f "Ignored unknown ARP message: %a" Arp_packet.pp_error e); - Lwt.return () + Lwt.return_unit | Ok arp -> match Client_eth.ARP.input fixed_arp arp with - | None -> return () + | None -> Lwt.return_unit | Some response -> iface#writev `ARP (fun b -> Arp_packet.encode_into response b; Arp_packet.size) @@ -60,8 +60,8 @@ let input_ipv4 get_ts cache ~iface ~router packet = match Nat_packet.of_ipv4_packet cache ~now:(get_ts ()) packet with | Error e -> Log.warn (fun f -> f "Ignored unknown IPv4 message: %a" Nat_packet.pp_error e); - Lwt.return () - | Ok None -> Lwt.return () + Lwt.return_unit + | Ok None -> Lwt.return_unit | Ok (Some packet) -> let `IPv4 (ip, _) = packet in let src = ip.Ipv4_packet.src in @@ -69,7 +69,7 @@ let input_ipv4 get_ts cache ~iface ~router 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); - return () + Lwt.return_unit ) (** Connect to a new client's interface and listen for incoming frames. *) @@ -92,12 +92,12 @@ let add_vif get_ts { Dao.ClientVif.domid; device_id } ~client_ip ~router ~cleanu Cstruct.hexdump_pp frame ); Lwt.return_unit - | Error err -> Log.warn (fun f -> f "Invalid Ethernet frame: %s" err); return () + | Error err -> Log.warn (fun f -> f "Invalid Ethernet frame: %s" err); Lwt.return_unit | 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 payload - | `IPv6 -> return () (* TODO: oh no! *) + | `IPv6 -> Lwt.return_unit (* TODO: oh no! *) ) >|= or_raise "Listen on client interface" Netback.pp_error @@ -112,7 +112,7 @@ let add_client get_ts ~router vif client_ip = (fun ex -> Log.warn (fun f -> f "Error with client %a: %s" Dao.ClientVif.pp vif (Printexc.to_string ex)); - return () + Lwt.return_unit ) ); cleanup_tasks diff --git a/config.ml b/config.ml index ae4f8f4..5e284fb 100644 --- a/config.ml +++ b/config.ml @@ -30,8 +30,8 @@ let main = package "netchannel" ~min:"1.11.0"; package "mirage-net-xen"; package "ipaddr" ~min:"4.0.0"; - package "mirage-qubes"; - package "mirage-nat" ~min:"1.2.0"; + package "mirage-qubes" ~min:"0.8.0"; + package "mirage-nat" ~min:"2.0.0"; package "mirage-logs"; package "mirage-xen" ~min:"5.0.0"; ] diff --git a/dao.ml b/dao.ml index a68cc64..a34b8b7 100644 --- a/dao.ml +++ b/dao.ml @@ -3,7 +3,6 @@ open Lwt.Infix open Qubes -open Fw_utils open Astring let src = Logs.Src.create "dao" ~doc:"QubesDB data access" @@ -68,13 +67,13 @@ let watch_clients fn = begin Lwt.catch (fun () -> directory ~handle backend_vifs) (function - | Xs_protocol.Enoent _ -> return [] - | ex -> fail ex) + | Xs_protocol.Enoent _ -> Lwt.return [] + | ex -> Lwt.fail ex) end >>= fun items -> Lwt_list.map_p (vifs ~handle) items >>= fun items -> fn (List.concat items |> VifMap.of_list); (* Wait for further updates *) - fail Xs_protocol.Eagain + Lwt.fail Xs_protocol.Eagain ) type network_config = { diff --git a/firewall.ml b/firewall.ml index beaa948..e80d7a3 100644 --- a/firewall.ml +++ b/firewall.ml @@ -1,7 +1,6 @@ (* Copyright (C) 2015, Thomas Leonard See the README file for details. *) -open Fw_utils open Packet open Lwt.Infix @@ -32,7 +31,7 @@ let transmit_ipv4 packet iface = Log.warn (fun f -> f "Failed to write packet to %a: %s" Ipaddr.V4.pp iface#other_ip (Printexc.to_string ex)); - Lwt.return () + Lwt.return_unit ) ) (fun ex -> @@ -40,7 +39,7 @@ let transmit_ipv4 packet iface = (Printexc.to_string ex) Nat_packet.pp packet ); - Lwt.return () + Lwt.return_unit ) let forward_ipv4 t packet = @@ -127,19 +126,19 @@ let add_nat_and_forward_ipv4 t packet = | Ok packet -> forward_ipv4 t packet | Error e -> Log.warn (fun f -> f "Failed to add NAT rewrite rule: %s (%a)" e pp_header packet); - Lwt.return () + Lwt.return_unit (* Add a NAT rule to redirect this conversation to [host:port] instead of us. *) let nat_to t ~host ~port packet = match Router.resolve t host with - | Ipaddr.V6 _ -> Log.warn (fun f -> f "Cannot NAT with IPv6"); Lwt.return () + | Ipaddr.V6 _ -> Log.warn (fun f -> f "Cannot NAT with IPv6"); Lwt.return_unit | Ipaddr.V4 target -> let xl_host = t.Router.uplink#my_ip in My_nat.add_nat_rule_and_translate t.Router.nat ~xl_host (`Redirect (target, port)) packet >>= function | Ok packet -> forward_ipv4 t packet | Error e -> Log.warn (fun f -> f "Failed to add NAT redirect rule: %s (%a)" e pp_header packet); - Lwt.return () + Lwt.return_unit (* Handle incoming packets *) @@ -150,12 +149,12 @@ let apply_rules t rules ~dst info = | `Accept, (`External _ | `NetVM) -> transmit_ipv4 packet t.Router.uplink | `Accept, `Firewall -> Log.warn (fun f -> f "Bad rule: firewall can't accept packets %a" (pp_packet t) info); - return () + Lwt.return_unit | `NAT, _ -> 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 (pp_packet t) info); - return () + Lwt.return_unit let handle_low_memory t = match Memory_pressure.status () with @@ -167,7 +166,7 @@ let handle_low_memory t = let ipv4_from_client t ~src packet = handle_low_memory t >>= function - | `Memory_critical -> return () + | `Memory_critical -> Lwt.return_unit | `Ok -> (* Check for existing NAT entry for this packet *) translate t packet >>= function @@ -177,23 +176,23 @@ let ipv4_from_client t ~src packet = let `IPv4 (ip, _transport) = packet in let dst = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in match classify ~src:(resolve_client src) ~dst:(resolve_host dst) packet with - | None -> return () + | None -> Lwt.return_unit | Some info -> apply_rules t Rules.from_client ~dst info let ipv4_from_netvm t packet = handle_low_memory t >>= function - | `Memory_critical -> return () + | `Memory_critical -> Lwt.return_unit | `Ok -> 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 classify ~src ~dst:(resolve_host dst) packet with - | None -> return () + | None -> Lwt.return_unit | Some info -> match src with | `Client _ | `Firewall -> Log.warn (fun f -> f "Frame from NetVM has internal source IP address! %a" (pp_packet t) info); - return () + Lwt.return_unit | `External _ | `NetVM as src -> translate t packet >>= function | Some frame -> forward_ipv4 t frame diff --git a/fw_utils.ml b/fw_utils.ml index c034e72..9c5bab4 100644 --- a/fw_utils.ml +++ b/fw_utils.ml @@ -41,9 +41,6 @@ let error fmt = let err s = Failure s in Printf.ksprintf err fmt -let return = Lwt.return -let fail = Lwt.fail - let or_raise msg pp = function | Ok x -> x | Error e -> failwith (Fmt.strf "%s: %a" msg pp e) diff --git a/unikernel.ml b/unikernel.ml index 25e4739..2b20c9f 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -46,7 +46,7 @@ module Main (Clock : Mirage_clock_lwt.MCLOCK) = struct (fun `Cant_happen -> assert false) (fun ex -> Log.warn (fun f -> f "GUI thread failed: %s" (Printexc.to_string ex)); - return () + Lwt.return_unit ) ) @@ -70,7 +70,7 @@ module Main (Clock : Mirage_clock_lwt.MCLOCK) = struct (* Watch for shutdown requests from Qubes *) let shutdown_rq = OS.Lifecycle.await_shutdown_request () >>= fun (`Poweroff | `Reboot) -> - return () in + Lwt.return_unit in (* Set up networking *) let max_entries = Key_gen.nat_table_size () in My_nat.create ~max_entries >>= fun nat -> diff --git a/uplink.ml b/uplink.ml index 92b46a6..042fc84 100644 --- a/uplink.ml +++ b/uplink.ml @@ -46,12 +46,12 @@ module Make(Clock : Mirage_clock_lwt.MCLOCK) = struct Lwt.return_unit | Error e -> Log.warn (fun f -> f "Ignored unknown IPv4 message from uplink: %a" Nat_packet.pp_error e); - Lwt.return () + Lwt.return_unit | Ok None -> Lwt.return_unit | Ok (Some packet) -> Firewall.ipv4_from_netvm router packet ) - ~ipv6:(fun _ip -> return ()) + ~ipv6:(fun _ip -> Lwt.return_unit) frame ) >|= or_raise "Uplink listen loop" Netif.pp_error @@ -70,5 +70,5 @@ module Make(Clock : Mirage_clock_lwt.MCLOCK) = struct ~my_ip:ip ~other_ip:config.Dao.uplink_netvm_ip in let fragments = Fragments.Cache.create (256 * 1024) in - return { net; eth; arp; interface ; fragments } + Lwt.return { net; eth; arp; interface ; fragments } end From 28bda78d209d8a436b3e6eff8a2142cac68a3093 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sat, 11 Jan 2020 15:46:02 +0100 Subject: [PATCH 087/281] fix deprecation warnings (Mirage_clock_lwt -> Mirage_clock) --- unikernel.ml | 2 +- uplink.ml | 2 +- uplink.mli | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/unikernel.ml b/unikernel.ml index 2b20c9f..27f772a 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -7,7 +7,7 @@ open Qubes let src = Logs.Src.create "unikernel" ~doc:"Main unikernel code" module Log = (val Logs.src_log src : Logs.LOG) -module Main (Clock : Mirage_clock_lwt.MCLOCK) = struct +module Main (Clock : Mirage_clock.MCLOCK) = struct module Uplink = Uplink.Make(Clock) (* Set up networking and listen for incoming packets. *) diff --git a/uplink.ml b/uplink.ml index 042fc84..1fde66b 100644 --- a/uplink.ml +++ b/uplink.ml @@ -9,7 +9,7 @@ module Eth = Ethernet.Make(Netif) let src = Logs.Src.create "uplink" ~doc:"Network connection to NetVM" module Log = (val Logs.src_log src : Logs.LOG) -module Make(Clock : Mirage_clock_lwt.MCLOCK) = struct +module Make(Clock : Mirage_clock.MCLOCK) = struct module Arp = Arp.Make(Eth)(OS.Time) type t = { diff --git a/uplink.mli b/uplink.mli index 14fbd86..0f494dd 100644 --- a/uplink.mli +++ b/uplink.mli @@ -5,7 +5,7 @@ open Fw_utils -module Make(Clock : Mirage_clock_lwt.MCLOCK) : sig +module Make(Clock : Mirage_clock.MCLOCK) : sig type t val connect : Dao.network_config -> t Lwt.t From 730957d19b00b66e03f6114915f01c45b13c88c3 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sat, 11 Jan 2020 15:46:22 +0100 Subject: [PATCH 088/281] upgrade opam repository to current head and mirage to 3.7.4 --- Dockerfile | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Dockerfile b/Dockerfile index c6ef858..3125969 100644 --- a/Dockerfile +++ b/Dockerfile @@ -7,9 +7,9 @@ FROM ocurrent/opam@sha256:3f3ce7e577a94942c7f9c63cbdd1ecbfe0ea793f581f69047f3155 # 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 ~/opam-repository && git fetch origin master && git reset --hard 5eed470abc5c7991e448c9653698c03d6ea146d1 && opam update +RUN cd ~/opam-repository && git fetch origin master && git reset --hard d205c265cee9a86869259180fd2238da98370430 && opam update -RUN opam depext -i -y mirage.3.5.2 lwt +RUN opam depext -i -y mirage.3.7.4 lwt RUN mkdir /home/opam/qubes-mirage-firewall ADD config.ml /home/opam/qubes-mirage-firewall/config.ml WORKDIR /home/opam/qubes-mirage-firewall From a734bcd2d3d87a93ce7cfd60d04c730520367d70 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sat, 11 Jan 2020 16:01:08 +0100 Subject: [PATCH 089/281] [ci skip] adjust expected 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 31dd331..d2944fe 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 qubes_firewall.xen)" -echo "SHA2 last known: cae3c66d38a50671f694cd529062c538592438b95935d707b97d80b57fbfc186" +echo "SHA2 last known: 8a337e61e7d093f7c1f0fa5fe277dace4d606bfa06cfde3f2d61d6bdee6eefbc" echo "(hashes should match for released versions)" From 48b38fa992cfe2567c21668ff967cc006dfdc73d Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Mon, 13 Jan 2020 09:49:37 +0000 Subject: [PATCH 090/281] Fix Lwt.4.5.0 in the Dockerfile for faster builds Otherwise, it installs Lwt 5 and then has to downgrade it in the next step. --- Dockerfile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Dockerfile b/Dockerfile index 3125969..8a9ed27 100644 --- a/Dockerfile +++ b/Dockerfile @@ -9,7 +9,7 @@ FROM ocurrent/opam@sha256:3f3ce7e577a94942c7f9c63cbdd1ecbfe0ea793f581f69047f3155 # latest versions. RUN cd ~/opam-repository && git fetch origin master && git reset --hard d205c265cee9a86869259180fd2238da98370430 && opam update -RUN opam depext -i -y mirage.3.7.4 lwt +RUN opam depext -i -y mirage.3.7.4 lwt.4.5.0 RUN mkdir /home/opam/qubes-mirage-firewall ADD config.ml /home/opam/qubes-mirage-firewall/config.ml WORKDIR /home/opam/qubes-mirage-firewall From ab3508a9367dcc69bff871521fcad5090c03eb3a Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Mon, 13 Jan 2020 09:50:48 +0000 Subject: [PATCH 091/281] Remove unused Clock argument to Uplink --- build-with-docker.sh | 2 +- unikernel.ml | 2 - uplink.ml | 118 +++++++++++++++++++++---------------------- uplink.mli | 16 +++--- 4 files changed, 66 insertions(+), 72 deletions(-) diff --git a/build-with-docker.sh b/build-with-docker.sh index d2944fe..5b1bc30 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 qubes_firewall.xen)" -echo "SHA2 last known: 8a337e61e7d093f7c1f0fa5fe277dace4d606bfa06cfde3f2d61d6bdee6eefbc" +echo "SHA2 last known: 6f8f0f19ba62bf5312039f2904ea8696584f8ff49443dec098facf261449ebf2" echo "(hashes should match for released versions)" diff --git a/unikernel.ml b/unikernel.ml index 27f772a..6eaca4e 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -8,8 +8,6 @@ let src = Logs.Src.create "unikernel" ~doc:"Main unikernel code" module Log = (val Logs.src_log src : Logs.LOG) module Main (Clock : Mirage_clock.MCLOCK) = struct - module Uplink = Uplink.Make(Clock) - (* Set up networking and listen for incoming packets. *) let network nat qubesDB = (* Read configuration from QubesDB *) diff --git a/uplink.ml b/uplink.ml index 1fde66b..039e6bd 100644 --- a/uplink.ml +++ b/uplink.ml @@ -9,66 +9,64 @@ module Eth = Ethernet.Make(Netif) let src = Logs.Src.create "uplink" ~doc:"Network connection to NetVM" module Log = (val Logs.src_log src : Logs.LOG) -module Make(Clock : Mirage_clock.MCLOCK) = struct - module Arp = Arp.Make(Eth)(OS.Time) +module Arp = Arp.Make(Eth)(OS.Time) - type t = { - net : Netif.t; - eth : Eth.t; - arp : Arp.t; - interface : interface; - fragments : Fragments.Cache.t; - } +type t = { + net : Netif.t; + eth : Eth.t; + arp : Arp.t; + interface : interface; + fragments : Fragments.Cache.t; +} - class netvm_iface eth mac ~my_ip ~other_ip : interface = object - val queue = FrameQ.create (Ipaddr.V4.to_string other_ip) - method my_mac = Eth.mac eth - method my_ip = my_ip - method other_ip = other_ip - method writev ethertype fillfn = - FrameQ.send queue (fun () -> - mac >>= fun dst -> - Eth.write eth dst ethertype fillfn >|= or_raise "Write to uplink" Eth.pp_error - ) - end - - let listen t get_ts router = - Netif.listen t.net ~header_size:Ethernet_wire.sizeof_ethernet (fun frame -> - (* Handle one Ethernet frame from NetVM *) - Eth.input t.eth - ~arpv4:(Arp.input t.arp) - ~ipv4:(fun ip -> - match Nat_packet.of_ipv4_packet t.fragments ~now:(get_ts ()) ip with - | exception ex -> - Log.err (fun f -> f "Error unmarshalling ethernet frame from uplink: %s@.%a" (Printexc.to_string ex) - Cstruct.hexdump_pp frame - ); - Lwt.return_unit - | Error e -> - Log.warn (fun f -> f "Ignored unknown IPv4 message from uplink: %a" Nat_packet.pp_error e); - Lwt.return_unit - | Ok None -> Lwt.return_unit - | Ok (Some packet) -> - Firewall.ipv4_from_netvm router packet - ) - ~ipv6:(fun _ip -> Lwt.return_unit) - frame - ) >|= or_raise "Uplink listen loop" Netif.pp_error - - let interface t = t.interface - - let connect config = - let ip = config.Dao.uplink_our_ip in - Netif.connect "0" >>= fun net -> - Eth.connect net >>= fun eth -> - Arp.connect eth >>= fun arp -> - Arp.add_ip arp ip >>= fun () -> - let netvm_mac = - Arp.query arp config.Dao.uplink_netvm_ip - >|= or_raise "Getting MAC of our NetVM" Arp.pp_error in - let interface = new netvm_iface eth netvm_mac - ~my_ip:ip - ~other_ip:config.Dao.uplink_netvm_ip in - let fragments = Fragments.Cache.create (256 * 1024) in - Lwt.return { net; eth; arp; interface ; fragments } +class netvm_iface eth mac ~my_ip ~other_ip : interface = object + val queue = FrameQ.create (Ipaddr.V4.to_string other_ip) + method my_mac = Eth.mac eth + method my_ip = my_ip + method other_ip = other_ip + method writev ethertype fillfn = + FrameQ.send queue (fun () -> + mac >>= fun dst -> + Eth.write eth dst ethertype fillfn >|= or_raise "Write to uplink" Eth.pp_error + ) end + +let listen t get_ts router = + Netif.listen t.net ~header_size:Ethernet_wire.sizeof_ethernet (fun frame -> + (* Handle one Ethernet frame from NetVM *) + Eth.input t.eth + ~arpv4:(Arp.input t.arp) + ~ipv4:(fun ip -> + match Nat_packet.of_ipv4_packet t.fragments ~now:(get_ts ()) ip with + | exception ex -> + Log.err (fun f -> f "Error unmarshalling ethernet frame from uplink: %s@.%a" (Printexc.to_string ex) + Cstruct.hexdump_pp frame + ); + Lwt.return_unit + | Error e -> + Log.warn (fun f -> f "Ignored unknown IPv4 message from uplink: %a" Nat_packet.pp_error e); + Lwt.return_unit + | Ok None -> Lwt.return_unit + | Ok (Some packet) -> + Firewall.ipv4_from_netvm router packet + ) + ~ipv6:(fun _ip -> Lwt.return_unit) + frame + ) >|= or_raise "Uplink listen loop" Netif.pp_error + +let interface t = t.interface + +let connect config = + let ip = config.Dao.uplink_our_ip in + Netif.connect "0" >>= fun net -> + Eth.connect net >>= fun eth -> + Arp.connect eth >>= fun arp -> + Arp.add_ip arp ip >>= fun () -> + let netvm_mac = + Arp.query arp config.Dao.uplink_netvm_ip + >|= or_raise "Getting MAC of our NetVM" Arp.pp_error in + let interface = new netvm_iface eth netvm_mac + ~my_ip:ip + ~other_ip:config.Dao.uplink_netvm_ip in + let fragments = Fragments.Cache.create (256 * 1024) in + Lwt.return { net; eth; arp; interface ; fragments } diff --git a/uplink.mli b/uplink.mli index 0f494dd..776b1a4 100644 --- a/uplink.mli +++ b/uplink.mli @@ -5,15 +5,13 @@ open Fw_utils -module Make(Clock : Mirage_clock.MCLOCK) : sig - type t +type t - val connect : Dao.network_config -> t Lwt.t - (** Connect to our NetVM (gateway). *) +val connect : Dao.network_config -> t Lwt.t +(** Connect to our NetVM (gateway). *) - val interface : t -> interface - (** The network interface to NetVM. *) +val interface : t -> interface +(** The network interface to NetVM. *) - val listen : t -> (unit -> int64) -> Router.t -> unit Lwt.t - (** Handle incoming frames from NetVM. *) -end +val listen : t -> (unit -> int64) -> Router.t -> unit Lwt.t +(** Handle incoming frames from NetVM. *) From 8e714c771244d9830036e05ad71c43a43e64d33f Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Mon, 13 Jan 2020 10:05:38 +0000 Subject: [PATCH 092/281] Removed unreachable Lwt.catch Spotted by Hannes Mehnert. --- build-with-docker.sh | 2 +- firewall.ml | 42 ++++++++++++++++-------------------------- 2 files changed, 17 insertions(+), 27 deletions(-) diff --git a/build-with-docker.sh b/build-with-docker.sh index 5b1bc30..e8e46cd 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 qubes_firewall.xen)" -echo "SHA2 last known: 6f8f0f19ba62bf5312039f2904ea8696584f8ff49443dec098facf261449ebf2" +echo "SHA2 last known: 91c5bf44a85339aaf14e4763a29c2b64537f5bc41cd7dc2571af954ec9dd3cad" echo "(hashes should match for released versions)" diff --git a/firewall.ml b/firewall.ml index e80d7a3..96ea516 100644 --- a/firewall.ml +++ b/firewall.ml @@ -12,33 +12,23 @@ module Log = (val Logs.src_log src : Logs.LOG) let transmit_ipv4 packet iface = Lwt.catch (fun () -> - Lwt.catch - (fun () -> - let fragments = ref [] in - iface#writev `IPv4 (fun b -> - match Nat_packet.into_cstruct packet b with - | Error e -> - Log.warn (fun f -> f "Failed to write packet to %a: %a" - Ipaddr.V4.pp iface#other_ip - Nat_packet.pp_error e); - 0 - | Ok (n, frags) -> fragments := frags ; n) >>= fun () -> - Lwt_list.iter_s (fun f -> - let size = Cstruct.len f in - iface#writev `IPv4 (fun b -> Cstruct.blit f 0 b 0 size ; size)) - !fragments) - (fun ex -> - Log.warn (fun f -> f "Failed to write packet to %a: %s" - Ipaddr.V4.pp iface#other_ip - (Printexc.to_string ex)); - Lwt.return_unit - ) - ) + let fragments = ref [] in + iface#writev `IPv4 (fun b -> + match Nat_packet.into_cstruct packet b with + | Error e -> + Log.warn (fun f -> f "Failed to NAT packet to %a: %a" + Ipaddr.V4.pp iface#other_ip + Nat_packet.pp_error e); + 0 + | Ok (n, frags) -> fragments := frags ; n) >>= fun () -> + Lwt_list.iter_s (fun f -> + let size = Cstruct.len f in + iface#writev `IPv4 (fun b -> Cstruct.blit f 0 b 0 size ; size)) + !fragments) (fun ex -> - Log.err (fun f -> f "Exception in transmit_ipv4: %s for:@.%a" - (Printexc.to_string ex) - Nat_packet.pp packet - ); + Log.warn (fun f -> f "Failed to write packet to %a: %s" + Ipaddr.V4.pp iface#other_ip + (Printexc.to_string ex)); Lwt.return_unit ) From e68962ac483095cd793fcb0442a5a0ae1535a26b Mon Sep 17 00:00:00 2001 From: xaki23 Date: Mon, 13 Jan 2020 20:48:46 +0100 Subject: [PATCH 093/281] support mirage-3.7 via qubes-builder --- Makefile.builder | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/Makefile.builder b/Makefile.builder index 23827af..30e4cec 100644 --- a/Makefile.builder +++ b/Makefile.builder @@ -3,5 +3,6 @@ OCAML_VERSION ?= 4.08.1 SOURCE_BUILD_DEP := firewall-build-dep firewall-build-dep: - opam pin -y add mirage 3.5.2 + opam install -y depext + opam depext -i -y mirage.3.7.4 lwt.4.5.0 From 554e73a46d252a7613d986f59718e9127c1aed9a Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sat, 8 Feb 2020 15:55:32 +0100 Subject: [PATCH 094/281] cleanup: remove exception cases during Ethernet decode / Nat.of_ipv4_packet - they do not raise exceptions anymore --- client_net.ml | 5 ----- uplink.ml | 5 ----- 2 files changed, 10 deletions(-) diff --git a/client_net.ml b/client_net.ml index 4665aa1..86f9d3a 100644 --- a/client_net.ml +++ b/client_net.ml @@ -87,11 +87,6 @@ let add_vif get_ts { Dao.ClientVif.domid; device_id } ~client_ip ~router ~cleanu let fragment_cache = Fragments.Cache.create (256 * 1024) in Netback.listen backend ~header_size:Ethernet_wire.sizeof_ethernet (fun frame -> match Ethernet_packet.Unmarshal.of_cstruct frame with - | exception ex -> - Log.err (fun f -> f "Error unmarshalling ethernet frame from client: %s@.%a" (Printexc.to_string ex) - Cstruct.hexdump_pp frame - ); - Lwt.return_unit | Error err -> Log.warn (fun f -> f "Invalid Ethernet frame: %s" err); Lwt.return_unit | Ok (eth, payload) -> match eth.Ethernet_packet.ethertype with diff --git a/uplink.ml b/uplink.ml index 039e6bd..4683d09 100644 --- a/uplink.ml +++ b/uplink.ml @@ -38,11 +38,6 @@ let listen t get_ts router = ~arpv4:(Arp.input t.arp) ~ipv4:(fun ip -> match Nat_packet.of_ipv4_packet t.fragments ~now:(get_ts ()) ip with - | exception ex -> - Log.err (fun f -> f "Error unmarshalling ethernet frame from uplink: %s@.%a" (Printexc.to_string ex) - Cstruct.hexdump_pp frame - ); - Lwt.return_unit | Error e -> Log.warn (fun f -> f "Ignored unknown IPv4 message from uplink: %a" Nat_packet.pp_error e); Lwt.return_unit From 88fec9fa490980c1049a1f5342179b2e8a301926 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sat, 8 Feb 2020 15:58:37 +0100 Subject: [PATCH 095/281] adapt to mirage-nat 2.1.0 API (Nat_packet returns a Fragments.Cache.t - which is now a Lru.F.t) --- client_net.ml | 6 ++++-- config.ml | 2 +- uplink.ml | 10 +++++++--- 3 files changed, 12 insertions(+), 6 deletions(-) diff --git a/client_net.ml b/client_net.ml index 86f9d3a..5b7b54b 100644 --- a/client_net.ml +++ b/client_net.ml @@ -57,7 +57,9 @@ let input_arp ~fixed_arp ~iface request = (** Handle an IPv4 packet from the client. *) let input_ipv4 get_ts cache ~iface ~router packet = - match Nat_packet.of_ipv4_packet cache ~now:(get_ts ()) packet with + let cache', r = Nat_packet.of_ipv4_packet !cache ~now:(get_ts ()) packet in + cache := cache'; + match r with | Error e -> Log.warn (fun f -> f "Ignored unknown IPv4 message: %a" Nat_packet.pp_error e); Lwt.return_unit @@ -84,7 +86,7 @@ let add_vif get_ts { Dao.ClientVif.domid; device_id } ~client_ip ~router ~cleanu Router.add_client router iface >>= fun () -> Cleanup.on_cleanup cleanup_tasks (fun () -> Router.remove_client router iface); let fixed_arp = Client_eth.ARP.create ~net:client_eth iface in - let fragment_cache = Fragments.Cache.create (256 * 1024) in + let fragment_cache = ref (Fragments.Cache.empty (256 * 1024)) in Netback.listen backend ~header_size:Ethernet_wire.sizeof_ethernet (fun frame -> match Ethernet_packet.Unmarshal.of_cstruct frame with | Error err -> Log.warn (fun f -> f "Invalid Ethernet frame: %s" err); Lwt.return_unit diff --git a/config.ml b/config.ml index 5e284fb..602fd32 100644 --- a/config.ml +++ b/config.ml @@ -31,7 +31,7 @@ let main = package "mirage-net-xen"; package "ipaddr" ~min:"4.0.0"; package "mirage-qubes" ~min:"0.8.0"; - package "mirage-nat" ~min:"2.0.0"; + package "mirage-nat" ~min:"2.1.0"; package "mirage-logs"; package "mirage-xen" ~min:"5.0.0"; ] diff --git a/uplink.ml b/uplink.ml index 4683d09..343eef3 100644 --- a/uplink.ml +++ b/uplink.ml @@ -16,7 +16,7 @@ type t = { eth : Eth.t; arp : Arp.t; interface : interface; - fragments : Fragments.Cache.t; + mutable fragments : Fragments.Cache.t; } class netvm_iface eth mac ~my_ip ~other_ip : interface = object @@ -37,7 +37,11 @@ let listen t get_ts router = Eth.input t.eth ~arpv4:(Arp.input t.arp) ~ipv4:(fun ip -> - match Nat_packet.of_ipv4_packet t.fragments ~now:(get_ts ()) ip with + let cache, r = + Nat_packet.of_ipv4_packet t.fragments ~now:(get_ts ()) ip + in + t.fragments <- cache; + match r with | Error e -> Log.warn (fun f -> f "Ignored unknown IPv4 message from uplink: %a" Nat_packet.pp_error e); Lwt.return_unit @@ -63,5 +67,5 @@ let connect config = let interface = new netvm_iface eth netvm_mac ~my_ip:ip ~other_ip:config.Dao.uplink_netvm_ip in - let fragments = Fragments.Cache.create (256 * 1024) in + let fragments = Fragments.Cache.empty (256 * 1024) in Lwt.return { net; eth; arp; interface ; fragments } From 65324b419761234e197fe2e47c29c55f3da1d957 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Wed, 19 Feb 2020 14:14:26 +0000 Subject: [PATCH 096/281] Update Dockerfile to get new mirage-nat version --- Dockerfile | 2 +- build-with-docker.sh | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/Dockerfile b/Dockerfile index 8a9ed27..7cbdc98 100644 --- a/Dockerfile +++ b/Dockerfile @@ -7,7 +7,7 @@ FROM ocurrent/opam@sha256:3f3ce7e577a94942c7f9c63cbdd1ecbfe0ea793f581f69047f3155 # 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 ~/opam-repository && git fetch origin master && git reset --hard d205c265cee9a86869259180fd2238da98370430 && opam update +RUN cd ~/opam-repository && git fetch origin master && git reset --hard ebac42783217016bd2c4108bbbef102aab56cdde && opam update RUN opam depext -i -y mirage.3.7.4 lwt.4.5.0 RUN mkdir /home/opam/qubes-mirage-firewall diff --git a/build-with-docker.sh b/build-with-docker.sh index e8e46cd..2a7bb42 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 qubes_firewall.xen)" -echo "SHA2 last known: 91c5bf44a85339aaf14e4763a29c2b64537f5bc41cd7dc2571af954ec9dd3cad" +echo "SHA2 last known: 83b96bd453c3c3cfb282076be81055026eca437b621b3ef3f2642af04ad782e2" echo "(hashes should match for released versions)" From 87df5bdcc015b1a9f06aeeadcb8a283e3b1fe100 Mon Sep 17 00:00:00 2001 From: linse Date: Wed, 29 Apr 2020 15:58:01 +0200 Subject: [PATCH 097/281] Read firewall rules from QubesDB. The module Rules contains a rule matcher instead of hardcoded rules now. Co-Authored-By: Mindy Preston --- Dockerfile | 4 +- Makefile.builder | 2 +- Makefile.user | 5 + README.md | 7 + client_net.ml | 69 ++++++-- client_net.mli | 10 +- config.ml | 9 +- dao.ml | 32 ++++ dao.mli | 7 + diagrams/components.txt | 12 +- firewall.ml | 103 +++--------- fw_utils.ml | 2 + my_nat.ml | 8 +- my_nat.mli | 5 +- packet.ml | 65 +++++--- packet.mli | 39 +++++ router.mli | 3 +- rules.ml | 133 +++++++++------ test/config.ml | 27 +++ test/test.sh | 138 ++++++++++++++++ test/unikernel.ml | 357 ++++++++++++++++++++++++++++++++++++++++ test/update-firewall.sh | 54 ++++++ unikernel.ml | 43 ++--- 23 files changed, 928 insertions(+), 206 deletions(-) create mode 100644 packet.mli create mode 100644 test/config.ml create mode 100755 test/test.sh create mode 100644 test/unikernel.ml create mode 100644 test/update-firewall.sh diff --git a/Dockerfile b/Dockerfile index 7cbdc98..d49cadf 100644 --- a/Dockerfile +++ b/Dockerfile @@ -7,9 +7,9 @@ FROM ocurrent/opam@sha256:3f3ce7e577a94942c7f9c63cbdd1ecbfe0ea793f581f69047f3155 # 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 ~/opam-repository && git fetch origin master && git reset --hard ebac42783217016bd2c4108bbbef102aab56cdde && opam update +RUN cd ~/opam-repository && git fetch origin master && git reset --hard 3548c2a8537029b8165466cd9c5a94bb7bc30405 && opam update -RUN opam depext -i -y mirage.3.7.4 lwt.4.5.0 +RUN opam depext -i -y mirage.3.7.6 lwt.5.2.0 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/Makefile.builder b/Makefile.builder index 30e4cec..ee3c966 100644 --- a/Makefile.builder +++ b/Makefile.builder @@ -4,5 +4,5 @@ SOURCE_BUILD_DEP := firewall-build-dep firewall-build-dep: opam install -y depext - opam depext -i -y mirage.3.7.4 lwt.4.5.0 + opam depext -i -y mirage.3.7.6 lwt.5.2.0 diff --git a/Makefile.user b/Makefile.user index da810cd..cc7a7f4 100644 --- a/Makefile.user +++ b/Makefile.user @@ -5,3 +5,8 @@ tar: build touch _build/mirage-firewall/modules.img cat /dev/null | gzip -n > _build/mirage-firewall/initramfs tar cjf mirage-firewall.tar.bz2 -C _build --mtime=./build-with-docker.sh mirage-firewall + +fetchmotron: qubes_firewall.xen + test-mirage qubes_firewall.xen mirage-fw-test & + sleep 1 + boot-mirage fetchmotron diff --git a/README.md b/README.md index 6556705..be85574 100644 --- a/README.md +++ b/README.md @@ -165,6 +165,13 @@ This takes a little more setting up the first time, but will be much quicker aft 2017-03-18 11:32:38 -00:00: INF [dao] Watching backend/vif 2017-03-18 11:32:38 -00:00: INF [qubes.db] got update: "/qubes-netvm-domid" = "1" +# Testing if the firewall works + +Build the test unikernel in the test directory. +Install it to a vm which has the firewall as netvm. +Set the rules for the testvm to "textfile". +Run the test unikernel. + # Security advisories See [issues tagged "security"](https://github.com/mirage/qubes-mirage-firewall/issues?utf8=%E2%9C%93&q=label%3Asecurity+) for security advisories affecting the firewall. diff --git a/client_net.ml b/client_net.ml index 5b7b54b..31f3f2d 100644 --- a/client_net.ml +++ b/client_net.ml @@ -30,6 +30,9 @@ class client_iface eth ~domid ~gateway_ip ~client_ip client_mac : client_link = let log_header = Fmt.strf "dom%d:%a" domid Ipaddr.V4.pp client_ip in object val queue = FrameQ.create (Ipaddr.V4.to_string client_ip) + val mutable rules = [] + method get_rules = rules + method set_rules new_db = rules <- Dao.read_rules new_db client_ip method my_mac = ClientEth.mac eth method other_mac = client_mac method my_ip = gateway_ip @@ -74,8 +77,8 @@ let input_ipv4 get_ts cache ~iface ~router packet = Lwt.return_unit ) -(** Connect to a new client's interface and listen for incoming frames. *) -let add_vif get_ts { Dao.ClientVif.domid; device_id } ~client_ip ~router ~cleanup_tasks = +(** 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 } ~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 -> @@ -83,28 +86,59 @@ let add_vif get_ts { Dao.ClientVif.domid; device_id } ~client_ip ~router ~cleanu let client_eth = router.Router.client_eth in let gateway_ip = Client_eth.client_gw client_eth in let iface = new client_iface eth ~domid ~gateway_ip ~client_ip client_mac in + (* update the rules whenever QubesDB notices a change for this IP *) + let qubesdb_updater = + Lwt.catch + (fun () -> + let rec update current_db current_rules = + Qubes.DB.got_new_commit qubesDB (Dao.db_root client_ip) current_db >>= fun new_db -> + iface#set_rules new_db; + let new_rules = iface#get_rules in + (if current_rules = new_rules then + Log.debug (fun m -> m "Rules did not change for %s" (Ipaddr.V4.to_string client_ip)) + else begin + Log.debug (fun m -> m "New firewall rules for %s@.%a" + (Ipaddr.V4.to_string client_ip) + Fmt.(list ~sep:(unit "@.") Pf_qubes.Parse_qubes.pp_rule) new_rules); + (* empty NAT table if rules are updated: they might deny old connections *) + My_nat.remove_connections router.Router.nat client_ip; + end); + update new_db new_rules + in + update Qubes.DB.KeyMap.empty []) + (function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e) + in + Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel qubesdb_updater); Router.add_client router iface >>= fun () -> Cleanup.on_cleanup cleanup_tasks (fun () -> Router.remove_client router iface); let fixed_arp = Client_eth.ARP.create ~net:client_eth iface in let fragment_cache = ref (Fragments.Cache.empty (256 * 1024)) in - Netback.listen backend ~header_size:Ethernet_wire.sizeof_ethernet (fun frame -> - match Ethernet_packet.Unmarshal.of_cstruct frame with - | Error err -> Log.warn (fun f -> f "Invalid Ethernet frame: %s" err); Lwt.return_unit - | 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 payload - | `IPv6 -> Lwt.return_unit (* TODO: oh no! *) - ) - >|= or_raise "Listen on client interface" Netback.pp_error + let listener = + Lwt.catch + (fun () -> + Netback.listen backend ~header_size:Ethernet_wire.sizeof_ethernet (fun frame -> + match Ethernet_packet.Unmarshal.of_cstruct frame with + | Error err -> Log.warn (fun f -> f "Invalid Ethernet frame: %s" err); Lwt.return_unit + | 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 payload + | `IPv6 -> Lwt.return_unit (* TODO: oh no! *) + ) + >|= or_raise "Listen on client interface" Netback.pp_error) + (function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e) + in + Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel listener); + 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 ~router vif client_ip = +let add_client get_ts ~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); + 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 ~client_ip ~router ~cleanup_tasks + add_vif get_ts vif ~client_ip ~router ~cleanup_tasks qubesDB ) (fun ex -> Log.warn (fun f -> f "Error with client %a: %s" @@ -115,7 +149,7 @@ let add_client get_ts ~router vif client_ip = cleanup_tasks (** Watch XenStore for notifications of new clients. *) -let listen get_ts router = +let listen get_ts qubesDB router = Dao.watch_clients (fun new_set -> (* Check for removed clients *) !clients |> Dao.VifMap.iter (fun key cleanup -> @@ -128,7 +162,8 @@ let listen get_ts 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 ~router key ip_addr in + let cleanup = add_client get_ts ~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 97ebd68..0bfbb01 100644 --- a/client_net.mli +++ b/client_net.mli @@ -3,8 +3,8 @@ (** Handling client VMs. *) -val listen : (unit -> int64) -> Router.t -> 'a Lwt.t -(** [listen get_timestamp 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. *) +val listen : (unit -> int64) -> Qubes.DB.t -> Router.t -> 'a Lwt.t +(** [listen get_timestamp 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/config.ml b/config.ml index 602fd32..87ba926 100644 --- a/config.ml +++ b/config.ml @@ -30,13 +30,14 @@ let main = package "netchannel" ~min:"1.11.0"; package "mirage-net-xen"; package "ipaddr" ~min:"4.0.0"; - package "mirage-qubes" ~min:"0.8.0"; - package "mirage-nat" ~min:"2.1.0"; + package "mirage-qubes" ~min:"0.8.2"; + package "mirage-nat" ~min:"2.2.1"; package "mirage-logs"; package "mirage-xen" ~min:"5.0.0"; + package "pf-qubes"; ] - "Unikernel.Main" (mclock @-> job) + "Unikernel.Main" (random @-> mclock @-> job) let () = - register "qubes-firewall" [main $ default_monotonic_clock] + register "qubes-firewall" [main $ default_random $ default_monotonic_clock] ~argv:no_argv diff --git a/dao.ml b/dao.ml index a34b8b7..8a14c22 100644 --- a/dao.ml +++ b/dao.ml @@ -33,6 +33,38 @@ let directory ~handle dir = | [""] -> [] (* XenStore client bug *) | items -> items +let db_root client_ip = + "/qubes-firewall/" ^ (Ipaddr.V4.to_string client_ip) + +let read_rules rules client_ip = + let root = db_root client_ip in + let rec get_rule n l : (Pf_qubes.Parse_qubes.rule list, string) result = + let pattern = root ^ "/" ^ Printf.sprintf "%04d" n in + Log.debug (fun f -> f "reading %s" pattern); + match Qubes.DB.KeyMap.find_opt pattern rules with + | None -> + Log.debug (fun f -> f "rule %d does not exist; won't look for more" n); + Ok (List.rev l) + | Some rule -> + Log.debug (fun f -> f "rule %d: %s" n rule); + match Pf_qubes.Parse_qubes.parse_qubes ~number:n rule with + | Error e -> Log.warn (fun f -> f "Error parsing rule %d: %s" n e); Error e + | Ok rule -> + Log.debug (fun f -> f "parsed rule: %a" Pf_qubes.Parse_qubes.pp_rule rule); + get_rule (n+1) (rule :: l) + in + 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 = None; + icmp_type = None; + number = 0;})] + let vifs ~handle domid = match String.to_int domid with | None -> Log.err (fun f -> f "Invalid domid %S" domid); Lwt.return [] diff --git a/dao.mli b/dao.mli index b1f56b6..811c2e7 100644 --- a/dao.mli +++ b/dao.mli @@ -30,4 +30,11 @@ 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 db_root : Ipaddr.V4.t -> string +(** Returns the root path of the firewall rules in the QubesDB for a given IP address. *) + +val read_rules : string Qubes.DB.KeyMap.t -> Ipaddr.V4.t -> Pf_qubes.Parse_qubes.rule list +(** [read_rules bindings ip] extracts firewall rule information for [ip] from [bindings]. + If any rules fail to parse, it will return only one rule denying all traffic. *) + val set_iptables_error : Qubes.DB.t -> string -> unit Lwt.t diff --git a/diagrams/components.txt b/diagrams/components.txt index 62e4f9e..8b7efbf 100644 --- a/diagrams/components.txt +++ b/diagrams/components.txt @@ -1,6 +1,12 @@ - +----------+ - | rules | - +----------+ + +--------------------+ + | rules from QubesDB | + +--------------------+ + ^ + if-not-in-nat | then check + | + +-----------+ + | nat-table | + +-----------+ ^ |checks | diff --git a/firewall.ml b/firewall.ml index 96ea516..48d4fe4 100644 --- a/firewall.ml +++ b/firewall.ml @@ -16,7 +16,7 @@ let transmit_ipv4 packet iface = iface#writev `IPv4 (fun b -> match Nat_packet.into_cstruct packet b with | Error e -> - Log.warn (fun f -> f "Failed to NAT packet to %a: %a" + Log.warn (fun f -> f "Failed to write packet to %a: %a" Ipaddr.V4.pp iface#other_ip Nat_packet.pp_error e); 0 @@ -38,72 +38,6 @@ let forward_ipv4 t packet = | Some iface -> transmit_ipv4 packet iface | None -> Lwt.return_unit -(* Packet classification *) - -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) - | (`Firewall | `NetVM) as x -> x - -let classify ~src ~dst packet = - let `IPv4 (_ip, transport) = packet in - let proto = - match transport with - | `TCP ({Tcp.Tcp_packet.src_port; dst_port; _}, _) -> `TCP {sport = src_port; dport = dst_port} - | `UDP ({Udp_packet.src_port; dst_port; _}, _) -> `UDP {sport = src_port; dport = dst_port} - | `ICMP _ -> `ICMP - in - Some { - packet; - src; - dst; - proto; - } - -let pp_ports fmt {sport; dport} = - Format.fprintf fmt "sport=%d dport=%d" sport dport - -let pp_host fmt = function - | `Client c -> Ipaddr.V4.pp fmt (c#other_ip) - | `Unknown_client ip -> Format.fprintf fmt "unknown-client(%a)" Ipaddr.pp ip - | `NetVM -> Format.pp_print_string fmt "net-vm" - | `External ip -> Format.fprintf fmt "external(%a)" Ipaddr.pp ip - | `Firewall -> Format.pp_print_string fmt "firewall" - -let pp_proto fmt = function - | `UDP ports -> Format.fprintf fmt "UDP(%a)" pp_ports ports - | `TCP ports -> Format.fprintf fmt "TCP(%a)" pp_ports ports - | `ICMP -> Format.pp_print_string fmt "ICMP" - | `Unknown -> Format.pp_print_string fmt "UnknownProtocol" - -let pp_packet t fmt {src = _; dst = _; proto; 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 - Format.fprintf fmt "[src=%a dst=%a proto=%a]" - pp_host src - pp_host dst - pp_proto proto - -let pp_transport_headers f = function - | `ICMP (h, _) -> Icmpv4_packet.pp f h - | `TCP (h, _) -> Tcp.Tcp_packet.pp f h - | `UDP (h, _) -> Udp_packet.pp f h - -let pp_header f = function - | `IPv4 (ip, transport) -> - Fmt.pf f "%a %a" - Ipv4_packet.pp ip - pp_transport_headers transport - (* NAT *) let translate t packet = @@ -115,7 +49,7 @@ let add_nat_and_forward_ipv4 t packet = My_nat.add_nat_rule_and_translate t.Router.nat ~xl_host `NAT packet >>= function | Ok packet -> forward_ipv4 t packet | Error e -> - Log.warn (fun f -> f "Failed to add NAT rewrite rule: %s (%a)" e pp_header packet); + Log.warn (fun f -> f "Failed to add NAT rewrite rule: %s (%a)" e Nat_packet.pp packet); Lwt.return_unit (* Add a NAT rule to redirect this conversation to [host:port] instead of us. *) @@ -127,23 +61,24 @@ let nat_to t ~host ~port packet = My_nat.add_nat_rule_and_translate t.Router.nat ~xl_host (`Redirect (target, port)) packet >>= function | Ok packet -> forward_ipv4 t packet | Error e -> - Log.warn (fun f -> f "Failed to add NAT redirect rule: %s (%a)" e pp_header packet); + Log.warn (fun f -> f "Failed to add NAT redirect rule: %s (%a)" e Nat_packet.pp packet); Lwt.return_unit -(* Handle incoming packets *) - -let apply_rules t rules ~dst info = - let packet = info.packet in - match rules info, dst with +let apply_rules t (rules : ('a, 'b) Packet.t -> Packet.action Lwt.t) ~dst (annotated_packet : ('a, 'b) Packet.t) : unit Lwt.t = + let packet = to_mirage_nat_packet annotated_packet in + rules annotated_packet >>= fun action -> + match action, dst with | `Accept, `Client client_link -> transmit_ipv4 packet client_link | `Accept, (`External _ | `NetVM) -> transmit_ipv4 packet t.Router.uplink | `Accept, `Firewall -> - Log.warn (fun f -> f "Bad rule: firewall can't accept packets %a" (pp_packet t) info); + Log.warn (fun f -> f "Bad rule: firewall can't accept packets %a" Nat_packet.pp packet); Lwt.return_unit - | `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 (pp_packet t) info); + Log.debug (fun f -> f "Dropped packet (%s) %a" reason Nat_packet.pp packet); Lwt.return_unit let handle_low_memory t = @@ -165,9 +100,9 @@ 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 - match classify ~src:(resolve_client src) ~dst:(resolve_host dst) packet with + match of_mirage_nat_packet ~src:(`Client src) ~dst packet with | None -> Lwt.return_unit - | Some info -> apply_rules t Rules.from_client ~dst info + | Some firewall_packet -> apply_rules t Rules.from_client ~dst firewall_packet let ipv4_from_netvm t packet = handle_low_memory t >>= function @@ -176,15 +111,17 @@ 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 classify ~src ~dst:(resolve_host dst) packet with + match Packet.of_mirage_nat_packet ~src ~dst packet with | None -> Lwt.return_unit - | Some info -> + | Some _ -> match src with | `Client _ | `Firewall -> - Log.warn (fun f -> f "Frame from NetVM has internal source IP address! %a" (pp_packet t) info); + Log.warn (fun f -> f "Frame from NetVM has internal source IP address! %a" Nat_packet.pp packet); Lwt.return_unit | `External _ | `NetVM as src -> translate t packet >>= function | Some frame -> forward_ipv4 t frame | None -> - apply_rules t Rules.from_netvm ~dst { info with src } + match Packet.of_mirage_nat_packet ~src ~dst packet with + | None -> Lwt.return_unit + | Some packet -> apply_rules t Rules.from_netvm ~dst packet diff --git a/fw_utils.ml b/fw_utils.ml index 9c5bab4..f6d5c7b 100644 --- a/fw_utils.ml +++ b/fw_utils.ml @@ -31,6 +31,8 @@ class type client_link = object inherit interface method other_mac : Macaddr.t method log_header : string (* For log messages *) + method get_rules: Pf_qubes.Parse_qubes.rule list + method set_rules: string Qubes.DB.KeyMap.t -> unit end (** An Ethernet header from [src]'s MAC address to [dst]'s with an IPv4 payload. *) diff --git a/my_nat.ml b/my_nat.ml index 02a4b5a..9dfcf68 100644 --- a/my_nat.ml +++ b/my_nat.ml @@ -39,6 +39,10 @@ let random_user_port () = let reset t = Nat.reset t.table +let remove_connections t ip = + let Mirage_nat.{ tcp ; udp } = Nat.remove_connections t.table ip in + ignore(tcp, udp) + let add_nat_rule_and_translate t ~xl_host action packet = let apply_action xl_port = Lwt.catch (fun () -> @@ -56,13 +60,13 @@ let add_nat_rule_and_translate t ~xl_host action packet = (* Because hash tables resize in big steps, this can happen even if we have a fair chunk of free memory. *) Log.warn (fun f -> f "Out_of_memory adding NAT rule. Dropping NAT table..."); - Nat.reset t.table >>= fun () -> + reset t >>= fun () -> aux ~retries:(retries - 1) | Error `Overlap when retries < 0 -> Lwt.return (Error "Too many retries") | Error `Overlap -> if retries = 0 then ( Log.warn (fun f -> f "Failed to find a free port; resetting NAT table"); - Nat.reset t.table >>= fun () -> + reset t >>= fun () -> aux ~retries:(retries - 1) ) else ( aux ~retries:(retries - 1) diff --git a/my_nat.mli b/my_nat.mli index cdc5eda..fc2049d 100644 --- a/my_nat.mli +++ b/my_nat.mli @@ -12,6 +12,7 @@ type action = [ val create : max_entries:int -> t Lwt.t val reset : t -> unit Lwt.t +val remove_connections : t -> Ipaddr.V4.t -> unit val translate : t -> Nat_packet.t -> Nat_packet.t option Lwt.t -val add_nat_rule_and_translate : t -> xl_host:Ipaddr.V4.t -> - action -> Nat_packet.t -> (Nat_packet.t, string) result Lwt.t +val add_nat_rule_and_translate : t -> + xl_host:Ipaddr.V4.t -> action -> Nat_packet.t -> (Nat_packet.t, string) result Lwt.t diff --git a/packet.ml b/packet.ml index 7838a6b..7d8c3c4 100644 --- a/packet.ml +++ b/packet.ml @@ -5,33 +5,60 @@ open Fw_utils type port = int -type ports = { - sport : port; (* Source port *) - dport : port; (* Destination *) -} - -type host = +type host = [ `Client of client_link | `Firewall | `NetVM | `External of Ipaddr.t ] -type ('src, 'dst) info = { - packet : Nat_packet.t; +type transport_header = [`TCP of Tcp.Tcp_packet.t + |`UDP of Udp_packet.t + |`ICMP of Icmpv4_packet.t] + +type ('src, 'dst) t = { + ipv4_header : Ipv4_packet.t; + transport_header : transport_header; + transport_payload : Cstruct.t; src : 'src; dst : 'dst; - proto : [ `UDP of ports | `TCP of ports | `ICMP | `Unknown ]; } +let pp_transport_header f = function + | `ICMP h -> Icmpv4_packet.pp f h + | `TCP h -> Tcp.Tcp_packet.pp f h + | `UDP h -> Udp_packet.pp f h -(* The first message in a TCP connection has SYN set and ACK clear. *) -let is_tcp_start = function - | `IPv4 (_ip, `TCP (hdr, _body)) -> Tcp.Tcp_packet.(hdr.syn && not hdr.ack) - | _ -> false +let pp_host fmt = function + | `Client c -> Ipaddr.V4.pp fmt (c#other_ip) + | `Unknown_client ip -> Format.fprintf fmt "unknown-client(%a)" Ipaddr.pp ip + | `NetVM -> Format.pp_print_string fmt "net-vm" + | `External ip -> Format.fprintf fmt "external(%a)" Ipaddr.pp ip + | `Firewall -> Format.pp_print_string fmt "firewall(client-gw)" -(* The possible actions we can take for a packet: *) +let to_mirage_nat_packet t : Nat_packet.t = + match t.transport_header with + | `TCP h -> `IPv4 (t.ipv4_header, (`TCP (h, t.transport_payload))) + | `UDP h -> `IPv4 (t.ipv4_header, (`UDP (h, t.transport_payload))) + | `ICMP h -> `IPv4 (t.ipv4_header, (`ICMP (h, t.transport_payload))) + +let of_mirage_nat_packet ~src ~dst packet : ('a, 'b) t option = + let `IPv4 (ipv4_header, ipv4_payload) = packet in + let transport_header, transport_payload = match ipv4_payload with + | `TCP (h, p) -> `TCP h, p + | `UDP (h, p) -> `UDP h, p + | `ICMP (h, p) -> `ICMP h, p + in + Some { + ipv4_header; + transport_header; + transport_payload; + src; + dst; + } + +(* possible actions to take for a packet: *) type action = [ - | `Accept (* Send the packet to its destination. *) - | `NAT (* Rewrite the packet's source field so packet appears to - have come from the firewall, via an unused port. - Also, add NAT rules so related packets will be translated accordingly. *) + | `Accept (* Send to destination, unmodified. *) + | `NAT (* Rewrite source field to the firewall's IP, with a fresh source port. + Also, add translation rules for future traffic in both directions, + between these hosts on these ports, and corresponding ICMP error traffic. *) | `NAT_to of host * port (* As for [`NAT], but also rewrite the packet's destination fields so it will be sent to [host:port]. *) - | `Drop of string (* Drop the packet and log the given reason. *) + | `Drop of string (* Drop packet for this reason. *) ] diff --git a/packet.mli b/packet.mli new file mode 100644 index 0000000..f7d2876 --- /dev/null +++ b/packet.mli @@ -0,0 +1,39 @@ +type port = int + +type host = + [ `Client of Fw_utils.client_link (** an IP address on the private network *) + | `Firewall (** the firewall's IP on the private network *) + | `NetVM (** the IP of the firewall's default route *) + | `External of Ipaddr.t (** an IP on the public network *) + ] + +type transport_header = [`TCP of Tcp.Tcp_packet.t + |`UDP of Udp_packet.t + |`ICMP of Icmpv4_packet.t] + +type ('src, 'dst) t = { + ipv4_header : Ipv4_packet.t; + transport_header : transport_header; + transport_payload : Cstruct.t; + src : 'src; + dst : 'dst; +} + +val pp_transport_header : Format.formatter -> transport_header -> unit + +val pp_host : Format.formatter -> host -> unit + +val to_mirage_nat_packet : ('a, 'b) t -> Nat_packet.t + +val of_mirage_nat_packet : src:'a -> dst:'b -> Nat_packet.t -> ('a, 'b) t option + +(* possible actions to take for a packet: *) +type action = [ + | `Accept (* Send to destination, unmodified. *) + | `NAT (* Rewrite source field to the firewall's IP, with a fresh source port. + Also, add translation rules for future traffic in both directions, + between these hosts on these ports, and corresponding ICMP error traffic. *) + | `NAT_to of host * port (* As for [`NAT], but also rewrite the packet's + destination fields so it will be sent to [host:port]. *) + | `Drop of string (* Drop packet for this reason. *) +] diff --git a/router.mli b/router.mli index 80678fb..34fa86b 100644 --- a/router.mli +++ b/router.mli @@ -10,14 +10,13 @@ type t = private { nat : My_nat.t; uplink : interface; } -(** A routing table. *) val create : client_eth:Client_eth.t -> uplink:interface -> nat:My_nat.t -> t -(** [create ~client_eth ~uplink] is a new routing table +(** [create ~client_eth ~uplink ~nat] is a new routing table that routes packets outside of [client_eth] via [uplink]. *) val target : t -> Ipv4_packet.t -> interface option diff --git a/rules.ml b/rules.ml index ec0c1c3..cb6bb6f 100644 --- a/rules.ml +++ b/rules.ml @@ -1,62 +1,101 @@ (* Copyright (C) 2015, Thomas Leonard See the README file for details. *) -(** Put your firewall rules in this file. *) +(** This module applies firewall rules from QubesDB. *) -open Packet (* Allow us to use definitions in packet.ml *) +open Packet +open Lwt.Infix +module Q = Pf_qubes.Parse_qubes -(* 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; - *) +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 -(* 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; - *) -] +module Classifier = struct -(* OCaml normally warns if you don't match all fields, but that's OK here. *) -[@@@ocaml.warning "-9"] + let matches_port dstports (port : int) = match dstports with + | None -> true + | Some (Q.Range_inclusive (min, max)) -> min <= port && port <= max -(** This function decides what to do with a packet from a client VM. + let matches_proto rule 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 + (* specialtarget=dns applies only to the specialtarget destination IPs, and + specialtarget=dns is also implicitly tcp/udp port 53 *) + match packet.transport_header with + | `TCP header -> header.Tcp.Tcp_packet.dst_port = dns_port + | `UDP header -> header.Udp_packet.dst_port = dns_port + | _ -> false + end + (* DNS rules can only match traffic headed to the specialtarget hosts, so any other destination + isn't a match for DNS rules *) + | None, Some `dns -> false + | Some rule_proto, _ -> match rule_proto, packet.transport_header with + | `tcp, `TCP header -> matches_port rule.Q.dstports header.Tcp.Tcp_packet.dst_port + | `udp, `UDP header -> matches_port rule.Q.dstports header.Udp_packet.dst_port + | `icmp, `ICMP header -> + begin + match rule.Q.icmp_type with + | None -> true + | Some rule_icmp_type -> + 0 = compare rule_icmp_type @@ Icmpv4_wire.ty_to_int header.Icmpv4_packet.ty + end + | _, _ -> false - It takes as input an argument [info] (of type [Packet.info]) describing the - packet, and returns an action (of type [Packet.action]) to perform. + let matches_dest rule packet = + let ip = packet.ipv4_header.Ipv4_packet.dst in + match rule.Q.dst with + | `any -> Lwt.return @@ `Match rule + | `hosts subnet -> + Lwt.return @@ if (Ipaddr.Prefix.mem Ipaddr.(V4 ip) subnet) then `Match rule else `No_match + | `dnsname name -> + Log.warn (fun f -> f "Resolving %a" Domain_name.pp name); + Lwt.return @@ `No_match - See packet.ml for the definitions of [info] and [action]. +end - Note: If the packet matched an existing NAT rule then this isn't called. *) -let from_client (info : ([`Client of _], _) Packet.info) : Packet.action = - match info with - (* Examples (add your own rules here): +let find_first_match packet acc rule = + match acc with + | `No_match -> + if Classifier.matches_proto rule packet + then Classifier.matches_dest rule packet + else Lwt.return `No_match + | q -> Lwt.return q - 1. Allows Dev to send SSH packets to Untrusted. - Note: responses are not covered by this! - 2. Allows Untrusted to reply to Dev. - 3. Blocks an external site. +(* Does the packet match our rules? *) +let classify_client_packet (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 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) - 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 = `Firewall; proto = `UDP { dport = 53 } } -> `NAT_to (`NetVM, 53) - | { dst = `Firewall } -> `Drop "packet addressed to firewall itself" - | { dst = `Client _ } -> `Drop "prevent communication between client VMs by default" +let translate_accepted_packets packet = + classify_client_packet packet >|= function + | `Accept -> `NAT + | `Drop s -> `Drop s -(** 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. *) -let from_netvm (info : ([`NetVM | `External of _], _) Packet.info) : Packet.action = - match info with - | _ -> `Drop "drop by default" +(** Packets from the private interface that don't match any NAT table entry are being checked against the fw rules here *) +let from_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 packet + | { dst = `Firewall ; _ } -> Lwt.return @@ `Drop "packet addressed to firewall itself" + | { dst = `Client _ ; _ } -> classify_client_packet 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 *) +let from_netvm (_packet : ([`NetVM | `External of _], _) Packet.t) : Packet.action Lwt.t = + Lwt.return @@ `Drop "drop by default" diff --git a/test/config.ml b/test/config.ml new file mode 100644 index 0000000..d8695e4 --- /dev/null +++ b/test/config.ml @@ -0,0 +1,27 @@ +open Mirage + +let pin = "git+https://github.com/roburio/alcotest.git#mirage" + +let packages = [ + package "ethernet"; + package "arp"; + package "arp-mirage"; + package "ipaddr"; + package "tcpip" ~sublibs:["stack-direct"; "icmpv4"; "ipv4"; "udp"; "tcp"]; + package "mirage-qubes"; + package "mirage-qubes-ipv4"; + package "dns-client" ~sublibs:["mirage"]; + package ~pin "alcotest"; + package ~pin "alcotest-mirage"; +] + +let client = + foreign ~packages + "Unikernel.Client" @@ random @-> time @-> mclock @-> network @-> qubesdb @-> job + +let db = default_qubesdb +let network = default_network + +let () = + let job = [ client $ default_random $ default_time $ default_monotonic_clock $ network $ db ] in + register "http-fetch" job diff --git a/test/test.sh b/test/test.sh new file mode 100755 index 0000000..2971207 --- /dev/null +++ b/test/test.sh @@ -0,0 +1,138 @@ +#!/bin/bash +function explain_commands { + echo "1) Set up test qubes:" +echo "First, set up the test-mirage script from https://github.com/talex5/qubes-test-mirage.git" + +echo "Then, use `qubes-manager` to create two new AppVMs called `mirage-fw-test` and `fetchmotron`. +You can make it standalone or not and use any template (it doesn't matter +because unikernels already contain all their code and don't need to use a disk +to boot)." + +echo "Next, still in dom0, create a new `mirage-fw-test` and `fetchmotron` kernels, with an empty `modules.img` and `vmlinuz` and a compressed empty file for the initramfs, and then set that as the kernel for the new VMs: + + mkdir /var/lib/qubes/vm-kernels/mirage-fw-test + cd /var/lib/qubes/vm-kernels/mirage-fw-test + touch modules.img vmlinuz test-mirage-ok + cat /dev/null | gzip > initramfs + qvm-prefs -s mirage-fw-test kernel mirage-fw-test + + mkdir /var/lib/qubes/vm-kernels/fetchmotron + cd /var/lib/qubes/vm-kernels/fetchmotron + touch modules.img vmlinuz test-mirage-ok + cat /dev/null | gzip > initramfs + qvm-prefs -s fetchmotron kernel fetchmotron +" +} + +function explain_service { +echo "2) Set up rule update service:" +echo "In dom0, make a new service: + +sudo bash +echo /usr/local/bin/update-firewall > /etc/qubes-rpc/yomimono.updateFirewall + +Make a policy file for this service, YOUR_DEV_VM being the qube from which you build (e.g. ocamldev): + +cd /etc/qubes-rpc/policy +cat << EOF >> yomimono.updateFirewall +YOUR_DEV_VM dom0 allow + +copy the update-firewall script: + +cd /usr/local/bin +qvm-run -p YOUR_DEV_VM 'cat /path/to/qubes-mirage-firewall/test/update-firewall.sh' > update-firewall +chmod +x update-firewall + +Now, back to YOUR_DEV_VM. Let's test to change fetchmotron's firewall rules: + +qrexec-client-vm dom0 yomimono.updateFirewall" +} + +function explain_upstream { +echo "Also, start the test services on the upstream NetVM (which is available at 10.137.0.5 from the test unikernel). +For the UDP and TCP reply services: +Install nmap-ncat (to persist this package, install it in your sys-net template VM): + +sudo dnf install nmap-ncat + +Allow incoming traffic from local virtual interfaces on the appropriate ports, +then run the services: + +sudo iptables -I INPUT -i vif+ -p udp --dport $udp_echo_port -j ACCEPT +sudo iptables -I INPUT -i vif+ -p tcp --dport $tcp_echo_port_lower -j ACCEPT +sudo iptables -I INPUT -i vif+ -p tcp --dport $tcp_echo_port_upper -j ACCEPT +ncat -e /bin/cat -k -u -l $udp_echo_port & +ncat -e /bin/cat -k -l $tcp_echo_port_lower & +ncat -e /bin/cat -k -l $tcp_echo_port_upper & +" +} + +if ! [ -x "$(command -v test-mirage)" ]; then + echo 'Error: test-mirage is not installed.' >&2 + explain_commands >&2 + exit 1 +fi +qrexec-client-vm dom0 yomimono.updateFirewall +if [ $? -ne 0 ]; then + echo "Error: can't update firewall rules." >&2 + explain_service >&2 + exit 1 +fi +echo_host=10.137.0.5 +udp_echo_port=1235 +tcp_echo_port_lower=6668 +tcp_echo_port_upper=6670 + +# Pretest that checks if our echo servers work. +# NOTE: we assume the dev qube has the same netvm as fetchmotron. +# If yours is different, this test will fail (comment it out) +function pretest { + protocol=$1 + port=$2 + if [ "$protocol" = "udp" ]; then + udp_arg="-u" + else + udp_arg="" + fi + reply=$(echo hi | nc $udp_arg $echo_host -w 1 $port) + if [ "$reply" != "hi" ]; then + echo "echo hi | nc $udp_arg $echo_host -w 1 $port" + echo "echo services not reachable at $protocol $echo_host:$port" >&2 + explain_upstream >&2 + exit 1 + fi +} + +pretest "udp" "$udp_echo_port" +pretest "tcp" "$tcp_echo_port_lower" +pretest "tcp" "$tcp_echo_port_upper" + +echo "We're gonna set up a unikernel for the mirage-fw-test qube" +cd .. +make clean && \ +#mirage configure -t xen -l "application:error,net-xen xenstore:error,firewall:debug,frameQ:debug,uplink:debug,rules:debug,udp:debug,ipv4:debug,fw-resolver:debug" && \ +mirage configure -t xen -l "net-xen xenstore:error,application:warning,qubes.db:warning" && \ +#mirage configure -t xen -l "*:debug" && \ +make depend && \ +make +if [ $? -ne 0 ]; then + echo "Could not build unikernel for mirage-fw-test qube" >&2 + exit 1 +fi +cd test + +echo "We're gonna set up a unikernel for fetchmotron qube" +make clean && \ +mirage configure -t qubes -l "net-xen frontend:error,firewall test:debug" && \ +#mirage configure -t qubes -l "*:error" && \ +make depend && \ +make +if [ $? -ne 0 ]; then + echo "Could not build unikernel for fetchmotron qube" >&2 + exit 1 +fi + +cd .. +test-mirage qubes_firewall.xen mirage-fw-test & +cd test +test-mirage http_fetch.xen fetchmotron diff --git a/test/unikernel.ml b/test/unikernel.ml new file mode 100644 index 0000000..9c347f3 --- /dev/null +++ b/test/unikernel.ml @@ -0,0 +1,357 @@ +open Lwt.Infix +(* https://www.qubes-os.org/doc/vm-interface/#firewall-rules-in-4x *) +let src = Logs.Src.create "firewall test" ~doc:"Firewalltest" +module Log = (val Logs.src_log src : Logs.LOG) + +(* TODO + * things we can have in rule + * - action: + x accept (UDP fetch test) + x drop (TCP connect denied test) + * - proto: + x None (TCP connect denied test) + x TCP (TCP connect test) + x UDP (UDP fetch test) + x ICMP (ping test) + * - specialtarget: + x None (UDP fetch test, TCP connect denied test) + x DNS (TCP connect test, TCP connect denied test) + * - destination: + x Any (TCP connect denied test) + x Some ipv4 host (UDP fetch test) + Some ipv6 host (we can't do this right now) + Some hostname (need a bunch of DNS stuff for that) + * - destination ports: + x none (TCP connect denied test) + x range is one port (UDP fetch test) + x range has different ports in pair + * - icmp type: + x None (TCP connect denied, UDP fetch test) + x query type (ping test) + error type + x - errors related to allowed traffic (does it have a host waiting for it?) + x - directly allowed outbound icmp errors (e.g. for forwarding) + * - number (ordering over rules, to resolve conflicts by precedence) + no overlap between rules, i.e. ordering unimportant + error case: multiple rules with same number? + x conflicting rules (specific accept rules with low numbers, drop all with high number) +*) + +(* Point-to-point links out of a netvm always have this IP TODO clarify with Marek *) +let netvm = "10.137.0.5" +(* default "nameserver"s, which netvm redirects to whatever its real nameservers are *) +let nameserver_1, nameserver_2 = "10.139.1.1", "10.139.1.2" + +module Client (R: Mirage_random.S) (Time: Mirage_time.S) (Clock : Mirage_clock.MCLOCK) (NET: Mirage_net.S) (DB : Qubes.S.DB) = struct + module E = Ethernet.Make(NET) + module A = Arp.Make(E)(Time) + module I = Qubesdb_ipv4.Make(DB)(R)(Clock)(E)(A) + module Icmp = Icmpv4.Make(I) + module U = Udp.Make(I)(R) + module T = Tcp.Flow.Make(I)(Time)(Clock)(R) + + module Alcotest = Alcotest_mirage.Make(Clock) + + module Stack = struct + (* A Mirage_stack.V4 implementation which diverts DHCP messages to a DHCP + server. The DHCP server needs to get the entire Ethernet frame, because + the Ethernet source address is the address to send replies to, its IPv4 + addresses (source, destination) do not matter (since the DHCP client that + sent this request does not have an IP address yet). ARP cannot be used + by DHCP, because the client does not have an IP address (and thus no ARP + replies). *) + + module UDPV4 = U + module TCPV4 = T + module IPV4 = I + + type t = { + net : NET.t ; eth : E.t ; arp : A.t ; + ip : I.t ; icmp : Icmp.t ; udp : U.t ; tcp : T.t ; + udp_listeners : (int, U.callback) Hashtbl.t ; + tcp_listeners : (int, T.listener) Hashtbl.t ; + mutable icmp_listener : (src:Ipaddr.V4.t -> dst:Ipaddr.V4.t -> Cstruct.t -> unit Lwt.t) option ; + } + + let ipv4 { ip ; _ } = ip + let udpv4 { udp ; _ } = udp + let tcpv4 { tcp ; _ } = tcp + let icmpv4 { icmp ; _ } = icmp + + let listener h port = Hashtbl.find_opt h port + let udp_listener h ~dst_port = listener h dst_port + + let listen_udpv4 { udp_listeners ; _ } ~port cb = + Hashtbl.replace udp_listeners port cb + + let stop_listen_udpv4 { udp_listeners ; _ } ~port = + Hashtbl.remove udp_listeners port + + let listen_tcpv4 ?keepalive { tcp_listeners ; _ } ~port cb = + Hashtbl.replace tcp_listeners port { T.process = cb ; T.keepalive } + + let stop_listen_tcpv4 { tcp_listeners ; _ } ~port = + Hashtbl.remove tcp_listeners port + + let listen_icmp t cb = t.icmp_listener <- cb + + let listen t = + let ethif_listener = + E.input + ~arpv4:(A.input t.arp) + ~ipv4:( + I.input + ~tcp:(T.input t.tcp ~listeners:(listener t.tcp_listeners)) + ~udp:(U.input t.udp ~listeners:(udp_listener t.udp_listeners)) + ~default:(fun ~proto ~src ~dst buf -> + match proto with + | 1 -> + begin match t.icmp_listener with + | None -> Icmp.input t.icmp ~src ~dst buf + | Some cb -> cb ~src ~dst buf + end + | _ -> Lwt.return_unit) + t.ip) + ~ipv6:(fun _ -> Lwt.return_unit) + t.eth + in + NET.listen t.net ~header_size:Ethernet_wire.sizeof_ethernet ethif_listener + >>= function + | Error e -> + Logs.warn (fun p -> p "%a" NET.pp_error e) ; + Lwt.return_unit + | Ok _res -> Lwt.return_unit + + let connect net eth arp ip icmp udp tcp = + { net ; eth ; arp ; ip ; icmp ; udp ; tcp ; + udp_listeners = Hashtbl.create 2 ; + tcp_listeners = Hashtbl.create 2 ; + icmp_listener = None ; + } + + let disconnect _ = + Logs.warn (fun m -> m "ignoring disconnect"); + Lwt.return_unit + end + + module Dns = Dns_client_mirage.Make(R)(Time)(Clock)(Stack) + + let make_ping_packet payload = + let echo_request = { Icmpv4_packet.code = 0; (* constant for echo request/reply *) + ty = Icmpv4_wire.Echo_request; + subheader = Icmpv4_packet.(Id_and_seq (0, 0)); } in + Icmpv4_packet.Marshal.make_cstruct echo_request ~payload + + let is_ping_reply src server packet = + 0 = Ipaddr.V4.(compare src @@ of_string_exn server) && + packet.Icmpv4_packet.code = 0 && + packet.Icmpv4_packet.ty = Icmpv4_wire.Echo_reply && + packet.Icmpv4_packet.subheader = Icmpv4_packet.(Id_and_seq (0, 0)) + + let ping_denied_listener server resp_received stack = + let icmp_listener ~src ~dst:_ buf = + (* hopefully this is a reply to an ICMP echo request we sent *) + Log.info (fun f -> f "ping test: ICMP message received from %a: %a" I.pp_ipaddr src Cstruct.hexdump_pp buf); + match Icmpv4_packet.Unmarshal.of_cstruct buf with + | Error e -> Log.err (fun f -> f "couldn't parse ICMP packet: %s" e); + Lwt.return_unit + | Ok (packet, _payload) -> + Log.info (fun f -> f "ICMP message: %a" Icmpv4_packet.pp packet); + if is_ping_reply src server packet then resp_received := true; + Lwt.return_unit + in + Stack.listen_icmp stack (Some icmp_listener) + + let ping_expect_failure server stack () = + let resp_received = ref false in + Log.info (fun f -> f "Entering ping test: %s" server); + ping_denied_listener server resp_received stack; + Icmp.write (Stack.icmpv4 stack) ~dst:(Ipaddr.V4.of_string_exn server) (make_ping_packet (Cstruct.of_string "hi")) >>= function + | Error e -> Log.err (fun f -> f "ping test: error sending ping: %a" Icmp.pp_error e); Lwt.return_unit + | Ok () -> + Log.info (fun f -> f "ping test: sent ping to %s" server); + Time.sleep_ns 2_000_000_000L >>= fun () -> + (if !resp_received then + Log.err (fun f -> f "ping test failed: server %s got a response, block expected :(" server) + else + Log.err (fun f -> f "ping test passed: successfully blocked :)") + ); + Stack.listen_icmp stack None; + Lwt.return_unit + + let icmp_error_type stack () = + let resp_correct = ref false in + let echo_server = Ipaddr.V4.of_string_exn netvm in + let icmp_callback ~src ~dst:_ buf = + if Ipaddr.V4.compare src echo_server = 0 then begin + (* TODO: check that packet is error packet *) + match Icmpv4_packet.Unmarshal.of_cstruct buf with + | Error e -> Log.err (fun f -> f "Error parsing icmp packet %s" e) + | Ok (packet, _) -> + (* TODO don't hardcode the numbers, make a datatype *) + if packet.Icmpv4_packet.code = 10 (* unreachable, admin prohibited *) + then resp_correct := true + else Log.debug (fun f -> f "Unrelated icmp packet %a" Icmpv4_packet.pp packet) + end; + Lwt.return_unit + in + let content = Cstruct.of_string "important data" in + Stack.listen_icmp stack (Some icmp_callback); + U.write ~src_port:1337 ~dst:echo_server ~dst_port:1338 (Stack.udpv4 stack) content >>= function + | Ok () -> (* .. listener: test with accept rule, if we get reply we're good *) + Time.sleep_ns 1_000_000_000L >>= fun () -> + if !resp_correct + then Log.info (fun m -> m "UDP fetch test to port %d succeeded :)" 1338) + else Log.err (fun f -> f "UDP fetch test to port %d: failed. :( correct response not received" 1338); + Stack.listen_icmp stack None; + Lwt.return_unit + | Error e -> + Log.err (fun f -> f "UDP fetch test to port %d failed: :( couldn't write the packet: %a" + 1338 U.pp_error e); + Lwt.return_unit + + let tcp_connect msg server port tcp () = + Log.info (fun f -> f "Entering tcp connect test: %s:%d" server port); + let ip = Ipaddr.V4.of_string_exn server in + let msg' = Printf.sprintf "TCP connect test %s to %s:%d" msg server port in + T.create_connection tcp (ip, port) >>= function + | Ok flow -> + Log.info (fun f -> f "%s passed :)" msg'); + T.close flow + | Error e -> Log.err (fun f -> f "%s failed: Connection failed (%a) :(" msg' T.pp_error e); + Lwt.return_unit + + let tcp_connect_denied msg server port tcp () = + let ip = Ipaddr.V4.of_string_exn server in + let msg' = Printf.sprintf "TCP connect denied test %s to %s:%d" msg server port in + let connect = (T.create_connection tcp (ip, port) >>= function + | Ok flow -> + Log.err (fun f -> f "%s failed: Connection should be denied, but was not. :(" msg'); + T.close flow + | Error e -> Log.info (fun f -> f "%s passed (error text: %a) :)" msg' T.pp_error e); + Lwt.return_unit) + in + let timeout = ( + Time.sleep_ns 1_000_000_000L >>= fun () -> + Log.info (fun f -> f "%s passed :)" msg'); + Lwt.return_unit) + in + Lwt.pick [ connect ; timeout ] + + let udp_fetch ~src_port ~echo_server_port stack () = + Log.info (fun f -> f "Entering udp fetch test: %d -> %s:%d" + src_port netvm echo_server_port); + let resp_correct = ref false in + let echo_server = Ipaddr.V4.of_string_exn netvm in + let content = Cstruct.of_string "important data" in + let udp_listener : U.callback = (fun ~src ~dst:_ ~src_port buf -> + Log.debug (fun f -> f "listen_udpv4 function invoked for packet: %a" Cstruct.hexdump_pp buf); + if ((0 = Ipaddr.V4.compare echo_server src) && src_port = echo_server_port) then + match Cstruct.equal buf content with + | true -> (* yay *) + Log.info (fun f -> f "UDP fetch test to port %d: passed :)" echo_server_port); + resp_correct := true; + Lwt.return_unit + | false -> (* oh no *) + Log.err (fun f -> f "UDP fetch test to port %d: failed. :( Packet corrupted; expected %a but got %a" + echo_server_port Cstruct.hexdump_pp content Cstruct.hexdump_pp buf); + Lwt.return_unit + else + begin + (* disregard this packet *) + Log.debug (fun f -> f "packet is not from the echo server or has the wrong source port (%d but we wanted %d)" + src_port echo_server_port); + (* don't cancel the listener, since we want to keep listening *) + Lwt.return_unit + end + ) + in + Stack.listen_udpv4 stack ~port:src_port udp_listener; + U.write ~src_port ~dst:echo_server ~dst_port:echo_server_port (Stack.udpv4 stack) content >>= function + | Ok () -> (* .. listener: test with accept rule, if we get reply we're good *) + Time.sleep_ns 1_000_000_000L >>= fun () -> + Stack.stop_listen_udpv4 stack ~port:src_port; + if !resp_correct then Lwt.return_unit else begin + Log.err (fun f -> f "UDP fetch test to port %d: failed. :( correct response not received" echo_server_port); + Lwt.return_unit + end + | Error e -> + Log.err (fun f -> f "UDP fetch test to port %d failed: :( couldn't write the packet: %a" + echo_server_port U.pp_error e); + Lwt.return_unit + + let dns_expect_failure ~nameserver ~hostname stack () = + let lookup = Domain_name.(of_string_exn hostname |> host_exn) in + let nameserver' = `UDP, (Ipaddr.V4.of_string_exn nameserver, 53) in + let dns = Dns.create ~nameserver:nameserver' stack in + Dns.gethostbyname dns lookup >>= function + | Error (`Msg s) when String.compare s "Truncated UDP response" <> 0 -> Log.debug (fun f -> f "DNS test to %s failed as expected: %s" + nameserver s); + Log.info (fun f -> f "DNS traffic to %s correctly blocked :)" nameserver); + Lwt.return_unit + | Error (`Msg s) -> + Log.debug (fun f -> f "DNS test to %s failed unexpectedly (truncated response): %s :(" + nameserver s); + Lwt.return_unit + | Ok addr -> Log.err (fun f -> f "DNS test to %s should have been blocked, but looked up %s:%a" nameserver hostname Ipaddr.V4.pp addr); + Lwt.return_unit + + let dns_then_tcp_denied server stack () = + let parsed_server = Domain_name.(of_string_exn server |> host_exn) in + (* ask dns about server *) + Log.debug (fun f -> f "going to make a dns thing using nameserver %s" nameserver_1); + let dns = Dns.create ~nameserver:(`UDP, ((Ipaddr.V4.of_string_exn nameserver_1), 53)) stack in + Log.debug (fun f -> f "OK, going to look up %s now" server); + Dns.gethostbyname dns parsed_server >>= function + | Error (`Msg s) -> Log.err (fun f -> f "couldn't look up ip for %s: %s" server s); Lwt.return_unit + | Ok addr -> + Log.debug (fun f -> f "looked up ip for %s: %a" server Ipaddr.V4.pp addr); + Log.err (fun f -> f "Do more stuff here!!!! :("); + Lwt.return_unit + + let start _random _time _clock network db = + E.connect network >>= fun ethernet -> + A.connect ethernet >>= fun arp -> + I.connect db ethernet arp >>= fun ipv4 -> + Icmp.connect ipv4 >>= fun icmp -> + U.connect ipv4 >>= fun udp -> + T.connect ipv4 >>= fun tcp -> + + let stack = Stack.connect network ethernet arp ipv4 icmp udp tcp in + Lwt.async (fun () -> Stack.listen stack); + + (* put this first because tcp_connect_denied tests also generate icmp messages *) + let general_tests : unit Alcotest.test = ("firewall tests", [ + ("UDP fetch", `Quick, udp_fetch ~src_port:9090 ~echo_server_port:1235 stack); + ("Ping expect failure", `Quick, ping_expect_failure "8.8.8.8" stack ); + (* TODO: ping_expect_success to the netvm, for which we have an icmptype rule in update-firewall.sh *) + ("ICMP error type", `Quick, icmp_error_type stack) + ] ) in + Alcotest.run ~and_exit:false "name" [ general_tests ] >>= fun () -> + let tcp_tests : unit Alcotest.test = ("tcp tests", [ + (* this test fails on 4.0R3 + ("TCP connect", `Quick, tcp_connect "when trying specialtarget" nameserver_1 53 tcp); *) + ("TCP connect", `Quick, tcp_connect_denied "" netvm 53 tcp); + ("TCP connect", `Quick, tcp_connect_denied "when trying below range" netvm 6667 tcp); + ("TCP connect", `Quick, tcp_connect "when trying lower bound in range" netvm 6668 tcp); + ("TCP connect", `Quick, tcp_connect "when trying upper bound in range" netvm 6670 tcp); + ("TCP connect", `Quick, tcp_connect_denied "when trying above range" netvm 6671 tcp); + ("TCP connect", `Quick, tcp_connect_denied "" netvm 8082 tcp); + ] ) in + + (* replace the udp-related listeners with the right one for tcp *) + Alcotest.run "name" [ tcp_tests ] >>= fun () -> + (* use the stack abstraction only after the other tests have run, since it's not friendly with outside use of its modules *) + let stack_tests = "stack tests", [ + ("DNS expect failure", `Quick, dns_expect_failure ~nameserver:"8.8.8.8" ~hostname:"mirage.io" stack); + + (* the test below won't work on @linse's internet, + * because the nameserver there doesn't answer on TCP port 53, + * only UDP port 53. Dns_mirage_client.ml disregards our request + * to use UDP and uses TCP anyway, so this request can never work there. *) + (* If we can figure out a way to have this test unikernel do a UDP lookup with minimal pain, + * we should re-enable this test. *) + ("DNS lookup + TCP connect", `Quick, dns_then_tcp_denied "google.com" stack); + ] in + Alcotest.run "name" [ stack_tests ] +end diff --git a/test/update-firewall.sh b/test/update-firewall.sh new file mode 100644 index 0000000..fcfaac4 --- /dev/null +++ b/test/update-firewall.sh @@ -0,0 +1,54 @@ +#!/bin/sh + +# this script sets a deny-all rule for a particular VM, set here as TEST_VM. +# it is intended to be used as part of a test suite which analyzes whether +# an upstream FirewallVM correctly applies rule changes when they occur. + +# Copy this script into dom0 at /usr/local/bin/update-firewall.sh so it can be +# remotely triggered by your development VM as part of the firewall testing +# script. + +TEST_VM=fetchmotron + +#echo "Current $TEST_VM firewall rules:" +#qvm-firewall $TEST_VM list + +echo "Removing $TEST_VM rules..." +rc=0 +while [ "$rc" = "0" ]; do + qvm-firewall $TEST_VM del --rule-no 0 + rc=$? +done + +#echo "$TEST_VM firewall rules are now:" +#qvm-firewall $TEST_VM list + +#echo "Setting $TEST_VM specialtarget=dns rule:" +qvm-firewall $TEST_VM add accept specialtarget=dns + +#echo "Setting $TEST_VM allow rule for UDP port 1235 to 10.137.0.5:" +qvm-firewall $TEST_VM add accept 10.137.0.5 udp 1235 + +#echo "Setting $TEST_VM allow rule for UDP port 1338 to 10.137.0.5:" +qvm-firewall $TEST_VM add accept 10.137.0.5 udp 1338 + +#echo "Setting $TEST_VM allow rule for TCP port 6668-6670 to 10.137.0.5:" +qvm-firewall $TEST_VM add accept 10.137.0.5 tcp 6668-6670 + +#echo "Setting $TEST_VM allow rule for ICMP type 8 (ping) to 10.137.0.5:" +qvm-firewall $TEST_VM add accept 10.137.0.5 icmp icmptype=8 + +#echo "Setting $TEST_VM allow rule for bogus.linse.me:" +qvm-firewall $TEST_VM add accept dsthost=bogus.linse.me + +#echo "Setting deny rule to host google.com:" +qvm-firewall $TEST_VM add drop dsthost=google.com + +#echo "Setting allow-all on port 443 rule:" +qvm-firewall $TEST_VM add accept proto=tcp dstports=443-443 + +#echo "Setting $TEST_VM deny-all rule:" +qvm-firewall $TEST_VM add drop + +echo "$TEST_VM firewall rules are now:" +qvm-firewall $TEST_VM list diff --git a/unikernel.ml b/unikernel.ml index 6eaca4e..7a3b1d7 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -7,27 +7,15 @@ open Qubes let src = Logs.Src.create "unikernel" ~doc:"Main unikernel code" module Log = (val Logs.src_log src : Logs.LOG) -module Main (Clock : Mirage_clock.MCLOCK) = struct +module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK) = struct + (* Set up networking and listen for incoming packets. *) - let network nat qubesDB = - (* Read configuration from QubesDB *) - Dao.read_network_config qubesDB >>= fun config -> - (* Initialise connection to NetVM *) - Uplink.connect config >>= fun uplink -> + let network uplink qubesDB router = (* Report success *) Dao.set_iptables_error qubesDB "" >>= fun () -> - (* Set up client-side networking *) - let client_eth = Client_eth.create - ~client_gw:config.Dao.clients_our_ip in - (* Set up routing between networks and hosts *) - let router = Router.create - ~client_eth - ~uplink:(Uplink.interface uplink) - ~nat - in (* Handle packets from both networks *) Lwt.choose [ - Client_net.listen Clock.elapsed_ns router; + Client_net.listen Clock.elapsed_ns qubesDB router; Uplink.listen uplink Clock.elapsed_ns router ] @@ -49,17 +37,18 @@ module Main (Clock : Mirage_clock.MCLOCK) = struct ) (* Main unikernel entry point (called from auto-generated main.ml). *) - let start _clock = + let start _random _clock = let start_time = Clock.elapsed_ns () in (* Start qrexec agent, GUI 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 *) qrexec >>= fun qrexec -> let agent_listener = RExec.listen qrexec Command.handler in qubesDB >>= fun qubesDB -> - let startup_time = + let startup_time = let (-) = Int64.sub in let time_in_ns = Clock.elapsed_ns () - start_time in Int64.to_float time_in_ns /. 1e9 @@ -72,7 +61,23 @@ module Main (Clock : Mirage_clock.MCLOCK) = struct (* Set up networking *) let max_entries = Key_gen.nat_table_size () in My_nat.create ~max_entries >>= fun nat -> - let net_listener = network nat qubesDB in + + (* Read network configuration from QubesDB *) + Dao.read_network_config qubesDB >>= fun config -> + + Uplink.connect config >>= fun uplink -> + (* Set up client-side networking *) + let client_eth = Client_eth.create + ~client_gw:config.Dao.clients_our_ip in + (* Set up routing between networks and hosts *) + let router = Router.create + ~client_eth + ~uplink:(Uplink.interface uplink) + ~nat + in + + let net_listener = network uplink qubesDB router in + (* Report memory usage to XenStore *) Memory_pressure.init (); (* Run until something fails or we get a shutdown request. *) From 2d78d47591b18fc147479f90edd0e8b2bac53ff7 Mon Sep 17 00:00:00 2001 From: linse Date: Wed, 29 Apr 2020 16:06:48 +0200 Subject: [PATCH 098/281] Support firewall rules with hostnames. Co-Authored-By: Mindy Preston Co-Authored-By: Olle Jonsson Co-Authored-By: hannes Co-Authored-By: cfcs --- client_net.ml | 18 ++++++------ client_net.mli | 6 ++-- config.ml | 1 + firewall.ml | 18 ++++++------ firewall.mli | 4 ++- my_dns.ml | 57 ++++++++++++++++++++++++++++++++++++++ my_nat.ml | 46 ++++++++++++++++++++++++------- my_nat.mli | 15 ++++++++-- ports.ml | 16 +++++++++++ router.ml | 5 +++- router.mli | 1 + rules.ml | 33 ++++++++++++++-------- unikernel.ml | 15 +++++++--- uplink.ml | 74 ++++++++++++++++++++++++++++++++++---------------- uplink.mli | 19 ++++++++----- 15 files changed, 247 insertions(+), 81 deletions(-) create mode 100644 my_dns.ml create mode 100644 ports.ml diff --git a/client_net.ml b/client_net.ml index 31f3f2d..10d4412 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 packet = +let input_ipv4 get_ts cache ~iface ~router dns_client 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 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 router ~src:iface packet + if src = iface#other_ip then Firewall.ipv4_from_client dns_client 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 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 } ~client_ip ~router ~cleanup_tasks qubesDB = +let add_vif get_ts { Dao.ClientVif.domid; device_id } dns_client ~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 -> @@ -101,7 +101,7 @@ let add_vif get_ts { Dao.ClientVif.domid; device_id } ~client_ip ~router ~cleanu (Ipaddr.V4.to_string client_ip) Fmt.(list ~sep:(unit "@.") Pf_qubes.Parse_qubes.pp_rule) new_rules); (* empty NAT table if rules are updated: they might deny old connections *) - My_nat.remove_connections router.Router.nat client_ip; + My_nat.remove_connections router.Router.nat router.Router.ports client_ip; end); update new_db new_rules in @@ -122,7 +122,7 @@ let add_vif get_ts { Dao.ClientVif.domid; device_id } ~client_ip ~router ~cleanu | 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 payload + | `IPv4 -> input_ipv4 get_ts fragment_cache ~iface ~router dns_client 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 } ~client_ip ~router ~cleanu 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 ~router vif client_ip qubesDB = +let add_client get_ts dns_client ~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 ~client_ip ~router ~cleanup_tasks qubesDB + add_vif get_ts vif dns_client ~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 ~router vif client_ip qubesDB = cleanup_tasks (** Watch XenStore for notifications of new clients. *) -let listen get_ts qubesDB router = +let listen get_ts dns_client 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 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 ~router key ip_addr qubesDB in + let cleanup = add_client get_ts dns_client ~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 0bfbb01..fc1953a 100644 --- a/client_net.mli +++ b/client_net.mli @@ -3,8 +3,10 @@ (** Handling client VMs. *) -val listen : (unit -> int64) -> Qubes.DB.t -> Router.t -> 'a Lwt.t -(** [listen get_timestamp db router] is a thread that watches for clients being added to and +val listen : (unit -> int64) -> + ([ `host ] Domain_name.t -> (int32 * Dns.Rr_map.Ipv4_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 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/config.ml b/config.ml index 87ba926..3075006 100644 --- a/config.ml +++ b/config.ml @@ -34,6 +34,7 @@ let main = package "mirage-nat" ~min:"2.2.1"; package "mirage-logs"; package "mirage-xen" ~min:"5.0.0"; + package ~min:"4.5.0" "dns-client"; package "pf-qubes"; ] "Unikernel.Main" (random @-> mclock @-> job) diff --git a/firewall.ml b/firewall.ml index 48d4fe4..9b1587c 100644 --- a/firewall.ml +++ b/firewall.ml @@ -45,8 +45,9 @@ let translate t packet = (* Add a NAT rule for the endpoints in this frame, via a random port on the firewall. *) let add_nat_and_forward_ipv4 t packet = - let xl_host = t.Router.uplink#my_ip in - My_nat.add_nat_rule_and_translate t.Router.nat ~xl_host `NAT packet >>= function + let open Router in + let xl_host = t.uplink#my_ip in + My_nat.add_nat_rule_and_translate t.nat t.ports ~xl_host `NAT packet >>= function | Ok packet -> forward_ipv4 t packet | Error e -> Log.warn (fun f -> f "Failed to add NAT rewrite rule: %s (%a)" e Nat_packet.pp packet); @@ -54,11 +55,12 @@ let add_nat_and_forward_ipv4 t packet = (* Add a NAT rule to redirect this conversation to [host:port] instead of us. *) let nat_to t ~host ~port packet = - match Router.resolve t host with + let open Router in + match resolve t host with | Ipaddr.V6 _ -> Log.warn (fun f -> f "Cannot NAT with IPv6"); Lwt.return_unit | Ipaddr.V4 target -> - let xl_host = t.Router.uplink#my_ip in - My_nat.add_nat_rule_and_translate t.Router.nat ~xl_host (`Redirect (target, port)) packet >>= function + let xl_host = t.uplink#my_ip in + My_nat.add_nat_rule_and_translate t.nat t.ports ~xl_host (`Redirect (target, port)) packet >>= function | Ok packet -> forward_ipv4 t packet | Error e -> Log.warn (fun f -> f "Failed to add NAT redirect rule: %s (%a)" e Nat_packet.pp packet); @@ -85,11 +87,11 @@ let handle_low_memory t = match Memory_pressure.status () with | `Memory_critical -> (* TODO: should happen before copying and async *) Log.warn (fun f -> f "Memory low - dropping packet and resetting NAT table"); - My_nat.reset t.Router.nat >|= fun () -> + My_nat.reset t.Router.nat t.Router.ports >|= fun () -> `Memory_critical | `Ok -> Lwt.return `Ok -let ipv4_from_client t ~src packet = +let ipv4_from_client resolver t ~src packet = handle_low_memory t >>= function | `Memory_critical -> Lwt.return_unit | `Ok -> @@ -102,7 +104,7 @@ let ipv4_from_client 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 ~dst firewall_packet + | Some firewall_packet -> apply_rules t (Rules.from_client resolver) ~dst firewall_packet let ipv4_from_netvm t packet = handle_low_memory t >>= function diff --git a/firewall.mli b/firewall.mli index 9900f56..88f02ba 100644 --- a/firewall.mli +++ b/firewall.mli @@ -6,6 +6,8 @@ val ipv4_from_netvm : Router.t -> Nat_packet.t -> unit Lwt.t (** Handle a packet from the outside world (this module will validate the source IP). *) -val ipv4_from_client : Router.t -> src:Fw_utils.client_link -> 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 * Dns.Rr_map.Ipv4_set.t, [> `Msg of string ]) result Lwt.t) -> + 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/my_dns.ml b/my_dns.ml new file mode 100644 index 0000000..c94cbb1 --- /dev/null +++ b/my_dns.ml @@ -0,0 +1,57 @@ +open Lwt.Infix + +module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) = struct + type +'a io = 'a Lwt.t + type io_addr = Ipaddr.V4.t * int + type ns_addr = [ `TCP | `UDP ] * io_addr + 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 + + type t = { + nameserver : ns_addr ; + stack : stack ; + timeout_ns : int64 ; + } + type context = { t : t ; timeout_ns : int64 ref; mutable src_port : int } + + let nameserver t = t.nameserver + let rng = R.generate ?g:None + let clock = C.elapsed_ns + + let create ?(nameserver = `UDP, (Ipaddr.V4.of_string_exn "91.239.100.100", 53)) ~timeout stack = + { nameserver ; stack ; timeout_ns = timeout } + + let with_timeout ctx f = + let timeout = OS.Time.sleep_ns !(ctx.timeout_ns) >|= fun () -> Error (`Msg "DNS request timeout") in + let start = clock () in + Lwt.pick [ f ; timeout ] >|= fun result -> + let stop = clock () in + ctx.timeout_ns := Int64.sub !(ctx.timeout_ns) (Int64.sub stop start); + result + + let connect ?nameserver:_ (t : t) = Lwt.return (Ok { t ; timeout_ns = ref t.timeout_ns ; src_port = 0 }) + + let send (ctx : context) buf : (unit, [> `Msg of string ]) result Lwt.t = + let open Router in + let open My_nat in + let dst, dst_port = snd ctx.t.nameserver in + let router, send_udp, _ = ctx.t.stack in + let src_port = Ports.pick_free_port ~consult:router.ports.nat_udp router.ports.dns_udp in + ctx.src_port <- src_port; + with_timeout ctx (send_udp ~src_port ~dst ~dst_port buf >|= Rresult.R.open_error_msg) + + let recv ctx = + let open Router in + let open My_nat in + let router, _, answers = ctx.t.stack in + with_timeout ctx + (Lwt_mvar.take answers >|= fun (_, dns_response) -> Ok dns_response) >|= fun result -> + router.ports.dns_udp := Ports.remove ctx.src_port !(router.ports.dns_udp); + result + + let close _ = Lwt.return_unit + + let bind = Lwt.bind + + let lift = Lwt.return +end + diff --git a/my_nat.ml b/my_nat.ml index 9dfcf68..2652ff5 100644 --- a/my_nat.ml +++ b/my_nat.ml @@ -11,6 +11,20 @@ type action = [ | `Redirect of Mirage_nat.endpoint ] +type ports = { + nat_tcp : Ports.t ref; + nat_udp : Ports.t ref; + nat_icmp : Ports.t ref; + dns_udp : Ports.t ref; +} + +let empty_ports () = + let nat_tcp = ref Ports.empty in + let nat_udp = ref Ports.empty in + let nat_icmp = ref Ports.empty in + let dns_udp = ref Ports.empty in + { nat_tcp ; nat_udp ; nat_icmp ; dns_udp } + module Nat = Mirage_nat_lru type t = { @@ -33,17 +47,23 @@ let translate t packet = None | Ok packet -> Some packet -let random_user_port () = - 1024 + Random.int (0xffff - 1024) +let pick_free_port ~nat_ports ~dns_ports = + Ports.pick_free_port ~consult:dns_ports nat_ports -let reset t = +(* just clears the nat ports, dns ports stay as is *) +let reset t ports = + ports.nat_tcp := Ports.empty; + ports.nat_udp := Ports.empty; + ports.nat_icmp := Ports.empty; Nat.reset t.table -let remove_connections t ip = - let Mirage_nat.{ tcp ; udp } = Nat.remove_connections t.table ip in - ignore(tcp, udp) +let remove_connections t ports ip = + let freed_ports = Nat.remove_connections t.table ip in + ports.nat_tcp := Ports.diff !(ports.nat_tcp) (Ports.of_list freed_ports.Mirage_nat.tcp); + ports.nat_udp := Ports.diff !(ports.nat_udp) (Ports.of_list freed_ports.Mirage_nat.udp); + ports.nat_icmp := Ports.diff !(ports.nat_icmp) (Ports.of_list freed_ports.Mirage_nat.icmp) -let add_nat_rule_and_translate t ~xl_host action packet = +let add_nat_rule_and_translate t ports ~xl_host action packet = let apply_action xl_port = Lwt.catch (fun () -> Nat.add t.table packet (xl_host, xl_port) action @@ -54,19 +74,25 @@ let add_nat_rule_and_translate t ~xl_host action packet = ) in let rec aux ~retries = - let xl_port = random_user_port () in + let nat_ports, dns_ports = + match packet with + | `IPv4 (_, `TCP _) -> ports.nat_tcp, ref Ports.empty + | `IPv4 (_, `UDP _) -> ports.nat_udp, ports.dns_udp + | `IPv4 (_, `ICMP _) -> ports.nat_icmp, ref Ports.empty + in + let xl_port = pick_free_port ~nat_ports ~dns_ports in apply_action xl_port >>= function | Error `Out_of_memory -> (* Because hash tables resize in big steps, this can happen even if we have a fair chunk of free memory. *) Log.warn (fun f -> f "Out_of_memory adding NAT rule. Dropping NAT table..."); - reset t >>= fun () -> + reset t ports >>= fun () -> aux ~retries:(retries - 1) | Error `Overlap when retries < 0 -> Lwt.return (Error "Too many retries") | Error `Overlap -> if retries = 0 then ( Log.warn (fun f -> f "Failed to find a free port; resetting NAT table"); - reset t >>= fun () -> + reset t ports >>= fun () -> aux ~retries:(retries - 1) ) else ( aux ~retries:(retries - 1) diff --git a/my_nat.mli b/my_nat.mli index fc2049d..2ee21e0 100644 --- a/my_nat.mli +++ b/my_nat.mli @@ -3,6 +3,15 @@ (* Abstract over NAT interface (todo: remove this) *) +type ports = private { + nat_tcp : Ports.t ref; + nat_udp : Ports.t ref; + nat_icmp : Ports.t ref; + dns_udp : Ports.t ref; +} + +val empty_ports : unit -> ports + type t type action = [ @@ -11,8 +20,8 @@ type action = [ ] val create : max_entries:int -> t Lwt.t -val reset : t -> unit Lwt.t -val remove_connections : t -> Ipaddr.V4.t -> unit +val reset : t -> ports -> unit Lwt.t +val remove_connections : t -> ports -> Ipaddr.V4.t -> unit val translate : t -> Nat_packet.t -> Nat_packet.t option Lwt.t -val add_nat_rule_and_translate : t -> +val add_nat_rule_and_translate : t -> ports -> xl_host:Ipaddr.V4.t -> action -> Nat_packet.t -> (Nat_packet.t, string) result Lwt.t diff --git a/ports.ml b/ports.ml new file mode 100644 index 0000000..59d3205 --- /dev/null +++ b/ports.ml @@ -0,0 +1,16 @@ +module Set = Set.Make(struct + type t = int + let compare a b = compare a b +end) + +include Set + +let rec pick_free_port ?(retries = 10) ~consult add_to = + let p = 1024 + Random.int (0xffff - 1024) in + if (mem p !consult || mem p !add_to) && retries <> 0 + then pick_free_port ~retries:(retries - 1) ~consult add_to + else + begin + add_to := add p !add_to; + p + end diff --git a/router.ml b/router.ml index 4d7ed90..b91da74 100644 --- a/router.ml +++ b/router.ml @@ -9,10 +9,13 @@ type t = { client_eth : Client_eth.t; nat : My_nat.t; uplink : interface; + (* NOTE: do not try to make this pure, it relies on mvars / side effects *) + ports : My_nat.ports; } let create ~client_eth ~uplink ~nat = - { client_eth; nat; uplink } + let ports = My_nat.empty_ports () in + { client_eth; nat; uplink; ports } let target t buf = let dst_ip = buf.Ipv4_packet.dst in diff --git a/router.mli b/router.mli index 34fa86b..610bddd 100644 --- a/router.mli +++ b/router.mli @@ -9,6 +9,7 @@ type t = private { client_eth : Client_eth.t; nat : My_nat.t; uplink : interface; + ports : My_nat.ports; } val create : diff --git a/rules.ml b/rules.ml index cb6bb6f..da4706c 100644 --- a/rules.ml +++ b/rules.ml @@ -49,51 +49,60 @@ module Classifier = struct end | _, _ -> false - let matches_dest rule packet = + let matches_dest dns_client rule packet = let ip = packet.ipv4_header.Ipv4_packet.dst in match rule.Q.dst with | `any -> Lwt.return @@ `Match rule | `hosts subnet -> Lwt.return @@ if (Ipaddr.Prefix.mem Ipaddr.(V4 ip) subnet) then `Match rule else `No_match | `dnsname name -> - Log.warn (fun f -> f "Resolving %a" Domain_name.pp name); - Lwt.return @@ `No_match + Log.debug (fun f -> f "Resolving %a" Domain_name.pp name); + dns_client name >|= function + | Ok (_ttl, found_ips) -> + if Dns.Rr_map.Ipv4_set.mem ip found_ips + then `Match rule + else `No_match + | Error (`Msg m) -> + Log.warn (fun f -> f "Ignoring rule %a, could not resolve" Q.pp_rule rule); + Log.debug (fun f -> f "%s" m); + `No_match + | Error _ -> assert false (* TODO: fix type of dns_client so that this case can go *) end -let find_first_match packet acc rule = +let find_first_match dns_client packet acc rule = match acc with | `No_match -> if Classifier.matches_proto rule packet - then Classifier.matches_dest rule 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 (packet : ([`Client of Fw_utils.client_link], _) Packet.t) = +let classify_client_packet dns_client (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 packet) `No_match rules >|= function + Lwt_list.fold_left_s (find_first_match dns_client 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 packet = - classify_client_packet packet >|= function +let translate_accepted_packets dns_client packet = + classify_client_packet dns_client 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 (packet : ([`Client of Fw_utils.client_link], _) Packet.t) : Packet.action Lwt.t = +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 packet + | { 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 packet + | { dst = `Client _ ; _ } -> classify_client_packet dns_client 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 7a3b1d7..72f2c83 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -8,15 +8,18 @@ let src = Logs.Src.create "unikernel" ~doc:"Main unikernel code" module Log = (val Logs.src_log src : Logs.LOG) module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK) = struct + module Uplink = Uplink.Make(R)(Clock) + module Dns_transport = My_dns.Transport(R)(Clock) + module Dns_client = Dns_client.Make(Dns_transport) (* Set up networking and listen for incoming packets. *) - let network uplink qubesDB router = + let network dns_client dns_responses uplink qubesDB router = (* Report success *) Dao.set_iptables_error qubesDB "" >>= fun () -> (* Handle packets from both networks *) Lwt.choose [ - Client_net.listen Clock.elapsed_ns qubesDB router; - Uplink.listen uplink Clock.elapsed_ns router + Client_net.listen Clock.elapsed_ns dns_client 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. @@ -76,7 +79,11 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK) = struct ~nat in - let net_listener = network uplink qubesDB router in + let send_dns_query = Uplink.send_dns_client_query uplink in + let dns_mvar = Lwt_mvar.create_empty () in + let dns_client = Dns_client.create (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 (* Report memory usage to XenStore *) Memory_pressure.init (); diff --git a/uplink.ml b/uplink.ml index 343eef3..d4372b3 100644 --- a/uplink.ml +++ b/uplink.ml @@ -9,15 +9,20 @@ module Eth = Ethernet.Make(Netif) let src = Logs.Src.create "uplink" ~doc:"Network connection to NetVM" module Log = (val Logs.src_log src : Logs.LOG) -module Arp = Arp.Make(Eth)(OS.Time) +module Make (R:Mirage_random.S) (Clock : Mirage_clock.MCLOCK) = struct + module Arp = Arp.Make(Eth)(OS.Time) + module I = Static_ipv4.Make(R)(Clock)(Eth)(Arp) + module U = Udp.Make(I)(R) -type t = { - net : Netif.t; - eth : Eth.t; - arp : Arp.t; - interface : interface; - mutable fragments : Fragments.Cache.t; -} + type t = { + net : Netif.t; + eth : Eth.t; + arp : Arp.t; + interface : interface; + mutable fragments : Fragments.Cache.t; + ip : I.t; + udp: U.t; + } class netvm_iface eth mac ~my_ip ~other_ip : interface = object val queue = FrameQ.create (Ipaddr.V4.to_string other_ip) @@ -31,10 +36,26 @@ class netvm_iface eth mac ~my_ip ~other_ip : interface = object ) end -let listen t get_ts router = - Netif.listen t.net ~header_size:Ethernet_wire.sizeof_ethernet (fun frame -> - (* Handle one Ethernet frame from NetVM *) - Eth.input t.eth + let send_dns_client_query t ~src_port ~dst ~dst_port buf = + U.write ~src_port ~dst ~dst_port t.udp buf >|= function + | Error s -> Log.err (fun f -> f "error sending udp packet: %a" U.pp_error s); Error (`Msg "failure") + | Ok () -> Ok () + + let listen t get_ts dns_responses router = + let handle_packet ip_header ip_packet = + let open Udp_packet in + + Log.debug (fun f -> f "received ipv4 packet from %a on uplink" Ipaddr.V4.pp ip_header.Ipv4_packet.src); + match ip_packet with + | `UDP (header, packet) when Ports.mem header.dst_port !(router.Router.ports.My_nat.dns_udp) -> + Log.debug (fun f -> f "found a DNS packet whose dst_port (%d) was in the list of dns_client ports" header.dst_port); + Lwt_mvar.put dns_responses (header, packet) + | _ -> + Firewall.ipv4_from_netvm router (`IPv4 (ip_header, ip_packet)) + in + Netif.listen t.net ~header_size:Ethernet_wire.sizeof_ethernet (fun frame -> + (* Handle one Ethernet frame from NetVM *) + Eth.input t.eth ~arpv4:(Arp.input t.arp) ~ipv4:(fun ip -> let cache, r = @@ -42,30 +63,35 @@ let listen t get_ts router = in t.fragments <- cache; match r with - | Error e -> - Log.warn (fun f -> f "Ignored unknown IPv4 message from uplink: %a" Nat_packet.pp_error e); - Lwt.return_unit - | Ok None -> Lwt.return_unit - | Ok (Some packet) -> - Firewall.ipv4_from_netvm router packet - ) + | Error e -> + Log.warn (fun f -> f "Ignored unknown IPv4 message from uplink: %a" Nat_packet.pp_error e); + Lwt.return () + | Ok None -> Lwt.return_unit + | Ok (Some (`IPv4 (header, packet))) -> handle_packet header packet + ) ~ipv6:(fun _ip -> Lwt.return_unit) frame ) >|= or_raise "Uplink listen loop" Netif.pp_error + let interface t = t.interface let connect config = - let ip = config.Dao.uplink_our_ip in + let my_ip = config.Dao.uplink_our_ip in + let gateway = config.Dao.uplink_netvm_ip in Netif.connect "0" >>= fun net -> Eth.connect net >>= fun eth -> Arp.connect eth >>= fun arp -> - Arp.add_ip arp ip >>= fun () -> + Arp.add_ip arp my_ip >>= fun () -> + let network = Ipaddr.V4.Prefix.make 0 Ipaddr.V4.any in + I.connect ~ip:(network, my_ip) ~gateway eth arp >>= fun ip -> + U.connect ip >>= fun udp -> let netvm_mac = - Arp.query arp config.Dao.uplink_netvm_ip + Arp.query arp gateway >|= or_raise "Getting MAC of our NetVM" Arp.pp_error in let interface = new netvm_iface eth netvm_mac - ~my_ip:ip + ~my_ip ~other_ip:config.Dao.uplink_netvm_ip in let fragments = Fragments.Cache.empty (256 * 1024) in - Lwt.return { net; eth; arp; interface ; fragments } + Lwt.return { net; eth; arp; interface ; fragments ; ip ; udp } +end diff --git a/uplink.mli b/uplink.mli index 776b1a4..438e04a 100644 --- a/uplink.mli +++ b/uplink.mli @@ -5,13 +5,18 @@ open Fw_utils -type t +[@@@ocaml.warning "-67"] +module Make (R: Mirage_random.S)(Clock : Mirage_clock.MCLOCK) : sig + type t -val connect : Dao.network_config -> t Lwt.t -(** Connect to our NetVM (gateway). *) + val connect : Dao.network_config -> t Lwt.t + (** Connect to our NetVM (gateway). *) -val interface : t -> interface -(** The network interface to NetVM. *) + val interface : t -> interface + (** The network interface to NetVM. *) -val listen : t -> (unit -> int64) -> Router.t -> unit Lwt.t -(** Handle incoming frames from NetVM. *) + val listen : t -> (unit -> int64) -> (Udp_packet.t * Cstruct.t) Lwt_mvar.t -> Router.t -> unit Lwt.t + (** Handle incoming frames from NetVM. *) + + val send_dns_client_query: t -> src_port:int-> dst:Ipaddr.V4.t -> dst_port:int -> Cstruct.t -> (unit, [`Msg of string]) result Lwt.t +end From 8927a45f43029a226c8a4dcba64666979f8283fe Mon Sep 17 00:00:00 2001 From: linse Date: Fri, 15 May 2020 17:31:30 +0200 Subject: [PATCH 099/281] [ci skip] Edit CHANGES --- CHANGES.md | 15 +++++++++++++++ build-with-docker.sh | 2 +- 2 files changed, 16 insertions(+), 1 deletion(-) diff --git a/CHANGES.md b/CHANGES.md index 6284c3e..5d4f268 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,18 @@ +### master branch + +This version adapts qubes-mirage-firewall with +- dynamic rulesets via QubesDB (as defined in Qubes 4.0), and +- adds support for DNS hostnames in rules, using the pf-qubes library for parsing. + +The DNS client is provided by DNS (>= 4.2.0) which uses a cache for name lookups. Not every packet will lead to a DNS lookup if DNS rules are in place. + +A test unikernel is available in the test subdirectory. + +This project was done by @linse and @yomimono in summer 2019, see PR #96. + +Additional changes and bugfixes: +TODO: describe based on commit log de7d05e .. 02e515d + ### 0.6 Changes to rules language: diff --git a/build-with-docker.sh b/build-with-docker.sh index 2a7bb42..4cefbb6 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 qubes_firewall.xen)" -echo "SHA2 last known: 83b96bd453c3c3cfb282076be81055026eca437b621b3ef3f2642af04ad782e2" +echo "SHA2 last known: 7a6b003e712256cce7ac8741239f6d8d5a0db4b71656396f7ee734568282c72d" echo "(hashes should match for released versions)" From 6a1b012527b98a3c1c7e7ce7703f584b67ae2422 Mon Sep 17 00:00:00 2001 From: xaki23 Date: Fri, 15 May 2020 18:36:03 +0200 Subject: [PATCH 100/281] bump qubes-builder ocaml-version to 4.10.0 for gcc-10 compatibility --- Makefile.builder | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile.builder b/Makefile.builder index ee3c966..2c049cd 100644 --- a/Makefile.builder +++ b/Makefile.builder @@ -1,5 +1,5 @@ MIRAGE_KERNEL_NAME = qubes_firewall.xen -OCAML_VERSION ?= 4.08.1 +OCAML_VERSION ?= 4.10.0 SOURCE_BUILD_DEP := firewall-build-dep firewall-build-dep: From 470160dcb2bad01e21a0df6dbb6f03d8d289fce4 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Sat, 16 May 2020 15:19:05 +0100 Subject: [PATCH 101/281] Update changelog --- CHANGES.md | 36 ++++++++++++++++++++++++++++++++++++ 1 file changed, 36 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index 5d4f268..12153de 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -13,6 +13,42 @@ This project was done by @linse and @yomimono in summer 2019, see PR #96. Additional changes and bugfixes: TODO: describe based on commit log de7d05e .. 02e515d +- Support Mirage 3.7 and mirage-nat 2.0.0 (@hannesm, #89). + The main improvement is fragmentation and reassembly support. + +- Use the smaller OCurrent images as the base for building the Docker images (@talex5, #80). + - Before: 1 GB (ocaml/opam2:debian-10-ocaml-4.08) + - Now: 309 MB (ocurrent/opam:alpine-3.10-ocaml-4.08) + +- Removed unreachable `Lwt.catch` (@hannesm, #90). + +Documentation: + +- Add note that AppVM used to build from source may need a private image larger than the default 2048MB (@marmot1791, #83). + +- README: create the symlink-redirected docker dir (@xaki23, #75). Otherwise, installing the docker package removes the dangling symlink. + +- Note that mirage-firewall cannot be used as UpdateVM (@talex5, #68). + +- Fix ln(1) call in build instructions (@jaseg, #69). The arguments were backwards. + +Keeping up with upstream changes: + +- Support mirage-3.7 via qubes-builder (@xaki23, #91). + +- Remove unused `Clock` argument to `Uplink` (@talex5, #90). + +- Rename things for newer mirage-xen versions (@xaki23, #80). + +- Adjust to ipaddr-4.0.0 renaming `_bytes` to `_octets` (@xaki23, #75). + +- Use OCaml 4.08.0 for qubes-builder builds (was 4.07.1) (@xaki23, #75). + +- Remove netchannel pin as 1.11.0 is now released (@talex5, #72). + +- Remove cmdliner pin as 1.0.4 is now released (@talex5, #71). + + ### 0.6 Changes to rules language: From cc534d9618edbdd909e2a1bc8e840d83a3043ed0 Mon Sep 17 00:00:00 2001 From: linse Date: Tue, 19 May 2020 11:07:25 +0200 Subject: [PATCH 102/281] Update changes for release. --- CHANGES.md | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 12153de..a9a3bc7 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,4 +1,4 @@ -### master branch +### 0.7 This version adapts qubes-mirage-firewall with - dynamic rulesets via QubesDB (as defined in Qubes 4.0), and @@ -11,7 +11,6 @@ A test unikernel is available in the test subdirectory. This project was done by @linse and @yomimono in summer 2019, see PR #96. Additional changes and bugfixes: -TODO: describe based on commit log de7d05e .. 02e515d - Support Mirage 3.7 and mirage-nat 2.0.0 (@hannesm, #89). The main improvement is fragmentation and reassembly support. From 53bf4f960cd910349e4fe7a097eb854f79c94be5 Mon Sep 17 00:00:00 2001 From: linse Date: Tue, 19 May 2020 14:35:22 +0200 Subject: [PATCH 103/281] update to ocaml 4.10 and mirage 3.7.7 --- Dockerfile | 8 ++++---- Makefile.builder | 2 +- build-with-docker.sh | 2 +- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/Dockerfile b/Dockerfile index d49cadf..5bd2d95 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,15 +1,15 @@ # Pin the base image to a specific hash for maximum reproducibility. # It will probably still work on newer images, though, unless Debian # changes some compiler optimisations (unlikely). -#FROM ocurrent/opam:alpine-3.10-ocaml-4.08 -FROM ocurrent/opam@sha256:3f3ce7e577a94942c7f9c63cbdd1ecbfe0ea793f581f69047f3155967bba36f6 +#FROM ocurrent/opam:alpine-3.10-ocaml-4.10 +FROM ocurrent/opam@sha256:d30098ff92b5ee10cf7c11c17f2351705e5226a6b05aa8b9b7280b3d87af9cde # 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 ~/opam-repository && git fetch origin master && git reset --hard 3548c2a8537029b8165466cd9c5a94bb7bc30405 && opam update +RUN cd ~/opam-repository && git fetch origin master && git reset --hard 4dd2620bcc821418bae53669a6c6163964c090a2 && opam update -RUN opam depext -i -y mirage.3.7.6 lwt.5.2.0 +RUN opam depext -i -y mirage.3.7.7 lwt.5.3.0 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/Makefile.builder b/Makefile.builder index 2c049cd..f93d74c 100644 --- a/Makefile.builder +++ b/Makefile.builder @@ -4,5 +4,5 @@ SOURCE_BUILD_DEP := firewall-build-dep firewall-build-dep: opam install -y depext - opam depext -i -y mirage.3.7.6 lwt.5.2.0 + opam depext -i -y mirage.3.7.7 lwt.5.3.0 diff --git a/build-with-docker.sh b/build-with-docker.sh index 4cefbb6..3e7eb33 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 qubes_firewall.xen)" -echo "SHA2 last known: 7a6b003e712256cce7ac8741239f6d8d5a0db4b71656396f7ee734568282c72d" +echo "SHA2 last known: 4f4456b5fe7c8ae1ba2f6934cf89749cf6aae9a90cce899cf744c89d311467a3" echo "(hashes should match for released versions)" From 60ebd61b72856b5ff17cc31efac5ebe56297851e Mon Sep 17 00:00:00 2001 From: linse Date: Tue, 19 May 2020 16:48:48 +0200 Subject: [PATCH 104/281] Update documentation. --- README.md | 14 +- diagrams/components.svg | 326 +++++++++++++++++++++++----------------- 2 files changed, 193 insertions(+), 147 deletions(-) diff --git a/README.md b/README.md index be85574..0c22988 100644 --- a/README.md +++ b/README.md @@ -3,8 +3,6 @@ A unikernel that can run as a QubesOS ProxyVM, replacing `sys-firewall`. It uses the [mirage-qubes][] library to implement the Qubes protocols. -Note: This firewall *ignores the rules set in the Qubes GUI*. See `rules.ml` for the actual policy. - See [A Unikernel Firewall for QubesOS][] for more details. @@ -63,8 +61,8 @@ Run this command in dom0 to create a `mirage-firewall` VM using the `mirage-fire qvm-create \ --property kernel=mirage-firewall \ --property kernelopts=None \ - --property memory=32 \ - --property maxmem=32 \ + --property memory=64 \ + --property maxmem=64 \ --property netvm=sys-net \ --property provides_network=True \ --property vcpus=1 \ @@ -106,7 +104,7 @@ This diagram show the main components (each box corresponds to a source `.ml` fi

Ethernet frames arrives from client qubes (such as `work` or `personal`) or from `sys-net`. -Internet (IP) packets are sent to `firewall`, which consults `rules` to decide what to do with the packet. +Internet (IP) packets are sent to `firewall`, which consults the NAT table and the rules from QubesDB to decide what to do with the packet. If it should be sent on, it uses `router` to send it to the chosen destination. `client_net` watches the XenStore database provided by dom0 to find out when clients need to be added or removed. @@ -167,10 +165,8 @@ This takes a little more setting up the first time, but will be much quicker aft # Testing if the firewall works -Build the test unikernel in the test directory. -Install it to a vm which has the firewall as netvm. -Set the rules for the testvm to "textfile". -Run the test unikernel. +A unikernel which tests the firewall is available in the `test/` subdirectory. +To use it, run `test.sh` and follow the instructions to set up the test environment. # Security advisories diff --git a/diagrams/components.svg b/diagrams/components.svg index 1e996b1..2d69f9d 100644 --- a/diagrams/components.svg +++ b/diagrams/components.svg @@ -1,149 +1,199 @@ - + - - - - - - - - - - - - - - - - + + + + + + + - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + - - + + - - - + + + + + - - - - - - - -l -y -s -t -k -r -u -l -n -_ -r -i -e -l -o -n -k -n -o -o -e -e -e -l -s -t -( -f -p -i -i -o -w -t -u -n -- -a -o -X -S -r -m -u -c -r -] -e -r -i -n -s -t -e -k -s -w -e -. -n -e -l -r -s -e -s -r + + + + + + + + + +r +e +n +k +e +t +t +w +o +w +e +c +n +n +o +S +( +n +t +0 +] +n +m +. +B +k +t l -[ -. -p -n -t -o -o -c -h -. -c -t -m +k +i +e +r +c +s +b +i +d +e +n +t +h +b +l +k +- +f +a +e +n +s +i +s +r +. +e +o +o +u +n +c +a +l +o +) +- +i +l +r +e +m +i +s +r +e +l +D +c +[ +n +s +o +f +- +- +l +o +r +t +c +_ +i +m +u +Q +t +e +a +h +. +t +p +l +n +r +e +p +s +n +n +y +X +e +u +s +e +t +h +o +u +a +t +r +r a -e -r -d -0 -) +o +t +- +e +f From b5ec221e2a95711660aac96838f1cdb32fdf943b Mon Sep 17 00:00:00 2001 From: linse Date: Tue, 19 May 2020 17:47:40 +0200 Subject: [PATCH 105/281] Handle other IP formats from xenstore. Example: "10.137.0.18 fd09:24ef:3178::a19:11" reported via https://twitter.com/t_grote/status/1262747002334408704 --- dao.ml | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) diff --git a/dao.ml b/dao.ml index 8a14c22..d1580e1 100644 --- a/dao.ml +++ b/dao.ml @@ -79,8 +79,20 @@ let vifs ~handle domid = Lwt.try_bind (fun () -> OS.Xs.read handle (Printf.sprintf "%s/%d/ip" path device_id)) (fun client_ip -> - let client_ip = Ipaddr.V4.of_string_exn client_ip in - Lwt.return (Some (vif, 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 From 620bbb5b353d2afe2a9e17cd628adb62707ef975 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 19 Jun 2020 08:24:18 +0000 Subject: [PATCH 106/281] update opam repository commit hash for release --- Dockerfile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Dockerfile b/Dockerfile index 5bd2d95..79bf15f 100644 --- a/Dockerfile +++ b/Dockerfile @@ -7,7 +7,7 @@ FROM ocurrent/opam@sha256:d30098ff92b5ee10cf7c11c17f2351705e5226a6b05aa8b9b7280b # 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 ~/opam-repository && git fetch origin master && git reset --hard 4dd2620bcc821418bae53669a6c6163964c090a2 && opam update +RUN cd ~/opam-repository && git fetch origin master && git reset --hard 0cd6dafebfb49a3b56cce8e6651aa83c591214d5 && opam update RUN opam depext -i -y mirage.3.7.7 lwt.5.3.0 RUN mkdir /home/opam/qubes-mirage-firewall From 3ee01b5243fb67c56c7827b6bf00613ba758e881 Mon Sep 17 00:00:00 2001 From: linse Date: Fri, 19 Jun 2020 08:56:33 +0000 Subject: [PATCH 107/281] changes for 0.7.1 Co-Authored-By: hannes --- CHANGES.md | 8 ++++++++ README.md | 2 ++ build-with-docker.sh | 2 +- 3 files changed, 11 insertions(+), 1 deletion(-) diff --git a/CHANGES.md b/CHANGES.md index a9a3bc7..a9615e4 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,11 @@ +### 0.7.1 + +Bugfixes: + +- More robust parsing of IP address in Xenstore, which may contain both IPv4 and IPv6 addresses (@linse, #103, reported by @grote) + +- Avoid stack overflow with many connections in the NAT table (@linse and @hannesm, reported by @talex5 in #105, fixed by mirage-nat 2.2.2 release) + ### 0.7 This version adapts qubes-mirage-firewall with diff --git a/README.md b/README.md index 0c22988..a316636 100644 --- a/README.md +++ b/README.md @@ -70,6 +70,8 @@ qvm-create \ --label=green \ --class StandaloneVM \ mirage-firewall + +qvm-features mirage-firewall qubes-firewall 1 ``` To upgrade from an earlier release, just overwrite `/var/lib/qubes/vm-kernels/mirage-firewall/vmlinuz` with the new version and restart the firewall VM. diff --git a/build-with-docker.sh b/build-with-docker.sh index 3e7eb33..5892333 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 qubes_firewall.xen)" -echo "SHA2 last known: 4f4456b5fe7c8ae1ba2f6934cf89749cf6aae9a90cce899cf744c89d311467a3" +echo "SHA2 last known: c2d7206d57e5977a608735af46e5ac5af0aa6cd5e052f0a177322dd76b67690c" echo "(hashes should match for released versions)" From f9842e8b188b7180b0e94ce8f143f4a1aff86e20 Mon Sep 17 00:00:00 2001 From: Krzysztof Burghardt Date: Sat, 20 Jun 2020 01:16:29 +0200 Subject: [PATCH 108/281] Do not run tar in dom0 (closes #84). Do not run tar and bzip2 in dom0 to decompresses and extract archive data created in, or downloaded to domU as any vulnerabilities in them can compromise Qubes OS security model. Instead of that run both tar and bzip2 in domU and copy unikernel to dom0 as described in official Qubes documentation ["Copying from (and to) dom0"](https://www.qubes-os.org/doc/copy-from-dom0/#copying-to-dom0). Auxiliary files required to run unikernel in Qubes OS domU can be easily created directly in dom0 using trusted tools available there. --- README.md | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) diff --git a/README.md b/README.md index a316636..c4be96c 100644 --- a/README.md +++ b/README.md @@ -48,12 +48,21 @@ However, it should still work fine. ## Deploy -If you want to deploy manually, unpack `mirage-firewall.tar.bz2` in dom0, inside `/var/lib/qubes/vm-kernels/`. e.g. (if `dev` is the AppVM where you built it): +If you want to deploy manually, unpack `mirage-firewall.tar.bz2` in domU. The tarball contains `vmlinuz`, +which is the unikernel itself, plus a couple of dummy files that Qubes requires: - [tal@dom0 ~]$ cd /var/lib/qubes/vm-kernels/ - [tal@dom0 vm-kernels]$ qvm-run -p dev 'cat qubes-mirage-firewall/mirage-firewall.tar.bz2' | tar xjf - + [user@dev ~]$ tar xjf mirage-firewall.tar.bz2 -The tarball contains `vmlinuz`, which is the unikernel itself, plus a couple of dummy files that Qubes requires. +Copy `vmlinuz` to `/var/lib/qubes/vm-kernels/mirage-firewall` directory in dom0, e.g. (if `dev` is the AppVM where you built it): + + [tal@dom0 ~]$ mkdir -p /var/lib/qubes/vm-kernels/mirage-firewall/ + [tal@dom0 ~]$ cd /var/lib/qubes/vm-kernels/mirage-firewall/ + [tal@dom0 mirage-firewall]$ qvm-run -p dev 'cat mirage-firewall/vmlinuz' > vmlinuz + +Finally create dummy files required by Qubes OS: + + [tal@dom0 mirage-firewall]$ touch modules.img + [tal@dom0 mirage-firewall]$ gzip -n9 < /dev/null > initramfs Run this command in dom0 to create a `mirage-firewall` VM using the `mirage-firewall` kernel you added above: From de0eb9d9703b2a68609a835e407fdf5a2c838b1f Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 3 Jul 2020 16:39:06 +0200 Subject: [PATCH 109/281] adapt to mirage 3.8.0 changes (ipaddr5, tcpip5); bump opam-repository hash (to get netchannel+mirage-net-xen 0.13.1) --- Dockerfile | 4 ++-- Makefile.builder | 2 +- uplink.ml | 4 ++-- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/Dockerfile b/Dockerfile index 79bf15f..43d1adb 100644 --- a/Dockerfile +++ b/Dockerfile @@ -7,9 +7,9 @@ FROM ocurrent/opam@sha256:d30098ff92b5ee10cf7c11c17f2351705e5226a6b05aa8b9b7280b # 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 ~/opam-repository && git fetch origin master && git reset --hard 0cd6dafebfb49a3b56cce8e6651aa83c591214d5 && opam update +RUN cd ~/opam-repository && git fetch origin master && git reset --hard e81ab2996896b21cba74c43a903b305a5a6341ef && opam update -RUN opam depext -i -y mirage.3.7.7 lwt.5.3.0 +RUN opam depext -i -y mirage.3.8.0 lwt.5.3.0 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/Makefile.builder b/Makefile.builder index f93d74c..37c5f43 100644 --- a/Makefile.builder +++ b/Makefile.builder @@ -4,5 +4,5 @@ SOURCE_BUILD_DEP := firewall-build-dep firewall-build-dep: opam install -y depext - opam depext -i -y mirage.3.7.7 lwt.5.3.0 + opam depext -i -y mirage.3.8.0 lwt.5.3.0 diff --git a/uplink.ml b/uplink.ml index d4372b3..683f006 100644 --- a/uplink.ml +++ b/uplink.ml @@ -83,8 +83,8 @@ let connect config = Eth.connect net >>= fun eth -> Arp.connect eth >>= fun arp -> Arp.add_ip arp my_ip >>= fun () -> - let network = Ipaddr.V4.Prefix.make 0 Ipaddr.V4.any in - I.connect ~ip:(network, my_ip) ~gateway eth arp >>= fun ip -> + let cidr = Ipaddr.V4.Prefix.make 0 my_ip in + I.connect ~cidr ~gateway eth arp >>= fun ip -> U.connect ip >>= fun udp -> let netvm_mac = Arp.query arp gateway From aebaa2cafcde70552a46e720dcb672acd24a5658 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 3 Jul 2020 16:55:38 +0200 Subject: [PATCH 110/281] update sha256 from travis run --- 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 5892333..9820d15 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 qubes_firewall.xen)" -echo "SHA2 last known: c2d7206d57e5977a608735af46e5ac5af0aa6cd5e052f0a177322dd76b67690c" +echo "SHA2 last known: 0f6b41fa3995afccff1809cb893c45c0863477d4dfacc441c11e3382bec31d39" echo "(hashes should match for released versions)" From c173bf1cb0c8ded105a36fa6aeb65adc52bc1e03 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sat, 24 Oct 2020 12:43:08 +0200 Subject: [PATCH 111/281] README: use kernelopts='' instead of None --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index c4be96c..68b28d5 100644 --- a/README.md +++ b/README.md @@ -69,7 +69,7 @@ Run this command in dom0 to create a `mirage-firewall` VM using the `mirage-fire ``` qvm-create \ --property kernel=mirage-firewall \ - --property kernelopts=None \ + --property kernelopts='' \ --property memory=64 \ --property maxmem=64 \ --property netvm=sys-net \ From 3dbb9ecb27846e786f2f096034a0a9dd9a24ed64 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Wed, 19 Aug 2020 14:09:01 +0100 Subject: [PATCH 112/281] BROKEN: Upgrade to Mirage 6 for solo5 PVH support For me, this mostly hangs at: ``` 2020-10-26 11:16:31 -00:00: INF [qubes.rexec] waiting for client... 2020-10-26 11:16:31 -00:00: INF [qubes.gui] waiting for client... 2020-10-26 11:16:31 -00:00: INF [qubes.db] connecting to server... ``` Sometimes it gets a bit further: ``` 2020-10-26 11:14:19 -00:00: INF [qubes.rexec] waiting for client... 2020-10-26 11:14:19 -00:00: INF [qubes.gui] waiting for client... 2020-10-26 11:14:19 -00:00: INF [qubes.db] connecting to server... 2020-10-26 11:14:19 -00:00: INF [qubes.db] connected 2020-10-26 11:14:19 -00:00: INF [qubes.rexec] client connected, using protocol version 2 2020-10-26 11:14:19 -00:00: INF [qubes.gui] client connected (screen size: 3840x2160 depth: 24 mem: 32401x) 2020-10-26 11:14:19 -00:00: INF [unikernel] GUI agent connected ``` --- Dockerfile | 6 +++--- build-with-docker.sh | 2 +- config.ml | 2 +- memory_pressure.ml | 42 +++++++++++++++++++++++------------------- 4 files changed, 28 insertions(+), 24 deletions(-) diff --git a/Dockerfile b/Dockerfile index 43d1adb..c09868d 100644 --- a/Dockerfile +++ b/Dockerfile @@ -2,14 +2,14 @@ # It will probably still work on newer images, though, unless Debian # changes some compiler optimisations (unlikely). #FROM ocurrent/opam:alpine-3.10-ocaml-4.10 -FROM ocurrent/opam@sha256:d30098ff92b5ee10cf7c11c17f2351705e5226a6b05aa8b9b7280b3d87af9cde +FROM ocurrent/opam@sha256:4546b41a99b54f163af435327c86f88d06346f2a059f0f42bea431b37329ea8d # 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 ~/opam-repository && git fetch origin master && git reset --hard e81ab2996896b21cba74c43a903b305a5a6341ef && opam update +RUN cd ~/opam-repository && git fetch origin master && git reset --hard 6ef290f5681b7ece5d9c085bcf0c55268c118292 && opam update -RUN opam depext -i -y mirage.3.8.0 lwt.5.3.0 +RUN opam depext -i -y mirage 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 9820d15..ed8e5e6 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 qubes_firewall.xen)" -echo "SHA2 last known: 0f6b41fa3995afccff1809cb893c45c0863477d4dfacc441c11e3382bec31d39" +echo "SHA2 last known: a635ead410ffb72abb8b44e8c5f8f2cfc8752c4787e737ed6cdc0089143ace00" echo "(hashes should match for released versions)" diff --git a/config.ml b/config.ml index 3075006..fb2cd2e 100644 --- a/config.ml +++ b/config.ml @@ -33,7 +33,7 @@ let main = package "mirage-qubes" ~min:"0.8.2"; package "mirage-nat" ~min:"2.2.1"; package "mirage-logs"; - package "mirage-xen" ~min:"5.0.0"; + package "mirage-xen" ~min:"6.0.0"; package ~min:"4.5.0" "dns-client"; package "pf-qubes"; ] diff --git a/memory_pressure.ml b/memory_pressure.ml index ed5b7e5..cecf4a9 100644 --- a/memory_pressure.ml +++ b/memory_pressure.ml @@ -6,44 +6,48 @@ open Lwt let src = Logs.Src.create "memory_pressure" ~doc:"Memory pressure monitor" module Log = (val Logs.src_log src : Logs.LOG) -let total_pages = OS.MM.Heap_pages.total () -let pagesize_kb = Io_page.page_size / 1024 +let wordsize_in_bytes = Sys.word_size / 8 -let meminfo ~used = - let mem_total = total_pages * pagesize_kb in - let mem_free = (total_pages - used) * pagesize_kb in - Log.info (fun f -> f "Writing meminfo: free %d / %d kB (%.2f %%)" - mem_free mem_total (float_of_int mem_free /. float_of_int mem_total *. 100.0)); +let fraction_free stats = + let { OS.Memory.free_words; heap_words; _ } = stats in + float free_words /. float heap_words + +let meminfo stats = + let { 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 "Writing meminfo: free %a / %a (%.2f %%)" + Fmt.bi_byte_size mem_free + Fmt.bi_byte_size mem_total + (fraction_free stats *. 100.0)); Printf.sprintf "MemTotal: %d kB\n\ MemFree: %d kB\n\ Buffers: 0 kB\n\ Cached: 0 kB\n\ SwapTotal: 0 kB\n\ - SwapFree: 0 kB\n" mem_total mem_free + SwapFree: 0 kB\n" (mem_total / 1024) (mem_free / 1024) -let report_mem_usage used = +let report_mem_usage stats = Lwt.async (fun () -> let open OS in Xs.make () >>= fun xs -> Xs.immediate xs (fun h -> - Xs.write h "memory/meminfo" (meminfo ~used) + Xs.write h "memory/meminfo" (meminfo stats) ) ) let init () = Gc.full_major (); - let used = OS.MM.Heap_pages.used () in - report_mem_usage used + let stats = OS.Memory.quick_stat () in + report_mem_usage stats let status () = - let used = OS.MM.Heap_pages.used () |> float_of_int in - let frac = used /. float_of_int total_pages in - if frac < 0.9 then `Ok + let stats = OS.Memory.quick_stat () in + if fraction_free stats > 0.1 then `Ok else ( Gc.full_major (); - let used = OS.MM.Heap_pages.used () in - report_mem_usage used; - let frac = float_of_int used /. float_of_int total_pages in - if frac > 0.9 then `Memory_critical + let stats = OS.Memory.quick_stat () in + report_mem_usage stats; + if fraction_free stats < 0.1 then `Memory_critical else `Ok ) From be7461a20a3aabf20822414d992fad72453197c7 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Mon, 26 Oct 2020 15:19:30 +0000 Subject: [PATCH 113/281] Switch Docker base image from Alpine to Fedora There seems to be a problem with Xen events getting lost on Alpine. --- Dockerfile | 6 +++--- build-with-docker.sh | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/Dockerfile b/Dockerfile index c09868d..cf568ce 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,8 +1,8 @@ # Pin the base image to a specific hash for maximum reproducibility. -# It will probably still work on newer images, though, unless Debian +# It will probably still work on newer images, though, unless an update # changes some compiler optimisations (unlikely). -#FROM ocurrent/opam:alpine-3.10-ocaml-4.10 -FROM ocurrent/opam@sha256:4546b41a99b54f163af435327c86f88d06346f2a059f0f42bea431b37329ea8d +#FROM ocurrent/opam:fedora-32-ocaml-4.10 +FROM ocurrent/opam@sha256:2e0e1689d2260c202bf944034f15ba8ebe945dba6b126cc6dd6b185c223014f3 # Pin last known-good version for reproducible builds. # Remove this line (and the base image pin above) if you want to test with the diff --git a/build-with-docker.sh b/build-with-docker.sh index ed8e5e6..74df80c 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 qubes_firewall.xen)" -echo "SHA2 last known: a635ead410ffb72abb8b44e8c5f8f2cfc8752c4787e737ed6cdc0089143ace00" +echo "SHA2 last known: 583d22327500fa092f436af1d0d9b1b78ebe12abd814c128ec7452c2f4cf319a" echo "(hashes should match for released versions)" From d8ae7f749cfcd01583caabf542c12c84cc874643 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Mon, 26 Oct 2020 15:38:14 +0000 Subject: [PATCH 114/281] Update README --- README.md | 26 ++++++++++++++++++++------ 1 file changed, 20 insertions(+), 6 deletions(-) diff --git a/README.md b/README.md index 68b28d5..7b8abbb 100644 --- a/README.md +++ b/README.md @@ -13,6 +13,10 @@ See the [Deploy](#deploy) section below for installation instructions. ## Build from source +Note: The most reliable way to build is using Docker. +Fedora 30 works well for this, but installing Docker on Fedora 31 or 32 is more difficult. +Debian 10 also works, but you'll need to follow the instructions at [docker.com][debian-docker] to get Docker +(don't use Debian's version). Create a new Fedora-30 AppVM (or reuse an existing one). In the Qube's Settings (Basic / Disk storage), increase the private storage max size from the default 2048 MiB to 4096 MiB. Open a terminal. @@ -33,8 +37,6 @@ It gives Docker more disk space and avoids losing the Docker image cache when yo Note: the object files are stored in the `_build` directory to speed up incremental builds. If you change the dependencies, you will need to delete this directory before rebuilding. -If you want to build on Debian, follow the instructions at [docker.com][debian-docker] to get Docker and then run `sudo ./build-with-docker.sh` as above. - It's OK to install the Docker package in a template VM if you want it to remain after a reboot, but the build of the firewall itself should be done in a regular AppVM. @@ -59,12 +61,11 @@ Copy `vmlinuz` to `/var/lib/qubes/vm-kernels/mirage-firewall` directory in dom0, [tal@dom0 ~]$ cd /var/lib/qubes/vm-kernels/mirage-firewall/ [tal@dom0 mirage-firewall]$ qvm-run -p dev 'cat mirage-firewall/vmlinuz' > vmlinuz -Finally create dummy files required by Qubes OS: +Finally, create [a dummy file required by Qubes OS](https://github.com/QubesOS/qubes-issues/issues/5516): - [tal@dom0 mirage-firewall]$ touch modules.img [tal@dom0 mirage-firewall]$ gzip -n9 < /dev/null > initramfs -Run this command in dom0 to create a `mirage-firewall` VM using the `mirage-firewall` kernel you added above: +Run this command in dom0 to create a `mirage-firewall` VM using the `mirage-firewall` kernel you added above ``` qvm-create \ @@ -75,16 +76,29 @@ qvm-create \ --property netvm=sys-net \ --property provides_network=True \ --property vcpus=1 \ - --property virt_mode=pv \ + --property virt_mode=pvh \ --label=green \ --class StandaloneVM \ mirage-firewall qvm-features mirage-firewall qubes-firewall 1 +qvm-features mirage-firewall no-default-kernelopts 1 ``` +**Note**: for `virt_mode`, use `pv` instead of `pvh` for firewall versions before 0.8. + +## Upgrading + To upgrade from an earlier release, just overwrite `/var/lib/qubes/vm-kernels/mirage-firewall/vmlinuz` with the new version and restart the firewall VM. +If upgrading from a version before 0.8, you will also need to update a few options: + +``` +qvm-prefs mirage-firewall kernelopts '' +qvm-prefs mirage-firewall virt_mode pvh +qvm-features mirage-firewall no-default-kernelopts 1 +``` + ### Configure AppVMs to use it You can run `mirage-firewall` alongside your existing `sys-firewall` and you can choose which AppVMs use which firewall using the GUI. From 26b5b59b56f218516f87dbff790e3fb1672ad723 Mon Sep 17 00:00:00 2001 From: xaki23 Date: Wed, 28 Oct 2020 13:14:16 +0100 Subject: [PATCH 115/281] unpin mirage+lwt versions for qubes-builder --- Makefile.builder | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile.builder b/Makefile.builder index 37c5f43..68a35b9 100644 --- a/Makefile.builder +++ b/Makefile.builder @@ -4,5 +4,5 @@ SOURCE_BUILD_DEP := firewall-build-dep firewall-build-dep: opam install -y depext - opam depext -i -y mirage.3.8.0 lwt.5.3.0 + opam depext -i -y mirage From a368b12648cbd737845190badc889e10c3e98e0a Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Thu, 3 Dec 2020 16:11:56 +0000 Subject: [PATCH 116/281] Update to mirage-qubes 0.9.1 for qrexec3 compatibility Also, switch to building with OCaml 4.11. --- Dockerfile | 6 +++--- build-with-docker.sh | 2 +- config.ml | 2 +- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/Dockerfile b/Dockerfile index cf568ce..a6d0773 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,13 +1,13 @@ # Pin the base image to a specific hash for maximum reproducibility. # It will probably still work on newer images, though, unless an update # changes some compiler optimisations (unlikely). -#FROM ocurrent/opam:fedora-32-ocaml-4.10 -FROM ocurrent/opam@sha256:2e0e1689d2260c202bf944034f15ba8ebe945dba6b126cc6dd6b185c223014f3 +#FROM ocurrent/opam:fedora-32-ocaml-4.11 +FROM ocurrent/opam@sha256:fce44a073ff874166b51c33a4e37782286d48dbba1b5aa43563a0dd35d15510f # 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 ~/opam-repository && git fetch origin master && git reset --hard 6ef290f5681b7ece5d9c085bcf0c55268c118292 && opam update +RUN cd ~/opam-repository && git fetch origin master && git reset --hard 0531bd9f8068f9cbd0815cfc5fcbd6b6568e9620 && opam update RUN opam depext -i -y mirage RUN mkdir /home/opam/qubes-mirage-firewall diff --git a/build-with-docker.sh b/build-with-docker.sh index 74df80c..65bbb0e 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 qubes_firewall.xen)" -echo "SHA2 last known: 583d22327500fa092f436af1d0d9b1b78ebe12abd814c128ec7452c2f4cf319a" +echo "SHA2 last known: d68d2a8d2337b8c1a78995e1acbb4f72082076c73be45bf40dd6268c87b2353e" echo "(hashes should match for released versions)" diff --git a/config.ml b/config.ml index fb2cd2e..87f9f23 100644 --- a/config.ml +++ b/config.ml @@ -30,7 +30,7 @@ let main = package "netchannel" ~min:"1.11.0"; package "mirage-net-xen"; package "ipaddr" ~min:"4.0.0"; - package "mirage-qubes" ~min:"0.8.2"; + package "mirage-qubes" ~min:"0.9.1"; package "mirage-nat" ~min:"2.2.1"; package "mirage-logs"; package "mirage-xen" ~min:"6.0.0"; From 4cb5cfa036def6b54bad939bcea6aaab27a6ff58 Mon Sep 17 00:00:00 2001 From: palainp Date: Thu, 28 Oct 2021 13:39:32 +0200 Subject: [PATCH 117/281] update to ocaml-dns 6.0.0 interface --- client_net.mli | 2 +- firewall.mli | 2 +- my_dns.ml | 15 ++++++++------- rules.ml | 2 +- 4 files changed, 11 insertions(+), 10 deletions(-) diff --git a/client_net.mli b/client_net.mli index fc1953a..192fc29 100644 --- a/client_net.mli +++ b/client_net.mli @@ -4,7 +4,7 @@ (** Handling client VMs. *) val listen : (unit -> int64) -> - ([ `host ] Domain_name.t -> (int32 * Dns.Rr_map.Ipv4_set.t, [> `Msg of string ]) result Lwt.t) -> + ([ `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 removed from XenStore. Clients are connected to the client network and diff --git a/firewall.mli b/firewall.mli index 88f02ba..0141d94 100644 --- a/firewall.mli +++ b/firewall.mli @@ -7,7 +7,7 @@ val ipv4_from_netvm : Router.t -> Nat_packet.t -> unit Lwt.t (** Handle a packet from the outside world (this module will validate the source IP). *) (* 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 * Dns.Rr_map.Ipv4_set.t, [> `Msg of string ]) result Lwt.t) -> +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 (** Handle a packet from a client. Caller must check the source IP matches the client's before calling this. *) diff --git a/my_dns.ml b/my_dns.ml index c94cbb1..bcdfa47 100644 --- a/my_dns.ml +++ b/my_dns.ml @@ -3,22 +3,22 @@ open Lwt.Infix module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) = struct type +'a io = 'a Lwt.t type io_addr = Ipaddr.V4.t * int - type ns_addr = [ `TCP | `UDP ] * io_addr + type ns_addr = Dns.proto * io_addr list 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 type t = { - nameserver : ns_addr ; + nameservers : ns_addr ; stack : stack ; timeout_ns : int64 ; } type context = { t : t ; timeout_ns : int64 ref; mutable src_port : int } - let nameserver t = t.nameserver + let nameservers t = t.nameservers let rng = R.generate ?g:None let clock = C.elapsed_ns - let create ?(nameserver = `UDP, (Ipaddr.V4.of_string_exn "91.239.100.100", 53)) ~timeout stack = - { nameserver ; stack ; timeout_ns = timeout } + let create ?(nameservers = `Udp, [(Ipaddr.V4.of_string_exn "91.239.100.100", 53)]) ~timeout stack = + { nameservers ; stack ; timeout_ns = timeout } let with_timeout ctx f = let timeout = OS.Time.sleep_ns !(ctx.timeout_ns) >|= fun () -> Error (`Msg "DNS request timeout") in @@ -28,12 +28,13 @@ module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) = struct ctx.timeout_ns := Int64.sub !(ctx.timeout_ns) (Int64.sub stop start); result - let connect ?nameserver:_ (t : t) = Lwt.return (Ok { t ; timeout_ns = ref t.timeout_ns ; src_port = 0 }) + let connect (t : t) = Lwt.return (Ok { t ; timeout_ns = ref t.timeout_ns ; src_port = 0 }) let send (ctx : context) buf : (unit, [> `Msg of string ]) result Lwt.t = let open Router in let open My_nat in - let dst, dst_port = snd ctx.t.nameserver in + let nslist = snd ctx.t.nameservers in + let dst, dst_port = List.hd(nslist) in let router, send_udp, _ = ctx.t.stack in let src_port = Ports.pick_free_port ~consult:router.ports.nat_udp router.ports.dns_udp in ctx.src_port <- src_port; diff --git a/rules.ml b/rules.ml index da4706c..a70127c 100644 --- a/rules.ml +++ b/rules.ml @@ -59,7 +59,7 @@ module Classifier = struct Log.debug (fun f -> f "Resolving %a" Domain_name.pp name); dns_client name >|= function | Ok (_ttl, found_ips) -> - if Dns.Rr_map.Ipv4_set.mem ip found_ips + if Ipaddr.V4.Set.mem ip found_ips then `Match rule else `No_match | Error (`Msg m) -> From ba8dbc3f579460baacec88b535043b143a0a6c58 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 5 Nov 2021 18:55:30 +0100 Subject: [PATCH 118/281] Dockerfile: update opam-repository to current master config.ml: require more recent dns and ipaddr packages --- Dockerfile | 2 +- config.ml | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/Dockerfile b/Dockerfile index a6d0773..cafdeb1 100644 --- a/Dockerfile +++ b/Dockerfile @@ -7,7 +7,7 @@ FROM ocurrent/opam@sha256:fce44a073ff874166b51c33a4e37782286d48dbba1b5aa43563a0d # 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 ~/opam-repository && git fetch origin master && git reset --hard 0531bd9f8068f9cbd0815cfc5fcbd6b6568e9620 && opam update +RUN cd ~/opam-repository && git fetch origin master && git reset --hard 87ef72b5cd492573258eb1b6f3b30c88af31ae3f && opam update RUN opam depext -i -y mirage RUN mkdir /home/opam/qubes-mirage-firewall diff --git a/config.ml b/config.ml index 87f9f23..a2173e4 100644 --- a/config.ml +++ b/config.ml @@ -29,12 +29,12 @@ let main = package "shared-memory-ring" ~min:"3.0.0"; package "netchannel" ~min:"1.11.0"; package "mirage-net-xen"; - package "ipaddr" ~min:"4.0.0"; + package "ipaddr" ~min:"5.2.0"; package "mirage-qubes" ~min:"0.9.1"; package "mirage-nat" ~min:"2.2.1"; package "mirage-logs"; package "mirage-xen" ~min:"6.0.0"; - package ~min:"4.5.0" "dns-client"; + package ~min:"6.0.0" "dns-client"; package "pf-qubes"; ] "Unikernel.Main" (random @-> mclock @-> job) From 65ff2a920378430cc665d85c7dcf337fbeb76add Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Thu, 3 Dec 2020 21:19:46 +0100 Subject: [PATCH 119/281] update arp to >= 2.3.0, where arp.mirage is a sublibrary --- config.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/config.ml b/config.ml index a2173e4..8e2a763 100644 --- a/config.ml +++ b/config.ml @@ -22,8 +22,7 @@ let main = package "cstruct"; package "astring"; package "tcpip" ~min:"3.7.0"; - package "arp"; - package "arp-mirage"; + package ~min:"2.3.0" ~sublibs:["mirage"] "arp"; package "ethernet"; package "mirage-protocols"; package "shared-memory-ring" ~min:"3.0.0"; From 7e3303a8d61b23696b2601c81238a45478f0357b Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 5 Nov 2021 19:53:39 +0100 Subject: [PATCH 120/281] read DNS resolver IP addresses from QubesDB as specified in https://www.qubes-os.org/doc/vm-interface/ --- dao.ml | 14 ++++++++++---- dao.mli | 1 + my_dns.ml | 2 +- unikernel.ml | 3 ++- 4 files changed, 14 insertions(+), 6 deletions(-) diff --git a/dao.ml b/dao.ml index d1580e1..383b1b6 100644 --- a/dao.ml +++ b/dao.ml @@ -125,11 +125,11 @@ type network_config = { uplink_our_ip : Ipaddr.V4.t; (* The IP address of our interface to NetVM *) clients_our_ip : Ipaddr.V4.t; (* The IP address of our interface to our client VMs (their gateway) *) + dns : Ipaddr.V4.t list; } exception Missing_key of string -(* TODO: /qubes-secondary-dns *) let try_read_network_config db = let get name = match DB.KeyMap.find_opt name db with @@ -138,14 +138,20 @@ let try_read_network_config db = let uplink_our_ip = get "/qubes-ip" |> Ipaddr.V4.of_string_exn in 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 ; + 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@]" + Our IP on client networks: %a@,\ + DNS resolvers: %a@]" Ipaddr.V4.pp uplink_netvm_ip Ipaddr.V4.pp uplink_our_ip - Ipaddr.V4.pp clients_our_ip); - { uplink_netvm_ip; uplink_our_ip; clients_our_ip } + Ipaddr.V4.pp clients_our_ip + Fmt.(list ~sep:(any ", ") Ipaddr.V4.pp) dns); + { uplink_netvm_ip; uplink_our_ip; clients_our_ip ; dns } let read_network_config qubesDB = let rec aux bindings = diff --git a/dao.mli b/dao.mli index 811c2e7..94d418e 100644 --- a/dao.mli +++ b/dao.mli @@ -24,6 +24,7 @@ type network_config = { uplink_our_ip : Ipaddr.V4.t; (* The IP address of our interface to NetVM *) clients_our_ip : Ipaddr.V4.t; (* The IP address of our interface to our client VMs (their gateway) *) + dns : Ipaddr.V4.t list; } val read_network_config : Qubes.DB.t -> network_config Lwt.t diff --git a/my_dns.ml b/my_dns.ml index bcdfa47..ca2c0f8 100644 --- a/my_dns.ml +++ b/my_dns.ml @@ -34,7 +34,7 @@ module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) = struct let open Router in let open My_nat in let nslist = snd ctx.t.nameservers in - let dst, dst_port = List.hd(nslist) in + let dst, dst_port = List.hd nslist in let router, send_udp, _ = ctx.t.stack in let src_port = Ports.pick_free_port ~consult:router.ports.nat_udp router.ports.dns_udp in ctx.src_port <- src_port; diff --git a/unikernel.ml b/unikernel.ml index 72f2c83..0621e42 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -81,7 +81,8 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK) = struct let send_dns_query = Uplink.send_dns_client_query uplink in let dns_mvar = Lwt_mvar.create_empty () in - let dns_client = Dns_client.create (router, send_dns_query, dns_mvar) in + let nameservers = `Udp, List.map (fun ip -> ip, 53) config.Dao.dns 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 From d4e365a49918311106a0ffb1c373788e2b0cd94f Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 5 Nov 2021 19:59:00 +0100 Subject: [PATCH 121/281] avoid fmt and cstruct deprecation warnings --- client_net.ml | 4 ++-- firewall.ml | 2 +- fw_utils.ml | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/client_net.ml b/client_net.ml index 10d4412..8f0f975 100644 --- a/client_net.ml +++ b/client_net.ml @@ -27,7 +27,7 @@ let writev eth dst proto fillfn = ) class client_iface eth ~domid ~gateway_ip ~client_ip client_mac : client_link = - let log_header = Fmt.strf "dom%d:%a" domid Ipaddr.V4.pp client_ip in + let log_header = Fmt.str "dom%d:%a" domid Ipaddr.V4.pp client_ip in object val queue = FrameQ.create (Ipaddr.V4.to_string client_ip) val mutable rules = [] @@ -99,7 +99,7 @@ let add_vif get_ts { Dao.ClientVif.domid; device_id } dns_client ~client_ip ~rou else begin Log.debug (fun m -> m "New firewall rules for %s@.%a" (Ipaddr.V4.to_string client_ip) - Fmt.(list ~sep:(unit "@.") Pf_qubes.Parse_qubes.pp_rule) new_rules); + Fmt.(list ~sep:(any "@.") Pf_qubes.Parse_qubes.pp_rule) new_rules); (* empty NAT table if rules are updated: they might deny old connections *) My_nat.remove_connections router.Router.nat router.Router.ports client_ip; end); diff --git a/firewall.ml b/firewall.ml index 9b1587c..aecc383 100644 --- a/firewall.ml +++ b/firewall.ml @@ -22,7 +22,7 @@ let transmit_ipv4 packet iface = 0 | Ok (n, frags) -> fragments := frags ; n) >>= fun () -> Lwt_list.iter_s (fun f -> - let size = Cstruct.len f in + let size = Cstruct.length f in iface#writev `IPv4 (fun b -> Cstruct.blit f 0 b 0 size ; size)) !fragments) (fun ex -> diff --git a/fw_utils.ml b/fw_utils.ml index f6d5c7b..e4a1789 100644 --- a/fw_utils.ml +++ b/fw_utils.ml @@ -45,4 +45,4 @@ let error fmt = let or_raise msg pp = function | Ok x -> x - | Error e -> failwith (Fmt.strf "%s: %a" msg pp e) + | Error e -> failwith (Fmt.str "%s: %a" msg pp e) From 6835072104f2705ce56e0615255486c20c9ef13c Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 5 Nov 2021 19:39:10 +0100 Subject: [PATCH 122/281] build-with-docker: update hash --- 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 65bbb0e..4f34782 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 qubes_firewall.xen)" -echo "SHA2 last known: d68d2a8d2337b8c1a78995e1acbb4f72082076c73be45bf40dd6268c87b2353e" +echo "SHA2 last known: 2615ab9a9cbe5b29cf0d2a82aff7e281d06666da9cad5e767dbbc08acb77e295" echo "(hashes should match for released versions)" From c4f91423768985b50753338bf4bb1a59a2c054b9 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 10 Nov 2021 15:26:17 +0100 Subject: [PATCH 123/281] DNS: address code review comments, use qubes-primary-dns from QubesDB --- dao.ml | 11 ++++------- dao.mli | 2 +- my_dns.ml | 17 ++++++++++------- unikernel.ml | 2 +- 4 files changed, 16 insertions(+), 16 deletions(-) diff --git a/dao.ml b/dao.ml index 383b1b6..30b4c2d 100644 --- a/dao.ml +++ b/dao.ml @@ -125,7 +125,7 @@ type network_config = { uplink_our_ip : Ipaddr.V4.t; (* The IP address of our interface to NetVM *) clients_our_ip : Ipaddr.V4.t; (* The IP address of our interface to our client VMs (their gateway) *) - dns : Ipaddr.V4.t list; + dns : Ipaddr.V4.t; } exception Missing_key of string @@ -138,19 +138,16 @@ let try_read_network_config db = let uplink_our_ip = get "/qubes-ip" |> Ipaddr.V4.of_string_exn in 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 ; - get "/qubes-secondary-dns" |> Ipaddr.V4.of_string_exn ] - in + let dns = get "/qubes-primary-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 resolvers: %a@]" + DNS resolver: %a@]" Ipaddr.V4.pp uplink_netvm_ip Ipaddr.V4.pp uplink_our_ip Ipaddr.V4.pp clients_our_ip - Fmt.(list ~sep:(any ", ") Ipaddr.V4.pp) dns); + Ipaddr.V4.pp dns); { uplink_netvm_ip; uplink_our_ip; clients_our_ip ; dns } let read_network_config qubesDB = diff --git a/dao.mli b/dao.mli index 94d418e..be6ebb9 100644 --- a/dao.mli +++ b/dao.mli @@ -24,7 +24,7 @@ type network_config = { uplink_our_ip : Ipaddr.V4.t; (* The IP address of our interface to NetVM *) clients_our_ip : Ipaddr.V4.t; (* The IP address of our interface to our client VMs (their gateway) *) - dns : Ipaddr.V4.t list; + dns : Ipaddr.V4.t; } val read_network_config : Qubes.DB.t -> network_config Lwt.t diff --git a/my_dns.ml b/my_dns.ml index ca2c0f8..24aeac3 100644 --- a/my_dns.ml +++ b/my_dns.ml @@ -3,22 +3,26 @@ open Lwt.Infix module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) = struct type +'a io = 'a Lwt.t type io_addr = Ipaddr.V4.t * int - type ns_addr = Dns.proto * io_addr list 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 type t = { - nameservers : ns_addr ; + protocol : Dns.proto ; + nameserver : io_addr ; stack : stack ; timeout_ns : int64 ; } type context = { t : t ; timeout_ns : int64 ref; mutable src_port : int } - let nameservers t = t.nameservers + let nameservers { protocol ; nameserver ; _ } = protocol, [ nameserver ] let rng = R.generate ?g:None let clock = C.elapsed_ns - let create ?(nameservers = `Udp, [(Ipaddr.V4.of_string_exn "91.239.100.100", 53)]) ~timeout stack = - { nameservers ; stack ; timeout_ns = timeout } + 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 with_timeout ctx f = let timeout = OS.Time.sleep_ns !(ctx.timeout_ns) >|= fun () -> Error (`Msg "DNS request timeout") in @@ -33,8 +37,7 @@ module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) = struct let send (ctx : context) buf : (unit, [> `Msg of string ]) result Lwt.t = let open Router in let open My_nat in - let nslist = snd ctx.t.nameservers in - let dst, dst_port = List.hd nslist in + let dst, dst_port = ctx.t.nameserver in let router, send_udp, _ = ctx.t.stack in let src_port = Ports.pick_free_port ~consult:router.ports.nat_udp router.ports.dns_udp in ctx.src_port <- src_port; diff --git a/unikernel.ml b/unikernel.ml index 0621e42..cccb710 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -81,7 +81,7 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK) = struct let send_dns_query = Uplink.send_dns_client_query uplink in let dns_mvar = Lwt_mvar.create_empty () in - let nameservers = `Udp, List.map (fun ip -> ip, 53) config.Dao.dns in + let nameservers = `Udp, [ config.Dao.dns, 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 From 6e76ab299b005ec88fdd4f46eef28b8ac1ee6d12 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 10 Nov 2021 15:31:36 +0100 Subject: [PATCH 124/281] update sha256 of build --- 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 4f34782..e2bb56f 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 qubes_firewall.xen)" -echo "SHA2 last known: 2615ab9a9cbe5b29cf0d2a82aff7e281d06666da9cad5e767dbbc08acb77e295" +echo "SHA2 last known: 14cc59ec7c3754f83f7422d48176bc0eb8e47d3c3ef116ae09619409b590d3cb" echo "(hashes should match for released versions)" From 748f803ca0ee2135aa70271d9ef3ef56f33baf2b Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 10 Nov 2021 18:16:55 +0100 Subject: [PATCH 125/281] update to dns 6.1.0 --- Dockerfile | 2 +- config.ml | 2 +- my_dns.ml | 35 +++++++++++++---------------------- 3 files changed, 15 insertions(+), 24 deletions(-) diff --git a/Dockerfile b/Dockerfile index cafdeb1..4c11bc1 100644 --- a/Dockerfile +++ b/Dockerfile @@ -7,7 +7,7 @@ FROM ocurrent/opam@sha256:fce44a073ff874166b51c33a4e37782286d48dbba1b5aa43563a0d # 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 ~/opam-repository && git fetch origin master && git reset --hard 87ef72b5cd492573258eb1b6f3b30c88af31ae3f && opam update +RUN cd ~/opam-repository && git fetch origin master && git reset --hard 295910defa4dedc27af45ca64d63e8927f8261ff && opam update RUN opam depext -i -y mirage RUN mkdir /home/opam/qubes-mirage-firewall diff --git a/config.ml b/config.ml index 8e2a763..452a165 100644 --- a/config.ml +++ b/config.ml @@ -33,7 +33,7 @@ let main = package "mirage-nat" ~min:"2.2.1"; package "mirage-logs"; package "mirage-xen" ~min:"6.0.0"; - package ~min:"6.0.0" "dns-client"; + package ~min:"6.1.0" "dns-client"; package "pf-qubes"; ] "Unikernel.Main" (random @-> mclock @-> job) diff --git a/my_dns.ml b/my_dns.ml index 24aeac3..a0e8b18 100644 --- a/my_dns.ml +++ b/my_dns.ml @@ -11,7 +11,7 @@ module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) = struct stack : stack ; timeout_ns : int64 ; } - type context = { t : t ; timeout_ns : int64 ref; mutable src_port : int } + type context = t let nameservers { protocol ; nameserver ; _ } = protocol, [ nameserver ] let rng = R.generate ?g:None @@ -24,32 +24,23 @@ module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) = struct in { protocol ; nameserver ; stack ; timeout_ns = timeout } - let with_timeout ctx f = - let timeout = OS.Time.sleep_ns !(ctx.timeout_ns) >|= fun () -> Error (`Msg "DNS request timeout") in - let start = clock () in - Lwt.pick [ f ; timeout ] >|= fun result -> - let stop = clock () in - ctx.timeout_ns := Int64.sub !(ctx.timeout_ns) (Int64.sub stop start); - result + let with_timeout timeout_ns f = + let timeout = OS.Time.sleep_ns timeout_ns >|= fun () -> Error (`Msg "DNS request timeout") in + Lwt.pick [ f ; timeout ] - let connect (t : t) = Lwt.return (Ok { t ; timeout_ns = ref t.timeout_ns ; src_port = 0 }) + let connect (t : t) = Lwt.return (Ok t) - let send (ctx : context) buf : (unit, [> `Msg of string ]) result Lwt.t = + 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.t.nameserver in - let router, send_udp, _ = ctx.t.stack in + let dst, dst_port = ctx.nameserver in + let router, send_udp, answer = ctx.stack in let src_port = Ports.pick_free_port ~consult:router.ports.nat_udp router.ports.dns_udp in - ctx.src_port <- src_port; - with_timeout ctx (send_udp ~src_port ~dst ~dst_port buf >|= Rresult.R.open_error_msg) - - let recv ctx = - let open Router in - let open My_nat in - let router, _, answers = ctx.t.stack in - with_timeout ctx - (Lwt_mvar.take answers >|= fun (_, dns_response) -> Ok dns_response) >|= fun result -> - router.ports.dns_udp := Ports.remove ctx.src_port !(router.ports.dns_udp); + 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 -> + router.ports.dns_udp := Ports.remove src_port !(router.ports.dns_udp); result let close _ = Lwt.return_unit From d36676a630eb21ee985fa976e5dfcc801bc0070a Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Thu, 11 Nov 2021 10:19:29 +0100 Subject: [PATCH 126/281] update hash --- 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 e2bb56f..fc10431 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 qubes_firewall.xen)" -echo "SHA2 last known: 14cc59ec7c3754f83f7422d48176bc0eb8e47d3c3ef116ae09619409b590d3cb" +echo "SHA2 last known: 4f4b21a8f9d131486700f8be9bd15067878907313b2ebc7a048c27af8a918e1e" echo "(hashes should match for released versions)" From ed0f7667e454bd93b94bc8a8989ca91de449f7ef Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 9 Jan 2022 12:36:35 +0100 Subject: [PATCH 127/281] update to ethernet 3.0 API --- Dockerfile | 2 +- build-with-docker.sh | 2 +- client_net.ml | 6 +++--- config.ml | 3 +-- fw_utils.ml | 4 ++-- uplink.ml | 2 +- 6 files changed, 9 insertions(+), 10 deletions(-) diff --git a/Dockerfile b/Dockerfile index 4c11bc1..c903ce6 100644 --- a/Dockerfile +++ b/Dockerfile @@ -7,7 +7,7 @@ FROM ocurrent/opam@sha256:fce44a073ff874166b51c33a4e37782286d48dbba1b5aa43563a0d # 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 ~/opam-repository && git fetch origin master && git reset --hard 295910defa4dedc27af45ca64d63e8927f8261ff && opam update +RUN cd ~/opam-repository && git fetch origin master && git reset --hard 479a47921a489d11833e03cf949bfb612bd65e41 && opam update RUN opam depext -i -y mirage RUN mkdir /home/opam/qubes-mirage-firewall diff --git a/build-with-docker.sh b/build-with-docker.sh index fc10431..ebacfca 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 qubes_firewall.xen)" -echo "SHA2 last known: 4f4b21a8f9d131486700f8be9bd15067878907313b2ebc7a048c27af8a918e1e" +echo "SHA2 last known: e2af3718b7f40ba533f378d1402a41008c3520fe84d991ab58d3230772cc824c" echo "(hashes should match for released versions)" diff --git a/client_net.ml b/client_net.ml index 8f0f975..a493f9b 100644 --- a/client_net.ml +++ b/client_net.ml @@ -116,11 +116,11 @@ let add_vif get_ts { Dao.ClientVif.domid; device_id } dns_client ~client_ip ~rou let listener = Lwt.catch (fun () -> - Netback.listen backend ~header_size:Ethernet_wire.sizeof_ethernet (fun frame -> - match Ethernet_packet.Unmarshal.of_cstruct frame with + Netback.listen backend ~header_size:Ethernet.Packet.sizeof_ethernet (fun frame -> + match Ethernet.Packet.of_cstruct frame with | Error err -> Log.warn (fun f -> f "Invalid Ethernet frame: %s" err); Lwt.return_unit | Ok (eth, payload) -> - match eth.Ethernet_packet.ethertype with + 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 | `IPv6 -> Lwt.return_unit (* TODO: oh no! *) diff --git a/config.ml b/config.ml index 452a165..2363eb5 100644 --- a/config.ml +++ b/config.ml @@ -23,8 +23,7 @@ let main = package "astring"; package "tcpip" ~min:"3.7.0"; package ~min:"2.3.0" ~sublibs:["mirage"] "arp"; - package "ethernet"; - package "mirage-protocols"; + package ~min:"3.0.0" "ethernet"; package "shared-memory-ring" ~min:"3.0.0"; package "netchannel" ~min:"1.11.0"; package "mirage-net-xen"; diff --git a/fw_utils.ml b/fw_utils.ml index e4a1789..3d547af 100644 --- a/fw_utils.ml +++ b/fw_utils.ml @@ -21,7 +21,7 @@ module IntMap = Map.Make(Int) (** An Ethernet interface. *) class type interface = object method my_mac : Macaddr.t - method writev : Mirage_protocols.Ethernet.proto -> (Cstruct.t -> int) -> unit Lwt.t + method writev : Ethernet.Packet.proto -> (Cstruct.t -> int) -> unit Lwt.t method my_ip : Ipaddr.V4.t method other_ip : Ipaddr.V4.t end @@ -37,7 +37,7 @@ end (** An Ethernet header from [src]'s MAC address to [dst]'s with an IPv4 payload. *) let eth_header ethertype ~src ~dst = - Ethernet_packet.Marshal.make_cstruct { Ethernet_packet.source = src; destination = dst; ethertype } + Ethernet.Packet.make_cstruct { Ethernet.Packet.source = src; destination = dst; ethertype } let error fmt = let err s = Failure s in diff --git a/uplink.ml b/uplink.ml index 683f006..c058d54 100644 --- a/uplink.ml +++ b/uplink.ml @@ -53,7 +53,7 @@ end | _ -> Firewall.ipv4_from_netvm router (`IPv4 (ip_header, ip_packet)) in - Netif.listen t.net ~header_size:Ethernet_wire.sizeof_ethernet (fun frame -> + Netif.listen t.net ~header_size:Ethernet.Packet.sizeof_ethernet (fun frame -> (* Handle one Ethernet frame from NetVM *) Eth.input t.eth ~arpv4:(Arp.input t.arp) From a99d7f8792f977b7a91abb8fdbce4bd73f459f33 Mon Sep 17 00:00:00 2001 From: palainp Date: Wed, 30 Mar 2022 03:12:01 -0400 Subject: [PATCH 128/281] update to mirage 4.0.0 & mirage-xen 7.0.0 --- Makefile.user | 2 +- README.md | 2 +- client_net.ml | 2 +- config.ml | 13 ++++++------- dao.ml | 8 ++++---- memory_pressure.ml | 12 ++++++------ my_dns.ml | 4 ++-- unikernel.ml | 12 ++++++------ uplink.ml | 4 ++-- uplink.mli | 2 +- 10 files changed, 30 insertions(+), 31 deletions(-) diff --git a/Makefile.user b/Makefile.user index cc7a7f4..04d772b 100644 --- a/Makefile.user +++ b/Makefile.user @@ -1,7 +1,7 @@ tar: build rm -rf _build/mirage-firewall mkdir _build/mirage-firewall - cp qubes_firewall.xen _build/mirage-firewall/vmlinuz + cp dist/qubes-firewall.xen _build/mirage-firewall/vmlinuz touch _build/mirage-firewall/modules.img cat /dev/null | gzip -n > _build/mirage-firewall/initramfs tar cjf mirage-firewall.tar.bz2 -C _build --mtime=./build-with-docker.sh mirage-firewall diff --git a/README.md b/README.md index 7b8abbb..4216e49 100644 --- a/README.md +++ b/README.md @@ -145,7 +145,7 @@ The boot process: ### Easy deployment for developers -For development, use the [test-mirage][] scripts to deploy the unikernel (`qubes_firewall.xen`) from your development AppVM. +For development, use the [test-mirage][] scripts to deploy the unikernel (`qubes-firewall.xen`) from your development AppVM. This takes a little more setting up the first time, but will be much quicker after that. e.g. $ test-mirage qubes_firewall.xen mirage-firewall diff --git a/client_net.ml b/client_net.ml index a493f9b..fc501df 100644 --- a/client_net.ml +++ b/client_net.ml @@ -4,7 +4,7 @@ open Lwt.Infix open Fw_utils -module Netback = Netchannel.Backend.Make(Netchannel.Xenstore.Make(OS.Xs)) +module Netback = Netchannel.Backend.Make(Netchannel.Xenstore.Make(Xen_os.Xs)) module ClientEth = Ethernet.Make(Netback) let src = Logs.Src.create "client_net" ~doc:"Client networking" diff --git a/config.ml b/config.ml index 2363eb5..a7a1f99 100644 --- a/config.ml +++ b/config.ml @@ -6,17 +6,16 @@ open Mirage let table_size = - let open Functoria_key in - let info = Arg.info + let info = Key.Arg.info ~doc:"The number of NAT entries to allocate." ~docv:"ENTRIES" ["nat-table-size"] in - let key = Arg.opt ~stage:`Both Arg.int 5_000 info in - create "nat_table_size" key + let key = Key.Arg.opt ~stage:`Both Key.Arg.int 5_000 info in + Key.create "nat_table_size" key let main = foreign - ~keys:[Functoria_key.abstract table_size] + ~keys:[Key.v table_size] ~packages:[ package "vchan" ~min:"4.0.2"; package "cstruct"; @@ -35,8 +34,8 @@ let main = package ~min:"6.1.0" "dns-client"; package "pf-qubes"; ] - "Unikernel.Main" (random @-> mclock @-> job) + "Unikernel.Main" (random @-> mclock @-> time @-> job) let () = - register "qubes-firewall" [main $ default_random $ default_monotonic_clock] + register "qubes-firewall" [main $ default_random $ default_monotonic_clock $ default_time] ~argv:no_argv diff --git a/dao.ml b/dao.ml index 30b4c2d..241a90f 100644 --- a/dao.ml +++ b/dao.ml @@ -29,7 +29,7 @@ module VifMap = struct end let directory ~handle dir = - OS.Xs.directory handle dir >|= function + Xen_os.Xs.directory handle dir >|= function | [""] -> [] (* XenStore client bug *) | items -> items @@ -77,7 +77,7 @@ let vifs ~handle domid = | Some device_id -> let vif = { ClientVif.domid; device_id } in Lwt.try_bind - (fun () -> OS.Xs.read handle (Printf.sprintf "%s/%d/ip" path device_id)) + (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"); "" @@ -104,10 +104,10 @@ let vifs ~handle domid = ) let watch_clients fn = - OS.Xs.make () >>= fun xs -> + Xen_os.Xs.make () >>= fun xs -> let backend_vifs = "backend/vif" in Log.info (fun f -> f "Watching %s" backend_vifs); - OS.Xs.wait xs (fun handle -> + Xen_os.Xs.wait xs (fun handle -> begin Lwt.catch (fun () -> directory ~handle backend_vifs) (function diff --git a/memory_pressure.ml b/memory_pressure.ml index cecf4a9..7f367fb 100644 --- a/memory_pressure.ml +++ b/memory_pressure.ml @@ -9,11 +9,11 @@ module Log = (val Logs.src_log src : Logs.LOG) let wordsize_in_bytes = Sys.word_size / 8 let fraction_free stats = - let { OS.Memory.free_words; heap_words; _ } = stats in + let { Xen_os.Memory.free_words; heap_words; _ } = stats in float free_words /. float heap_words let meminfo stats = - let { OS.Memory.free_words; heap_words; _ } = stats 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 "Writing meminfo: free %a / %a (%.2f %%)" @@ -29,7 +29,7 @@ let meminfo stats = let report_mem_usage stats = Lwt.async (fun () -> - let open OS in + let open Xen_os in Xs.make () >>= fun xs -> Xs.immediate xs (fun h -> Xs.write h "memory/meminfo" (meminfo stats) @@ -38,15 +38,15 @@ let report_mem_usage stats = let init () = Gc.full_major (); - let stats = OS.Memory.quick_stat () in + let stats = Xen_os.Memory.quick_stat () in report_mem_usage stats let status () = - let stats = OS.Memory.quick_stat () in + let stats = Xen_os.Memory.quick_stat () in if fraction_free stats > 0.1 then `Ok else ( Gc.full_major (); - let stats = OS.Memory.quick_stat () in + let stats = Xen_os.Memory.quick_stat () in report_mem_usage stats; if fraction_free stats < 0.1 then `Memory_critical else `Ok diff --git a/my_dns.ml b/my_dns.ml index a0e8b18..01ce370 100644 --- a/my_dns.ml +++ b/my_dns.ml @@ -1,6 +1,6 @@ open Lwt.Infix -module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) = struct +module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) (Time : Mirage_time.S) = struct type +'a io = 'a Lwt.t 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 @@ -25,7 +25,7 @@ module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) = struct { protocol ; nameserver ; stack ; timeout_ns = timeout } let with_timeout timeout_ns f = - let timeout = OS.Time.sleep_ns timeout_ns >|= fun () -> Error (`Msg "DNS request timeout") in + let timeout = Time.sleep_ns timeout_ns >|= fun () -> Error (`Msg "DNS request timeout") in Lwt.pick [ f ; timeout ] let connect (t : t) = Lwt.return (Ok t) diff --git a/unikernel.ml b/unikernel.ml index cccb710..f4e65fe 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -7,9 +7,9 @@ open Qubes let src = Logs.Src.create "unikernel" ~doc:"Main unikernel code" module Log = (val Logs.src_log src : Logs.LOG) -module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK) = struct - module Uplink = Uplink.Make(R)(Clock) - module Dns_transport = My_dns.Transport(R)(Clock) +module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_time.S) = struct + module Uplink = Uplink.Make(R)(Clock)(Time) + module Dns_transport = My_dns.Transport(R)(Clock)(Time) module Dns_client = Dns_client.Make(Dns_transport) (* Set up networking and listen for incoming packets. *) @@ -40,7 +40,7 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK) = struct ) (* Main unikernel entry point (called from auto-generated main.ml). *) - let start _random _clock = + let start _random _clock _time = let start_time = Clock.elapsed_ns () in (* Start qrexec agent, GUI agent and QubesDB agent in parallel *) let qrexec = RExec.connect ~domid:0 () in @@ -59,7 +59,7 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK) = struct Log.info (fun f -> f "QubesDB and qrexec agents connected in %.3f s" startup_time); (* Watch for shutdown requests from Qubes *) let shutdown_rq = - OS.Lifecycle.await_shutdown_request () >>= fun (`Poweroff | `Reboot) -> + Xen_os.Lifecycle.await_shutdown_request () >>= fun (`Poweroff | `Reboot) -> Lwt.return_unit in (* Set up networking *) let max_entries = Key_gen.nat_table_size () in @@ -91,5 +91,5 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK) = struct (* Run until something fails or we get a shutdown request. *) Lwt.choose [agent_listener; net_listener; shutdown_rq] >>= fun () -> (* Give the console daemon time to show any final log messages. *) - OS.Time.sleep_ns (1.0 *. 1e9 |> Int64.of_float) + Time.sleep_ns (1.0 *. 1e9 |> Int64.of_float) end diff --git a/uplink.ml b/uplink.ml index c058d54..1e5d30e 100644 --- a/uplink.ml +++ b/uplink.ml @@ -9,8 +9,8 @@ module Eth = Ethernet.Make(Netif) let src = Logs.Src.create "uplink" ~doc:"Network connection to NetVM" module Log = (val Logs.src_log src : Logs.LOG) -module Make (R:Mirage_random.S) (Clock : Mirage_clock.MCLOCK) = struct - module Arp = Arp.Make(Eth)(OS.Time) +module Make (R:Mirage_random.S) (Clock : Mirage_clock.MCLOCK) (Time : Mirage_time.S) = struct + module Arp = Arp.Make(Eth)(Time) module I = Static_ipv4.Make(R)(Clock)(Eth)(Arp) module U = Udp.Make(I)(R) diff --git a/uplink.mli b/uplink.mli index 438e04a..0052d75 100644 --- a/uplink.mli +++ b/uplink.mli @@ -6,7 +6,7 @@ open Fw_utils [@@@ocaml.warning "-67"] -module Make (R: Mirage_random.S)(Clock : Mirage_clock.MCLOCK) : sig +module Make (R: Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_time.S) : sig type t val connect : Dao.network_config -> t Lwt.t From 3cce2a5629a6aaeae75b5534650d0594a0ea208c Mon Sep 17 00:00:00 2001 From: palainp Date: Wed, 30 Mar 2022 03:15:11 -0400 Subject: [PATCH 129/281] bump lower bound for mirage-xen --- config.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config.ml b/config.ml index a7a1f99..ba29704 100644 --- a/config.ml +++ b/config.ml @@ -30,7 +30,7 @@ let main = package "mirage-qubes" ~min:"0.9.1"; package "mirage-nat" ~min:"2.2.1"; package "mirage-logs"; - package "mirage-xen" ~min:"6.0.0"; + package "mirage-xen" ~min:"7.0.0"; package ~min:"6.1.0" "dns-client"; package "pf-qubes"; ] From dbe068c0fe7913413cbbadfed02164b21afc7d02 Mon Sep 17 00:00:00 2001 From: palainp Date: Mon, 4 Apr 2022 10:09:16 -0400 Subject: [PATCH 130/281] update qubes-builder script for mirage 4.0 --- Makefile.builder | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/Makefile.builder b/Makefile.builder index 68a35b9..6ef27b3 100644 --- a/Makefile.builder +++ b/Makefile.builder @@ -1,8 +1,7 @@ MIRAGE_KERNEL_NAME = qubes_firewall.xen -OCAML_VERSION ?= 4.10.0 +OCAML_VERSION ?= 4.14.0 SOURCE_BUILD_DEP := firewall-build-dep firewall-build-dep: - opam install -y depext - opam depext -i -y mirage + opam -i -y mirage From 6f257c5b7b3f11e18401e300fd64ed15ea5ee39f Mon Sep 17 00:00:00 2001 From: palainp Date: Mon, 4 Apr 2022 10:10:43 -0400 Subject: [PATCH 131/281] fix opam option --- Makefile.builder | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile.builder b/Makefile.builder index 6ef27b3..bfcf4dc 100644 --- a/Makefile.builder +++ b/Makefile.builder @@ -3,5 +3,5 @@ OCAML_VERSION ?= 4.14.0 SOURCE_BUILD_DEP := firewall-build-dep firewall-build-dep: - opam -i -y mirage + opam install -y mirage From f33db2b42a5cca3ee10c169aaea0f86cda1b4553 Mon Sep 17 00:00:00 2001 From: palainp Date: Mon, 4 Apr 2022 10:23:54 -0400 Subject: [PATCH 132/281] fix kernel name --- Makefile.builder | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile.builder b/Makefile.builder index bfcf4dc..5d79a54 100644 --- a/Makefile.builder +++ b/Makefile.builder @@ -1,4 +1,4 @@ -MIRAGE_KERNEL_NAME = qubes_firewall.xen +MIRAGE_KERNEL_NAME = dist/qubes-firewall.xen OCAML_VERSION ?= 4.14.0 SOURCE_BUILD_DEP := firewall-build-dep From 7718c95f203e21f7331a7893e17c63189aa27907 Mon Sep 17 00:00:00 2001 From: palainp Date: Fri, 27 May 2022 15:59:49 +0200 Subject: [PATCH 133/281] no_argv not needed anymore with no-default-kernelopts for the VM in Qubes --- config.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/config.ml b/config.ml index ba29704..a28f2f0 100644 --- a/config.ml +++ b/config.ml @@ -38,4 +38,3 @@ let main = let () = register "qubes-firewall" [main $ default_random $ default_monotonic_clock $ default_time] - ~argv:no_argv From 68ab4f37c11ee955cc85a2c7a223edb3cd52bbe5 Mon Sep 17 00:00:00 2001 From: palainp Date: Wed, 27 Jul 2022 14:26:58 +0200 Subject: [PATCH 134/281] use the new quick_stat+trim from mirage-xen 8.0.0 --- config.ml | 2 +- memory_pressure.ml | 5 +++-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/config.ml b/config.ml index a28f2f0..d33bf23 100644 --- a/config.ml +++ b/config.ml @@ -30,7 +30,7 @@ let main = package "mirage-qubes" ~min:"0.9.1"; package "mirage-nat" ~min:"2.2.1"; package "mirage-logs"; - package "mirage-xen" ~min:"7.0.0"; + package "mirage-xen" ~min:"8.0.0"; package ~min:"6.1.0" "dns-client"; package "pf-qubes"; ] diff --git a/memory_pressure.ml b/memory_pressure.ml index 7f367fb..665ae14 100644 --- a/memory_pressure.ml +++ b/memory_pressure.ml @@ -43,11 +43,12 @@ let init () = let status () = let stats = Xen_os.Memory.quick_stat () in - if fraction_free stats > 0.1 then `Ok + if fraction_free stats > 0.4 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.1 then `Memory_critical + if fraction_free stats < 0.4 then `Memory_critical else `Ok ) From e73c160cd40edfff7b8c35ced2f422cd2d91ef47 Mon Sep 17 00:00:00 2001 From: palainp Date: Tue, 9 Aug 2022 14:16:16 +0200 Subject: [PATCH 135/281] update docker build for mirage 4.2 --- Dockerfile | 16 +++++++++------- build-with-docker.sh | 4 ++-- 2 files changed, 11 insertions(+), 9 deletions(-) diff --git a/Dockerfile b/Dockerfile index c903ce6..2655efc 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,18 +1,20 @@ # Pin the base image to a specific hash for maximum reproducibility. # It will probably still work on newer images, though, unless an update # changes some compiler optimisations (unlikely). -#FROM ocurrent/opam:fedora-32-ocaml-4.11 -FROM ocurrent/opam@sha256:fce44a073ff874166b51c33a4e37782286d48dbba1b5aa43563a0dd35d15510f +FROM ocaml/opam@sha256:68b7ce1fd4c992d6f3bfc9b4b0a88ee572ced52427f0547b6e4eb6194415f585 +ENV PATH="${PATH}:/home/opam/.opam/4.14/bin" + +# Since mirage 4.2 we must use opam version 2.1 or later +RUN sudo cp /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 ~/opam-repository && git fetch origin master && git reset --hard 479a47921a489d11833e03cf949bfb612bd65e41 && opam update +RUN cd /home/opam/opam-repository && git fetch origin master && git reset --hard f85e121f6dd1fd92d9a3d9c8ac9fa553495258bc && opam update -RUN opam depext -i -y mirage +RUN opam install -y mirage opam-monorepo RUN mkdir /home/opam/qubes-mirage-firewall ADD config.ml /home/opam/qubes-mirage-firewall/config.ml WORKDIR /home/opam/qubes-mirage-firewall -RUN opam config exec -- mirage configure -t xen && make depend -CMD opam config exec -- mirage configure -t xen && \ - opam config exec -- make tar +RUN opam exec -- mirage configure -t xen && make depend +CMD opam exec -- mirage configure -t xen && make tar diff --git a/build-with-docker.sh b/build-with-docker.sh index ebacfca..3be3e7b 100755 --- a/build-with-docker.sh +++ b/build-with-docker.sh @@ -4,6 +4,6 @@ echo Building Docker image with dependencies.. 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 qubes_firewall.xen)" -echo "SHA2 last known: e2af3718b7f40ba533f378d1402a41008c3520fe84d991ab58d3230772cc824c" +echo "SHA2 of build: $(sha256sum ./dist/qubes-firewall.xen)" +echo "SHA2 last known: c0a94169eb0642db26168688e735f616c675f9b9c02349cac485ec8925e28d10" echo "(hashes should match for released versions)" From ba1b04432dd682f4be44326229009d1ae72d7f8b Mon Sep 17 00:00:00 2001 From: palainp Date: Thu, 11 Aug 2022 13:17:44 +0200 Subject: [PATCH 136/281] must make depend before building solo5 with make tar --- Dockerfile | 3 +-- build-with-docker.sh | 2 +- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/Dockerfile b/Dockerfile index 2655efc..fcd5c43 100644 --- a/Dockerfile +++ b/Dockerfile @@ -16,5 +16,4 @@ RUN opam install -y mirage opam-monorepo RUN mkdir /home/opam/qubes-mirage-firewall ADD config.ml /home/opam/qubes-mirage-firewall/config.ml WORKDIR /home/opam/qubes-mirage-firewall -RUN opam exec -- mirage configure -t xen && make depend -CMD opam exec -- mirage configure -t xen && make tar +CMD opam exec -- mirage configure -t xen && make depend && make tar diff --git a/build-with-docker.sh b/build-with-docker.sh index 3be3e7b..821821d 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: c0a94169eb0642db26168688e735f616c675f9b9c02349cac485ec8925e28d10" +echo "SHA2 last known: 588e921b9d78a99f6f49d468a7b68284c50dabeba95698648ea52e99b381723b" echo "(hashes should match for released versions)" From 008b5b3b2f165253b5901afb68bef70c81c83798 Mon Sep 17 00:00:00 2001 From: palainp Date: Sat, 13 Aug 2022 16:59:09 +0200 Subject: [PATCH 137/281] drop PV from README.md for recent versions of qubes-mirage-firewall --- README.md | 90 +++++++++++++++++++++++++------------------------------ 1 file changed, 40 insertions(+), 50 deletions(-) diff --git a/README.md b/README.md index 7b8abbb..82facc0 100644 --- a/README.md +++ b/README.md @@ -14,11 +14,10 @@ See the [Deploy](#deploy) section below for installation instructions. ## Build from source Note: The most reliable way to build is using Docker. -Fedora 30 works well for this, but installing Docker on Fedora 31 or 32 is more difficult. -Debian 10 also works, but you'll need to follow the instructions at [docker.com][debian-docker] to get Docker +Fedora 35 works well for this and Debian 11 also works, but you'll need to follow the instructions at [docker.com][debian-docker] to get Docker (don't use Debian's version). -Create a new Fedora-30 AppVM (or reuse an existing one). In the Qube's Settings (Basic / Disk storage), increase the private storage max size from the default 2048 MiB to 4096 MiB. Open a terminal. +Create a new Fedora-35 AppVM (or reuse an existing one). In the Qube's Settings (Basic / Disk storage), increase the private storage max size from the default 2048 MiB to 4096 MiB. Open a terminal. Clone this Git repository and run the `build-with-docker.sh` script: @@ -51,7 +50,7 @@ However, it should still work fine. ## Deploy If you want to deploy manually, unpack `mirage-firewall.tar.bz2` in domU. The tarball contains `vmlinuz`, -which is the unikernel itself, plus a couple of dummy files that Qubes requires: +which is the unikernel itself, plus a dummy initramfs file that Qubes requires: [user@dev ~]$ tar xjf mirage-firewall.tar.bz2 @@ -85,20 +84,10 @@ qvm-features mirage-firewall qubes-firewall 1 qvm-features mirage-firewall no-default-kernelopts 1 ``` -**Note**: for `virt_mode`, use `pv` instead of `pvh` for firewall versions before 0.8. - ## Upgrading To upgrade from an earlier release, just overwrite `/var/lib/qubes/vm-kernels/mirage-firewall/vmlinuz` with the new version and restart the firewall VM. -If upgrading from a version before 0.8, you will also need to update a few options: - -``` -qvm-prefs mirage-firewall kernelopts '' -qvm-prefs mirage-firewall virt_mode pvh -qvm-features mirage-firewall no-default-kernelopts 1 -``` - ### Configure AppVMs to use it You can run `mirage-firewall` alongside your existing `sys-firewall` and you can choose which AppVMs use which firewall using the GUI. @@ -150,43 +139,44 @@ This takes a little more setting up the first time, but will be much quicker aft $ test-mirage qubes_firewall.xen mirage-firewall Waiting for 'Ready'... OK - Uploading 'qubes_firewall.xen' (5901080 bytes) to "mirage-firewall" + Uploading 'dist/qubes-firewall.xen' (7454880 bytes) to "mirage-test" Waiting for 'Booting'... OK - --> Loading the VM (type = ProxyVM)... - --> Starting Qubes DB... - --> Setting Qubes DB info for the VM... - --> Updating firewall rules... - --> Starting the VM... - --> Starting the qrexec daemon... - Waiting for VM's qrexec agent.connected - --> Starting Qubes GUId... - Connecting to VM's GUI agent: .connected - --> Sending monitor layout... - --> Waiting for qubes-session... - Connecting to mirage-firewall console... - MirageOS booting... - Initialising timer interface - Initialising console ... done. - gnttab_stubs.c: initialised mini-os gntmap - 2017-03-18 11:32:37 -00:00: INF [qubes.rexec] waiting for client... - 2017-03-18 11:32:37 -00:00: INF [qubes.gui] waiting for client... - 2017-03-18 11:32:37 -00:00: INF [qubes.db] connecting to server... - 2017-03-18 11:32:37 -00:00: INF [qubes.db] connected - 2017-03-18 11:32:37 -00:00: INF [qubes.rexec] client connected, using protocol version 2 - 2017-03-18 11:32:37 -00:00: INF [qubes.db] got update: "/qubes-keyboard" = "xkb_keymap {\n\txkb_keycodes { include \"evdev+aliases(qwerty)\"\t};\n\txkb_types { include \"complete\"\t};\n\txkb_compat { include \"complete\"\t};\n\txkb_symbols { include \"pc+gb+inet(evdev)\"\t};\n\txkb_geometry { include \"pc(pc105)\"\t};\n};" - 2017-03-18 11:32:37 -00:00: INF [qubes.gui] client connected (screen size: 6720x2160) - 2017-03-18 11:32:37 -00:00: INF [unikernel] Qubes agents connected in 0.095 s (CPU time used since boot: 0.008 s) - 2017-03-18 11:32:37 -00:00: INF [net-xen:frontend] connect 0 - 2017-03-18 11:32:37 -00:00: INF [memory_pressure] Writing meminfo: free 6584 / 17504 kB (37.61 %) - Note: cannot write Xen 'control' directory - 2017-03-18 11:32:37 -00:00: INF [net-xen:frontend] create: id=0 domid=1 - 2017-03-18 11:32:37 -00:00: INF [net-xen:frontend] sg:true gso_tcpv4:true rx_copy:true rx_flip:false smart_poll:false - 2017-03-18 11:32:37 -00:00: INF [net-xen:frontend] MAC: 00:16:3e:5e:6c:11 - 2017-03-18 11:32:37 -00:00: WRN [command] << Unknown command "QUBESRPC qubes.SetMonitorLayout dom0" - 2017-03-18 11:32:38 -00:00: INF [ethif] Connected Ethernet interface 00:16:3e:5e:6c:11 - 2017-03-18 11:32:38 -00:00: INF [arpv4] Connected arpv4 device on 00:16:3e:5e:6c:11 - 2017-03-18 11:32:38 -00:00: INF [dao] Watching backend/vif - 2017-03-18 11:32:38 -00:00: INF [qubes.db] got update: "/qubes-netvm-domid" = "1" + Connecting to mirage-test console... + Solo5: Xen console: port 0x2, ring @0x00000000FEFFF000 + | ___| + __| _ \ | _ \ __ \ + \__ \ ( | | ( | ) | + ____/\___/ _|\___/____/ + Solo5: Bindings version v0.7.3 + Solo5: Memory map: 64 MB addressable: + Solo5: reserved @ (0x0 - 0xfffff) + Solo5: text @ (0x100000 - 0x31bfff) + Solo5: rodata @ (0x31c000 - 0x386fff) + Solo5: data @ (0x387000 - 0x544fff) + Solo5: heap >= 0x545000 < stack < 0x4000000 + 2022-08-13 14:55:38 -00:00: INF [qubes.rexec] waiting for client... + 2022-08-13 14:55:38 -00:00: INF [qubes.gui] waiting for client... + 2022-08-13 14:55:38 -00:00: INF [qubes.db] connecting to server... + 2022-08-13 14:55:38 -00:00: INF [qubes.db] connected + 2022-08-13 14:55:38 -00:00: INF [qubes.db] got update: "/mapped-ip/10.137.0.20/visible-ip" = "10.137.0.20" + 2022-08-13 14:55:38 -00:00: INF [qubes.db] got update: "/mapped-ip/10.137.0.20/visible-gateway" = "10.137.0.23" + 2022-08-13 14:55:38 -00:00: INF [qubes.rexec] client connected, other end wants to use protocol version 3, continuing with version 2 + 2022-08-13 14:55:38 -00:00: INF [unikernel] QubesDB and qrexec agents connected in 0.041 s + 2022-08-13 14:55:38 -00:00: INF [dao] Got network configuration from QubesDB: + NetVM IP on uplink network: 10.137.0.4 + Our IP on uplink network: 10.137.0.23 + Our IP on client networks: 10.137.0.23 + DNS resolver: 10.139.1.1 + 2022-08-13 14:55:38 -00:00: INF [net-xen frontend] connect 0 + 2022-08-13 14:55:38 -00:00: INF [net-xen frontend] create: id=0 domid=1 + 2022-08-13 14:55:38 -00:00: INF [net-xen frontend] sg:true gso_tcpv4:true rx_copy:true rx_flip:false smart_poll:false + 2022-08-13 14:55:38 -00:00: INF [net-xen frontend] MAC: 00:16:3e:5e:6c:00 + 2022-08-13 14:55:38 -00:00: INF [ethernet] Connected Ethernet interface 00:16:3e:5e:6c:00 + 2022-08-13 14:55:38 -00:00: INF [ARP] Sending gratuitous ARP for 10.137.0.23 (00:16:3e:5e:6c:00) + 2022-08-13 14:55:38 -00:00: INF [ARP] Sending gratuitous ARP for 10.137.0.23 (00:16:3e:5e:6c:00) + 2022-08-13 14:55:38 -00:00: INF [udp] UDP layer connected on 10.137.0.23 + 2022-08-13 14:55:38 -00:00: INF [dao] Watching backend/vif + 2022-08-13 14:55:38 -00:00: INF [memory_pressure] Writing meminfo: free 52MiB / 59MiB (87.55 %) # Testing if the firewall works From df4f7bf8117bc4dec0f7da74b83f390854db6e2b Mon Sep 17 00:00:00 2001 From: palainp Date: Mon, 29 Aug 2022 11:31:44 +0200 Subject: [PATCH 138/281] update to mirage 4.2.1 --- Dockerfile | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/Dockerfile b/Dockerfile index fcd5c43..e4aa533 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,16 +1,17 @@ # Pin the base image to a specific hash for maximum reproducibility. # It will probably still work on newer images, though, unless an update # changes some compiler optimisations (unlikely). +# fedora-35-ocaml-4.14 FROM ocaml/opam@sha256:68b7ce1fd4c992d6f3bfc9b4b0a88ee572ced52427f0547b6e4eb6194415f585 ENV PATH="${PATH}:/home/opam/.opam/4.14/bin" # Since mirage 4.2 we must use opam version 2.1 or later -RUN sudo cp /usr/bin/opam-2.1 /usr/bin/opam +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 f85e121f6dd1fd92d9a3d9c8ac9fa553495258bc && opam update +RUN cd /home/opam/opam-repository && git fetch origin master && git reset --hard f904585098b809001380caada4b7426c112d086c && opam update RUN opam install -y mirage opam-monorepo RUN mkdir /home/opam/qubes-mirage-firewall From b0205f7dab9d7af5a0a2cdbd90fef10aeaf6cc07 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 31 Aug 2022 11:39:31 +0200 Subject: [PATCH 139/281] changes for 0.8.0 --- CHANGES.md | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index a9615e4..7a3142b 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,17 @@ +### 0.8.0 + +The major change is to use PVH instead of PV. The effort was in solo5 (https://github.com/solo5/solo5) which since 0.6.6 supports Xen and PVH (developed by @mato, with some fixes (multiboot, mem size computed uniformly, not skipping first token of command line arguments) by @marmarek, @xaki23, @palainp, and @hannesm). + +Another user-visible change is that the DNS resolver is read from QubesDB /qubes-primary-dns instead of using a hardcoded IP address (@palainp and @hannesm). + +Also, the qrexec version negotiation has been implemented (in mirage-qubes by @reynir). + +Thanks to @palainp and @winux138 keeping track of memory allocation has been improved, and also memory can be freed now. + +This release uses the latest mirage release (4.2.1). It can be built with a Fedora 35 container. It uses OCaml 4.14.0. + +Thanks to @talex5 for lots of code cleanups, reviews, and merges. Also thanks to @xaki23 for early and detailed feedback. Testing was done by @Tommytran732 and @Szewcson. Thanks to @burghardt for documentation improvements. + ### 0.7.1 Bugfixes: From 699088bbde169a777eec7d5c0694c23873882278 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 7 Sep 2022 16:29:57 +0200 Subject: [PATCH 140/281] remove no longer needed _tags file --- _tags | 2 -- 1 file changed, 2 deletions(-) delete mode 100644 _tags diff --git a/_tags b/_tags deleted file mode 100644 index 7441bd2..0000000 --- a/_tags +++ /dev/null @@ -1,2 +0,0 @@ -not : warn(A-4), strict_sequence -: package(cstruct.syntax) From 147fe18e7493e6cb5e9bb2ebad5540dbe2d7ccb4 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 7 Sep 2022 16:33:34 +0200 Subject: [PATCH 141/281] travis is no longer online --- .travis.yml | 10 ---------- 1 file changed, 10 deletions(-) delete mode 100644 .travis.yml diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index 77b3499..0000000 --- a/.travis.yml +++ /dev/null @@ -1,10 +0,0 @@ -language: c -script: - - echo 'ADD . /home/opam/qubes-mirage-firewall' >> Dockerfile - - echo 'RUN sudo chown -R opam /home/opam/qubes-mirage-firewall' >> Dockerfile - - docker build -t qubes-mirage-firewall . - - docker run --name build -i qubes-mirage-firewall - - docker cp build:/home/opam/qubes-mirage-firewall/qubes_firewall.xen . - - sha256sum qubes_firewall.xen -sudo: required -dist: trusty From 29ddbea03d4f7614d9d5ee2842626f245e7efde6 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 14 Sep 2022 09:42:35 +0200 Subject: [PATCH 142/281] 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 143/281] 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 144/281] 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 145/281] 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 146/281] 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 147/281] 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)" From 721f552a3ce4f09659e315b918c935c9e9af810b Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 14 Sep 2022 11:10:23 +0200 Subject: [PATCH 148/281] CHANGES for 0.8.1 --- CHANGES.md | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index 7a3142b..b272744 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,11 @@ +### 0.8.1 (2022-09-14) + +- support qrexec protocol version 3 (@reynir @palainp in mirage-qubes 0.9.3) +- remove special DNS rule (which used to be required for Qubes 3, issue #63, fix #142, @hannesm) +- use DNS servers from QubesDB instead of hardcoded ones for evaluation of the DNS rule (#142 @hannesm) +- remove the GUI code (not needed in Qubes 4.1 anymore, issue #62, fix #144, @palainp) +- trigger GC slightly earlier (at < 50% free space, issue #143, fix #147, @palainp) + ### 0.8.0 The major change is to use PVH instead of PV. The effort was in solo5 (https://github.com/solo5/solo5) which since 0.6.6 supports Xen and PVH (developed by @mato, with some fixes (multiboot, mem size computed uniformly, not skipping first token of command line arguments) by @marmarek, @xaki23, @palainp, and @hannesm). From abb508000ea7af121705d4922022ee607803cb92 Mon Sep 17 00:00:00 2001 From: palainp Date: Thu, 6 Oct 2022 18:06:02 +0200 Subject: [PATCH 149/281] remove memory management code not needed anymore --- client_net.ml | 5 +---- firewall.ml | 12 ++---------- frameQ.ml | 32 -------------------------------- frameQ.mli | 15 --------------- memory_pressure.ml | 1 - uplink.ml | 7 ++----- 6 files changed, 5 insertions(+), 67 deletions(-) delete mode 100644 frameQ.ml delete mode 100644 frameQ.mli diff --git a/client_net.ml b/client_net.ml index 84a1401..15a659e 100644 --- a/client_net.ml +++ b/client_net.ml @@ -29,7 +29,6 @@ let writev eth dst proto fillfn = class client_iface eth ~domid ~gateway_ip ~client_ip client_mac : client_link = let log_header = Fmt.str "dom%d:%a" domid Ipaddr.V4.pp client_ip in object - val queue = FrameQ.create (Ipaddr.V4.to_string client_ip) val mutable rules = [] method get_rules = rules method set_rules new_db = rules <- Dao.read_rules new_db client_ip @@ -38,9 +37,7 @@ class client_iface eth ~domid ~gateway_ip ~client_ip client_mac : client_link = method my_ip = gateway_ip method other_ip = client_ip method writev proto fillfn = - FrameQ.send queue (fun () -> - writev eth client_mac proto fillfn - ) + writev eth client_mac proto fillfn method log_header = log_header end diff --git a/firewall.ml b/firewall.ml index 44e6c9b..52eb208 100644 --- a/firewall.ml +++ b/firewall.ml @@ -83,16 +83,8 @@ let apply_rules t (rules : ('a, 'b) Packet.t -> Packet.action Lwt.t) ~dst (annot Log.debug (fun f -> f "Dropped packet (%s) %a" reason Nat_packet.pp packet); Lwt.return_unit -let handle_low_memory t = - match Memory_pressure.status () with - | `Memory_critical -> (* TODO: should happen before copying and async *) - Log.warn (fun f -> f "Memory low - dropping packet and resetting NAT table"); - My_nat.reset t.Router.nat t.Router.ports >|= fun () -> - `Memory_critical - | `Ok -> Lwt.return `Ok - let ipv4_from_client resolver dns_servers t ~src packet = - handle_low_memory t >>= function + match Memory_pressure.status () with | `Memory_critical -> Lwt.return_unit | `Ok -> (* Check for existing NAT entry for this packet *) @@ -107,7 +99,7 @@ let ipv4_from_client resolver dns_servers t ~src 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 + match Memory_pressure.status () with | `Memory_critical -> Lwt.return_unit | `Ok -> let `IPv4 (ip, _transport) = packet in diff --git a/frameQ.ml b/frameQ.ml deleted file mode 100644 index 390ac7a..0000000 --- a/frameQ.ml +++ /dev/null @@ -1,32 +0,0 @@ -(* Copyright (C) 2016, Thomas Leonard - See the README file for details. *) - -let src = Logs.Src.create "frameQ" ~doc:"Interface output queue" -module Log = (val Logs.src_log src : Logs.LOG) - -type t = { - name : string; - mutable items : int; -} - -let create name = { name; items = 0 } - -(* Note: the queue is only used if we already filled the transmit buffer. *) -let max_qlen = 10 - -let send q fn = - if q.items = max_qlen then ( - Log.warn (fun f -> f "Maximum queue length exceeded for %s: dropping frame" q.name); - Lwt.return_unit - ) else ( - let sent = fn () in - if Lwt.state sent = Lwt.Sleep then ( - q.items <- q.items + 1; - Log.info (fun f -> f "Queue length for %s: incr to %d" q.name q.items); - Lwt.on_termination sent (fun () -> - q.items <- q.items - 1; - Log.info (fun f -> f "Queue length for %s: decr to %d" q.name q.items); - ) - ); - sent - ) diff --git a/frameQ.mli b/frameQ.mli deleted file mode 100644 index f11e1ae..0000000 --- a/frameQ.mli +++ /dev/null @@ -1,15 +0,0 @@ -(* Copyright (C) 2016, Thomas Leonard - See the README file for details. *) - -(** Keep track of the queue length for output buffers. *) - -type t - -val create : string -> t -(** [create name] is a new empty queue. [name] is used in log messages. *) - -val send : t -> (unit -> unit Lwt.t) -> unit Lwt.t -(** [send t fn] checks that the queue isn't overloaded and calls [fn ()] if it's OK. - The item is considered to be queued until the result of [fn] has resolved. - In the case of mirage-net-xen's [writev], this happens when the frame has been - added to the ring (not when it is consumed), which is fine for us. *) diff --git a/memory_pressure.ml b/memory_pressure.ml index 3b14f4b..b867573 100644 --- a/memory_pressure.ml +++ b/memory_pressure.ml @@ -54,7 +54,6 @@ let print_mem_usage = let init () = Gc.full_major (); let stats = Xen_os.Memory.quick_stat () in - print_mem_usage ; report_mem_usage stats let status () = diff --git a/uplink.ml b/uplink.ml index 1e5d30e..40695ed 100644 --- a/uplink.ml +++ b/uplink.ml @@ -25,15 +25,12 @@ module Make (R:Mirage_random.S) (Clock : Mirage_clock.MCLOCK) (Time : Mirage_tim } class netvm_iface eth mac ~my_ip ~other_ip : interface = object - val queue = FrameQ.create (Ipaddr.V4.to_string other_ip) method my_mac = Eth.mac eth method my_ip = my_ip method other_ip = other_ip method writev ethertype fillfn = - FrameQ.send queue (fun () -> - mac >>= fun dst -> - Eth.write eth dst ethertype fillfn >|= or_raise "Write to uplink" Eth.pp_error - ) + mac >>= fun dst -> + Eth.write eth dst ethertype fillfn >|= or_raise "Write to uplink" Eth.pp_error end let send_dns_client_query t ~src_port ~dst ~dst_port buf = From eb4d0fc37195c80619b13c139aeefc5a84e74211 Mon Sep 17 00:00:00 2001 From: palainp Date: Thu, 6 Oct 2022 18:06:18 +0200 Subject: [PATCH 150/281] update documentation --- README.md | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/README.md b/README.md index 8b4b1a9..a24f6cd 100644 --- a/README.md +++ b/README.md @@ -70,8 +70,8 @@ Run this command in dom0 to create a `mirage-firewall` VM using the `mirage-fire qvm-create \ --property kernel=mirage-firewall \ --property kernelopts='' \ - --property memory=64 \ - --property maxmem=64 \ + --property memory=32 \ + --property maxmem=32 \ --property netvm=sys-net \ --property provides_network=True \ --property vcpus=1 \ @@ -137,7 +137,7 @@ The boot process: For development, use the [test-mirage][] scripts to deploy the unikernel (`qubes-firewall.xen`) from your development AppVM. This takes a little more setting up the first time, but will be much quicker after that. e.g. - $ test-mirage qubes_firewall.xen mirage-firewall + $ test-mirage dist/qubes-firewall.xen mirage-firewall Waiting for 'Ready'... OK Uploading 'dist/qubes-firewall.xen' (7454880 bytes) to "mirage-test" Waiting for 'Booting'... OK @@ -148,25 +148,25 @@ This takes a little more setting up the first time, but will be much quicker aft \__ \ ( | | ( | ) | ____/\___/ _|\___/____/ Solo5: Bindings version v0.7.3 - Solo5: Memory map: 64 MB addressable: + Solo5: Memory map: 32 MB addressable: Solo5: reserved @ (0x0 - 0xfffff) - Solo5: text @ (0x100000 - 0x31bfff) - Solo5: rodata @ (0x31c000 - 0x386fff) - Solo5: data @ (0x387000 - 0x544fff) - Solo5: heap >= 0x545000 < stack < 0x4000000 + Solo5: text @ (0x100000 - 0x319fff) + Solo5: rodata @ (0x31a000 - 0x384fff) + Solo5: data @ (0x385000 - 0x53ffff) + Solo5: heap >= 0x540000 < stack < 0x2000000 2022-08-13 14:55:38 -00:00: INF [qubes.rexec] waiting for client... - 2022-08-13 14:55:38 -00:00: INF [qubes.gui] waiting for client... 2022-08-13 14:55:38 -00:00: INF [qubes.db] connecting to server... 2022-08-13 14:55:38 -00:00: INF [qubes.db] connected 2022-08-13 14:55:38 -00:00: INF [qubes.db] got update: "/mapped-ip/10.137.0.20/visible-ip" = "10.137.0.20" 2022-08-13 14:55:38 -00:00: INF [qubes.db] got update: "/mapped-ip/10.137.0.20/visible-gateway" = "10.137.0.23" - 2022-08-13 14:55:38 -00:00: INF [qubes.rexec] client connected, other end wants to use protocol version 3, continuing with version 2 + 2022-08-13 14:55:38 -00:00: INF [qubes.rexec] client connected, using protocol version 3 2022-08-13 14:55:38 -00:00: INF [unikernel] QubesDB and qrexec agents connected in 0.041 s 2022-08-13 14:55:38 -00:00: INF [dao] Got network configuration from QubesDB: NetVM IP on uplink network: 10.137.0.4 Our IP on uplink network: 10.137.0.23 Our IP on client networks: 10.137.0.23 DNS resolver: 10.139.1.1 + DNS secondary resolver: 10.139.1.2 2022-08-13 14:55:38 -00:00: INF [net-xen frontend] connect 0 2022-08-13 14:55:38 -00:00: INF [net-xen frontend] create: id=0 domid=1 2022-08-13 14:55:38 -00:00: INF [net-xen frontend] sg:true gso_tcpv4:true rx_copy:true rx_flip:false smart_poll:false @@ -176,7 +176,7 @@ This takes a little more setting up the first time, but will be much quicker aft 2022-08-13 14:55:38 -00:00: INF [ARP] Sending gratuitous ARP for 10.137.0.23 (00:16:3e:5e:6c:00) 2022-08-13 14:55:38 -00:00: INF [udp] UDP layer connected on 10.137.0.23 2022-08-13 14:55:38 -00:00: INF [dao] Watching backend/vif - 2022-08-13 14:55:38 -00:00: INF [memory_pressure] Writing meminfo: free 52MiB / 59MiB (87.55 %) + 2022-08-13 14:55:38 -00:00: INF [memory_pressure] Writing meminfo: free 20MiB / 27MiB (72.68 %) # Testing if the firewall works From 06b9a883314e974378cbe88ffb3680a4cec5b714 Mon Sep 17 00:00:00 2001 From: palainp Date: Sun, 9 Oct 2022 12:38:44 +0200 Subject: [PATCH 151/281] remove unneeded logs: be silent if the GC is enough --- memory_pressure.ml | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/memory_pressure.ml b/memory_pressure.ml index b867573..629ecda 100644 --- a/memory_pressure.ml +++ b/memory_pressure.ml @@ -63,7 +63,8 @@ let status () = Gc.full_major (); Xen_os.Memory.trim (); let stats = Xen_os.Memory.quick_stat () in - report_mem_usage stats; - if fraction_free stats < 0.6 then `Memory_critical - else `Ok + if fraction_free stats < 0.6 then begin + report_mem_usage stats; + `Memory_critical + end else `Ok ) From 8187096bfa030eac410669681f21f7b207e7eb06 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 7 Oct 2022 18:49:03 +0200 Subject: [PATCH 152/281] updates to recent mirage-nat changes --- firewall.ml | 52 ++++++++++++++++++++++++++-------------------------- my_nat.ml | 33 ++++++++------------------------- my_nat.mli | 8 ++++---- unikernel.ml | 2 +- 4 files changed, 39 insertions(+), 56 deletions(-) diff --git a/firewall.ml b/firewall.ml index 52eb208..aab9b21 100644 --- a/firewall.ml +++ b/firewall.ml @@ -47,7 +47,7 @@ let translate t packet = let add_nat_and_forward_ipv4 t packet = let open Router in let xl_host = t.uplink#my_ip in - My_nat.add_nat_rule_and_translate t.nat t.ports ~xl_host `NAT packet >>= function + match My_nat.add_nat_rule_and_translate t.nat t.ports ~xl_host `NAT packet with | Ok packet -> forward_ipv4 t packet | Error e -> Log.warn (fun f -> f "Failed to add NAT rewrite rule: %s (%a)" e Nat_packet.pp packet); @@ -60,7 +60,7 @@ let nat_to t ~host ~port packet = | Ipaddr.V6 _ -> Log.warn (fun f -> f "Cannot NAT with IPv6"); Lwt.return_unit | Ipaddr.V4 target -> let xl_host = t.uplink#my_ip in - My_nat.add_nat_rule_and_translate t.nat t.ports ~xl_host (`Redirect (target, port)) packet >>= function + match My_nat.add_nat_rule_and_translate t.nat t.ports ~xl_host (`Redirect (target, port)) packet with | Ok packet -> forward_ipv4 t packet | Error e -> Log.warn (fun f -> f "Failed to add NAT redirect rule: %s (%a)" e Nat_packet.pp packet); @@ -88,34 +88,34 @@ let ipv4_from_client resolver dns_servers t ~src packet = | `Memory_critical -> Lwt.return_unit | `Ok -> (* Check for existing NAT entry for this packet *) - translate t packet >>= function - | Some frame -> forward_ipv4 t frame (* Some existing connection or redirect *) - | None -> - (* 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 - 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 dns_servers) ~dst firewall_packet + match translate t packet with + | Some frame -> forward_ipv4 t frame (* Some existing connection or redirect *) + | None -> + (* 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 + 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 dns_servers) ~dst firewall_packet let ipv4_from_netvm t packet = match Memory_pressure.status () with | `Memory_critical -> Lwt.return_unit | `Ok -> - 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 packet with - | None -> Lwt.return_unit - | Some _ -> - match src with - | `Client _ | `Firewall -> - Log.warn (fun f -> f "Frame from NetVM has internal source IP address! %a" Nat_packet.pp packet); - Lwt.return_unit - | `External _ | `NetVM as src -> - translate t packet >>= function - | Some frame -> forward_ipv4 t frame - | None -> + 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 packet with | None -> Lwt.return_unit - | Some packet -> apply_rules t Rules.from_netvm ~dst packet + | Some _ -> + match src with + | `Client _ | `Firewall -> + Log.warn (fun f -> f "Frame from NetVM has internal source IP address! %a" Nat_packet.pp packet); + Lwt.return_unit + | `External _ | `NetVM as src -> + match translate t packet with + | Some frame -> forward_ipv4 t frame + | None -> + match Packet.of_mirage_nat_packet ~src ~dst packet with + | None -> Lwt.return_unit + | Some packet -> apply_rules t Rules.from_netvm ~dst packet diff --git a/my_nat.ml b/my_nat.ml index 2652ff5..1f1bd32 100644 --- a/my_nat.ml +++ b/my_nat.ml @@ -34,11 +34,11 @@ type t = { let create ~max_entries = let tcp_size = 7 * max_entries / 8 in let udp_size = max_entries - tcp_size in - Nat.empty ~tcp_size ~udp_size ~icmp_size:100 >|= fun table -> + let table = Nat.empty ~tcp_size ~udp_size ~icmp_size:100 in { table } let translate t packet = - Nat.translate t.table packet >|= function + match Nat.translate t.table packet with | Error (`Untranslated | `TTL_exceeded as e) -> Log.debug (fun f -> f "Failed to NAT %a: %a" Nat_packet.pp packet @@ -64,15 +64,6 @@ let remove_connections t ports ip = ports.nat_icmp := Ports.diff !(ports.nat_icmp) (Ports.of_list freed_ports.Mirage_nat.icmp) let add_nat_rule_and_translate t ports ~xl_host action packet = - let apply_action xl_port = - Lwt.catch (fun () -> - Nat.add t.table packet (xl_host, xl_port) action - ) - (function - | Out_of_memory -> Lwt.return (Error `Out_of_memory) - | x -> Lwt.fail x - ) - in let rec aux ~retries = let nat_ports, dns_ports = match packet with @@ -81,29 +72,21 @@ let add_nat_rule_and_translate t ports ~xl_host action packet = | `IPv4 (_, `ICMP _) -> ports.nat_icmp, ref Ports.empty in let xl_port = pick_free_port ~nat_ports ~dns_ports in - apply_action xl_port >>= function - | Error `Out_of_memory -> - (* Because hash tables resize in big steps, this can happen even if we have a fair - chunk of free memory. *) - Log.warn (fun f -> f "Out_of_memory adding NAT rule. Dropping NAT table..."); - reset t ports >>= fun () -> - aux ~retries:(retries - 1) - | Error `Overlap when retries < 0 -> Lwt.return (Error "Too many retries") + match Nat.add t.table packet xl_host (fun () -> xl_port) action with + | Error `Overlap when retries < 0 -> Error "Too many retries" | Error `Overlap -> if retries = 0 then ( Log.warn (fun f -> f "Failed to find a free port; resetting NAT table"); - reset t ports >>= fun () -> + reset t ports; aux ~retries:(retries - 1) ) else ( aux ~retries:(retries - 1) ) | Error `Cannot_NAT -> - Lwt.return (Error "Cannot NAT this packet") + Error "Cannot NAT this packet" | Ok () -> Log.debug (fun f -> f "Updated NAT table: %a" Nat.pp_summary t.table); - translate t packet >|= function - | None -> Error "No NAT entry, even after adding one!" - | Some packet -> - Ok packet + Option.to_result ~none:"No NAT entry, even after adding one!" + (translate t packet) in aux ~retries:100 diff --git a/my_nat.mli b/my_nat.mli index 2ee21e0..488aae1 100644 --- a/my_nat.mli +++ b/my_nat.mli @@ -19,9 +19,9 @@ type action = [ | `Redirect of Mirage_nat.endpoint ] -val create : max_entries:int -> t Lwt.t -val reset : t -> ports -> unit Lwt.t +val create : max_entries:int -> t +val reset : t -> ports -> unit val remove_connections : t -> ports -> Ipaddr.V4.t -> unit -val translate : t -> Nat_packet.t -> Nat_packet.t option Lwt.t +val translate : t -> Nat_packet.t -> Nat_packet.t option val add_nat_rule_and_translate : t -> ports -> - xl_host:Ipaddr.V4.t -> action -> Nat_packet.t -> (Nat_packet.t, string) result Lwt.t + xl_host:Ipaddr.V4.t -> action -> Nat_packet.t -> (Nat_packet.t, string) result diff --git a/unikernel.ml b/unikernel.ml index 02cb5a3..65f7b3a 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -45,7 +45,7 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_tim Lwt.return_unit in (* Set up networking *) let max_entries = Key_gen.nat_table_size () in - My_nat.create ~max_entries >>= fun nat -> + let nat = My_nat.create ~max_entries in (* Read network configuration from QubesDB *) Dao.read_network_config qubesDB >>= fun config -> From f2d3faf1da0a12a535df5505964f70115d70a851 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 7 Oct 2022 20:54:49 +0200 Subject: [PATCH 153/281] revise port management this needs mirage-nat at hannesm#fixes --- client_net.ml | 2 +- firewall.ml | 4 +-- my_dns.ml | 4 +-- my_nat.ml | 92 ++++++++++++++++++++------------------------------- my_nat.mli | 18 ++++------ ports.ml | 16 --------- router.ml | 5 +-- router.mli | 1 - uplink.ml | 2 +- 9 files changed, 49 insertions(+), 95 deletions(-) delete mode 100644 ports.ml diff --git a/client_net.ml b/client_net.ml index 15a659e..b9b74fe 100644 --- a/client_net.ml +++ b/client_net.ml @@ -98,7 +98,7 @@ let add_vif get_ts { Dao.ClientVif.domid; device_id } dns_client dns_servers ~cl (Ipaddr.V4.to_string client_ip) Fmt.(list ~sep:(any "@.") Pf_qubes.Parse_qubes.pp_rule) new_rules); (* empty NAT table if rules are updated: they might deny old connections *) - My_nat.remove_connections router.Router.nat router.Router.ports client_ip; + My_nat.remove_connections router.Router.nat client_ip; end); update new_db new_rules in diff --git a/firewall.ml b/firewall.ml index aab9b21..06d32a4 100644 --- a/firewall.ml +++ b/firewall.ml @@ -47,7 +47,7 @@ let translate t packet = let add_nat_and_forward_ipv4 t packet = let open Router in let xl_host = t.uplink#my_ip in - match My_nat.add_nat_rule_and_translate t.nat t.ports ~xl_host `NAT packet with + match My_nat.add_nat_rule_and_translate t.nat ~xl_host `NAT packet with | Ok packet -> forward_ipv4 t packet | Error e -> Log.warn (fun f -> f "Failed to add NAT rewrite rule: %s (%a)" e Nat_packet.pp packet); @@ -60,7 +60,7 @@ let nat_to t ~host ~port packet = | Ipaddr.V6 _ -> Log.warn (fun f -> f "Cannot NAT with IPv6"); Lwt.return_unit | Ipaddr.V4 target -> let xl_host = t.uplink#my_ip in - match My_nat.add_nat_rule_and_translate t.nat t.ports ~xl_host (`Redirect (target, port)) packet with + match My_nat.add_nat_rule_and_translate t.nat ~xl_host (`Redirect (target, port)) packet with | Ok packet -> forward_ipv4 t packet | Error e -> Log.warn (fun f -> f "Failed to add NAT redirect rule: %s (%a)" e Nat_packet.pp packet); diff --git a/my_dns.ml b/my_dns.ml index 01ce370..8cb169d 100644 --- a/my_dns.ml +++ b/my_dns.ml @@ -35,12 +35,12 @@ module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) (Time : Mirage_ let open My_nat in let dst, dst_port = ctx.nameserver in let router, send_udp, answer = ctx.stack in - let src_port = Ports.pick_free_port ~consult:router.ports.nat_udp router.ports.dns_udp in + let src_port = My_nat.free_udp_port router.nat ~src:router.uplink#my_ip ~dst ~dst_port:53 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 -> - router.ports.dns_udp := Ports.remove src_port !(router.ports.dns_udp); + router.nat.udp_dns <- List.filter (fun p -> p <> src_port) router.nat.udp_dns; result let close _ = Lwt.return_unit diff --git a/my_nat.ml b/my_nat.ml index 1f1bd32..2591483 100644 --- a/my_nat.ml +++ b/my_nat.ml @@ -11,31 +11,38 @@ type action = [ | `Redirect of Mirage_nat.endpoint ] -type ports = { - nat_tcp : Ports.t ref; - nat_udp : Ports.t ref; - nat_icmp : Ports.t ref; - dns_udp : Ports.t ref; -} - -let empty_ports () = - let nat_tcp = ref Ports.empty in - let nat_udp = ref Ports.empty in - let nat_icmp = ref Ports.empty in - let dns_udp = ref Ports.empty in - { nat_tcp ; nat_udp ; nat_icmp ; dns_udp } - module Nat = Mirage_nat_lru type t = { table : Nat.t; + mutable udp_dns : int list; } let create ~max_entries = let tcp_size = 7 * max_entries / 8 in let udp_size = max_entries - tcp_size in let table = Nat.empty ~tcp_size ~udp_size ~icmp_size:100 in - { table } + { table ; udp_dns = [] } + +let pick_free_port t proto = + let rec go () = + let p = 1024 + Random.int (0xffff - 1024) in + match proto with + | `Udp when List.mem p t.udp_dns -> go () + | _ -> p + in + go () + +let free_udp_port t ~src ~dst ~dst_port = + let rec go () = + let src_port = pick_free_port t `Udp in + if Nat.is_port_free t.table `Udp ~src ~dst ~src_port ~dst_port then begin + t.udp_dns <- src_port :: t.udp_dns; + src_port + end else + go () + in + go () let translate t packet = match Nat.translate t.table packet with @@ -47,46 +54,19 @@ let translate t packet = None | Ok packet -> Some packet -let pick_free_port ~nat_ports ~dns_ports = - Ports.pick_free_port ~consult:dns_ports nat_ports +let remove_connections t ip = + ignore (Nat.remove_connections t.table ip) -(* just clears the nat ports, dns ports stay as is *) -let reset t ports = - ports.nat_tcp := Ports.empty; - ports.nat_udp := Ports.empty; - ports.nat_icmp := Ports.empty; - Nat.reset t.table - -let remove_connections t ports ip = - let freed_ports = Nat.remove_connections t.table ip in - ports.nat_tcp := Ports.diff !(ports.nat_tcp) (Ports.of_list freed_ports.Mirage_nat.tcp); - ports.nat_udp := Ports.diff !(ports.nat_udp) (Ports.of_list freed_ports.Mirage_nat.udp); - ports.nat_icmp := Ports.diff !(ports.nat_icmp) (Ports.of_list freed_ports.Mirage_nat.icmp) - -let add_nat_rule_and_translate t ports ~xl_host action packet = - let rec aux ~retries = - let nat_ports, dns_ports = - match packet with - | `IPv4 (_, `TCP _) -> ports.nat_tcp, ref Ports.empty - | `IPv4 (_, `UDP _) -> ports.nat_udp, ports.dns_udp - | `IPv4 (_, `ICMP _) -> ports.nat_icmp, ref Ports.empty - in - let xl_port = pick_free_port ~nat_ports ~dns_ports in - match Nat.add t.table packet xl_host (fun () -> xl_port) action with - | Error `Overlap when retries < 0 -> Error "Too many retries" - | Error `Overlap -> - if retries = 0 then ( - Log.warn (fun f -> f "Failed to find a free port; resetting NAT table"); - reset t ports; - aux ~retries:(retries - 1) - ) else ( - aux ~retries:(retries - 1) - ) - | Error `Cannot_NAT -> - Error "Cannot NAT this packet" - | Ok () -> - Log.debug (fun f -> f "Updated NAT table: %a" Nat.pp_summary t.table); - Option.to_result ~none:"No NAT entry, even after adding one!" - (translate t packet) +let add_nat_rule_and_translate t ~xl_host action packet = + let proto = match packet with + | `IPv4 (_, `TCP _) -> `Tcp + | `IPv4 (_, `UDP _) -> `Udp + | `IPv4 (_, `ICMP _) -> `Icmp in - aux ~retries:100 + match Nat.add t.table packet xl_host (fun () -> pick_free_port t proto) action with + | Error `Overlap -> Error "Too many retries" + | Error `Cannot_NAT -> Error "Cannot NAT this packet" + | Ok () -> + Log.debug (fun f -> f "Updated NAT table: %a" Nat.pp_summary t.table); + Option.to_result ~none:"No NAT entry, even after adding one!" + (translate t packet) diff --git a/my_nat.mli b/my_nat.mli index 488aae1..1a9c1e7 100644 --- a/my_nat.mli +++ b/my_nat.mli @@ -3,25 +3,19 @@ (* Abstract over NAT interface (todo: remove this) *) -type ports = private { - nat_tcp : Ports.t ref; - nat_udp : Ports.t ref; - nat_icmp : Ports.t ref; - dns_udp : Ports.t ref; +type t = { + table : Mirage_nat_lru.t; + mutable udp_dns : int list; } -val empty_ports : unit -> ports - -type t - type action = [ | `NAT | `Redirect of Mirage_nat.endpoint ] +val free_udp_port : t -> src:Ipaddr.V4.t -> dst:Ipaddr.V4.t -> dst_port:int -> int val create : max_entries:int -> t -val reset : t -> ports -> unit -val remove_connections : t -> ports -> Ipaddr.V4.t -> unit +val remove_connections : t -> Ipaddr.V4.t -> unit val translate : t -> Nat_packet.t -> Nat_packet.t option -val add_nat_rule_and_translate : t -> ports -> +val add_nat_rule_and_translate : t -> xl_host:Ipaddr.V4.t -> action -> Nat_packet.t -> (Nat_packet.t, string) result diff --git a/ports.ml b/ports.ml deleted file mode 100644 index 59d3205..0000000 --- a/ports.ml +++ /dev/null @@ -1,16 +0,0 @@ -module Set = Set.Make(struct - type t = int - let compare a b = compare a b -end) - -include Set - -let rec pick_free_port ?(retries = 10) ~consult add_to = - let p = 1024 + Random.int (0xffff - 1024) in - if (mem p !consult || mem p !add_to) && retries <> 0 - then pick_free_port ~retries:(retries - 1) ~consult add_to - else - begin - add_to := add p !add_to; - p - end diff --git a/router.ml b/router.ml index b91da74..4d7ed90 100644 --- a/router.ml +++ b/router.ml @@ -9,13 +9,10 @@ type t = { client_eth : Client_eth.t; nat : My_nat.t; uplink : interface; - (* NOTE: do not try to make this pure, it relies on mvars / side effects *) - ports : My_nat.ports; } let create ~client_eth ~uplink ~nat = - let ports = My_nat.empty_ports () in - { client_eth; nat; uplink; ports } + { client_eth; nat; uplink } let target t buf = let dst_ip = buf.Ipv4_packet.dst in diff --git a/router.mli b/router.mli index 610bddd..34fa86b 100644 --- a/router.mli +++ b/router.mli @@ -9,7 +9,6 @@ type t = private { client_eth : Client_eth.t; nat : My_nat.t; uplink : interface; - ports : My_nat.ports; } val create : diff --git a/uplink.ml b/uplink.ml index 40695ed..8ff4c10 100644 --- a/uplink.ml +++ b/uplink.ml @@ -44,7 +44,7 @@ end Log.debug (fun f -> f "received ipv4 packet from %a on uplink" Ipaddr.V4.pp ip_header.Ipv4_packet.src); match ip_packet with - | `UDP (header, packet) when Ports.mem header.dst_port !(router.Router.ports.My_nat.dns_udp) -> + | `UDP (header, packet) when List.mem header.dst_port router.Router.nat.My_nat.udp_dns -> Log.debug (fun f -> f "found a DNS packet whose dst_port (%d) was in the list of dns_client ports" header.dst_port); Lwt_mvar.put dns_responses (header, packet) | _ -> From 93b92c041bc3a9d243f9e1f674980868f5f56d07 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sat, 8 Oct 2022 10:50:29 +0200 Subject: [PATCH 154/281] Adapt to mirage-nat changes: allow pick_free_port to fail reserve a special udp port for dns (as last resort) --- my_dns.ml | 6 ++++-- my_nat.ml | 43 ++++++++++++++++++++++++++++++++----------- my_nat.mli | 9 ++++----- uplink.ml | 2 +- 4 files changed, 41 insertions(+), 19 deletions(-) diff --git a/my_dns.ml b/my_dns.ml index 8cb169d..80f5ab0 100644 --- a/my_dns.ml +++ b/my_dns.ml @@ -35,12 +35,14 @@ module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) (Time : Mirage_ let open My_nat in let dst, dst_port = ctx.nameserver in let router, send_udp, answer = ctx.stack in - let src_port = My_nat.free_udp_port router.nat ~src:router.uplink#my_ip ~dst ~dst_port:53 in + let src_port, evict = + My_nat.free_udp_port router.nat ~src:router.uplink#my_ip ~dst ~dst_port:53 + 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 -> - router.nat.udp_dns <- List.filter (fun p -> p <> src_port) router.nat.udp_dns; + evict (); result let close _ = Lwt.return_unit diff --git a/my_nat.ml b/my_nat.ml index 2591483..209a562 100644 --- a/my_nat.ml +++ b/my_nat.ml @@ -13,37 +13,58 @@ type action = [ module Nat = Mirage_nat_lru +module S = + Set.Make(struct type t = int let compare (a : int) (b : int) = compare a b end) + type t = { table : Nat.t; - mutable udp_dns : int list; + mutable udp_dns : S.t; + last_resort_port : int } +let pick_port () = + 1024 + Random.int (0xffff - 1024) + let create ~max_entries = let tcp_size = 7 * max_entries / 8 in let udp_size = max_entries - tcp_size in let table = Nat.empty ~tcp_size ~udp_size ~icmp_size:100 in - { table ; udp_dns = [] } + let last_resort_port = pick_port () in + { table ; udp_dns = S.empty ; last_resort_port } let pick_free_port t proto = - let rec go () = - let p = 1024 + Random.int (0xffff - 1024) in - match proto with - | `Udp when List.mem p t.udp_dns -> go () - | _ -> p + let rec go retries = + if retries = 0 then + None + else + let p = 1024 + Random.int (0xffff - 1024) in + match proto with + | `Udp when S.mem p t.udp_dns || p = t.last_resort_port -> + go (retries - 1) + | _ -> Some p in - go () + go 10 let free_udp_port t ~src ~dst ~dst_port = let rec go () = - let src_port = pick_free_port t `Udp in + 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 - t.udp_dns <- src_port :: t.udp_dns; - src_port + 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 () in go () +let dns_port t port = S.mem port t.udp_dns || port = t.last_resort_port + let translate t packet = match Nat.translate t.table packet with | Error (`Untranslated | `TTL_exceeded as e) -> diff --git a/my_nat.mli b/my_nat.mli index 1a9c1e7..eab1a34 100644 --- a/my_nat.mli +++ b/my_nat.mli @@ -3,17 +3,16 @@ (* Abstract over NAT interface (todo: remove this) *) -type t = { - table : Mirage_nat_lru.t; - mutable udp_dns : int list; -} +type t type action = [ | `NAT | `Redirect of Mirage_nat.endpoint ] -val free_udp_port : t -> src:Ipaddr.V4.t -> dst:Ipaddr.V4.t -> dst_port:int -> int +val free_udp_port : t -> src:Ipaddr.V4.t -> dst:Ipaddr.V4.t -> dst_port:int -> + int * (unit -> unit) +val dns_port : t -> int -> bool val create : max_entries:int -> t val remove_connections : t -> Ipaddr.V4.t -> unit val translate : t -> Nat_packet.t -> Nat_packet.t option diff --git a/uplink.ml b/uplink.ml index 8ff4c10..b74d1df 100644 --- a/uplink.ml +++ b/uplink.ml @@ -44,7 +44,7 @@ end Log.debug (fun f -> f "received ipv4 packet from %a on uplink" Ipaddr.V4.pp ip_header.Ipv4_packet.src); match ip_packet with - | `UDP (header, packet) when List.mem header.dst_port router.Router.nat.My_nat.udp_dns -> + | `UDP (header, packet) when My_nat.dns_port router.Router.nat header.dst_port -> Log.debug (fun f -> f "found a DNS packet whose dst_port (%d) was in the list of dns_client ports" header.dst_port); Lwt_mvar.put dns_responses (header, packet) | _ -> From c66d6a8727a6f263bdddd68d3715f2a53973cfb6 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 11 Oct 2022 13:34:55 +0200 Subject: [PATCH 155/281] raise lower bound of mirage-nat to 3.0.0, bump opam-repo commit --- Dockerfile | 2 +- config.ml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/Dockerfile b/Dockerfile index cf6a662..62637b6 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 632ef7fd6add02a7789f896751c51b408dca0373 && opam update +RUN cd /home/opam/opam-repository && git fetch origin master && git reset --hard 0f451c34c56458ee18495a98eb35d7dcb14f519a && opam update RUN opam install -y mirage opam-monorepo RUN mkdir /home/opam/qubes-mirage-firewall diff --git a/config.ml b/config.ml index d33bf23..8f187ae 100644 --- a/config.ml +++ b/config.ml @@ -28,7 +28,7 @@ let main = package "mirage-net-xen"; package "ipaddr" ~min:"5.2.0"; package "mirage-qubes" ~min:"0.9.1"; - package "mirage-nat" ~min:"2.2.1"; + package "mirage-nat" ~min:"3.0.0"; package "mirage-logs"; package "mirage-xen" ~min:"8.0.0"; package ~min:"6.1.0" "dns-client"; From b958c106904c92b09142347f7b6c2052e4ab8c80 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 11 Oct 2022 13:55:36 +0200 Subject: [PATCH 156/281] build-with-docker: update sha --- 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 0b6e016..cc00274 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: d0ec19d5b392509955edccf100852bcc9c0e05bf31f1ec25c9cc9c9e74c3b7bf" +echo "SHA2 last known: 73488b0c54d6c43d662ddf58916b6d472430894f6394c6bdb8a879723abcc06f" echo "(hashes should match for released versions)" From 07da67c8cffdec2ee3b5fc9821de06e808b7bdcd Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 12 Oct 2022 09:09:03 +0200 Subject: [PATCH 157/281] changes for 0.8.2 --- CHANGES.md | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index b272744..6143c5c 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,10 @@ +### 0.8.2 (2022-10-12) + +- Advise to use 32 MB memory, which is sufficient (#150, @palainp) +- Improve documentation (#150, @palainp) +- Remove unneeded memory management code and log messages (#150, @palainp) +- Use mirage-nat 3.0.0, remove global mutable state (#151, @hannesm) + ### 0.8.1 (2022-09-14) - support qrexec protocol version 3 (@reynir @palainp in mirage-qubes 0.9.3) From 2afa24536ddf10e4605b71a430aaa56c3ef9a62d Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Thu, 27 Oct 2022 11:24:59 +0200 Subject: [PATCH 158/281] update to dns 6.4.0 --- Dockerfile | 2 +- build-with-docker.sh | 2 +- config.ml | 2 +- my_dns.ml | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/Dockerfile b/Dockerfile index 62637b6..58cdeae 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 0f451c34c56458ee18495a98eb35d7dcb14f519a && opam update +RUN cd /home/opam/opam-repository && git fetch origin master && git reset --hard 7b89f6e5c24cf4076252e71abcbbe4d205705627 && opam update RUN opam install -y mirage opam-monorepo RUN mkdir /home/opam/qubes-mirage-firewall diff --git a/build-with-docker.sh b/build-with-docker.sh index cc00274..9a312a2 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: 73488b0c54d6c43d662ddf58916b6d472430894f6394c6bdb8a879723abcc06f" +echo "SHA2 last known: 88fdd86993dfbd2e2c4a4d502c350bef091d7831405cf983aebe85f936799f2d" echo "(hashes should match for released versions)" diff --git a/config.ml b/config.ml index 8f187ae..5d3c532 100644 --- a/config.ml +++ b/config.ml @@ -31,7 +31,7 @@ let main = package "mirage-nat" ~min:"3.0.0"; package "mirage-logs"; package "mirage-xen" ~min:"8.0.0"; - package ~min:"6.1.0" "dns-client"; + package ~min:"6.4.0" "dns-client"; package "pf-qubes"; ] "Unikernel.Main" (random @-> mclock @-> time @-> job) diff --git a/my_dns.ml b/my_dns.ml index 80f5ab0..35fbb8d 100644 --- a/my_dns.ml +++ b/my_dns.ml @@ -28,7 +28,7 @@ module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) (Time : Mirage_ let timeout = Time.sleep_ns timeout_ns >|= fun () -> Error (`Msg "DNS request timeout") in Lwt.pick [ f ; timeout ] - let connect (t : t) = Lwt.return (Ok t) + let connect (t : t) = Lwt.return (Ok (t.protocol, t)) let send_recv (ctx : context) buf : (Cstruct.t, [> `Msg of string ]) result Lwt.t = let open Router in From bed0aa5cc4c6fe84e27b18749b81ac4ac9be0a8f Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 11 Nov 2022 13:40:04 +0100 Subject: [PATCH 159/281] add github action to compile the firewall --- .github/actions/main.yml | 35 +++++++++++++++++++++++++++++++++++ 1 file changed, 35 insertions(+) create mode 100644 .github/actions/main.yml diff --git a/.github/actions/main.yml b/.github/actions/main.yml new file mode 100644 index 0000000..1b40e48 --- /dev/null +++ b/.github/actions/main.yml @@ -0,0 +1,35 @@ +name: Main workflow + +on: + pull_request: + push: + schedule: + # Prime the caches every Monday + - cron: 0 1 * * MON + +jobs: + build: + strategy: + fail-fast: false + matrix: + os: + - ubuntu-latest + ocaml-compiler: + - 4.14.x + + runs-on: ${{ matrix.os }} + + steps: + - name: Checkout code + uses: actions/checkout@v2 + + - name: Use OCaml ${{ matrix.ocaml-compiler }} + uses: ocaml/setup-ocaml@v2 + with: + ocaml-compiler: ${{ matrix.ocaml-compiler }} + + - run: opam install --confirm-level=unsafe-yes "mirage>4" + + - run: opam exec -- mirage configure -t xen && make depend && dune build + + - run: sha256sum dist/qubes-firewall.xen From 7370ba85f6d747591bc2425fee88b53043416a29 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 11 Nov 2022 13:46:29 +0100 Subject: [PATCH 160/281] github action should be in .github/workflows --- .github/{actions => workflows}/main.yml | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename .github/{actions => workflows}/main.yml (100%) diff --git a/.github/actions/main.yml b/.github/workflows/main.yml similarity index 100% rename from .github/actions/main.yml rename to .github/workflows/main.yml From af60225671742bb316ca8a0f8fbcc69906c2179c Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 11 Nov 2022 13:58:46 +0100 Subject: [PATCH 161/281] github action: something sets OPAMCLI to 2.0, so no --confirm-level=yes available --- .github/workflows/main.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index 1b40e48..637231e 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -28,7 +28,7 @@ jobs: with: ocaml-compiler: ${{ matrix.ocaml-compiler }} - - run: opam install --confirm-level=unsafe-yes "mirage>4" + - run: opam install "mirage>4" - run: opam exec -- mirage configure -t xen && make depend && dune build From ecc5cbc409ae71822d775137ab8a355ca4fbf597 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 11 Nov 2022 14:32:31 +0100 Subject: [PATCH 162/281] fix github action --- .github/workflows/main.yml | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index 637231e..379dce8 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -28,8 +28,14 @@ jobs: with: ocaml-compiler: ${{ matrix.ocaml-compiler }} - - run: opam install "mirage>4" + - run: opam depext solo5 "mirage>4" - - run: opam exec -- mirage configure -t xen && make depend && dune build + - run: opam install solo5 "mirage>4" + + - run: opam exec -- mirage configure -t xen + + - run: opam exec -- make depend + + - run: opam exec -- dune build - run: sha256sum dist/qubes-firewall.xen From 33c7c24dfd78742ca0b4cf329ca2773af9dd144e Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 11 Nov 2022 11:11:38 +0100 Subject: [PATCH 163/281] code cleanups (removed profile release from dune-workspace to find some warnings) --- memory_pressure.ml | 15 --------------- my_dns.ml | 1 - my_nat.ml | 2 -- uplink.mli | 1 - 4 files changed, 19 deletions(-) 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..9f3c877 100644 --- a/my_dns.ml +++ b/my_dns.ml @@ -32,7 +32,6 @@ 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 src_port, evict = diff --git a/my_nat.ml b/my_nat.ml index 209a562..17b3a59 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) 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 From ddfb17c0b26b142fa2b1b8486b2b9b81c23cb590 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 11 Nov 2022 11:35:37 +0100 Subject: [PATCH 164/281] remove unused integer module, intset, intmap --- fw_utils.ml | 8 -------- 1 file changed, 8 deletions(-) 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 From 0e0917f4fef33f35ec3152825cff29541b367161 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 11 Nov 2022 12:07:06 +0100 Subject: [PATCH 165/281] DNS: start task reading Lwt_mvar and distributing DNS replies to clients Before, a DNS request was sent and the first thing appearing in the Lwt_mvar was taken as reply. The issue with this was two-fold: - it could be a reply for a different request - there could be DNS replies being sent to the uplink stack leading to Lwt_mvar.put being called, which blocks if there is already a value in the mvar. No, the separate task is a loop reading the mvar, using a Lwt_condition to signal the receive of that ID (potentially discarding if there's no client waiting). The DNS query registers itself (using the ID) in the map with a Lwt_condition, and waits to be notified (or a timeout occurs). --- my_dns.ml | 31 ++++++++++++++++++++++++++----- 1 file changed, 26 insertions(+), 5 deletions(-) diff --git a/my_dns.ml b/my_dns.ml index 9f3c877..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 @@ -33,14 +50,18 @@ 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 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 From d094b2095053b4b6b21f29fee9e1048cb191c05b Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Thu, 10 Nov 2022 23:08:21 +0100 Subject: [PATCH 166/281] use a fresh client for requesting vif and ip in the callback to "Xs_client.wait", all operations are tracked and new watches are installed (that are never removed, due to xenstore's xs_handle "accessed_path" never removes any elements of the "accessed_paths" (a mutable StringSet). So, whatever is done in the callback of wait needs to take care (if returning EAGAIN and thus forcing xenstore to continue waiting/watching) that accesses are tracked. Our way out is to create a fresh client and read the IP address with that new client -> the watcher isn't extended -> no dangling (leaking) watches, and no leaking only-expanding StringSet. --- dao.ml | 70 ++++++++++++++++++++++++++++++---------------------------- 1 file changed, 36 insertions(+), 34 deletions(-) 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 From e8e03fe6a6e97fefb7cbdd09a94515d9998671af Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 8 Nov 2022 18:57:09 +0100 Subject: [PATCH 167/281] My_nat.free_udp_port: avoid looping forever, use last_resort_port earlier --- my_nat.ml | 31 +++++++++++++++++-------------- 1 file changed, 17 insertions(+), 14 deletions(-) diff --git a/my_nat.ml b/my_nat.ml index 17b3a59..1e86c2d 100644 --- a/my_nat.ml +++ b/my_nat.ml @@ -44,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 From 20ce084a496b06fb7f6290d38f8b54263a00589b Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 11 Nov 2022 13:37:43 +0100 Subject: [PATCH 168/281] set netchannel + mirage-nat lower bounds --- config.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) 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"; From 2023cc46550509b2c076e8c310a1d32addfe5277 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 11 Nov 2022 15:12:30 +0100 Subject: [PATCH 169/281] changes for 0.8.3, and checksum updates --- CHANGES.md | 20 ++++++++++++++++++++ Dockerfile | 2 +- build-with-docker.sh | 2 +- 3 files changed, 22 insertions(+), 2 deletions(-) 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..ac2ba7c 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 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 mkdir /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)" From b414230735cda9b1c08496088676d8f7986f9e7e Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 11 Nov 2022 15:59:06 +0100 Subject: [PATCH 170/281] Dockerfile: install ocaml-solo5 earlier to help caching more --- Dockerfile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Dockerfile b/Dockerfile index ac2ba7c..564f56e 100644 --- a/Dockerfile +++ b/Dockerfile @@ -13,7 +13,7 @@ RUN sudo ln -sf /usr/bin/opam-2.1 /usr/bin/opam # latest versions. 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 From ba6629f4ca5cfe99a0bf546eb28be55eb777314c Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 13 Nov 2022 12:22:59 +0100 Subject: [PATCH 171/281] Reproducible build systems: use in GitHub action the build-with-docker.sh Also upload the artifact to GitHub action, and in addition use the same setup (ubuntu 20.04 image) and build directories as done on builds.robur.coop. Also use `strip` on the resulting binary to reduce it's size (since the debug section aren't mapped into the running unikernel, there's nothing we get from them -- also they are preserved (as .debug file) and uploaded to https://builds.robur.coop if one needs them). This entails binary reproducibility between the different systems: - a developer using ./build-with-docker.sh - GitHub action (run on every PR) - builds.robur.coop with the ubuntu-20.04 worker --- .github/workflows/main.yml | 23 ++++++----------------- Dockerfile | 25 +++++++++++++------------ Makefile.user | 2 ++ build-with-docker.sh | 4 ++-- 4 files changed, 23 insertions(+), 31 deletions(-) diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index 379dce8..d5efec6 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -14,8 +14,6 @@ jobs: matrix: os: - ubuntu-latest - ocaml-compiler: - - 4.14.x runs-on: ${{ matrix.os }} @@ -23,19 +21,10 @@ jobs: - name: Checkout code uses: actions/checkout@v2 - - name: Use OCaml ${{ matrix.ocaml-compiler }} - uses: ocaml/setup-ocaml@v2 + - run: ./build-with-docker.sh + + - name: Upload Artifact + uses: actions/upload-artifact@v3 with: - ocaml-compiler: ${{ matrix.ocaml-compiler }} - - - run: opam depext solo5 "mirage>4" - - - run: opam install solo5 "mirage>4" - - - run: opam exec -- mirage configure -t xen - - - run: opam exec -- make depend - - - run: opam exec -- dune build - - - run: sha256sum dist/qubes-firewall.xen + name: mirage-firewall.tar.bz2 + path: mirage-firewall.tar.bz2 diff --git a/Dockerfile b/Dockerfile index 564f56e..c511cdb 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,20 +1,21 @@ # Pin the base image to a specific hash for maximum reproducibility. # It will probably still work on newer images, though, unless an update # changes some compiler optimisations (unlikely). -# fedora-35-ocaml-4.14 -FROM ocaml/opam@sha256:68b7ce1fd4c992d6f3bfc9b4b0a88ee572ced52427f0547b6e4eb6194415f585 -ENV PATH="${PATH}:/home/opam/.opam/4.14/bin" +# ubuntu-20.04 +FROM ubuntu@sha256:b25ef49a40b7797937d0d23eca3b0a41701af6757afca23d504d50826f0b37ce -# Since mirage 4.2 we must use opam version 2.1 or later -RUN sudo ln -sf /usr/bin/opam-2.1 /usr/bin/opam +RUN apt update && apt install --no-install-recommends --no-install-suggests -y wget ca-certificates git patch unzip make gcc g++ libc-dev +RUN wget -O /usr/bin/opam https://github.com/ocaml/opam/releases/download/2.1.3/opam-2.1.3-i686-linux && chmod 755 /usr/bin/opam +ENV OPAMROOT=/tmp +ENV OPAMCONFIRMLEVEL=unsafe-yes # 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 685eb4efcebfa671660e55d76dea017f00fed4d9 && opam update - -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 -CMD opam exec -- mirage configure -t xen && make depend && make tar +RUN opam init --disable-sandboxing -a --bare https://github.com/ocaml/opam-repository.git#685eb4efcebfa671660e55d76dea017f00fed4d9 +RUN opam switch create myswitch 4.14.0 +RUN opam exec -- opam install -y mirage opam-monorepo ocaml-solo5 +RUN mkdir /tmp/orb-build +ADD config.ml /tmp/orb-build/config.ml +WORKDIR /tmp/orb-build +CMD opam exec -- sh -exc 'mirage configure -t xen --allocation-policy=best-fit && make depend && make tar' diff --git a/Makefile.user b/Makefile.user index 04d772b..fb04a23 100644 --- a/Makefile.user +++ b/Makefile.user @@ -1,6 +1,8 @@ tar: build rm -rf _build/mirage-firewall mkdir _build/mirage-firewall + cp dist/qubes-firewall.xen dist/qubes-firewall.xen.debug + strip dist/qubes-firewall.xen cp dist/qubes-firewall.xen _build/mirage-firewall/vmlinuz touch _build/mirage-firewall/modules.img cat /dev/null | gzip -n > _build/mirage-firewall/initramfs diff --git a/build-with-docker.sh b/build-with-docker.sh index e3ddce7..4dfbb34 100755 --- a/build-with-docker.sh +++ b/build-with-docker.sh @@ -3,7 +3,7 @@ set -eu echo Building Docker image with dependencies.. docker build -t qubes-mirage-firewall . echo Building Firewall... -docker run --rm -i -v `pwd`:/home/opam/qubes-mirage-firewall qubes-mirage-firewall +docker run --rm -i -v `pwd`:/tmp/orb-build qubes-mirage-firewall echo "SHA2 of build: $(sha256sum ./dist/qubes-firewall.xen)" -echo "SHA2 last known: f499b2379c62917ac32854be63f201e6b90466e645e54dea51e376baccdf26ab" +echo "SHA2 last known: 3f71a1b672a15d145c7d40405dd75f06a2b148d2cfa106dc136e3da38552de41" echo "(hashes should match for released versions)" From 9239aa5277335a4bbe056bf8175b52e02dad08c7 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 13 Nov 2022 15:58:00 +0100 Subject: [PATCH 172/281] github action: check checksum before uploading --- .github/workflows/main.yml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index d5efec6..148d4e3 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -23,6 +23,8 @@ jobs: - run: ./build-with-docker.sh + - run: sh -exc 'if [ $(sha256sum dist/qubes-firewall.xen | cut -d " " -f 1) = $(grep "SHA2 last known" build-with-docker.sh | rev | cut -d ":" -f 1 | rev | cut -d "\"" -f 1 | tr -d " ") ]; then echo "SHA256 MATCHES"; else exit 42; fi' + - name: Upload Artifact uses: actions/upload-artifact@v3 with: From 0c3959af04e9e16d81b87703b5eee26f3853f53d Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 7 Dec 2022 19:15:44 +0100 Subject: [PATCH 173/281] update opam repository commit to get solo5 0.7.5 --- Dockerfile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Dockerfile b/Dockerfile index c511cdb..1c1e0f1 100644 --- a/Dockerfile +++ b/Dockerfile @@ -12,7 +12,7 @@ ENV OPAMCONFIRMLEVEL=unsafe-yes # 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 opam init --disable-sandboxing -a --bare https://github.com/ocaml/opam-repository.git#685eb4efcebfa671660e55d76dea017f00fed4d9 +RUN opam init --disable-sandboxing -a --bare https://github.com/ocaml/opam-repository.git#c9b2f766b7c7009be8cd68ac423d0d5b36044aca RUN opam switch create myswitch 4.14.0 RUN opam exec -- opam install -y mirage opam-monorepo ocaml-solo5 RUN mkdir /tmp/orb-build From 916813b6eabe73178a48f10ab6743a9db598facb Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 7 Dec 2022 20:00:55 +0100 Subject: [PATCH 174/281] update hash of build product --- 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 4dfbb34..7cd77a6 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`:/tmp/orb-build qubes-mirage-firewall echo "SHA2 of build: $(sha256sum ./dist/qubes-firewall.xen)" -echo "SHA2 last known: 3f71a1b672a15d145c7d40405dd75f06a2b148d2cfa106dc136e3da38552de41" +echo "SHA2 last known: 55a2f823d66473c7d0be66a93289d48b6557f18c9257c6f98aa5a4583663d3c2" echo "(hashes should match for released versions)" From 609f5295c7b315886244426b685807244c7dbe81 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 7 Dec 2022 20:44:00 +0100 Subject: [PATCH 175/281] changes for 0.8.4 --- CHANGES.md | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index 5550cdc..e147c1f 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,11 @@ +### 0.8.4 (2022-12-07) + +- Fix remote denial of service due to excessive console output (#166 @burghardt, + fix in solo5/solo5#538 by @palainp) +- Use Ubuntu container for build, now GitHub action, ./build-with-docker.sh and + builds.robur.coop are synchronized (and result in the same artifact) + (#164 @hannesm) + ### 0.8.3 (2022-11-11) - Fix "DNS issues", a firewall ruleset with a domain name lead to 100% CPU usage From cbf6c8c941e5b5cd46a8701191c7f9133cbe1184 Mon Sep 17 00:00:00 2001 From: palainp Date: Tue, 18 Apr 2023 11:46:45 +0200 Subject: [PATCH 176/281] update build script --- Dockerfile | 14 ++++++++------ build-with-docker.sh | 2 +- 2 files changed, 9 insertions(+), 7 deletions(-) diff --git a/Dockerfile b/Dockerfile index 1c1e0f1..8e55ec5 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,19 +1,21 @@ # Pin the base image to a specific hash for maximum reproducibility. # It will probably still work on newer images, though, unless an update # changes some compiler optimisations (unlikely). -# ubuntu-20.04 -FROM ubuntu@sha256:b25ef49a40b7797937d0d23eca3b0a41701af6757afca23d504d50826f0b37ce +# bookworm-slim +FROM debian@sha256:07c6cb2ae86479dcc1942a89b0a1f4049b6e9415f7de327ff641aed58b8e3100 +# and set the package source to a specific release too +RUN echo deb http://snapshot.notset.fr/archive/debian/20230418T024659Z bookworm main > /etc/apt/sources.list -RUN apt update && apt install --no-install-recommends --no-install-suggests -y wget ca-certificates git patch unzip make gcc g++ libc-dev -RUN wget -O /usr/bin/opam https://github.com/ocaml/opam/releases/download/2.1.3/opam-2.1.3-i686-linux && chmod 755 /usr/bin/opam +RUN apt update && apt install --no-install-recommends --no-install-suggests -y wget ca-certificates git patch unzip bzip2 make gcc g++ libc-dev +RUN wget -O /usr/bin/opam https://github.com/ocaml/opam/releases/download/2.1.4/opam-2.1.4-i686-linux && chmod 755 /usr/bin/opam ENV OPAMROOT=/tmp ENV OPAMCONFIRMLEVEL=unsafe-yes # 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 opam init --disable-sandboxing -a --bare https://github.com/ocaml/opam-repository.git#c9b2f766b7c7009be8cd68ac423d0d5b36044aca -RUN opam switch create myswitch 4.14.0 +RUN opam init --disable-sandboxing -a --bare https://github.com/ocaml/opam-repository.git#28b35f67988702df5018fbf30d1c725734425670 +RUN opam switch create myswitch 4.14.1 RUN opam exec -- opam install -y mirage opam-monorepo ocaml-solo5 RUN mkdir /tmp/orb-build ADD config.ml /tmp/orb-build/config.ml diff --git a/build-with-docker.sh b/build-with-docker.sh index 7cd77a6..ec91399 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`:/tmp/orb-build qubes-mirage-firewall echo "SHA2 of build: $(sha256sum ./dist/qubes-firewall.xen)" -echo "SHA2 last known: 55a2f823d66473c7d0be66a93289d48b6557f18c9257c6f98aa5a4583663d3c2" +echo "SHA2 last known: 4a3cd3f555f39c47b9675fd08425eee968a6484cb38aa19fb94f4c96844c2ae6" echo "(hashes should match for released versions)" From ffc8e95bc31583807203f8ad5ae0a8f5b113517e Mon Sep 17 00:00:00 2001 From: palainp Date: Tue, 25 Apr 2023 10:16:57 +0200 Subject: [PATCH 177/281] create a shasum file matching the tarball release --- Makefile.user | 1 + 1 file changed, 1 insertion(+) diff --git a/Makefile.user b/Makefile.user index fb04a23..c8a1d5d 100644 --- a/Makefile.user +++ b/Makefile.user @@ -7,6 +7,7 @@ tar: build touch _build/mirage-firewall/modules.img cat /dev/null | gzip -n > _build/mirage-firewall/initramfs tar cjf mirage-firewall.tar.bz2 -C _build --mtime=./build-with-docker.sh mirage-firewall + sha256sum mirage-firewall.tar.bz2 > mirage-firewall.sha256 fetchmotron: qubes_firewall.xen test-mirage qubes_firewall.xen mirage-fw-test & From d3e8e691fd95e003461aca5708bda33800fd27d7 Mon Sep 17 00:00:00 2001 From: palainp Date: Tue, 16 May 2023 11:18:34 +0200 Subject: [PATCH 178/281] do not check valid-until in debian release file: this permits to keep a debian packages list more than one week --- Dockerfile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Dockerfile b/Dockerfile index 8e55ec5..e0eaa70 100644 --- a/Dockerfile +++ b/Dockerfile @@ -4,7 +4,7 @@ # bookworm-slim FROM debian@sha256:07c6cb2ae86479dcc1942a89b0a1f4049b6e9415f7de327ff641aed58b8e3100 # and set the package source to a specific release too -RUN echo deb http://snapshot.notset.fr/archive/debian/20230418T024659Z bookworm main > /etc/apt/sources.list +RUN printf "deb [check-valid-until=no] http://snapshot.notset.fr/archive/debian/20230418T024659Z bookworm main" > /etc/apt/sources.list RUN apt update && apt install --no-install-recommends --no-install-suggests -y wget ca-certificates git patch unzip bzip2 make gcc g++ libc-dev RUN wget -O /usr/bin/opam https://github.com/ocaml/opam/releases/download/2.1.4/opam-2.1.4-i686-linux && chmod 755 /usr/bin/opam From b288481d2ffc7dc71f37db6aee515babf0dfa56e Mon Sep 17 00:00:00 2001 From: palainp Date: Fri, 26 May 2023 10:27:29 +0200 Subject: [PATCH 179/281] remove memreport to Xen to avoid Qubes trying to get back some memory from us --- build-with-docker.sh | 2 +- memory_pressure.ml | 19 +++---------------- 2 files changed, 4 insertions(+), 17 deletions(-) diff --git a/build-with-docker.sh b/build-with-docker.sh index 7cd77a6..b4faef7 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`:/tmp/orb-build qubes-mirage-firewall echo "SHA2 of build: $(sha256sum ./dist/qubes-firewall.xen)" -echo "SHA2 last known: 55a2f823d66473c7d0be66a93289d48b6557f18c9257c6f98aa5a4583663d3c2" +echo "SHA2 last known: d9f7827e2f2c8150ac97a4d348a29f5ee0810a455dbab9233490fff97470f7b8" echo "(hashes should match for released versions)" diff --git a/memory_pressure.ml b/memory_pressure.ml index 2e9e95a..87289c2 100644 --- a/memory_pressure.ml +++ b/memory_pressure.ml @@ -27,19 +27,8 @@ let meminfo stats = SwapTotal: 0 kB\n\ SwapFree: 0 kB\n" (mem_total / 1024) (mem_free / 1024) -let report_mem_usage stats = - Lwt.async (fun () -> - let open Xen_os in - Xs.make () >>= fun xs -> - Xs.immediate xs (fun h -> - Xs.write h "memory/meminfo" (meminfo stats) - ) - ) - let init () = - Gc.full_major (); - let stats = Xen_os.Memory.quick_stat () in - report_mem_usage stats + Gc.full_major () let status () = let stats = Xen_os.Memory.quick_stat () in @@ -48,8 +37,6 @@ let status () = Gc.full_major (); Xen_os.Memory.trim (); let stats = Xen_os.Memory.quick_stat () in - if fraction_free stats < 0.6 then begin - report_mem_usage stats; - `Memory_critical - end else `Ok + if fraction_free stats < 0.6 then `Memory_critical + else `Ok ) From 9cabe7e303aa0eaafb72303bc8bbaa7df34e8d7d Mon Sep 17 00:00:00 2001 From: palainp Date: Fri, 30 Jun 2023 13:59:03 +0200 Subject: [PATCH 180/281] allow to have no netvm defined (will fail on uplink.connect) --- client_eth.ml | 15 ++++++++------- client_eth.mli | 2 +- client_net.ml | 2 +- dao.ml | 14 +++++++------- router.ml | 16 ++++++++-------- router.mli | 4 ++-- unikernel.ml | 5 ++--- 7 files changed, 29 insertions(+), 29 deletions(-) diff --git a/client_eth.ml b/client_eth.ml index 10c84d1..45337b2 100644 --- a/client_eth.ml +++ b/client_eth.ml @@ -10,7 +10,7 @@ module Log = (val Logs.src_log src : Logs.LOG) type t = { mutable iface_of_ip : client_link IpMap.t; changed : unit Lwt_condition.t; (* Fires when [iface_of_ip] changes. *) - client_gw : Ipaddr.V4.t; (* The IP that clients are given as their default gateway. *) + my_ip : Ipaddr.V4.t; (* The IP that clients are given as their default gateway. *) } type host = @@ -18,11 +18,12 @@ type host = | `Firewall | `External of Ipaddr.t ] -let create ~client_gw = +let create config = let changed = Lwt_condition.create () in - { iface_of_ip = IpMap.empty; client_gw; changed } + let my_ip = config.Dao.uplink_our_ip in + Lwt.return { iface_of_ip = IpMap.empty; my_ip; changed } -let client_gw t = t.client_gw +let client_gw t = t.my_ip let add_client t iface = let ip = iface#other_ip in @@ -52,14 +53,14 @@ let classify t ip = match ip with | Ipaddr.V6 _ -> `External ip | Ipaddr.V4 ip4 -> - if ip4 = t.client_gw then `Firewall + if ip4 = t.my_ip then `Firewall else match lookup t ip4 with | Some client_link -> `Client client_link | None -> `External ip let resolve t : host -> Ipaddr.t = function | `Client client_link -> Ipaddr.V4 client_link#other_ip - | `Firewall -> Ipaddr.V4 t.client_gw + | `Firewall -> Ipaddr.V4 t.my_ip | `External addr -> addr module ARP = struct @@ -69,7 +70,7 @@ module ARP = struct } let lookup t ip = - if ip = t.net.client_gw then Some t.client_link#my_mac + if ip = t.net.my_ip then Some t.client_link#my_mac else if (Ipaddr.V4.to_octets ip).[3] = '\x01' then ( Log.info (fun f -> f ~header:t.client_link#log_header "Request for %a is invalid, but pretending it's me (see Qubes issue #5022)" Ipaddr.V4.pp ip); diff --git a/client_eth.mli b/client_eth.mli index 2bbb672..02ccee9 100644 --- a/client_eth.mli +++ b/client_eth.mli @@ -17,7 +17,7 @@ type host = disconnected client. See: https://github.com/talex5/qubes-mirage-firewall/issues/9#issuecomment-246956850 *) -val create : client_gw:Ipaddr.V4.t -> t +val create : Dao.network_config -> t Lwt.t (** [create ~client_gw] is a network of client machines. Qubes will have configured the client machines to use [client_gw] as their default gateway. *) diff --git a/client_net.ml b/client_net.ml index b9b74fe..6e46327 100644 --- a/client_net.ml +++ b/client_net.ml @@ -80,7 +80,7 @@ let add_vif get_ts { Dao.ClientVif.domid; device_id } dns_client dns_servers ~cl Log.info (fun f -> f "Client %d (IP: %s) ready" domid (Ipaddr.V4.to_string client_ip)); ClientEth.connect backend >>= fun eth -> let client_mac = Netback.frontend_mac backend in - let client_eth = router.Router.client_eth in + let client_eth = router.Router.clients in let gateway_ip = Client_eth.client_gw client_eth in let iface = new client_iface eth ~domid ~gateway_ip ~client_ip client_mac in (* update the rules whenever QubesDB notices a change for this IP *) diff --git a/dao.ml b/dao.ml index 1c3785e..d5bfffa 100644 --- a/dao.ml +++ b/dao.ml @@ -136,13 +136,13 @@ exception Missing_key of string let try_read_network_config db = let get name = match DB.KeyMap.find_opt name db with - | None -> raise (Missing_key name) - | Some value -> value in - let uplink_our_ip = get "/qubes-ip" |> Ipaddr.V4.of_string_exn in - 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 + | None -> Ipaddr.V4.make 0 0 0 0 + | Some value -> Ipaddr.V4.of_string_exn value in + let uplink_our_ip = get "/qubes-ip" in + let uplink_netvm_ip = get "/qubes-gateway" in + let clients_our_ip = get "/qubes-netvm-gateway" in + let dns = get "/qubes-primary-dns" in + let dns2 = get "/qubes-secondary-dns" in Log.info (fun f -> f "@[Got network configuration from QubesDB:@,\ NetVM IP on uplink network: %a@,\ Our IP on uplink network: %a@,\ diff --git a/router.ml b/router.ml index 4d7ed90..1e18005 100644 --- a/router.ml +++ b/router.ml @@ -6,29 +6,29 @@ open Fw_utils (* The routing table *) type t = { - client_eth : Client_eth.t; + clients : Client_eth.t; nat : My_nat.t; uplink : interface; } -let create ~client_eth ~uplink ~nat = - { client_eth; nat; uplink } +let create ~clients ~uplink ~nat = + { clients; nat; uplink } let target t buf = let dst_ip = buf.Ipv4_packet.dst in - match Client_eth.lookup t.client_eth dst_ip with + match Client_eth.lookup t.clients dst_ip with | Some client_link -> Some (client_link :> interface) | None -> Some t.uplink -let add_client t = Client_eth.add_client t.client_eth -let remove_client t = Client_eth.remove_client t.client_eth +let add_client t = Client_eth.add_client t.clients +let remove_client t = Client_eth.remove_client t.clients let classify t ip = if ip = Ipaddr.V4 t.uplink#my_ip then `Firewall else if ip = Ipaddr.V4 t.uplink#other_ip then `NetVM - else (Client_eth.classify t.client_eth ip :> Packet.host) + else (Client_eth.classify t.clients ip :> Packet.host) let resolve t = function | `Firewall -> Ipaddr.V4 t.uplink#my_ip | `NetVM -> Ipaddr.V4 t.uplink#other_ip - | #Client_eth.host as host -> Client_eth.resolve t.client_eth host + | #Client_eth.host as host -> Client_eth.resolve t.clients host diff --git a/router.mli b/router.mli index 34fa86b..515277e 100644 --- a/router.mli +++ b/router.mli @@ -6,13 +6,13 @@ open Fw_utils type t = private { - client_eth : Client_eth.t; + clients : Client_eth.t; nat : My_nat.t; uplink : interface; } val create : - client_eth:Client_eth.t -> + clients:Client_eth.t -> uplink:interface -> nat:My_nat.t -> t diff --git a/unikernel.ml b/unikernel.ml index 65f7b3a..c065f94 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -52,11 +52,10 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_tim Uplink.connect config >>= fun uplink -> (* Set up client-side networking *) - let client_eth = Client_eth.create - ~client_gw:config.Dao.clients_our_ip in + Client_eth.create config >>= fun clients -> (* Set up routing between networks and hosts *) let router = Router.create - ~client_eth + ~clients ~uplink:(Uplink.interface uplink) ~nat in From 5a0711bb2db3e39456c50b11f8b98f5424c4da45 Mon Sep 17 00:00:00 2001 From: palainp Date: Fri, 30 Jun 2023 15:31:30 +0200 Subject: [PATCH 181/281] in Qubes doc client_our_ip is always netvm_our_ip --- client_eth.ml | 2 +- dao.ml | 19 +++++++------------ dao.mli | 6 ++---- uplink.ml | 6 +++--- 4 files changed, 13 insertions(+), 20 deletions(-) diff --git a/client_eth.ml b/client_eth.ml index 45337b2..de41f70 100644 --- a/client_eth.ml +++ b/client_eth.ml @@ -20,7 +20,7 @@ type host = let create config = let changed = Lwt_condition.create () in - let my_ip = config.Dao.uplink_our_ip in + let my_ip = config.Dao.our_ip in Lwt.return { iface_of_ip = IpMap.empty; my_ip; changed } let client_gw t = t.my_ip diff --git a/dao.ml b/dao.ml index d5bfffa..c6ba241 100644 --- a/dao.ml +++ b/dao.ml @@ -123,10 +123,8 @@ let watch_clients fn = ) type network_config = { - uplink_netvm_ip : Ipaddr.V4.t; (* The IP address of NetVM (our gateway) *) - uplink_our_ip : Ipaddr.V4.t; (* The IP address of our interface to NetVM *) - - clients_our_ip : Ipaddr.V4.t; (* The IP address of our interface to our client VMs (their gateway) *) + netvm_ip : Ipaddr.V4.t; (* The IP address of NetVM (our gateway) *) + our_ip : Ipaddr.V4.t; (* The IP address of our interface to NetVM *) dns : Ipaddr.V4.t; dns2 : Ipaddr.V4.t; } @@ -138,23 +136,20 @@ let try_read_network_config db = match DB.KeyMap.find_opt name db with | None -> Ipaddr.V4.make 0 0 0 0 | Some value -> Ipaddr.V4.of_string_exn value in - let uplink_our_ip = get "/qubes-ip" in - let uplink_netvm_ip = get "/qubes-gateway" in - let clients_our_ip = get "/qubes-netvm-gateway" in + let our_ip = get "/qubes-ip" in (* - IP address for this VM (only when VM has netvm set) *) + let netvm_ip = get "/qubes-gateway" in (* - default gateway IP (only when VM has netvm set); VM should add host route to this address directly via eth0 (or whatever default interface name is) *) let dns = get "/qubes-primary-dns" in let dns2 = get "/qubes-secondary-dns" 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 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 netvm_ip + Ipaddr.V4.pp our_ip Ipaddr.V4.pp dns Ipaddr.V4.pp dns2); - { uplink_netvm_ip; uplink_our_ip; clients_our_ip ; dns ; dns2 } + { netvm_ip ; our_ip ; dns ; dns2 } let read_network_config qubesDB = let rec aux bindings = diff --git a/dao.mli b/dao.mli index 2b3d97a..df3c23b 100644 --- a/dao.mli +++ b/dao.mli @@ -20,10 +20,8 @@ val watch_clients : (Ipaddr.V4.t VifMap.t -> unit) -> 'a Lwt.t in XenStore, and again each time XenStore updates. *) type network_config = { - uplink_netvm_ip : Ipaddr.V4.t; (* The IP address of NetVM (our gateway) *) - uplink_our_ip : Ipaddr.V4.t; (* The IP address of our interface to NetVM *) - - clients_our_ip : Ipaddr.V4.t; (* The IP address of our interface to our client VMs (their gateway) *) + netvm_ip : Ipaddr.V4.t; (* The IP address of NetVM (our gateway) *) + our_ip : Ipaddr.V4.t; (* The IP address of our interface to NetVM *) dns : Ipaddr.V4.t; dns2 : Ipaddr.V4.t; } diff --git a/uplink.ml b/uplink.ml index b74d1df..a7b0350 100644 --- a/uplink.ml +++ b/uplink.ml @@ -74,8 +74,8 @@ end let interface t = t.interface let connect config = - let my_ip = config.Dao.uplink_our_ip in - let gateway = config.Dao.uplink_netvm_ip in + let my_ip = config.Dao.our_ip in + let gateway = config.Dao.netvm_ip in Netif.connect "0" >>= fun net -> Eth.connect net >>= fun eth -> Arp.connect eth >>= fun arp -> @@ -88,7 +88,7 @@ let connect config = >|= or_raise "Getting MAC of our NetVM" Arp.pp_error in let interface = new netvm_iface eth netvm_mac ~my_ip - ~other_ip:config.Dao.uplink_netvm_ip in + ~other_ip:config.Dao.netvm_ip in let fragments = Fragments.Cache.empty (256 * 1024) in Lwt.return { net; eth; arp; interface ; fragments ; ip ; udp } end From de9a1dbd1c7bc9a82762c38b50d8cddd715a3566 Mon Sep 17 00:00:00 2001 From: palainp Date: Fri, 30 Jun 2023 15:33:41 +0200 Subject: [PATCH 182/281] add the network_config to the router --- router.ml | 13 +++++++------ router.mli | 8 +++++--- unikernel.ml | 1 + 3 files changed, 13 insertions(+), 9 deletions(-) diff --git a/router.ml b/router.ml index 1e18005..fbd7175 100644 --- a/router.ml +++ b/router.ml @@ -6,13 +6,14 @@ open Fw_utils (* The routing table *) type t = { + config : Dao.network_config; clients : Client_eth.t; nat : My_nat.t; uplink : interface; } -let create ~clients ~uplink ~nat = - { clients; nat; uplink } +let create ~config ~clients ~uplink ~nat = + { config; clients; nat; uplink } let target t buf = let dst_ip = buf.Ipv4_packet.dst in @@ -24,11 +25,11 @@ let add_client t = Client_eth.add_client t.clients let remove_client t = Client_eth.remove_client t.clients let classify t ip = - if ip = Ipaddr.V4 t.uplink#my_ip then `Firewall - else if ip = Ipaddr.V4 t.uplink#other_ip then `NetVM + if ip = Ipaddr.V4 t.config.our_ip then `Firewall + else if ip = Ipaddr.V4 t.config.netvm_ip then `NetVM else (Client_eth.classify t.clients ip :> Packet.host) let resolve t = function - | `Firewall -> Ipaddr.V4 t.uplink#my_ip - | `NetVM -> Ipaddr.V4 t.uplink#other_ip + | `Firewall -> Ipaddr.V4 t.config.our_ip + | `NetVM -> Ipaddr.V4 t.config.netvm_ip | #Client_eth.host as host -> Client_eth.resolve t.clients host diff --git a/router.mli b/router.mli index 515277e..e17b7db 100644 --- a/router.mli +++ b/router.mli @@ -6,15 +6,17 @@ open Fw_utils type t = private { + config : Dao.network_config; clients : Client_eth.t; nat : My_nat.t; uplink : interface; } val create : - clients:Client_eth.t -> - uplink:interface -> - nat:My_nat.t -> + config : Dao.network_config -> + clients : Client_eth.t -> + uplink : interface -> + nat : My_nat.t -> t (** [create ~client_eth ~uplink ~nat] is a new routing table that routes packets outside of [client_eth] via [uplink]. *) diff --git a/unikernel.ml b/unikernel.ml index c065f94..d0e84cc 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -55,6 +55,7 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_tim Client_eth.create config >>= fun clients -> (* Set up routing between networks and hosts *) let router = Router.create + ~config ~clients ~uplink:(Uplink.interface uplink) ~nat From 55b2f191963e28e2f5956f8ab6d495d9f9380d9d Mon Sep 17 00:00:00 2001 From: palainp Date: Fri, 30 Jun 2023 16:58:08 +0200 Subject: [PATCH 183/281] add optional uplink interface --- config.ml | 24 +++++++++++++++++++++- dao.ml | 28 +++++++++++++++++-------- dao.mli | 4 ++++ firewall.ml | 14 ++++++++++--- my_dns.ml | 2 +- router.ml | 6 +++--- router.mli | 4 ++-- unikernel.ml | 27 ++++++++++++++++++++++-- uplink.ml | 58 ++++++++++++++++++++++++++++++---------------------- uplink.mli | 6 +++--- 10 files changed, 125 insertions(+), 48 deletions(-) diff --git a/config.ml b/config.ml index 314172f..53bf8e3 100644 --- a/config.ml +++ b/config.ml @@ -13,9 +13,31 @@ let table_size = let key = Key.Arg.opt ~stage:`Both Key.Arg.int 5_000 info in Key.create "nat_table_size" key +let ipv4 = + let doc = Key.Arg.info ~doc:"Manual IP setting." ["ipv4"] in + Key.(create "ipv4" Arg.(opt string "0.0.0.0" doc)) + +let ipv4_gw = + let doc = Key.Arg.info ~doc:"Manual Gateway IP setting." ["ipv4-gw"] in + Key.(create "ipv4_gw" Arg.(opt string "0.0.0.0" doc)) + +let ipv4_dns = + let doc = Key.Arg.info ~doc:"Manual DNS IP setting." ["ipv4-dns"] in + Key.(create "ipv4_dns" Arg.(opt string "10.139.0.1" doc)) + +let ipv4_dns2 = + let doc = Key.Arg.info ~doc:"Manual Second DNS IP setting." ["ipv4-dns2"] in + Key.(create "ipv4_dns2" Arg.(opt string "10.139.0.2" doc)) + let main = foreign - ~keys:[Key.v table_size] + ~keys:[ + Key.v table_size; + Key.v ipv4; + Key.v ipv4_gw; + Key.v ipv4_dns; + Key.v ipv4_dns2; + ] ~packages:[ package "vchan" ~min:"4.0.2"; package "cstruct"; diff --git a/dao.ml b/dao.ml index c6ba241..ade9662 100644 --- a/dao.ml +++ b/dao.ml @@ -140,15 +140,6 @@ let try_read_network_config db = let netvm_ip = get "/qubes-gateway" in (* - default gateway IP (only when VM has netvm set); VM should add host route to this address directly via eth0 (or whatever default interface name is) *) let dns = get "/qubes-primary-dns" in let dns2 = get "/qubes-secondary-dns" in - Log.info (fun f -> f "@[Got network configuration from QubesDB:@,\ - NetVM IP on uplink network: %a@,\ - Our IP on client networks: %a@,\ - DNS primary resolver: %a@,\ - DNS secondary resolver: %a@]" - Ipaddr.V4.pp netvm_ip - Ipaddr.V4.pp our_ip - Ipaddr.V4.pp dns - Ipaddr.V4.pp dns2); { netvm_ip ; our_ip ; dns ; dns2 } let read_network_config qubesDB = @@ -160,4 +151,23 @@ let read_network_config qubesDB = in aux (DB.bindings qubesDB) +let print_network_config config = + Log.info (fun f -> f "@[Got network configuration from QubesDB:@,\ + NetVM IP on uplink network: %a@,\ + Our IP on client networks: %a@,\ + DNS primary resolver: %a@,\ + DNS secondary resolver: %a@]" + Ipaddr.V4.pp config.netvm_ip + Ipaddr.V4.pp config.our_ip + Ipaddr.V4.pp config.dns + Ipaddr.V4.pp config.dns2) + +let update_network_config config update_config = + let zero_ip = Ipaddr.V4.make 0 0 0 0 in + let netvm_ip = if config.netvm_ip = zero_ip then update_config.netvm_ip else config.netvm_ip in + let our_ip = if config.our_ip = zero_ip then update_config.our_ip else config.our_ip in + let dns = if config.dns = zero_ip then update_config.dns else config.dns in + let dns2 = if config.dns2 = zero_ip then update_config.dns2 else config.dns2 in + Lwt.return { netvm_ip ; our_ip ; dns ; dns2 } + let set_iptables_error db = Qubes.DB.write db "/qubes-iptables-error" diff --git a/dao.mli b/dao.mli index df3c23b..780d82c 100644 --- a/dao.mli +++ b/dao.mli @@ -37,4 +37,8 @@ val read_rules : string Qubes.DB.KeyMap.t -> Ipaddr.V4.t -> Pf_qubes.Parse_qubes (** [read_rules bindings ip] extracts firewall rule information for [ip] from [bindings]. If any rules fail to parse, it will return only one rule denying all traffic. *) +val update_network_config : network_config -> network_config -> network_config Lwt.t + +val print_network_config : network_config -> unit + val set_iptables_error : Qubes.DB.t -> string -> unit Lwt.t diff --git a/firewall.ml b/firewall.ml index 06d32a4..ebe80dd 100644 --- a/firewall.ml +++ b/firewall.ml @@ -46,7 +46,7 @@ let translate t packet = (* Add a NAT rule for the endpoints in this frame, via a random port on the firewall. *) let add_nat_and_forward_ipv4 t packet = let open Router in - let xl_host = t.uplink#my_ip in + let xl_host = t.config.our_ip in match My_nat.add_nat_rule_and_translate t.nat ~xl_host `NAT packet with | Ok packet -> forward_ipv4 t packet | Error e -> @@ -59,7 +59,7 @@ let nat_to t ~host ~port packet = match resolve t host with | Ipaddr.V6 _ -> Log.warn (fun f -> f "Cannot NAT with IPv6"); Lwt.return_unit | Ipaddr.V4 target -> - let xl_host = t.uplink#my_ip in + let xl_host = t.config.our_ip in match My_nat.add_nat_rule_and_translate t.nat ~xl_host (`Redirect (target, port)) packet with | Ok packet -> forward_ipv4 t packet | Error e -> @@ -71,7 +71,15 @@ let apply_rules t (rules : ('a, 'b) Packet.t -> Packet.action Lwt.t) ~dst (annot rules annotated_packet >>= fun action -> match action, dst with | `Accept, `Client client_link -> transmit_ipv4 packet client_link - | `Accept, (`External _ | `NetVM) -> transmit_ipv4 packet t.Router.uplink + | `Accept, (`External _ | `NetVM) -> + begin match t.Router.uplink with + | Some uplink -> transmit_ipv4 packet uplink + | None -> begin match Client_eth.lookup t.clients t.config.netvm_ip with + | Some iface -> transmit_ipv4 packet iface + | None -> Log.warn (fun f -> f "No output interface for %a : drop" Nat_packet.pp packet); + Lwt.return_unit + end + end | `Accept, `Firewall -> Log.warn (fun f -> f "Bad rule: firewall can't accept packets %a" Nat_packet.pp packet); Lwt.return_unit diff --git a/my_dns.ml b/my_dns.ml index 372c29a..33a0ed5 100644 --- a/my_dns.ml +++ b/my_dns.ml @@ -52,7 +52,7 @@ module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) (Time : Mirage_ let dst, dst_port = ctx.nameserver 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 + My_nat.free_udp_port router.nat ~src:router.config.our_ip ~dst ~dst_port:53 in let id = Cstruct.BE.get_uint16 buf 0 in with_timeout ctx.timeout_ns diff --git a/router.ml b/router.ml index fbd7175..a8dc89d 100644 --- a/router.ml +++ b/router.ml @@ -9,17 +9,17 @@ type t = { config : Dao.network_config; clients : Client_eth.t; nat : My_nat.t; - uplink : interface; + uplink : interface option; } -let create ~config ~clients ~uplink ~nat = +let create ~config ~clients ~nat ?uplink = { config; clients; nat; uplink } let target t buf = let dst_ip = buf.Ipv4_packet.dst in match Client_eth.lookup t.clients dst_ip with | Some client_link -> Some (client_link :> interface) - | None -> Some t.uplink + | None -> t.uplink let add_client t = Client_eth.add_client t.clients let remove_client t = Client_eth.remove_client t.clients diff --git a/router.mli b/router.mli index e17b7db..532c39e 100644 --- a/router.mli +++ b/router.mli @@ -9,14 +9,14 @@ type t = private { config : Dao.network_config; clients : Client_eth.t; nat : My_nat.t; - uplink : interface; + uplink : interface option; } val create : config : Dao.network_config -> clients : Client_eth.t -> - uplink : interface -> nat : My_nat.t -> + ?uplink : interface -> t (** [create ~client_eth ~uplink ~nat] is a new routing table that routes packets outside of [client_eth] via [uplink]. *) diff --git a/unikernel.ml b/unikernel.ml index d0e84cc..ce28b72 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -49,16 +49,39 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_tim (* Read network configuration from QubesDB *) Dao.read_network_config qubesDB >>= fun config -> + (* config.netvm_ip might be 0.0.0.0 if there's no netvm provided via Qubes *) - Uplink.connect config >>= fun uplink -> (* Set up client-side networking *) Client_eth.create config >>= fun clients -> + + let connect_if_netvm = + if config.netvm_ip <> (Ipaddr.V4.make 0 0 0 0) then ( + Uplink.connect config >>= fun uplink -> + Lwt.return (config, Some uplink) + ) else ( + (* If we have no netvm IP address we must not try to Uplink.connect and we can update the config + with command option (if any) *) + let netvm_ip = Ipaddr.V4.of_string_exn (Key_gen.ipv4_gw ()) in + let our_ip = Ipaddr.V4.of_string_exn (Key_gen.ipv4 ()) in + let dns = Ipaddr.V4.of_string_exn (Key_gen.ipv4_dns ()) in + let dns2 = Ipaddr.V4.of_string_exn (Key_gen.ipv4_dns2 ()) in + let default_config:Dao.network_config = {netvm_ip; our_ip; dns; dns2} in + Dao.update_network_config config default_config >>= fun config -> + Lwt.return (config, None) + ) + in + connect_if_netvm >>= fun (config, uplink) -> + + (* We now must have a valid netvm IP address or crash *) + Dao.print_network_config config ; + assert(config.netvm_ip <> (Ipaddr.V4.make 0 0 0 0)); + (* Set up routing between networks and hosts *) let router = Router.create ~config ~clients - ~uplink:(Uplink.interface uplink) ~nat + ?uplink:(Uplink.interface uplink) in let send_dns_query = Uplink.send_dns_client_query uplink in diff --git a/uplink.ml b/uplink.ml index a7b0350..2f7ea5e 100644 --- a/uplink.ml +++ b/uplink.ml @@ -34,9 +34,13 @@ class netvm_iface eth mac ~my_ip ~other_ip : interface = object end let send_dns_client_query t ~src_port ~dst ~dst_port buf = - U.write ~src_port ~dst ~dst_port t.udp buf >|= function - | Error s -> Log.err (fun f -> f "error sending udp packet: %a" U.pp_error s); Error (`Msg "failure") - | Ok () -> Ok () + match t with + | None -> + Log.err (fun f -> f "No uplink interface"); Lwt.return (Error (`Msg "failure")) + | Some t -> + U.write ~src_port ~dst ~dst_port t.udp buf >|= function + | Error s -> Log.err (fun f -> f "error sending udp packet: %a" U.pp_error s); Error (`Msg "failure") + | Ok () -> Ok () let listen t get_ts dns_responses router = let handle_packet ip_header ip_packet = @@ -50,28 +54,34 @@ end | _ -> Firewall.ipv4_from_netvm router (`IPv4 (ip_header, ip_packet)) in - Netif.listen t.net ~header_size:Ethernet.Packet.sizeof_ethernet (fun frame -> - (* Handle one Ethernet frame from NetVM *) - Eth.input t.eth - ~arpv4:(Arp.input t.arp) - ~ipv4:(fun ip -> - let cache, r = - Nat_packet.of_ipv4_packet t.fragments ~now:(get_ts ()) ip - in - t.fragments <- cache; - match r with - | Error e -> - Log.warn (fun f -> f "Ignored unknown IPv4 message from uplink: %a" Nat_packet.pp_error e); - Lwt.return () - | Ok None -> Lwt.return_unit - | Ok (Some (`IPv4 (header, packet))) -> handle_packet header packet - ) - ~ipv6:(fun _ip -> Lwt.return_unit) - frame - ) >|= or_raise "Uplink listen loop" Netif.pp_error + begin match t with + | None -> Lwt.return_unit + | Some t -> + Netif.listen t.net ~header_size:Ethernet.Packet.sizeof_ethernet (fun frame -> + (* Handle one Ethernet frame from NetVM *) + Eth.input t.eth + ~arpv4:(Arp.input t.arp) + ~ipv4:(fun ip -> + let cache, r = + Nat_packet.of_ipv4_packet t.fragments ~now:(get_ts ()) ip + in + t.fragments <- cache; + match r with + | Error e -> + Log.warn (fun f -> f "Ignored unknown IPv4 message from uplink: %a" Nat_packet.pp_error e); + Lwt.return () + | Ok None -> Lwt.return_unit + | Ok (Some (`IPv4 (header, packet))) -> handle_packet header packet + ) + ~ipv6:(fun _ip -> Lwt.return_unit) + frame + ) >|= or_raise "Uplink listen loop" Netif.pp_error + end - -let interface t = t.interface +let interface t = + match t with + | None -> None + | Some t -> Some t.interface let connect config = let my_ip = config.Dao.our_ip in diff --git a/uplink.mli b/uplink.mli index f6edaaf..0d35e5e 100644 --- a/uplink.mli +++ b/uplink.mli @@ -11,11 +11,11 @@ module Make (R: Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_time val connect : Dao.network_config -> t Lwt.t (** Connect to our NetVM (gateway). *) - val interface : t -> interface + val interface : t option -> interface option (** The network interface to NetVM. *) - val listen : t -> (unit -> int64) -> (Udp_packet.t * Cstruct.t) Lwt_mvar.t -> Router.t -> unit Lwt.t + val listen : t option -> (unit -> int64) -> (Udp_packet.t * Cstruct.t) Lwt_mvar.t -> Router.t -> unit Lwt.t (** Handle incoming frames from NetVM. *) - val send_dns_client_query: t -> src_port:int-> dst:Ipaddr.V4.t -> dst_port:int -> Cstruct.t -> (unit, [`Msg of string]) result Lwt.t + val send_dns_client_query: t option -> src_port:int-> dst:Ipaddr.V4.t -> dst_port:int -> Cstruct.t -> (unit, [`Msg of string]) result Lwt.t end From fe99021dc05cf43bcaef2db23b1463d5686312f6 Mon Sep 17 00:00:00 2001 From: palainp Date: Fri, 30 Jun 2023 17:06:17 +0200 Subject: [PATCH 184/281] add minimal README information about using mirage-firewall without netvm --- README.md | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/README.md b/README.md index a24f6cd..0dc963d 100644 --- a/README.md +++ b/README.md @@ -109,6 +109,17 @@ https://www.qubes-os.org/doc/software-update-dom0/ says: > there are no significant security implications in this choice. By default, > this role is assigned to the firewallvm. +### Configure firewall with OpenBSD-like netvm + +OpenBSD is currently unable to be used as netvm, so if you want to use a BSD as your sys-net VM, you'll need to set its netvm to qubes-mirage-firewall (see https://github.com/mirage/qubes-mirage-firewall/issues/146 for more information). +That means you'll have `AppVMs -> qubes-mirage-firewall <- OpenBSD` with the arrow standing for the netvm property setting. + +In that case you'll have to tell qubes-mirage-firewall which AppVM client should be used as uplink: +``` +qvm-prefs --set mirage-firewall -- kernelopts '--ipv4=X.X.X.X --ipv4-gw=Y.Y.Y.Y' +``` +with `X.X.X.X` the IP address for mirage-firewall and `Y.Y.Y.Y` the IP address of your OpenBSD HVM. + ### Components This diagram show the main components (each box corresponds to a source `.ml` file with the same name): From e5349c22a7f3c6e7db678098b2aaf7abe0de7c83 Mon Sep 17 00:00:00 2001 From: palainp Date: Fri, 30 Jun 2023 17:13:56 +0200 Subject: [PATCH 185/281] do not stop the unikernel if netvm is None --- unikernel.ml | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/unikernel.ml b/unikernel.ml index ce28b72..708fe53 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -17,10 +17,13 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_tim (* Report success *) Dao.set_iptables_error qubesDB "" >>= fun () -> (* Handle packets from both networks *) - Lwt.choose [ - Client_net.listen Clock.elapsed_ns dns_client dns_servers qubesDB router; - Uplink.listen uplink Clock.elapsed_ns dns_responses router - ] + match uplink with + | None -> Client_net.listen Clock.elapsed_ns dns_client dns_servers qubesDB router + | _ -> + Lwt.choose [ + Client_net.listen Clock.elapsed_ns dns_client dns_servers qubesDB router; + Uplink.listen uplink Clock.elapsed_ns dns_responses router + ] (* Main unikernel entry point (called from auto-generated main.ml). *) let start _random _clock _time = From e99e80b1508248c1c122a1962b5d0753a23fd6fa Mon Sep 17 00:00:00 2001 From: palainp Date: Fri, 30 Jun 2023 17:57:08 +0200 Subject: [PATCH 186/281] only set clients when we have a correct netvm IP address --- unikernel.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/unikernel.ml b/unikernel.ml index 708fe53..227e75a 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -54,9 +54,6 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_tim Dao.read_network_config qubesDB >>= fun config -> (* config.netvm_ip might be 0.0.0.0 if there's no netvm provided via Qubes *) - (* Set up client-side networking *) - Client_eth.create config >>= fun clients -> - let connect_if_netvm = if config.netvm_ip <> (Ipaddr.V4.make 0 0 0 0) then ( Uplink.connect config >>= fun uplink -> @@ -79,6 +76,9 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_tim Dao.print_network_config config ; assert(config.netvm_ip <> (Ipaddr.V4.make 0 0 0 0)); + (* Set up client-side networking *) + Client_eth.create config >>= fun clients -> + (* Set up routing between networks and hosts *) let router = Router.create ~config From 7f5729a12d5b0ab0a3d0f995b22d9ad69ff37f7f Mon Sep 17 00:00:00 2001 From: palainp Date: Sat, 1 Jul 2023 10:46:55 +0200 Subject: [PATCH 187/281] prevent usage of both command line options and netvm property --- unikernel.ml | 22 ++++++++++++++-------- 1 file changed, 14 insertions(+), 8 deletions(-) diff --git a/unikernel.ml b/unikernel.ml index 227e75a..fe602e2 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -54,27 +54,33 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_tim Dao.read_network_config qubesDB >>= fun config -> (* config.netvm_ip might be 0.0.0.0 if there's no netvm provided via Qubes *) + let zero_ip = (Ipaddr.V4.make 0 0 0 0) in + let connect_if_netvm = - if config.netvm_ip <> (Ipaddr.V4.make 0 0 0 0) then ( + let netvm_ip = Ipaddr.V4.of_string_exn (Key_gen.ipv4_gw ()) in + let our_ip = Ipaddr.V4.of_string_exn (Key_gen.ipv4 ()) in + let dns = Ipaddr.V4.of_string_exn (Key_gen.ipv4_dns ()) in + let dns2 = Ipaddr.V4.of_string_exn (Key_gen.ipv4_dns2 ()) in + let default_config:Dao.network_config = {netvm_ip; our_ip; dns; dns2} in + + if config.netvm_ip <> zero_ip then ( + if (netvm_ip <> zero_ip || our_ip <> zero_ip) then begin + Log.err (fun f -> f "You must not specify --ipv4 or --ipv4-gw when using the netvm property: discard command line options") + end ; Uplink.connect config >>= fun uplink -> Lwt.return (config, Some uplink) ) else ( (* If we have no netvm IP address we must not try to Uplink.connect and we can update the config with command option (if any) *) - let netvm_ip = Ipaddr.V4.of_string_exn (Key_gen.ipv4_gw ()) in - let our_ip = Ipaddr.V4.of_string_exn (Key_gen.ipv4 ()) in - let dns = Ipaddr.V4.of_string_exn (Key_gen.ipv4_dns ()) in - let dns2 = Ipaddr.V4.of_string_exn (Key_gen.ipv4_dns2 ()) in - let default_config:Dao.network_config = {netvm_ip; our_ip; dns; dns2} in Dao.update_network_config config default_config >>= fun config -> Lwt.return (config, None) ) in connect_if_netvm >>= fun (config, uplink) -> - (* We now must have a valid netvm IP address or crash *) + (* We now must have a valid netvm IP address and our IP address or crash *) Dao.print_network_config config ; - assert(config.netvm_ip <> (Ipaddr.V4.make 0 0 0 0)); + assert(config.netvm_ip <> zero_ip && config.our_ip <> zero_ip); (* Set up client-side networking *) Client_eth.create config >>= fun clients -> From ee2409dc6134bc8ce15dd923b756ef467786efdb Mon Sep 17 00:00:00 2001 From: palainp Date: Sat, 1 Jul 2023 11:56:14 +0200 Subject: [PATCH 188/281] fallback to the command line specified uplink interface if no netvm interface --- firewall.ml | 37 ++++++++++++++++++++++--------------- router.ml | 11 ++++++++++- 2 files changed, 32 insertions(+), 16 deletions(-) diff --git a/firewall.ml b/firewall.ml index ebe80dd..3bf0e6f 100644 --- a/firewall.ml +++ b/firewall.ml @@ -91,21 +91,6 @@ let apply_rules t (rules : ('a, 'b) Packet.t -> Packet.action Lwt.t) ~dst (annot Log.debug (fun f -> f "Dropped packet (%s) %a" reason Nat_packet.pp packet); Lwt.return_unit -let ipv4_from_client resolver dns_servers t ~src packet = - match Memory_pressure.status () with - | `Memory_critical -> Lwt.return_unit - | `Ok -> - (* Check for existing NAT entry for this packet *) - match translate t packet with - | Some frame -> forward_ipv4 t frame (* Some existing connection or redirect *) - | None -> - (* 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 - 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 dns_servers) ~dst firewall_packet - let ipv4_from_netvm t packet = match Memory_pressure.status () with | `Memory_critical -> Lwt.return_unit @@ -127,3 +112,25 @@ let ipv4_from_netvm t packet = match Packet.of_mirage_nat_packet ~src ~dst packet with | None -> Lwt.return_unit | Some packet -> apply_rules t Rules.from_netvm ~dst packet + +let ipv4_from_client resolver dns_servers t ~src packet = + match Memory_pressure.status () with + | `Memory_critical -> Lwt.return_unit + | `Ok -> + (* Check for existing NAT entry for this packet *) + match translate t packet with + | Some frame -> forward_ipv4 t frame (* Some existing connection or redirect *) + | None -> + (* No existing NAT entry. Check the firewall rules. *) + let `IPv4 (ip, _transport) = packet in + match Router.classify t (Ipaddr.V4 ip.Ipv4_packet.src) with + | `Client _ | `Firewall -> ( + 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 dns_servers) ~dst firewall_packet + ) + | `NetVM -> ipv4_from_netvm t packet + | `External _ -> + Log.warn (fun f -> f "Frame from Inside has external source IP address! %a" Nat_packet.pp packet); + Lwt.return_unit diff --git a/router.ml b/router.ml index a8dc89d..3ca586a 100644 --- a/router.ml +++ b/router.ml @@ -4,6 +4,8 @@ open Fw_utils (* The routing table *) +let src = Logs.Src.create "router" ~doc:"Packet router" +module Log = (val Logs.src_log src : Logs.LOG) type t = { config : Dao.network_config; @@ -19,7 +21,14 @@ let target t buf = let dst_ip = buf.Ipv4_packet.dst in match Client_eth.lookup t.clients dst_ip with | Some client_link -> Some (client_link :> interface) - | None -> t.uplink + | None -> begin match t.uplink with + | None -> ( + match Client_eth.lookup t.clients t.config.netvm_ip with + | Some uplink -> Some (uplink :> interface) + | None -> None + ) + | uplink -> uplink + end let add_client t = Client_eth.add_client t.clients let remove_client t = Client_eth.remove_client t.clients From 95812a7458018c03fc3552d9ef0c38639974676b Mon Sep 17 00:00:00 2001 From: palainp Date: Sat, 1 Jul 2023 16:49:07 +0200 Subject: [PATCH 189/281] fix default DNS addresses --- config.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/config.ml b/config.ml index 53bf8e3..e3eb2ad 100644 --- a/config.ml +++ b/config.ml @@ -23,11 +23,11 @@ let ipv4_gw = let ipv4_dns = let doc = Key.Arg.info ~doc:"Manual DNS IP setting." ["ipv4-dns"] in - Key.(create "ipv4_dns" Arg.(opt string "10.139.0.1" doc)) + Key.(create "ipv4_dns" Arg.(opt string "10.139.1.1" doc)) let ipv4_dns2 = let doc = Key.Arg.info ~doc:"Manual Second DNS IP setting." ["ipv4-dns2"] in - Key.(create "ipv4_dns2" Arg.(opt string "10.139.0.2" doc)) + Key.(create "ipv4_dns2" Arg.(opt string "10.139.1.2" doc)) let main = foreign From e055f810c7744f761184cf852f72ff817ec5a5d2 Mon Sep 17 00:00:00 2001 From: palainp Date: Sat, 1 Jul 2023 17:26:34 +0200 Subject: [PATCH 190/281] update hashsum --- 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 7cd77a6..65f6867 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`:/tmp/orb-build qubes-mirage-firewall echo "SHA2 of build: $(sha256sum ./dist/qubes-firewall.xen)" -echo "SHA2 last known: 55a2f823d66473c7d0be66a93289d48b6557f18c9257c6f98aa5a4583663d3c2" +echo "SHA2 last known: 1f621d3bde2cf2905b5ad333f7dbde9ef99479251118e1a1da9b4da15957a87d" echo "(hashes should match for released versions)" From a34aab52e97dc3e5495e5700c6adc48cb7e546c1 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 5 Jul 2023 17:06:00 +0200 Subject: [PATCH 191/281] Apply suggestions from code review --- Dockerfile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Dockerfile b/Dockerfile index e0eaa70..0c3c0c8 100644 --- a/Dockerfile +++ b/Dockerfile @@ -7,7 +7,7 @@ FROM debian@sha256:07c6cb2ae86479dcc1942a89b0a1f4049b6e9415f7de327ff641aed58b8e3 RUN printf "deb [check-valid-until=no] http://snapshot.notset.fr/archive/debian/20230418T024659Z bookworm main" > /etc/apt/sources.list RUN apt update && apt install --no-install-recommends --no-install-suggests -y wget ca-certificates git patch unzip bzip2 make gcc g++ libc-dev -RUN wget -O /usr/bin/opam https://github.com/ocaml/opam/releases/download/2.1.4/opam-2.1.4-i686-linux && chmod 755 /usr/bin/opam +RUN wget -O /usr/bin/opam https://github.com/ocaml/opam/releases/download/2.1.5/opam-2.1.5-i686-linux && chmod 755 /usr/bin/opam ENV OPAMROOT=/tmp ENV OPAMCONFIRMLEVEL=unsafe-yes From 8e87f2e9e0b13e60c59f974b73618af12e407aa1 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 5 Jul 2023 17:14:14 +0200 Subject: [PATCH 192/281] update sha --- 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 b4faef7..e5a9a17 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`:/tmp/orb-build qubes-mirage-firewall echo "SHA2 of build: $(sha256sum ./dist/qubes-firewall.xen)" -echo "SHA2 last known: d9f7827e2f2c8150ac97a4d348a29f5ee0810a455dbab9233490fff97470f7b8" +echo "SHA2 last known: 8ae5314edf5b863b788c4b873e27bc4b206a2ff7ef1051c4c62ae41584ed3e14" echo "(hashes should match for released versions)" From e4f4c3e958f745e4d4a0d2bc2d7afa536583a33a Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 5 Jul 2023 17:34:20 +0200 Subject: [PATCH 193/281] changes for 0.8.5 --- CHANGES.md | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index e147c1f..f37b080 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,10 @@ +### 0.8.5 (2023-07-05) + +- Remove memreport to Xen to avoid Qubes trying to get back some memory + (#176 @palainp) +- Use bookworm and snapshot.notset.fr debian packages for reproducibility + (#175 @palainp) + ### 0.8.4 (2022-12-07) - Fix remote denial of service due to excessive console output (#166 @burghardt, From 764e95e5be9d49c3ff0617a1b1417a34dee4647c Mon Sep 17 00:00:00 2001 From: palainp Date: Wed, 5 Jul 2023 11:56:19 +0200 Subject: [PATCH 194/281] WIP: - merge router+uplink+client_net+firewall into a single dispatcher file - watch qubesDB for netvm update - dynamic netvm should works - without netvm (but command line options) forward packet to a client, and warn the user if the "netvm" is not connected - apply ocamlformat --- client_net.ml | 167 --------------- client_net.mli | 12 -- dao.ml | 13 +- dao.mli | 3 +- dispatcher.ml | 550 +++++++++++++++++++++++++++++++++++++++++++++++++ firewall.ml | 136 ------------ firewall.mli | 13 -- my_dns.ml | 4 +- router.ml | 44 ---- router.mli | 33 --- unikernel.ml | 68 +++--- uplink.ml | 104 ---------- uplink.mli | 21 -- 13 files changed, 585 insertions(+), 583 deletions(-) delete mode 100644 client_net.ml delete mode 100644 client_net.mli create mode 100644 dispatcher.ml delete mode 100644 firewall.ml delete mode 100644 firewall.mli delete mode 100644 router.ml delete mode 100644 router.mli delete mode 100644 uplink.ml delete mode 100644 uplink.mli diff --git a/client_net.ml b/client_net.ml deleted file mode 100644 index 6e46327..0000000 --- a/client_net.ml +++ /dev/null @@ -1,167 +0,0 @@ -(* Copyright (C) 2015, Thomas Leonard - See the README file for details. *) - -open Lwt.Infix -open Fw_utils - -module Netback = Netchannel.Backend.Make(Netchannel.Xenstore.Make(Xen_os.Xs)) -module ClientEth = Ethernet.Make(Netback) - -let src = Logs.Src.create "client_net" ~doc:"Client networking" -module Log = (val Logs.src_log src : Logs.LOG) - -let writev eth dst proto fillfn = - Lwt.catch - (fun () -> - ClientEth.write eth dst proto fillfn >|= function - | Ok () -> () - | Error e -> - Log.err (fun f -> f "error trying to send to client: @[%a@]" - ClientEth.pp_error e); - ) - (fun ex -> - (* Usually Netback_shutdown, because the client disconnected *) - Log.err (fun f -> f "uncaught exception trying to send to client: @[%s@]" - (Printexc.to_string ex)); - Lwt.return_unit - ) - -class client_iface eth ~domid ~gateway_ip ~client_ip client_mac : client_link = - let log_header = Fmt.str "dom%d:%a" domid Ipaddr.V4.pp client_ip in - object - val mutable rules = [] - method get_rules = rules - method set_rules new_db = rules <- Dao.read_rules new_db client_ip - method my_mac = ClientEth.mac eth - method other_mac = client_mac - method my_ip = gateway_ip - method other_ip = client_ip - method writev proto fillfn = - writev eth client_mac proto fillfn - method log_header = log_header - end - -let clients : Cleanup.t Dao.VifMap.t ref = ref Dao.VifMap.empty - -(** Handle an ARP message from the client. *) -let input_arp ~fixed_arp ~iface request = - match Arp_packet.decode request with - | Error e -> - Log.warn (fun f -> f "Ignored unknown ARP message: %a" Arp_packet.pp_error e); - Lwt.return_unit - | Ok arp -> - match Client_eth.ARP.input fixed_arp arp with - | None -> Lwt.return_unit - | Some response -> - 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 dns_servers packet = - let cache', r = Nat_packet.of_ipv4_packet !cache ~now:(get_ts ()) packet in - cache := cache'; - match r with - | Error e -> - Log.warn (fun f -> f "Ignored unknown IPv4 message: %a" Nat_packet.pp_error e); - Lwt.return_unit - | Ok None -> Lwt.return_unit - | 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 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); - Lwt.return_unit - ) - -(** 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 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 -> - let client_mac = Netback.frontend_mac backend in - let client_eth = router.Router.clients in - let gateway_ip = Client_eth.client_gw client_eth in - let iface = new client_iface eth ~domid ~gateway_ip ~client_ip client_mac in - (* update the rules whenever QubesDB notices a change for this IP *) - let qubesdb_updater = - Lwt.catch - (fun () -> - let rec update current_db current_rules = - Qubes.DB.got_new_commit qubesDB (Dao.db_root client_ip) current_db >>= fun new_db -> - iface#set_rules new_db; - let new_rules = iface#get_rules in - (if current_rules = new_rules then - Log.debug (fun m -> m "Rules did not change for %s" (Ipaddr.V4.to_string client_ip)) - else begin - Log.debug (fun m -> m "New firewall rules for %s@.%a" - (Ipaddr.V4.to_string client_ip) - Fmt.(list ~sep:(any "@.") Pf_qubes.Parse_qubes.pp_rule) new_rules); - (* empty NAT table if rules are updated: they might deny old connections *) - My_nat.remove_connections router.Router.nat client_ip; - end); - update new_db new_rules - in - update Qubes.DB.KeyMap.empty []) - (function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e) - in - Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel qubesdb_updater); - Router.add_client router iface >>= fun () -> - Cleanup.on_cleanup cleanup_tasks (fun () -> Router.remove_client router iface); - let fixed_arp = Client_eth.ARP.create ~net:client_eth iface in - let fragment_cache = ref (Fragments.Cache.empty (256 * 1024)) in - let listener = - Lwt.catch - (fun () -> - Netback.listen backend ~header_size:Ethernet.Packet.sizeof_ethernet (fun frame -> - match Ethernet.Packet.of_cstruct frame with - | Error err -> Log.warn (fun f -> f "Invalid Ethernet frame: %s" err); Lwt.return_unit - | 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 dns_servers payload - | `IPv6 -> Lwt.return_unit (* TODO: oh no! *) - ) - >|= or_raise "Listen on client interface" Netback.pp_error) - (function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e) - in - Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel listener); - 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 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 dns_servers ~client_ip ~router ~cleanup_tasks qubesDB - ) - (fun ex -> - Log.warn (fun f -> f "Error with client %a: %s" - Dao.ClientVif.pp vif (Printexc.to_string ex)); - Lwt.return_unit - ) - ); - cleanup_tasks - -(** Watch XenStore for notifications of new clients. *) -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 -> - if not (Dao.VifMap.mem key new_set) then ( - clients := !clients |> Dao.VifMap.remove key; - Log.info (fun f -> f "client %a has gone" Dao.ClientVif.pp key); - Cleanup.cleanup cleanup - ) - ); - (* 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 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 deleted file mode 100644 index e6254a6..0000000 --- a/client_net.mli +++ /dev/null @@ -1,12 +0,0 @@ -(* Copyright (C) 2015, Thomas Leonard - See the README file for details. *) - -(** Handling client VMs. *) - -val listen : (unit -> int64) -> - ([ `host ] Domain_name.t -> (int32 * Ipaddr.V4.Set.t, [> `Msg of string ]) result Lwt.t) -> - 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 ade9662..5c81543 100644 --- a/dao.ml +++ b/dao.ml @@ -123,6 +123,7 @@ let watch_clients fn = ) type network_config = { + from_cmdline : bool; (* Specify if we have network configuration from command line or from qubesDB*) netvm_ip : Ipaddr.V4.t; (* The IP address of NetVM (our gateway) *) our_ip : Ipaddr.V4.t; (* The IP address of our interface to NetVM *) dns : Ipaddr.V4.t; @@ -134,13 +135,13 @@ exception Missing_key of string let try_read_network_config db = let get name = match DB.KeyMap.find_opt name db with - | None -> Ipaddr.V4.make 0 0 0 0 + | None -> raise (Missing_key name) | Some value -> Ipaddr.V4.of_string_exn value in let our_ip = get "/qubes-ip" in (* - IP address for this VM (only when VM has netvm set) *) let netvm_ip = get "/qubes-gateway" in (* - default gateway IP (only when VM has netvm set); VM should add host route to this address directly via eth0 (or whatever default interface name is) *) let dns = get "/qubes-primary-dns" in let dns2 = get "/qubes-secondary-dns" in - { netvm_ip ; our_ip ; dns ; dns2 } + { from_cmdline=false; netvm_ip ; our_ip ; dns ; dns2 } let read_network_config qubesDB = let rec aux bindings = @@ -162,12 +163,4 @@ let print_network_config config = Ipaddr.V4.pp config.dns Ipaddr.V4.pp config.dns2) -let update_network_config config update_config = - let zero_ip = Ipaddr.V4.make 0 0 0 0 in - let netvm_ip = if config.netvm_ip = zero_ip then update_config.netvm_ip else config.netvm_ip in - let our_ip = if config.our_ip = zero_ip then update_config.our_ip else config.our_ip in - let dns = if config.dns = zero_ip then update_config.dns else config.dns in - let dns2 = if config.dns2 = zero_ip then update_config.dns2 else config.dns2 in - Lwt.return { netvm_ip ; our_ip ; dns ; dns2 } - let set_iptables_error db = Qubes.DB.write db "/qubes-iptables-error" diff --git a/dao.mli b/dao.mli index 780d82c..bff4cbf 100644 --- a/dao.mli +++ b/dao.mli @@ -20,6 +20,7 @@ val watch_clients : (Ipaddr.V4.t VifMap.t -> unit) -> 'a Lwt.t in XenStore, and again each time XenStore updates. *) type network_config = { + from_cmdline : bool; (* Specify if we have network configuration from command line or from qubesDB*) netvm_ip : Ipaddr.V4.t; (* The IP address of NetVM (our gateway) *) our_ip : Ipaddr.V4.t; (* The IP address of our interface to NetVM *) dns : Ipaddr.V4.t; @@ -37,8 +38,6 @@ val read_rules : string Qubes.DB.KeyMap.t -> Ipaddr.V4.t -> Pf_qubes.Parse_qubes (** [read_rules bindings ip] extracts firewall rule information for [ip] from [bindings]. If any rules fail to parse, it will return only one rule denying all traffic. *) -val update_network_config : network_config -> network_config -> network_config Lwt.t - val print_network_config : network_config -> unit val set_iptables_error : Qubes.DB.t -> string -> unit Lwt.t diff --git a/dispatcher.ml b/dispatcher.ml new file mode 100644 index 0000000..19f829a --- /dev/null +++ b/dispatcher.ml @@ -0,0 +1,550 @@ +open Lwt.Infix +open Fw_utils +module Netback = Netchannel.Backend.Make (Netchannel.Xenstore.Make (Xen_os.Xs)) +module ClientEth = Ethernet.Make (Netback) +module UplinkEth = Ethernet.Make (Netif) + +let src = Logs.Src.create "dispatcher" ~doc:"Networking dispatch" + +module Log = (val Logs.src_log src : Logs.LOG) + +module Make + (R : Mirage_random.S) + (Clock : Mirage_clock.MCLOCK) + (Time : Mirage_time.S) = +struct + module Arp = Arp.Make (UplinkEth) (Time) + module I = Static_ipv4.Make (R) (Clock) (UplinkEth) (Arp) + module U = Udp.Make (I) (R) + + let clients : Cleanup.t Dao.VifMap.t ref = ref Dao.VifMap.empty + + class client_iface eth ~domid ~gateway_ip ~client_ip client_mac : client_link + = + let log_header = Fmt.str "dom%d:%a" domid Ipaddr.V4.pp client_ip in + object + val mutable rules = [] + method get_rules = rules + method set_rules new_db = rules <- Dao.read_rules new_db client_ip + method my_mac = ClientEth.mac eth + method other_mac = client_mac + method my_ip = gateway_ip + method other_ip = client_ip + + method writev proto fillfn = + Lwt.catch + (fun () -> + ClientEth.write eth client_mac proto fillfn >|= function + | Ok () -> () + | Error e -> + Log.err (fun f -> + f "error trying to send to client: @[%a@]" + ClientEth.pp_error e)) + (fun ex -> + (* Usually Netback_shutdown, because the client disconnected *) + Log.err (fun f -> + f "uncaught exception trying to send to client: @[%s@]" + (Printexc.to_string ex)); + Lwt.return_unit) + + method log_header = log_header + end + + class netvm_iface eth mac ~my_ip ~other_ip : interface = + object + method my_mac = UplinkEth.mac eth + method my_ip = my_ip + method other_ip = other_ip + + method writev ethertype fillfn = + mac >>= fun dst -> + UplinkEth.write eth dst ethertype fillfn + >|= or_raise "Write to uplink" UplinkEth.pp_error + end + + type uplink = { + net : Netif.t; + eth : UplinkEth.t; + arp : Arp.t; + interface : interface; + mutable fragments : Fragments.Cache.t; + ip : I.t; + udp : U.t; + } + + type t = { + uplink_wait_config : unit Lwt_condition.t; + mutable config : Dao.network_config; + clients : Client_eth.t; + nat : My_nat.t; + mutable uplink : uplink option; + } + + let create ~config ~clients ~nat ?uplink = + { + uplink_wait_config = Lwt_condition.create (); + config; + clients; + nat; + uplink; + } + + let update t ~config ?uplink = + t.config <- config; + t.uplink <- uplink; + Lwt.return_unit + + let target t buf = + let dst_ip = buf.Ipv4_packet.dst in + match Client_eth.lookup t.clients dst_ip with + | Some client_link -> Some (client_link :> interface) + | None -> ( (* if dest is not a client, transfer it to our uplink *) + match t.uplink with + | None -> ( + match Client_eth.lookup t.clients t.config.netvm_ip with + | Some uplink -> + Some (uplink :> interface) + | None -> + Log.err (fun f -> f "We have a command line configuration %a but it's currently not connected to us (please check its netvm property)...%!" Ipaddr.V4.pp t.config.netvm_ip); + None) + | Some uplink -> Some uplink.interface) + + let add_client t = Client_eth.add_client t.clients + let remove_client t = Client_eth.remove_client t.clients + + let classify t ip = + if ip = Ipaddr.V4 t.config.our_ip then `Firewall + else if ip = Ipaddr.V4 t.config.netvm_ip then `NetVM + else (Client_eth.classify t.clients ip :> Packet.host) + + let resolve t = function + | `Firewall -> Ipaddr.V4 t.config.our_ip + | `NetVM -> Ipaddr.V4 t.config.netvm_ip + | #Client_eth.host as host -> Client_eth.resolve t.clients host + + (* Transmission *) + + let transmit_ipv4 packet iface = + Lwt.catch + (fun () -> + let fragments = ref [] in + iface#writev `IPv4 (fun b -> + match Nat_packet.into_cstruct packet b with + | Error e -> + Log.warn (fun f -> + f "Failed to write packet to %a: %a" Ipaddr.V4.pp + iface#other_ip Nat_packet.pp_error e); + 0 + | Ok (n, frags) -> + fragments := frags; + n) + >>= fun () -> + Lwt_list.iter_s + (fun f -> + let size = Cstruct.length f in + iface#writev `IPv4 (fun b -> + Cstruct.blit f 0 b 0 size; + size)) + !fragments) + (fun ex -> + Log.warn (fun f -> + f "Failed to write packet to %a: %s" Ipaddr.V4.pp iface#other_ip + (Printexc.to_string ex)); + Lwt.return_unit) + + let forward_ipv4 t packet = + let (`IPv4 (ip, _)) = packet in + match target t ip with + | Some iface -> transmit_ipv4 packet iface + | None -> Lwt.return_unit + + (* NAT *) + + let translate t packet = My_nat.translate t.nat packet + + (* Add a NAT rule for the endpoints in this frame, via a random port on the firewall. *) + let add_nat_and_forward_ipv4 t packet = + let xl_host = t.config.our_ip in + match My_nat.add_nat_rule_and_translate t.nat ~xl_host `NAT packet with + | Ok packet -> forward_ipv4 t packet + | Error e -> + Log.warn (fun f -> + f "Failed to add NAT rewrite rule: %s (%a)" e Nat_packet.pp packet); + Lwt.return_unit + + (* Add a NAT rule to redirect this conversation to [host:port] instead of us. *) + let nat_to t ~host ~port packet = + match resolve t host with + | Ipaddr.V6 _ -> + Log.warn (fun f -> f "Cannot NAT with IPv6"); + Lwt.return_unit + | Ipaddr.V4 target -> ( + let xl_host = t.config.our_ip in + match + My_nat.add_nat_rule_and_translate t.nat ~xl_host + (`Redirect (target, port)) + packet + with + | Ok packet -> forward_ipv4 t packet + | Error e -> + Log.warn (fun f -> + f "Failed to add NAT redirect rule: %s (%a)" e Nat_packet.pp + packet); + Lwt.return_unit) + + let apply_rules t (rules : ('a, 'b) Packet.t -> Packet.action Lwt.t) ~dst + (annotated_packet : ('a, 'b) Packet.t) : unit Lwt.t = + let packet = Packet.to_mirage_nat_packet annotated_packet in + rules annotated_packet >>= fun action -> + match (action, dst) with + | `Accept, `Client client_link -> transmit_ipv4 packet client_link + | `Accept, (`External _ | `NetVM) -> ( + match t.uplink with + | Some uplink -> transmit_ipv4 packet uplink.interface + | None -> ( + match Client_eth.lookup t.clients t.config.netvm_ip with + | Some iface -> transmit_ipv4 packet iface + | None -> + Log.warn (fun f -> + f "No output interface for %a : drop" Nat_packet.pp packet); + Lwt.return_unit)) + | `Accept, `Firewall -> + Log.warn (fun f -> + f "Bad rule: firewall can't accept packets %a" Nat_packet.pp packet); + Lwt.return_unit + | `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.debug (fun f -> + f "Dropped packet (%s) %a" reason Nat_packet.pp packet); + Lwt.return_unit + + let ipv4_from_netvm t packet = + match Memory_pressure.status () with + | `Memory_critical -> Lwt.return_unit + | `Ok -> ( + let (`IPv4 (ip, _transport)) = packet in + let src = classify t (Ipaddr.V4 ip.Ipv4_packet.src) in + let dst = classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in + match Packet.of_mirage_nat_packet ~src ~dst packet with + | None -> Lwt.return_unit + | Some _ -> ( + match src with + | `Client _ | `Firewall -> + Log.warn (fun f -> + f "Frame from NetVM has internal source IP address! %a" + Nat_packet.pp packet); + Lwt.return_unit + | (`External _ | `NetVM) as src -> ( + match translate t packet with + | Some frame -> forward_ipv4 t frame + | None -> ( + match Packet.of_mirage_nat_packet ~src ~dst packet with + | None -> Lwt.return_unit + | Some packet -> apply_rules t Rules.from_netvm ~dst packet) + ))) + + let ipv4_from_client resolver dns_servers t ~src packet = + match Memory_pressure.status () with + | `Memory_critical -> Lwt.return_unit + | `Ok -> ( + (* Check for existing NAT entry for this packet *) + match translate t packet with + | Some frame -> + forward_ipv4 t frame (* Some existing connection or redirect *) + | None -> ( + (* No existing NAT entry. Check the firewall rules. *) + let (`IPv4 (ip, _transport)) = packet in + match classify t (Ipaddr.V4 ip.Ipv4_packet.src) with + | `Client _ | `Firewall -> ( + let dst = classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in + match + Packet.of_mirage_nat_packet ~src:(`Client src) ~dst packet + with + | None -> Lwt.return_unit + | Some firewall_packet -> + apply_rules t + (Rules.from_client resolver dns_servers) + ~dst firewall_packet) + | `NetVM -> ipv4_from_netvm t packet + | `External _ -> + Log.warn (fun f -> + f "Frame from Inside has external source IP address! %a" + Nat_packet.pp packet); + Lwt.return_unit)) + + (** Handle an ARP message from the client. *) + let client_handle_arp ~fixed_arp ~iface request = + match Arp_packet.decode request with + | Error e -> + Log.warn (fun f -> + f "Ignored unknown ARP message: %a" Arp_packet.pp_error e); + Lwt.return_unit + | Ok arp -> ( + match Client_eth.ARP.input fixed_arp arp with + | None -> Lwt.return_unit + | Some response -> + iface#writev `ARP (fun b -> + Arp_packet.encode_into response b; + Arp_packet.size)) + + (** Handle an IPv4 packet from the client. *) + let client_handle_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 + | Error e -> + Log.warn (fun f -> + f "Ignored unknown IPv4 message: %a" Nat_packet.pp_error e); + Lwt.return_unit + | Ok None -> Lwt.return_unit + | Ok (Some packet) -> + let (`IPv4 (ip, _)) = packet in + let src = ip.Ipv4_packet.src in + if src = iface#other_ip then + 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); + Lwt.return_unit) + + (** 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 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 -> + let client_mac = Netback.frontend_mac backend in + let client_eth = router.clients in + let gateway_ip = Client_eth.client_gw client_eth in + let iface = new client_iface eth ~domid ~gateway_ip ~client_ip client_mac in + (* update the rules whenever QubesDB notices a change for this IP *) + let qubesdb_updater = + Lwt.catch + (fun () -> + let rec update current_db current_rules = + Qubes.DB.got_new_commit qubesDB (Dao.db_root client_ip) current_db + >>= fun new_db -> + iface#set_rules new_db; + let new_rules = iface#get_rules in + if current_rules = new_rules then + Log.info (fun m -> + m "Rules did not change for %s" + (Ipaddr.V4.to_string client_ip)) + else ( + Log.info (fun m -> + m "New firewall rules for %s@.%a" + (Ipaddr.V4.to_string client_ip) + Fmt.(list ~sep:(any "@.") Pf_qubes.Parse_qubes.pp_rule) + new_rules); + (* empty NAT table if rules are updated: they might deny old connections *) + My_nat.remove_connections router.nat client_ip); + update new_db new_rules + in + update Qubes.DB.KeyMap.empty []) + (function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e) + in + Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel qubesdb_updater); + add_client router iface >>= fun () -> + Cleanup.on_cleanup cleanup_tasks (fun () -> remove_client router iface); + let fixed_arp = Client_eth.ARP.create ~net:client_eth iface in + let fragment_cache = ref (Fragments.Cache.empty (256 * 1024)) in + let listener = + Lwt.catch + (fun () -> + Netback.listen backend ~header_size:Ethernet.Packet.sizeof_ethernet + (fun frame -> + match Ethernet.Packet.of_cstruct frame with + | Error err -> + Log.warn (fun f -> f "Invalid Ethernet frame: %s" err); + Lwt.return_unit + | Ok (eth, payload) -> ( + match eth.Ethernet.Packet.ethertype with + | `ARP -> client_handle_arp ~fixed_arp ~iface payload + | `IPv4 -> + client_handle_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) + (function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e) + in + Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel listener); + 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 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 dns_servers ~client_ip ~router + ~cleanup_tasks qubesDB) + (fun ex -> + Log.warn (fun f -> + f "Error with client %a: %s" Dao.ClientVif.pp vif + (Printexc.to_string ex)); + Lwt.return_unit)); + cleanup_tasks + + (** Watch XenStore for notifications of new clients. *) + let wait_clients 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 -> + if not (Dao.VifMap.mem key new_set) then ( + clients := !clients |> Dao.VifMap.remove key; + Log.info (fun f -> f "client %a has gone" Dao.ClientVif.pp key); + Cleanup.cleanup cleanup)); + (* 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 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))) + + let send_dns_client_query t ~src_port ~dst ~dst_port buf = + match t with + | None -> + Log.err (fun f -> f "No uplink interface"); + Lwt.return (Error (`Msg "failure")) + | Some t -> ( + U.write ~src_port ~dst ~dst_port t.udp buf >|= function + | Error s -> + Log.err (fun f -> f "error sending udp packet: %a" U.pp_error s); + Error (`Msg "failure") + | Ok () -> Ok ()) + + (** Wait for packet from our uplink (we must have an uplink here...). *) + let rec uplink_listen get_ts dns_responses router = + let handle_packet ip_header ip_packet = + let open Udp_packet in + Log.debug (fun f -> + f "received ipv4 packet from %a on uplink" Ipaddr.V4.pp + ip_header.Ipv4_packet.src); + match ip_packet with + | `UDP (header, packet) when My_nat.dns_port router.nat header.dst_port -> + Log.debug (fun f -> + f + "found a DNS packet whose dst_port (%d) was in the list of \ + dns_client ports" + header.dst_port); + Lwt_mvar.put dns_responses (header, packet) + | _ -> ipv4_from_netvm router (`IPv4 (ip_header, ip_packet)) + in + match router.uplink with + | None -> + Lwt_condition.wait router.uplink_wait_config >>= fun () -> + uplink_listen get_ts dns_responses router + | Some uplink -> + let listen = + Netif.listen uplink.net ~header_size:Ethernet.Packet.sizeof_ethernet + (fun frame -> + (* Handle one Ethernet frame from NetVM *) + UplinkEth.input uplink.eth ~arpv4:(Arp.input uplink.arp) + ~ipv4:(fun ip -> + let cache, r = + Nat_packet.of_ipv4_packet uplink.fragments ~now:(get_ts ()) + ip + in + uplink.fragments <- cache; + match r with + | Error e -> + Log.warn (fun f -> + f "Ignored unknown IPv4 message from uplink: %a" + Nat_packet.pp_error e); + Lwt.return () + | Ok None -> Lwt.return_unit + | Ok (Some (`IPv4 (header, packet))) -> + handle_packet header packet) + ~ipv6:(fun _ip -> Lwt.return_unit) + frame) + >|= or_raise "Uplink listen loop" Netif.pp_error + in + let reconnect_uplink = + Lwt_condition.wait router.uplink_wait_config >>= fun () -> + uplink_listen get_ts dns_responses router + in + Lwt.pick [ listen; reconnect_uplink ] + + (** Connect to our uplink backend (we must have an uplink here...). *) + let connect config = + let my_ip = config.Dao.our_ip in + let gateway = config.Dao.netvm_ip in + Netif.connect "0" >>= fun net -> + UplinkEth.connect net >>= fun eth -> + Arp.connect eth >>= fun arp -> + Arp.add_ip arp my_ip >>= fun () -> + let cidr = Ipaddr.V4.Prefix.make 0 my_ip in + I.connect ~cidr ~gateway eth arp >>= fun ip -> + U.connect ip >>= fun udp -> + let netvm_mac = + Arp.query arp gateway >|= or_raise "Getting MAC of our NetVM" Arp.pp_error + in + let interface = + new netvm_iface eth netvm_mac ~my_ip ~other_ip:config.Dao.netvm_ip + in + let fragments = Fragments.Cache.empty (256 * 1024) in + Lwt.return { net; eth; arp; interface; fragments; ip; udp } + + (** Wait Xenstore for our uplink changes (we must have an uplink here...). *) + let uplink_wait_update qubesDB router = + let rec aux current_db = + let netvm = "/qubes-gateway" in + Log.info (fun f -> f "Waiting for netvm changes from %S...%!" netvm); + Qubes.DB.after qubesDB current_db >>= fun new_db -> + (match (router.uplink, Qubes.DB.KeyMap.find_opt netvm new_db) with + | Some uplink, Some netvm + when not + (String.equal netvm + (Ipaddr.V4.to_string uplink.interface#other_ip)) -> + Log.info (fun f -> + f "Our netvm IP has changed, before it was %s, now it's: %s%!" + (Ipaddr.V4.to_string uplink.interface#other_ip) + netvm); + Netif.disconnect uplink.net; + Dao.read_network_config qubesDB >>= fun config -> + Dao.print_network_config config; + Time.sleep_ns (Duration.of_sec 1) >>= fun () -> + (* We need to wait for uplink_listen callback to be killed off *) + connect config >>= fun uplink -> + update router ~config ?uplink:(Some uplink) >>= fun () -> + Lwt_condition.broadcast router.uplink_wait_config (); + Lwt.return_unit + | None, Some _ -> + (* a new interface is attributed to qubes-mirage-firewall *) + Log.info (fun f -> f "Going from netvm not connected to %s%!" netvm); + Dao.read_network_config qubesDB >>= fun config -> + Dao.print_network_config config; + connect config >>= fun uplink -> + update router ~config ?uplink:(Some uplink) >>= fun () -> + Lwt_condition.broadcast router.uplink_wait_config (); + Lwt.return_unit + | Some uplink, None -> + (* qubes-mirage-firewall now have netvm set to none: this is currently not supported... *) + Log.info (fun f -> + f "TODO: Our netvm disapeared, troubles are coming!%!"); + Netif.disconnect uplink.net; + Dao.read_network_config qubesDB >>= fun config -> + update router ~config ?uplink:None + | Some _, Some _ (* The new netvm IP is unchanged (it's our old netvm IP) *) + | None, None -> + Log.info (fun f -> + f "QubesDB has changed but not the situation of our netvm!%!"); + Lwt.return_unit) + >>= fun () -> aux new_db + in + aux Qubes.DB.KeyMap.empty +end diff --git a/firewall.ml b/firewall.ml deleted file mode 100644 index 3bf0e6f..0000000 --- a/firewall.ml +++ /dev/null @@ -1,136 +0,0 @@ -(* Copyright (C) 2015, Thomas Leonard - See the README file for details. *) - -open Packet -open Lwt.Infix - -let src = Logs.Src.create "firewall" ~doc:"Packet handler" -module Log = (val Logs.src_log src : Logs.LOG) - -(* Transmission *) - -let transmit_ipv4 packet iface = - Lwt.catch - (fun () -> - let fragments = ref [] in - iface#writev `IPv4 (fun b -> - match Nat_packet.into_cstruct packet b with - | Error e -> - Log.warn (fun f -> f "Failed to write packet to %a: %a" - Ipaddr.V4.pp iface#other_ip - Nat_packet.pp_error e); - 0 - | Ok (n, frags) -> fragments := frags ; n) >>= fun () -> - Lwt_list.iter_s (fun f -> - let size = Cstruct.length f in - iface#writev `IPv4 (fun b -> Cstruct.blit f 0 b 0 size ; size)) - !fragments) - (fun ex -> - Log.warn (fun f -> f "Failed to write packet to %a: %s" - Ipaddr.V4.pp iface#other_ip - (Printexc.to_string ex)); - Lwt.return_unit - ) - -let forward_ipv4 t packet = - let `IPv4 (ip, _) = packet in - match Router.target t ip with - | Some iface -> transmit_ipv4 packet iface - | None -> Lwt.return_unit - -(* NAT *) - -let translate t packet = - My_nat.translate t.Router.nat packet - -(* Add a NAT rule for the endpoints in this frame, via a random port on the firewall. *) -let add_nat_and_forward_ipv4 t packet = - let open Router in - let xl_host = t.config.our_ip in - match My_nat.add_nat_rule_and_translate t.nat ~xl_host `NAT packet with - | Ok packet -> forward_ipv4 t packet - | Error e -> - Log.warn (fun f -> f "Failed to add NAT rewrite rule: %s (%a)" e Nat_packet.pp packet); - Lwt.return_unit - -(* Add a NAT rule to redirect this conversation to [host:port] instead of us. *) -let nat_to t ~host ~port packet = - let open Router in - match resolve t host with - | Ipaddr.V6 _ -> Log.warn (fun f -> f "Cannot NAT with IPv6"); Lwt.return_unit - | Ipaddr.V4 target -> - let xl_host = t.config.our_ip in - match My_nat.add_nat_rule_and_translate t.nat ~xl_host (`Redirect (target, port)) packet with - | Ok packet -> forward_ipv4 t packet - | Error e -> - Log.warn (fun f -> f "Failed to add NAT redirect rule: %s (%a)" e Nat_packet.pp packet); - Lwt.return_unit - -let apply_rules t (rules : ('a, 'b) Packet.t -> Packet.action Lwt.t) ~dst (annotated_packet : ('a, 'b) Packet.t) : unit Lwt.t = - let packet = to_mirage_nat_packet annotated_packet in - rules annotated_packet >>= fun action -> - match action, dst with - | `Accept, `Client client_link -> transmit_ipv4 packet client_link - | `Accept, (`External _ | `NetVM) -> - begin match t.Router.uplink with - | Some uplink -> transmit_ipv4 packet uplink - | None -> begin match Client_eth.lookup t.clients t.config.netvm_ip with - | Some iface -> transmit_ipv4 packet iface - | None -> Log.warn (fun f -> f "No output interface for %a : drop" Nat_packet.pp packet); - Lwt.return_unit - end - end - | `Accept, `Firewall -> - Log.warn (fun f -> f "Bad rule: firewall can't accept packets %a" Nat_packet.pp packet); - Lwt.return_unit - | `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.debug (fun f -> f "Dropped packet (%s) %a" reason Nat_packet.pp packet); - Lwt.return_unit - -let ipv4_from_netvm t packet = - match Memory_pressure.status () with - | `Memory_critical -> Lwt.return_unit - | `Ok -> - 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 packet with - | None -> Lwt.return_unit - | Some _ -> - match src with - | `Client _ | `Firewall -> - Log.warn (fun f -> f "Frame from NetVM has internal source IP address! %a" Nat_packet.pp packet); - Lwt.return_unit - | `External _ | `NetVM as src -> - match translate t packet with - | Some frame -> forward_ipv4 t frame - | None -> - match Packet.of_mirage_nat_packet ~src ~dst packet with - | None -> Lwt.return_unit - | Some packet -> apply_rules t Rules.from_netvm ~dst packet - -let ipv4_from_client resolver dns_servers t ~src packet = - match Memory_pressure.status () with - | `Memory_critical -> Lwt.return_unit - | `Ok -> - (* Check for existing NAT entry for this packet *) - match translate t packet with - | Some frame -> forward_ipv4 t frame (* Some existing connection or redirect *) - | None -> - (* No existing NAT entry. Check the firewall rules. *) - let `IPv4 (ip, _transport) = packet in - match Router.classify t (Ipaddr.V4 ip.Ipv4_packet.src) with - | `Client _ | `Firewall -> ( - 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 dns_servers) ~dst firewall_packet - ) - | `NetVM -> ipv4_from_netvm t packet - | `External _ -> - Log.warn (fun f -> f "Frame from Inside has external source IP address! %a" Nat_packet.pp packet); - Lwt.return_unit diff --git a/firewall.mli b/firewall.mli deleted file mode 100644 index c26cfbe..0000000 --- a/firewall.mli +++ /dev/null @@ -1,13 +0,0 @@ -(* Copyright (C) 2015, Thomas Leonard - See the README file for details. *) - -(** Classify IP packets, apply rules and send as appropriate. *) - -val ipv4_from_netvm : Router.t -> Nat_packet.t -> unit Lwt.t -(** Handle a packet from the outside world (this module will validate the source IP). *) - -(* 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) -> - 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/my_dns.ml b/my_dns.ml index 33a0ed5..849aa8d 100644 --- a/my_dns.ml +++ b/my_dns.ml @@ -3,7 +3,8 @@ open Lwt.Infix module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) (Time : Mirage_time.S) = struct type +'a io = 'a Lwt.t 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 Dispatcher = Dispatcher.Make(R)(C)(Time) + type stack = Dispatcher.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) @@ -48,7 +49,6 @@ module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) (Time : Mirage_ let connect (t : t) = Lwt.return (Ok (t.protocol, t)) let send_recv (ctx : context) buf : (Cstruct.t, [> `Msg of string ]) result Lwt.t = - let open Router in let dst, dst_port = ctx.nameserver in let router, send_udp, _ = ctx.stack in let src_port, evict = diff --git a/router.ml b/router.ml deleted file mode 100644 index 3ca586a..0000000 --- a/router.ml +++ /dev/null @@ -1,44 +0,0 @@ -(* Copyright (C) 2015, Thomas Leonard - See the README file for details. *) - -open Fw_utils - -(* The routing table *) -let src = Logs.Src.create "router" ~doc:"Packet router" -module Log = (val Logs.src_log src : Logs.LOG) - -type t = { - config : Dao.network_config; - clients : Client_eth.t; - nat : My_nat.t; - uplink : interface option; -} - -let create ~config ~clients ~nat ?uplink = - { config; clients; nat; uplink } - -let target t buf = - let dst_ip = buf.Ipv4_packet.dst in - match Client_eth.lookup t.clients dst_ip with - | Some client_link -> Some (client_link :> interface) - | None -> begin match t.uplink with - | None -> ( - match Client_eth.lookup t.clients t.config.netvm_ip with - | Some uplink -> Some (uplink :> interface) - | None -> None - ) - | uplink -> uplink - end - -let add_client t = Client_eth.add_client t.clients -let remove_client t = Client_eth.remove_client t.clients - -let classify t ip = - if ip = Ipaddr.V4 t.config.our_ip then `Firewall - else if ip = Ipaddr.V4 t.config.netvm_ip then `NetVM - else (Client_eth.classify t.clients ip :> Packet.host) - -let resolve t = function - | `Firewall -> Ipaddr.V4 t.config.our_ip - | `NetVM -> Ipaddr.V4 t.config.netvm_ip - | #Client_eth.host as host -> Client_eth.resolve t.clients host diff --git a/router.mli b/router.mli deleted file mode 100644 index 532c39e..0000000 --- a/router.mli +++ /dev/null @@ -1,33 +0,0 @@ -(* Copyright (C) 2015, Thomas Leonard - See the README file for details. *) - -(** Routing packets to the right network interface. *) - -open Fw_utils - -type t = private { - config : Dao.network_config; - clients : Client_eth.t; - nat : My_nat.t; - uplink : interface option; -} - -val create : - config : Dao.network_config -> - clients : Client_eth.t -> - nat : My_nat.t -> - ?uplink : interface -> - t -(** [create ~client_eth ~uplink ~nat] is a new routing table - that routes packets outside of [client_eth] via [uplink]. *) - -val target : t -> Ipv4_packet.t -> interface option -(** [target t packet] is the interface to which [packet] should be routed. *) - -val add_client : t -> client_link -> unit Lwt.t -(** [add_client t iface] adds a rule for routing packets addressed to [iface]. *) - -val remove_client : t -> client_link -> unit - -val classify : t -> Ipaddr.t -> Packet.host -val resolve : t -> Packet.host -> Ipaddr.t diff --git a/unikernel.ml b/unikernel.ml index fe602e2..ef02620 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -8,22 +8,20 @@ let src = Logs.Src.create "unikernel" ~doc:"Main unikernel code" module Log = (val Logs.src_log src : Logs.LOG) module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_time.S) = struct - module Uplink = Uplink.Make(R)(Clock)(Time) + module Dispatcher = Dispatcher.Make(R)(Clock)(Time) module Dns_transport = My_dns.Transport(R)(Clock)(Time) module Dns_client = Dns_client.Make(Dns_transport) (* Set up networking and listen for incoming packets. *) - let network dns_client dns_responses dns_servers uplink qubesDB router = + let network dns_client dns_responses dns_servers qubesDB router = (* Report success *) Dao.set_iptables_error qubesDB "" >>= fun () -> (* Handle packets from both networks *) - match uplink with - | None -> Client_net.listen Clock.elapsed_ns dns_client dns_servers qubesDB router - | _ -> - Lwt.choose [ - Client_net.listen Clock.elapsed_ns dns_client dns_servers qubesDB router; - Uplink.listen uplink Clock.elapsed_ns dns_responses router - ] + Lwt.choose [ + Dispatcher.wait_clients Clock.elapsed_ns dns_client dns_servers qubesDB router ; + Dispatcher.uplink_wait_update qubesDB router ; + Dispatcher.uplink_listen Clock.elapsed_ns dns_responses router + ] (* Main unikernel entry point (called from auto-generated main.ml). *) let start _random _clock _time = @@ -50,56 +48,48 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_tim let max_entries = Key_gen.nat_table_size () in let nat = My_nat.create ~max_entries in - (* Read network configuration from QubesDB *) - Dao.read_network_config qubesDB >>= fun config -> - (* config.netvm_ip might be 0.0.0.0 if there's no netvm provided via Qubes *) - + let netvm_ip = Ipaddr.V4.of_string_exn (Key_gen.ipv4_gw ()) in + let our_ip = Ipaddr.V4.of_string_exn (Key_gen.ipv4 ()) in + let dns = Ipaddr.V4.of_string_exn (Key_gen.ipv4_dns ()) in + let dns2 = Ipaddr.V4.of_string_exn (Key_gen.ipv4_dns2 ()) in + let zero_ip = (Ipaddr.V4.make 0 0 0 0) in - - let connect_if_netvm = - let netvm_ip = Ipaddr.V4.of_string_exn (Key_gen.ipv4_gw ()) in - let our_ip = Ipaddr.V4.of_string_exn (Key_gen.ipv4 ()) in - let dns = Ipaddr.V4.of_string_exn (Key_gen.ipv4_dns ()) in - let dns2 = Ipaddr.V4.of_string_exn (Key_gen.ipv4_dns2 ()) in - let default_config:Dao.network_config = {netvm_ip; our_ip; dns; dns2} in - - if config.netvm_ip <> zero_ip then ( - if (netvm_ip <> zero_ip || our_ip <> zero_ip) then begin - Log.err (fun f -> f "You must not specify --ipv4 or --ipv4-gw when using the netvm property: discard command line options") - end ; - Uplink.connect config >>= fun uplink -> - Lwt.return (config, Some uplink) - ) else ( - (* If we have no netvm IP address we must not try to Uplink.connect and we can update the config - with command option (if any) *) - Dao.update_network_config config default_config >>= fun config -> - Lwt.return (config, None) - ) + + let network_config = + if (netvm_ip = zero_ip && our_ip = zero_ip) then (* Read network configuration from QubesDB *) + Dao.read_network_config qubesDB >>= fun config -> + if config.netvm_ip = zero_ip || config.our_ip = zero_ip then + Log.info (fun f -> f "We currently have no netvm nor command line for setting it up, aborting..."); + assert (config.netvm_ip <> zero_ip && config.our_ip <> zero_ip); + Lwt.return config + else begin + let config:Dao.network_config = {from_cmdline=true; netvm_ip; our_ip; dns; dns2} in + Lwt.return config + end in - connect_if_netvm >>= fun (config, uplink) -> + network_config >>= fun config -> (* We now must have a valid netvm IP address and our IP address or crash *) Dao.print_network_config config ; - assert(config.netvm_ip <> zero_ip && config.our_ip <> zero_ip); (* Set up client-side networking *) Client_eth.create config >>= fun clients -> (* Set up routing between networks and hosts *) - let router = Router.create + let router = Dispatcher.create ~config ~clients ~nat - ?uplink:(Uplink.interface uplink) + ?uplink:None in - let send_dns_query = Uplink.send_dns_client_query uplink in + let send_dns_query = Dispatcher.send_dns_client_query None in let dns_mvar = Lwt_mvar.create_empty () 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 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 + let net_listener = network (Dns_client.getaddrinfo dns_client Dns.Rr_map.A) dns_mvar dns_servers qubesDB router in (* Report memory usage to XenStore *) Memory_pressure.init (); diff --git a/uplink.ml b/uplink.ml deleted file mode 100644 index 2f7ea5e..0000000 --- a/uplink.ml +++ /dev/null @@ -1,104 +0,0 @@ -(* Copyright (C) 2015, Thomas Leonard - See the README file for details. *) - -open Lwt.Infix -open Fw_utils - -module Eth = Ethernet.Make(Netif) - -let src = Logs.Src.create "uplink" ~doc:"Network connection to NetVM" -module Log = (val Logs.src_log src : Logs.LOG) - -module Make (R:Mirage_random.S) (Clock : Mirage_clock.MCLOCK) (Time : Mirage_time.S) = struct - module Arp = Arp.Make(Eth)(Time) - module I = Static_ipv4.Make(R)(Clock)(Eth)(Arp) - module U = Udp.Make(I)(R) - - type t = { - net : Netif.t; - eth : Eth.t; - arp : Arp.t; - interface : interface; - mutable fragments : Fragments.Cache.t; - ip : I.t; - udp: U.t; - } - -class netvm_iface eth mac ~my_ip ~other_ip : interface = object - method my_mac = Eth.mac eth - method my_ip = my_ip - method other_ip = other_ip - method writev ethertype fillfn = - mac >>= fun dst -> - Eth.write eth dst ethertype fillfn >|= or_raise "Write to uplink" Eth.pp_error -end - - let send_dns_client_query t ~src_port ~dst ~dst_port buf = - match t with - | None -> - Log.err (fun f -> f "No uplink interface"); Lwt.return (Error (`Msg "failure")) - | Some t -> - U.write ~src_port ~dst ~dst_port t.udp buf >|= function - | Error s -> Log.err (fun f -> f "error sending udp packet: %a" U.pp_error s); Error (`Msg "failure") - | Ok () -> Ok () - - let listen t get_ts dns_responses router = - let handle_packet ip_header ip_packet = - let open Udp_packet in - - Log.debug (fun f -> f "received ipv4 packet from %a on uplink" Ipaddr.V4.pp ip_header.Ipv4_packet.src); - match ip_packet with - | `UDP (header, packet) when My_nat.dns_port router.Router.nat header.dst_port -> - Log.debug (fun f -> f "found a DNS packet whose dst_port (%d) was in the list of dns_client ports" header.dst_port); - Lwt_mvar.put dns_responses (header, packet) - | _ -> - Firewall.ipv4_from_netvm router (`IPv4 (ip_header, ip_packet)) - in - begin match t with - | None -> Lwt.return_unit - | Some t -> - Netif.listen t.net ~header_size:Ethernet.Packet.sizeof_ethernet (fun frame -> - (* Handle one Ethernet frame from NetVM *) - Eth.input t.eth - ~arpv4:(Arp.input t.arp) - ~ipv4:(fun ip -> - let cache, r = - Nat_packet.of_ipv4_packet t.fragments ~now:(get_ts ()) ip - in - t.fragments <- cache; - match r with - | Error e -> - Log.warn (fun f -> f "Ignored unknown IPv4 message from uplink: %a" Nat_packet.pp_error e); - Lwt.return () - | Ok None -> Lwt.return_unit - | Ok (Some (`IPv4 (header, packet))) -> handle_packet header packet - ) - ~ipv6:(fun _ip -> Lwt.return_unit) - frame - ) >|= or_raise "Uplink listen loop" Netif.pp_error - end - -let interface t = - match t with - | None -> None - | Some t -> Some t.interface - -let connect config = - let my_ip = config.Dao.our_ip in - let gateway = config.Dao.netvm_ip in - Netif.connect "0" >>= fun net -> - Eth.connect net >>= fun eth -> - Arp.connect eth >>= fun arp -> - Arp.add_ip arp my_ip >>= fun () -> - let cidr = Ipaddr.V4.Prefix.make 0 my_ip in - I.connect ~cidr ~gateway eth arp >>= fun ip -> - U.connect ip >>= fun udp -> - let netvm_mac = - Arp.query arp gateway - >|= or_raise "Getting MAC of our NetVM" Arp.pp_error in - let interface = new netvm_iface eth netvm_mac - ~my_ip - ~other_ip:config.Dao.netvm_ip in - let fragments = Fragments.Cache.empty (256 * 1024) in - Lwt.return { net; eth; arp; interface ; fragments ; ip ; udp } -end diff --git a/uplink.mli b/uplink.mli deleted file mode 100644 index 0d35e5e..0000000 --- a/uplink.mli +++ /dev/null @@ -1,21 +0,0 @@ -(* Copyright (C) 2015, Thomas Leonard - See the README file for details. *) - -(** The link from us to NetVM (and, through that, to the outside world). *) - -open Fw_utils - -module Make (R: Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_time.S) : sig - type t - - val connect : Dao.network_config -> t Lwt.t - (** Connect to our NetVM (gateway). *) - - val interface : t option -> interface option - (** The network interface to NetVM. *) - - val listen : t option -> (unit -> int64) -> (Udp_packet.t * Cstruct.t) Lwt_mvar.t -> Router.t -> unit Lwt.t - (** Handle incoming frames from NetVM. *) - - val send_dns_client_query: t option -> src_port:int-> dst:Ipaddr.V4.t -> dst_port:int -> Cstruct.t -> (unit, [`Msg of string]) result Lwt.t -end From f7bfa0299e42e22c5d19529b9615e5b22dda3383 Mon Sep 17 00:00:00 2001 From: palainp Date: Tue, 11 Jul 2023 14:26:12 +0200 Subject: [PATCH 195/281] put uplink disconnect into a Lwt.Canceled callback --- dao.ml | 2 +- dispatcher.ml | 52 +++++++++++++++++++++++++++++++++++---------------- 2 files changed, 37 insertions(+), 17 deletions(-) diff --git a/dao.ml b/dao.ml index 5c81543..7c6eecb 100644 --- a/dao.ml +++ b/dao.ml @@ -153,7 +153,7 @@ let read_network_config qubesDB = aux (DB.bindings qubesDB) let print_network_config config = - Log.info (fun f -> f "@[Got network configuration from QubesDB:@,\ + Log.info (fun f -> f "@[Current network configuration (QubesDB or command line):@,\ NetVM IP on uplink network: %a@,\ Our IP on client networks: %a@,\ DNS primary resolver: %a@,\ diff --git a/dispatcher.ml b/dispatcher.ml index 19f829a..1ceabf7 100644 --- a/dispatcher.ml +++ b/dispatcher.ml @@ -73,7 +73,9 @@ struct } type t = { - uplink_wait_config : unit Lwt_condition.t; + uplink_connected : unit Lwt_condition.t; + uplink_disconnect : unit Lwt_condition.t; + uplink_disconnected : unit Lwt_condition.t; mutable config : Dao.network_config; clients : Client_eth.t; nat : My_nat.t; @@ -82,7 +84,9 @@ struct let create ~config ~clients ~nat ?uplink = { - uplink_wait_config = Lwt_condition.create (); + uplink_connected = Lwt_condition.create (); + uplink_disconnect = Lwt_condition.create (); + uplink_disconnected = Lwt_condition.create (); config; clients; nat; @@ -444,12 +448,17 @@ struct Lwt_mvar.put dns_responses (header, packet) | _ -> ipv4_from_netvm router (`IPv4 (ip_header, ip_packet)) in + Lwt_condition.wait router.uplink_connected >>= fun () -> match router.uplink with | None -> - Lwt_condition.wait router.uplink_wait_config >>= fun () -> + Log.err (fun f -> + f + "Uplink is connected but not found in the router, retrying...%!"); uplink_listen get_ts dns_responses router | Some uplink -> let listen = + Lwt.catch + (fun () -> Netif.listen uplink.net ~header_size:Ethernet.Packet.sizeof_ethernet (fun frame -> (* Handle one Ethernet frame from NetVM *) @@ -471,13 +480,26 @@ struct handle_packet header packet) ~ipv6:(fun _ip -> Lwt.return_unit) frame) - >|= or_raise "Uplink listen loop" Netif.pp_error + >|= or_raise "Uplink listen loop" Netif.pp_error) + (function Lwt.Canceled -> + (* We can be cancelled if reconnect_uplink is achieved (via the Lwt_condition), so we need to disconnect and broadcast when it's done + currently we delay 1s as Netif.disconnect is non-blocking... (need to fix upstream?) *) + Log.info (fun f -> + f "disconnecting from our uplink"); + Netif.disconnect uplink.net; + Time.sleep_ns (Duration.of_sec 1) >>= fun () -> + Lwt_condition.broadcast router.uplink_disconnected (); + Lwt.return_unit + | e -> Lwt.fail e) in let reconnect_uplink = - Lwt_condition.wait router.uplink_wait_config >>= fun () -> - uplink_listen get_ts dns_responses router + Lwt_condition.wait router.uplink_disconnect >>= fun () -> + Log.info (fun f -> + f "we need to reconnect to the new uplink"); + Lwt.return_unit in - Lwt.pick [ listen; reconnect_uplink ] + Lwt.pick [ listen ; reconnect_uplink ] >>= fun () -> + uplink_listen get_ts dns_responses router (** Connect to our uplink backend (we must have an uplink here...). *) let connect config = @@ -514,14 +536,14 @@ struct f "Our netvm IP has changed, before it was %s, now it's: %s%!" (Ipaddr.V4.to_string uplink.interface#other_ip) netvm); - Netif.disconnect uplink.net; + Lwt_condition.broadcast router.uplink_disconnect (); + (* wait for uplink disconnexion *) + Lwt_condition.wait router.uplink_disconnected >>= fun () -> Dao.read_network_config qubesDB >>= fun config -> Dao.print_network_config config; - Time.sleep_ns (Duration.of_sec 1) >>= fun () -> - (* We need to wait for uplink_listen callback to be killed off *) connect config >>= fun uplink -> update router ~config ?uplink:(Some uplink) >>= fun () -> - Lwt_condition.broadcast router.uplink_wait_config (); + Lwt_condition.broadcast router.uplink_connected (); Lwt.return_unit | None, Some _ -> (* a new interface is attributed to qubes-mirage-firewall *) @@ -530,15 +552,13 @@ struct Dao.print_network_config config; connect config >>= fun uplink -> update router ~config ?uplink:(Some uplink) >>= fun () -> - Lwt_condition.broadcast router.uplink_wait_config (); + Lwt_condition.broadcast router.uplink_connected (); Lwt.return_unit | Some uplink, None -> - (* qubes-mirage-firewall now have netvm set to none: this is currently not supported... *) + (* This currently is never triggered :( *) Log.info (fun f -> f "TODO: Our netvm disapeared, troubles are coming!%!"); - Netif.disconnect uplink.net; - Dao.read_network_config qubesDB >>= fun config -> - update router ~config ?uplink:None + Lwt.return_unit | Some _, Some _ (* The new netvm IP is unchanged (it's our old netvm IP) *) | None, None -> Log.info (fun f -> From 6f6eab5cd54be9cbe148181a45c59855eb0bc950 Mon Sep 17 00:00:00 2001 From: palainp Date: Tue, 11 Jul 2023 14:33:09 +0200 Subject: [PATCH 196/281] minor changes --- dispatcher.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dispatcher.ml b/dispatcher.ml index 1ceabf7..dd7499d 100644 --- a/dispatcher.ml +++ b/dispatcher.ml @@ -525,7 +525,7 @@ struct let uplink_wait_update qubesDB router = let rec aux current_db = let netvm = "/qubes-gateway" in - Log.info (fun f -> f "Waiting for netvm changes from %S...%!" netvm); + Log.info (fun f -> f "Waiting for netvm changes to %S...%!" netvm); Qubes.DB.after qubesDB current_db >>= fun new_db -> (match (router.uplink, Qubes.DB.KeyMap.find_opt netvm new_db) with | Some uplink, Some netvm From 2d822302d8493d880156b8d80c2749ea84e73813 Mon Sep 17 00:00:00 2001 From: palainp Date: Wed, 12 Jul 2023 16:10:33 +0200 Subject: [PATCH 197/281] remove delay as the fix should be in mirage-net-xen --- dispatcher.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/dispatcher.ml b/dispatcher.ml index dd7499d..988eda1 100644 --- a/dispatcher.ml +++ b/dispatcher.ml @@ -487,7 +487,6 @@ struct Log.info (fun f -> f "disconnecting from our uplink"); Netif.disconnect uplink.net; - Time.sleep_ns (Duration.of_sec 1) >>= fun () -> Lwt_condition.broadcast router.uplink_disconnected (); Lwt.return_unit | e -> Lwt.fail e) From 82d5a239fcfdb3fed2b94cb70e53460b9fd46743 Mon Sep 17 00:00:00 2001 From: palainp Date: Wed, 12 Jul 2023 16:51:03 +0200 Subject: [PATCH 198/281] catch arp packet failure: potential packets created before an uplink change and pending to be sent --- dispatcher.ml | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/dispatcher.ml b/dispatcher.ml index 988eda1..eac0231 100644 --- a/dispatcher.ml +++ b/dispatcher.ml @@ -290,9 +290,17 @@ struct match Client_eth.ARP.input fixed_arp arp with | None -> Lwt.return_unit | Some response -> - iface#writev `ARP (fun b -> - Arp_packet.encode_into response b; - Arp_packet.size)) + Lwt.catch + (fun () -> + iface#writev `ARP (fun b -> + Arp_packet.encode_into response b; + Arp_packet.size)) + (fun ex -> + Log.warn (fun f -> + f "Failed to write APR to %a: %s" Ipaddr.V4.pp iface#other_ip + (Printexc.to_string ex)); + Lwt.return_unit) + ) (** Handle an IPv4 packet from the client. *) let client_handle_ipv4 get_ts cache ~iface ~router dns_client dns_servers From e6fd4e864644799c62e82bd69722082848e86dcb Mon Sep 17 00:00:00 2001 From: palainp Date: Fri, 14 Jul 2023 14:48:19 +0200 Subject: [PATCH 199/281] more catch around writes fix uncaught exceptions due to remaining promises when changing uplink --- dispatcher.ml | 77 ++++++++++++++++++++++++++++++++------------------- 1 file changed, 49 insertions(+), 28 deletions(-) diff --git a/dispatcher.ml b/dispatcher.ml index eac0231..40abe2f 100644 --- a/dispatcher.ml +++ b/dispatcher.ml @@ -57,9 +57,16 @@ struct method other_ip = other_ip method writev ethertype fillfn = - mac >>= fun dst -> - UplinkEth.write eth dst ethertype fillfn - >|= or_raise "Write to uplink" UplinkEth.pp_error + Lwt.catch + (fun () -> + mac >>= fun dst -> + UplinkEth.write eth dst ethertype fillfn + >|= or_raise "Write to uplink" UplinkEth.pp_error) + (fun ex -> + Log.err (fun f -> + f "uncaught exception trying to send to uplink: @[%s@]" + (Printexc.to_string ex)); + Lwt.return_unit) end type uplink = { @@ -158,9 +165,17 @@ struct let forward_ipv4 t packet = let (`IPv4 (ip, _)) = packet in - match target t ip with - | Some iface -> transmit_ipv4 packet iface - | None -> Lwt.return_unit + Lwt.catch + (fun () -> + match target t ip with + | Some iface -> transmit_ipv4 packet iface + | None -> Lwt.return_unit) + (fun ex -> + let dst_ip = ip.Ipv4_packet.dst in + Log.warn (fun f -> + f "Failed to lookup for target %a: %s" Ipaddr.V4.pp dst_ip + (Printexc.to_string ex)); + Lwt.return_unit) (* NAT *) @@ -433,29 +448,21 @@ struct Log.err (fun f -> f "No uplink interface"); Lwt.return (Error (`Msg "failure")) | Some t -> ( - U.write ~src_port ~dst ~dst_port t.udp buf >|= function - | Error s -> - Log.err (fun f -> f "error sending udp packet: %a" U.pp_error s); - Error (`Msg "failure") - | Ok () -> Ok ()) + Lwt.catch + (fun () -> + U.write ~src_port ~dst ~dst_port t.udp buf >|= function + | Error s -> + Log.err (fun f -> f "error sending udp packet: %a" U.pp_error s); + Error (`Msg "failure") + | Ok () -> Ok ()) + (fun ex -> + Log.err (fun f -> + f "uncaught exception trying to send DNS request to uplink: @[%s@]" + (Printexc.to_string ex)); + Lwt.return (Error (`Msg "DNS request not sent")))) (** Wait for packet from our uplink (we must have an uplink here...). *) let rec uplink_listen get_ts dns_responses router = - let handle_packet ip_header ip_packet = - let open Udp_packet in - Log.debug (fun f -> - f "received ipv4 packet from %a on uplink" Ipaddr.V4.pp - ip_header.Ipv4_packet.src); - match ip_packet with - | `UDP (header, packet) when My_nat.dns_port router.nat header.dst_port -> - Log.debug (fun f -> - f - "found a DNS packet whose dst_port (%d) was in the list of \ - dns_client ports" - header.dst_port); - Lwt_mvar.put dns_responses (header, packet) - | _ -> ipv4_from_netvm router (`IPv4 (ip_header, ip_packet)) - in Lwt_condition.wait router.uplink_connected >>= fun () -> match router.uplink with | None -> @@ -477,7 +484,7 @@ struct ip in uplink.fragments <- cache; - match r with + begin match r with | Error e -> Log.warn (fun f -> f "Ignored unknown IPv4 message from uplink: %a" @@ -485,7 +492,21 @@ struct Lwt.return () | Ok None -> Lwt.return_unit | Ok (Some (`IPv4 (header, packet))) -> - handle_packet header packet) + let open Udp_packet in + Log.debug (fun f -> + f "received ipv4 packet from %a on uplink" Ipaddr.V4.pp + header.Ipv4_packet.src); + begin match packet with + | `UDP (header, packet) when My_nat.dns_port router.nat header.dst_port -> + Log.debug (fun f -> + f + "found a DNS packet whose dst_port (%d) was in the list of \ + dns_client ports" + header.dst_port); + Lwt_mvar.put dns_responses (header, packet) + | _ -> ipv4_from_netvm router (`IPv4 (header, packet)) + end + end) ~ipv6:(fun _ip -> Lwt.return_unit) frame) >|= or_raise "Uplink listen loop" Netif.pp_error) From 1ad564455309eacbabb416fdc6e2512067bb1cbf Mon Sep 17 00:00:00 2001 From: palainp Date: Sun, 16 Jul 2023 18:26:38 +0200 Subject: [PATCH 200/281] catch exception in IpMap.find --- fw_utils.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/fw_utils.ml b/fw_utils.ml index ffb58dc..4469e4d 100644 --- a/fw_utils.ml +++ b/fw_utils.ml @@ -8,6 +8,7 @@ module IpMap = struct let find x map = try Some (find x map) with Not_found -> None + | e -> Logs.err( fun f -> f "uncaught exception in find...%!"); None end (** An Ethernet interface. *) From 27236eafac09698bff2280ac04d433b614a1dfff Mon Sep 17 00:00:00 2001 From: palainp Date: Sun, 16 Jul 2023 18:37:38 +0200 Subject: [PATCH 201/281] do not forget to disconnect layers --- dispatcher.ml | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/dispatcher.ml b/dispatcher.ml index 40abe2f..d3c3241 100644 --- a/dispatcher.ml +++ b/dispatcher.ml @@ -515,6 +515,12 @@ struct currently we delay 1s as Netif.disconnect is non-blocking... (need to fix upstream?) *) Log.info (fun f -> f "disconnecting from our uplink"); + U.disconnect uplink.udp; + I.disconnect uplink.ip; + (* mutable fragments : Fragments.Cache.t; *) + (* interface : interface; *) + Arp.disconnect uplink.arp; + UplinkEth.disconnect uplink.eth; Netif.disconnect uplink.net; Lwt_condition.broadcast router.uplink_disconnected (); Lwt.return_unit From 4fde2df8049cdf11b82be20aceb7078911921dd9 Mon Sep 17 00:00:00 2001 From: Pierre Alain <65669679+palainp@users.noreply.github.com> Date: Sun, 30 Jul 2023 17:28:52 +0200 Subject: [PATCH 202/281] bump mirage-net-xen version --- config.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/config.ml b/config.ml index e3eb2ad..f28928e 100644 --- a/config.ml +++ b/config.ml @@ -46,8 +46,8 @@ 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 ~min:"2.1.2" "netchannel"; - package "mirage-net-xen"; + package ~min:"2.1.3" "netchannel"; + package ~min:"2.1.3" "mirage-net-xen"; package "ipaddr" ~min:"5.2.0"; package "mirage-qubes" ~min:"0.9.1"; package ~min:"3.0.1" "mirage-nat"; From c87f2305aba863d5b19a6b9ab1a45d555069a2e8 Mon Sep 17 00:00:00 2001 From: 100111001 <43482858+100111001@users.noreply.github.com> Date: Fri, 18 Aug 2023 00:27:06 +0200 Subject: [PATCH 203/281] Update README.md for using SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls --- README.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/README.md b/README.md index a24f6cd..930057b 100644 --- a/README.md +++ b/README.md @@ -49,6 +49,7 @@ However, it should still work fine. ## Deploy +### Manual deployment If you want to deploy manually, unpack `mirage-firewall.tar.bz2` in domU. The tarball contains `vmlinuz`, which is the unikernel itself, plus a dummy initramfs file that Qubes requires: @@ -84,6 +85,9 @@ qvm-features mirage-firewall qubes-firewall 1 qvm-features mirage-firewall no-default-kernelopts 1 ``` +### Deployment using saltstack +If you're familiar how to run salt states in Qubes, you can also use the script "SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls" to automatically deploy the latest version of mirage firewall in your Qubes OS. The script checks the checksum from the integration server and compares with the latest version provided in the github releases. It might be necessary to adjust the VM templates in the script which are used for downloading of the mirage unikernel. Also don't forget to change the VMs in which the uni kernel should be used or adjust the "Qubes Global Settings". + ## Upgrading To upgrade from an earlier release, just overwrite `/var/lib/qubes/vm-kernels/mirage-firewall/vmlinuz` with the new version and restart the firewall VM. From 3006c1445387ac8a2d9cbc9814840a5f1368d0ea Mon Sep 17 00:00:00 2001 From: 100111001 <43482858+100111001@users.noreply.github.com> Date: Fri, 18 Aug 2023 00:16:32 +0200 Subject: [PATCH 204/281] Create SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls --- ...ownloadAndInstallMirageFirewallInQubes.sls | 103 ++++++++++++++++++ 1 file changed, 103 insertions(+) create mode 100644 SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls diff --git a/SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls b/SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls new file mode 100644 index 0000000..ec3a486 --- /dev/null +++ b/SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls @@ -0,0 +1,103 @@ +# How to install the superlight mirage-firewall for Qubes OS by using saltstack +# Tested on Qubes v4.1 and mirage v0.8.5 +# After the install, you have to switch your AppVMs to use the mirage firewall vm created by this script e.g. by using "Qubes Global Settings" +# inspired by: https://github.com/one7two99/my-qubes/tree/master/mirage-firewall + +# You might want to adjust the following 2 variables to use up-to-date templates on your qubes +{% set DownloadVMTemplate = "fedora-38" %} +{% set DispVM = "fedora-38-dvm" %} + +{% set DownloadVM = "DownloadVmMirage" %} +{% set MirageFW = "sys-mirage-fw" %} +{% set GithubUrl = "https://github.com/mirage/qubes-mirage-firewall" %} +{% set Filename = "mirage-firewall.tar.bz2" %} +{% set MirageInstallDir = "/var/lib/qubes/vm-kernels/mirage-firewall" %} + +#download and install the latest version +{% set Release = salt['cmd.shell']("qvm-run --dispvm " ~ DispVM ~ " --pass-io \"curl --silent --location -o /dev/null -w %{url_effective} " ~ GithubUrl ~ "/releases/latest | rev | cut -d \"/\" -f 1 | rev\"") %} + +{% if Release != salt['cmd.shell']("[ ! -f " ~ MirageInstallDir ~ "/version.txt" ~ " ] && touch " ~ MirageInstallDir ~ "/version.txt" ~ ";cat " ~ MirageInstallDir ~ "/version.txt") %} + +create-downloader-VM: + qvm.vm: + - name: {{ DownloadVM }} + - present: + - template: {{ DownloadVMTemplate }} + - label: red + - prefs: + - template: {{ DownloadVMTemplate }} + - include-in-backups: false + +{% set DownloadBinary = GithubUrl ~ "/releases/download/" ~ Release ~ "/" ~ Filename %} + +download-and-unpack-in-DownloadVM4mirage: + cmd.run: + - names: + - qvm-run --pass-io {{ DownloadVM }} {{ "wget " ~ DownloadBinary }} + - qvm-run --pass-io {{ DownloadVM }} {{ "tar -xvjf " ~ Filename }} + - require: + - create-downloader-VM + + +check-checksum-in-DownloadVM: + cmd.run: + - names: + - qvm-run --pass-io {{ DownloadVM }} {{ "\"echo \\\"Checksum of last build on github:\\\";curl -s https://raw.githubusercontent.com/mirage/qubes-mirage-firewall/main/build-with-docker.sh | grep \\\"SHA2 last known:\\\" | cut -d\' \' -f5 | tr -d \\\\\\\"\"" }} + - qvm-run --pass-io {{ DownloadVM }} {{ "\"echo \\\"Checksum of downloaded local file:\\\";sha256sum ~/mirage-firewall/vmlinuz | cut -d\' \' -f1\"" }} + - qvm-run --pass-io {{ DownloadVM }} {{ "\"diff <(curl -s https://raw.githubusercontent.com/mirage/qubes-mirage-firewall/main/build-with-docker.sh | grep \\\"SHA2 last known:\\\" | cut -d\' \' -f5 | tr -d \\\\\\\") <(sha256sum ~/mirage-firewall/vmlinuz | cut -d\' \' -f1) && echo \\\"Checksums DO match.\\\" || (echo \\\"Checksums do NOT match.\\\";exit 101)\"" }} #~/mirage-firewall/modules.img + - require: + - download-and-unpack-in-DownloadVM4mirage + +copy-mirage-kernel-to-dom0: + cmd.run: + - name: mkdir -p {{ MirageInstallDir }}; qvm-run --pass-io --no-gui {{ DownloadVM }} "cat ~/mirage-firewall/vmlinuz" > {{ MirageInstallDir ~ "/vmlinuz" }} + - require: + - download-and-unpack-in-DownloadVM4mirage + - check-checksum-in-DownloadVM + +create-initramfs: + cmd.run: + - names: + - gzip -n9 < /dev/null > {{ MirageInstallDir ~ "/initramfs" }} + - echo {{ Release }} > {{ MirageInstallDir ~ "/version.txt" }} + - require: + - copy-mirage-kernel-to-dom0 + +create-sys-mirage-fw: + qvm.vm: + - name: {{ MirageFW }} + - present: + - class: StandaloneVM + - label: black + - prefs: + - kernel: mirage-firewall + - kernelopts: + - include-in-backups: False + - memory: 32 + - maxmem: 32 + - netvm: sys-net + - provides-network: True + - vcpus: 1 + - virt-mode: pvh + - features: + - enable: + - qubes-firewall + - no-default-kernelopts + - require: + - copy-mirage-kernel-to-dom0 + + +cleanup-in-DownloadVM: + cmd.run: + - names: + - qvm-run -a --pass-io --no-gui {{ DownloadVM }} "{{ "rm " ~ Filename ~ "; rm -R ~/mirage-firewall" }}" + - require: + - create-initramfs + +remove-DownloadVM4mirage: + qvm.absent: + - name: {{ DownloadVM }} + - require: + - cleanup-in-DownloadVM + +{% endif %} From 6df70c1b35f8ba447d8c38d6e74bb15df5947094 Mon Sep 17 00:00:00 2001 From: 100111001 <43482858+100111001@users.noreply.github.com> Date: Fri, 18 Aug 2023 00:46:39 +0200 Subject: [PATCH 205/281] Update README.md - using correct formating --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 930057b..6adf62f 100644 --- a/README.md +++ b/README.md @@ -86,7 +86,7 @@ qvm-features mirage-firewall no-default-kernelopts 1 ``` ### Deployment using saltstack -If you're familiar how to run salt states in Qubes, you can also use the script "SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls" to automatically deploy the latest version of mirage firewall in your Qubes OS. The script checks the checksum from the integration server and compares with the latest version provided in the github releases. It might be necessary to adjust the VM templates in the script which are used for downloading of the mirage unikernel. Also don't forget to change the VMs in which the uni kernel should be used or adjust the "Qubes Global Settings". +If you're familiar how to run salt states in Qubes, you can also use the script `SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls` to automatically deploy the latest version of mirage firewall in your Qubes OS. The script checks the checksum from the integration server and compares with the latest version provided in the github releases. It might be necessary to adjust the VM templates in the script which are used for downloading of the mirage unikernel. Also don't forget to change the VMs in which the uni kernel should be used or adjust the "Qubes Global Settings". ## Upgrading From 4dda3f513c113cdeeb93a4ee009afb74a8338c0b Mon Sep 17 00:00:00 2001 From: 100111001 <43482858+100111001@users.noreply.github.com> Date: Wed, 23 Aug 2023 14:48:29 +0200 Subject: [PATCH 206/281] Added description how to run salt states --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 6adf62f..130f602 100644 --- a/README.md +++ b/README.md @@ -86,7 +86,7 @@ qvm-features mirage-firewall no-default-kernelopts 1 ``` ### Deployment using saltstack -If you're familiar how to run salt states in Qubes, you can also use the script `SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls` to automatically deploy the latest version of mirage firewall in your Qubes OS. The script checks the checksum from the integration server and compares with the latest version provided in the github releases. It might be necessary to adjust the VM templates in the script which are used for downloading of the mirage unikernel. Also don't forget to change the VMs in which the uni kernel should be used or adjust the "Qubes Global Settings". +If you're familiar how to run salt states in Qubes, you can also use the script `SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls` to automatically deploy the latest version of mirage firewall in your Qubes OS. An introduction can be found [here](https://forum.qubes-os.org/t/qubes-salt-beginners-guide/20126) and [here](https://www.qubes-os.org/doc/salt/). Following the instructions from the former link, you can run the script in dom0 with the command `sudo qubesctl --show-output state.apply SaltScriptToDownloadAndInstallMirageFirewallInQubes saltenv=user`. The script checks the checksum from the integration server and compares with the latest version provided in the github releases. It might be necessary to adjust the VM templates in the script which are used for downloading of the mirage unikernel, if your default templates do not have the tools `curl` and `tar` installed by default. Also don't forget to change the VMs in which the uni kernel should be used or adjust the "Qubes Global Settings". ## Upgrading From 354c2517016fd5b71e59b5675ce0a3f60ce265fd Mon Sep 17 00:00:00 2001 From: 100111001 <43482858+100111001@users.noreply.github.com> Date: Wed, 23 Aug 2023 14:56:47 +0200 Subject: [PATCH 207/281] Changed hard coded templates to default templates from qubes Also replaced wget by curl to make it compatible additionally for the default template of debian. (wget is not installed by default) --- SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls b/SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls index ec3a486..1055faa 100644 --- a/SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls +++ b/SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls @@ -3,9 +3,9 @@ # After the install, you have to switch your AppVMs to use the mirage firewall vm created by this script e.g. by using "Qubes Global Settings" # inspired by: https://github.com/one7two99/my-qubes/tree/master/mirage-firewall -# You might want to adjust the following 2 variables to use up-to-date templates on your qubes -{% set DownloadVMTemplate = "fedora-38" %} -{% set DispVM = "fedora-38-dvm" %} +# default template + dispvm template are used. Possible optimization is to use min-dvms +{% set DownloadVMTemplate = salt['cmd.shell']("qubes-prefs default_template") %} +{% set DispVM = salt['cmd.shell']("qubes-prefs default_dispvm") %} {% set DownloadVM = "DownloadVmMirage" %} {% set MirageFW = "sys-mirage-fw" %} @@ -33,7 +33,7 @@ create-downloader-VM: download-and-unpack-in-DownloadVM4mirage: cmd.run: - names: - - qvm-run --pass-io {{ DownloadVM }} {{ "wget " ~ DownloadBinary }} + - qvm-run --pass-io {{ DownloadVM }} {{ "curl -L -O " ~ DownloadBinary }} - qvm-run --pass-io {{ DownloadVM }} {{ "tar -xvjf " ~ Filename }} - require: - create-downloader-VM From 95c870b14e51121fc4e09436b2e74852d70a7cf0 Mon Sep 17 00:00:00 2001 From: Dimas Alexander <51lieal@ileg.al> Date: Sun, 10 Sep 2023 19:10:07 +0700 Subject: [PATCH 208/281] Using too little RAM causes Mirage to stop working. --- README.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index 130f602..452bb7f 100644 --- a/README.md +++ b/README.md @@ -71,8 +71,8 @@ Run this command in dom0 to create a `mirage-firewall` VM using the `mirage-fire qvm-create \ --property kernel=mirage-firewall \ --property kernelopts='' \ - --property memory=32 \ - --property maxmem=32 \ + --property memory=64 \ + --property maxmem=64 \ --property netvm=sys-net \ --property provides_network=True \ --property vcpus=1 \ From 708040c3b4ff1b0487faa926ba5e241be70b9a58 Mon Sep 17 00:00:00 2001 From: Dimas Alexander <51lieal@ileg.al> Date: Mon, 11 Sep 2023 18:55:32 +0700 Subject: [PATCH 209/281] Increase RAM on default install --- SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls b/SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls index 1055faa..3f932c9 100644 --- a/SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls +++ b/SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls @@ -73,8 +73,8 @@ create-sys-mirage-fw: - kernel: mirage-firewall - kernelopts: - include-in-backups: False - - memory: 32 - - maxmem: 32 + - memory: 64 + - maxmem: 64 - netvm: sys-net - provides-network: True - vcpus: 1 From 173832e053b3309f391772c3698eb1642b13e131 Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Fri, 13 Oct 2023 09:21:40 +0200 Subject: [PATCH 210/281] comply with SELinux enforcement AppVM --- README.md | 9 +++++---- build-with-docker.sh | 2 +- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/README.md b/README.md index 452bb7f..9b23fc9 100644 --- a/README.md +++ b/README.md @@ -14,15 +14,16 @@ See the [Deploy](#deploy) section below for installation instructions. ## Build from source Note: The most reliable way to build is using Docker. -Fedora 35 works well for this and Debian 11 also works, but you'll need to follow the instructions at [docker.com][debian-docker] to get Docker +Fedora 38 works well for this, Debian 11 also works (and Debian 12 should), but you'll need to follow the instructions at [docker.com][debian-docker] to get Docker (don't use Debian's version). -Create a new Fedora-35 AppVM (or reuse an existing one). In the Qube's Settings (Basic / Disk storage), increase the private storage max size from the default 2048 MiB to 4096 MiB. Open a terminal. +Create a new Fedora-38 AppVM (or reuse an existing one). In the Qube's Settings (Basic / Disk storage), increase the private storage max size from the default 2048 MiB to 4096 MiB. Open a terminal. -Clone this Git repository and run the `build-with-docker.sh` script: +Clone this Git repository and run the `build-with-docker.sh` script (Note: The `chcon` call is mandatory with new SELinux policies which do not allow to standardly keep the images in homedir): mkdir /home/user/docker sudo ln -s /home/user/docker /var/lib/docker + sudo chcon -Rt container_file_t /home/user/docker sudo dnf install docker sudo systemctl start docker git clone https://github.com/mirage/qubes-mirage-firewall.git @@ -141,7 +142,7 @@ The boot process: For development, use the [test-mirage][] scripts to deploy the unikernel (`qubes-firewall.xen`) from your development AppVM. This takes a little more setting up the first time, but will be much quicker after that. e.g. - $ test-mirage dist/qubes-firewall.xen mirage-firewall + [user@dev ~]$ test-mirage dist/qubes-firewall.xen mirage-firewall Waiting for 'Ready'... OK Uploading 'dist/qubes-firewall.xen' (7454880 bytes) to "mirage-test" Waiting for 'Booting'... OK diff --git a/build-with-docker.sh b/build-with-docker.sh index e5a9a17..ba69427 100755 --- a/build-with-docker.sh +++ b/build-with-docker.sh @@ -3,7 +3,7 @@ set -eu echo Building Docker image with dependencies.. docker build -t qubes-mirage-firewall . echo Building Firewall... -docker run --rm -i -v `pwd`:/tmp/orb-build qubes-mirage-firewall +docker run --rm -i -v `pwd`:/tmp/orb-build:Z qubes-mirage-firewall echo "SHA2 of build: $(sha256sum ./dist/qubes-firewall.xen)" echo "SHA2 last known: 8ae5314edf5b863b788c4b873e27bc4b206a2ff7ef1051c4c62ae41584ed3e14" echo "(hashes should match for released versions)" From 95f165a05924f18bebea806323ae8d90550a7e89 Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Tue, 7 Nov 2023 13:47:12 +0100 Subject: [PATCH 211/281] change snapshots for debian ones --- Dockerfile | 14 ++++++++++---- README.md | 6 +++--- build-with-docker.sh | 2 +- 3 files changed, 14 insertions(+), 8 deletions(-) diff --git a/Dockerfile b/Dockerfile index 0c3c0c8..aede321 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,10 +1,15 @@ # Pin the base image to a specific hash for maximum reproducibility. # It will probably still work on newer images, though, unless an update # changes some compiler optimisations (unlikely). -# bookworm-slim -FROM debian@sha256:07c6cb2ae86479dcc1942a89b0a1f4049b6e9415f7de327ff641aed58b8e3100 +# bookworm-slim taken from https://hub.docker.com/_/debian/tags?page=1&name=bookworm-slim +FROM debian@sha256:ea5ad531efe1ac11ff69395d032909baf423b8b88e9aade07e11b40b2e5a1338 +# install ca-certificates and remove default packages repository +RUN rm /etc/apt/sources.list.d/debian.sources # and set the package source to a specific release too -RUN printf "deb [check-valid-until=no] http://snapshot.notset.fr/archive/debian/20230418T024659Z bookworm main" > /etc/apt/sources.list +# taken from https://snapshot.debian.org/archive/debian +RUN printf "deb [check-valid-until=no] http://snapshot.debian.org/archive/debian/20231107T084929Z bookworm main\n" > /etc/apt/sources.list +# taken from https://snapshot.debian.org/archive/debian-security/ +RUN printf "deb [check-valid-until=no] http://snapshot.debian.org/archive/debian-security/20231108T004541Z bookworm-security main\n" >> /etc/apt/sources.list RUN apt update && apt install --no-install-recommends --no-install-suggests -y wget ca-certificates git patch unzip bzip2 make gcc g++ libc-dev RUN wget -O /usr/bin/opam https://github.com/ocaml/opam/releases/download/2.1.5/opam-2.1.5-i686-linux && chmod 755 /usr/bin/opam @@ -14,7 +19,8 @@ ENV OPAMCONFIRMLEVEL=unsafe-yes # 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 opam init --disable-sandboxing -a --bare https://github.com/ocaml/opam-repository.git#28b35f67988702df5018fbf30d1c725734425670 +# taken from https://github.com/ocaml/opam-repository +RUN opam init --disable-sandboxing -a --bare https://github.com/ocaml/opam-repository.git#d1a8bf040fbb2c81ddb2612f1a49a471a06083dc RUN opam switch create myswitch 4.14.1 RUN opam exec -- opam install -y mirage opam-monorepo ocaml-solo5 RUN mkdir /tmp/orb-build diff --git a/README.md b/README.md index 9b23fc9..ea05670 100644 --- a/README.md +++ b/README.md @@ -14,12 +14,12 @@ See the [Deploy](#deploy) section below for installation instructions. ## Build from source Note: The most reliable way to build is using Docker. -Fedora 38 works well for this, Debian 11 also works (and Debian 12 should), but you'll need to follow the instructions at [docker.com][debian-docker] to get Docker +Fedora 38 works well for this, Debian 12 also works, but you'll need to follow the instructions at [docker.com][debian-docker] to get Docker (don't use Debian's version). Create a new Fedora-38 AppVM (or reuse an existing one). In the Qube's Settings (Basic / Disk storage), increase the private storage max size from the default 2048 MiB to 4096 MiB. Open a terminal. -Clone this Git repository and run the `build-with-docker.sh` script (Note: The `chcon` call is mandatory with new SELinux policies which do not allow to standardly keep the images in homedir): +Clone this Git repository and run the `build-with-docker.sh` script (Note: The `chcon` call is mandatory on Fedora with new SELinux policies which do not allow to standardly keep the docker images in homedir): mkdir /home/user/docker sudo ln -s /home/user/docker /var/lib/docker @@ -30,7 +30,7 @@ Clone this Git repository and run the `build-with-docker.sh` script (Note: The ` cd qubes-mirage-firewall sudo ./build-with-docker.sh -This took about 10 minutes on my laptop (it will be much quicker if you run it again). +This took about 15 minutes on my laptop (it will be much quicker if you run it again). The symlink step at the start isn't needed if your build VM is standalone. It gives Docker more disk space and avoids losing the Docker image cache when you reboot the Qube. diff --git a/build-with-docker.sh b/build-with-docker.sh index ba69427..8daa1b0 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`:/tmp/orb-build:Z qubes-mirage-firewall echo "SHA2 of build: $(sha256sum ./dist/qubes-firewall.xen)" -echo "SHA2 last known: 8ae5314edf5b863b788c4b873e27bc4b206a2ff7ef1051c4c62ae41584ed3e14" +echo "SHA2 last known: 2c3f68f49afdeaeedd2c03f8ef6d30d6bb4d6306bda0a1ff40f95f440a90034c" echo "(hashes should match for released versions)" From 2e86ea2ad34af6c004334b717ee527d0a61cd97a Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Wed, 8 Nov 2023 10:20:59 +0100 Subject: [PATCH 212/281] pin to specific overlays hashes --- Dockerfile | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/Dockerfile b/Dockerfile index aede321..d058b63 100644 --- a/Dockerfile +++ b/Dockerfile @@ -26,4 +26,7 @@ RUN opam exec -- opam install -y mirage opam-monorepo ocaml-solo5 RUN mkdir /tmp/orb-build ADD config.ml /tmp/orb-build/config.ml WORKDIR /tmp/orb-build -CMD opam exec -- sh -exc 'mirage configure -t xen --allocation-policy=best-fit && make depend && make tar' +CMD opam exec -- sh -exc 'mirage configure -t xen --extra-repos=\ +opam-overlays:https://github.com/dune-universe/opam-overlays.git#91a371754a2c9f4febbb6c7bb039649ad49a3c13,\ +mirage-overlays:https://github.com/dune-universe/mirage-opam-overlays.git#05f1c1823d891ce4d8adab91f5db3ac51d86dc0b \ +--allocation-policy=best-fit && make depend && make tar' From 90de455fdb35397225cc530c5aeaff8a571016e6 Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Wed, 8 Nov 2023 12:13:11 +0100 Subject: [PATCH 213/281] update disk size requirement --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index ea05670..aa9d594 100644 --- a/README.md +++ b/README.md @@ -17,7 +17,7 @@ Note: The most reliable way to build is using Docker. Fedora 38 works well for this, Debian 12 also works, but you'll need to follow the instructions at [docker.com][debian-docker] to get Docker (don't use Debian's version). -Create a new Fedora-38 AppVM (or reuse an existing one). In the Qube's Settings (Basic / Disk storage), increase the private storage max size from the default 2048 MiB to 4096 MiB. Open a terminal. +Create a new Fedora-38 AppVM (or reuse an existing one). In the Qube's Settings (Basic / Disk storage), increase the private storage max size from the default 2048 MiB to 8192 MiB. Open a terminal. Clone this Git repository and run the `build-with-docker.sh` script (Note: The `chcon` call is mandatory on Fedora with new SELinux policies which do not allow to standardly keep the docker images in homedir): From b9c8674b524c6bc6db96a40f4b1b82bfa530fe43 Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Thu, 9 Nov 2023 14:41:16 +0100 Subject: [PATCH 214/281] check opam hashsum in Dockerfile --- Dockerfile | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/Dockerfile b/Dockerfile index d058b63..f959047 100644 --- a/Dockerfile +++ b/Dockerfile @@ -3,7 +3,7 @@ # changes some compiler optimisations (unlikely). # bookworm-slim taken from https://hub.docker.com/_/debian/tags?page=1&name=bookworm-slim FROM debian@sha256:ea5ad531efe1ac11ff69395d032909baf423b8b88e9aade07e11b40b2e5a1338 -# install ca-certificates and remove default packages repository +# install remove default packages repository RUN rm /etc/apt/sources.list.d/debian.sources # and set the package source to a specific release too # taken from https://snapshot.debian.org/archive/debian @@ -13,6 +13,9 @@ RUN printf "deb [check-valid-until=no] http://snapshot.debian.org/archive/debian RUN apt update && apt install --no-install-recommends --no-install-suggests -y wget ca-certificates git patch unzip bzip2 make gcc g++ libc-dev RUN wget -O /usr/bin/opam https://github.com/ocaml/opam/releases/download/2.1.5/opam-2.1.5-i686-linux && chmod 755 /usr/bin/opam +# taken from https://raw.githubusercontent.com/ocaml/opam/master/shell/install.sh +RUN test `sha512sum /usr/bin/opam | cut -d' ' -f1` = \ +"38802b3079eeceb27aab3465bfd0f9f05a710dccf9487eb35fa2c02fbaf9a0659e1447aa19dd36df9cd01f760229de28c523c08c1c86a3aa3f5e25dbe7b551dd" || exit ENV OPAMROOT=/tmp ENV OPAMCONFIRMLEVEL=unsafe-yes From d2b72f6a875a861f4b54ad9df4f14d7e5e0d8d45 Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Tue, 26 Dec 2023 10:45:13 +0100 Subject: [PATCH 215/281] set back recommended memory amount to 32MB --- README.md | 4 ++-- SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/README.md b/README.md index aa9d594..07d24c9 100644 --- a/README.md +++ b/README.md @@ -72,8 +72,8 @@ Run this command in dom0 to create a `mirage-firewall` VM using the `mirage-fire qvm-create \ --property kernel=mirage-firewall \ --property kernelopts='' \ - --property memory=64 \ - --property maxmem=64 \ + --property memory=32 \ + --property maxmem=32 \ --property netvm=sys-net \ --property provides_network=True \ --property vcpus=1 \ diff --git a/SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls b/SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls index 3f932c9..1055faa 100644 --- a/SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls +++ b/SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls @@ -73,8 +73,8 @@ create-sys-mirage-fw: - kernel: mirage-firewall - kernelopts: - include-in-backups: False - - memory: 64 - - maxmem: 64 + - memory: 32 + - maxmem: 32 - netvm: sys-net - provides-network: True - vcpus: 1 From 16a50aad9bc56ab11ea9df5ff22934187ea285e2 Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Tue, 26 Dec 2023 11:12:06 +0100 Subject: [PATCH 216/281] allow podman as building system --- .github/workflows/{main.yml => docker.yml} | 4 +-- .github/workflows/podman.yml | 32 +++++++++++++++++++ Makefile.user | 2 +- README.md | 25 +++++++++------ ...ownloadAndInstallMirageFirewallInQubes.sls | 4 +-- build-with-docker.sh | 9 ------ build-with.sh | 24 ++++++++++++++ 7 files changed, 77 insertions(+), 23 deletions(-) rename .github/workflows/{main.yml => docker.yml} (72%) create mode 100644 .github/workflows/podman.yml delete mode 100755 build-with-docker.sh create mode 100755 build-with.sh diff --git a/.github/workflows/main.yml b/.github/workflows/docker.yml similarity index 72% rename from .github/workflows/main.yml rename to .github/workflows/docker.yml index 148d4e3..53b3324 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/docker.yml @@ -21,9 +21,9 @@ jobs: - name: Checkout code uses: actions/checkout@v2 - - run: ./build-with-docker.sh + - run: ./build-with.sh docker - - run: sh -exc 'if [ $(sha256sum dist/qubes-firewall.xen | cut -d " " -f 1) = $(grep "SHA2 last known" build-with-docker.sh | rev | cut -d ":" -f 1 | rev | cut -d "\"" -f 1 | tr -d " ") ]; then echo "SHA256 MATCHES"; else exit 42; fi' + - run: sh -exc 'if [ $(sha256sum dist/qubes-firewall.xen | cut -d " " -f 1) = $(grep "SHA2 last known" build-with.sh | rev | cut -d ":" -f 1 | rev | cut -d "\"" -f 1 | tr -d " ") ]; then echo "SHA256 MATCHES"; else exit 42; fi' - name: Upload Artifact uses: actions/upload-artifact@v3 diff --git a/.github/workflows/podman.yml b/.github/workflows/podman.yml new file mode 100644 index 0000000..fba19eb --- /dev/null +++ b/.github/workflows/podman.yml @@ -0,0 +1,32 @@ +name: Main workflow + +on: + pull_request: + push: + schedule: + # Prime the caches every Monday + - cron: 0 1 * * MON + +jobs: + build: + strategy: + fail-fast: false + matrix: + os: + - ubuntu-latest + + runs-on: ${{ matrix.os }} + + steps: + - name: Checkout code + uses: actions/checkout@v2 + + - run: ./build-with.sh podman + + - run: sh -exc 'if [ $(sha256sum dist/qubes-firewall.xen | cut -d " " -f 1) = $(grep "SHA2 last known" build-with.sh | rev | cut -d ":" -f 1 | rev | cut -d "\"" -f 1 | tr -d " ") ]; then echo "SHA256 MATCHES"; else exit 42; fi' + + - name: Upload Artifact + uses: actions/upload-artifact@v3 + with: + name: mirage-firewall.tar.bz2 + path: mirage-firewall.tar.bz2 diff --git a/Makefile.user b/Makefile.user index c8a1d5d..00890f6 100644 --- a/Makefile.user +++ b/Makefile.user @@ -6,7 +6,7 @@ tar: build cp dist/qubes-firewall.xen _build/mirage-firewall/vmlinuz touch _build/mirage-firewall/modules.img cat /dev/null | gzip -n > _build/mirage-firewall/initramfs - tar cjf mirage-firewall.tar.bz2 -C _build --mtime=./build-with-docker.sh mirage-firewall + tar cjf mirage-firewall.tar.bz2 -C _build --mtime=./build-with.sh mirage-firewall sha256sum mirage-firewall.tar.bz2 > mirage-firewall.sha256 fetchmotron: qubes_firewall.xen diff --git a/README.md b/README.md index aa9d594..27a7107 100644 --- a/README.md +++ b/README.md @@ -13,13 +13,13 @@ See the [Deploy](#deploy) section below for installation instructions. ## Build from source -Note: The most reliable way to build is using Docker. +Note: The most reliable way to build is using Docker or Podman. Fedora 38 works well for this, Debian 12 also works, but you'll need to follow the instructions at [docker.com][debian-docker] to get Docker (don't use Debian's version). Create a new Fedora-38 AppVM (or reuse an existing one). In the Qube's Settings (Basic / Disk storage), increase the private storage max size from the default 2048 MiB to 8192 MiB. Open a terminal. -Clone this Git repository and run the `build-with-docker.sh` script (Note: The `chcon` call is mandatory on Fedora with new SELinux policies which do not allow to standardly keep the docker images in homedir): +Clone this Git repository and run the `build-with.sh` script with either `docker` or `podman` as argument (Note: The `chcon` call is mandatory on Fedora with new SELinux policies which do not allow to standardly keep the docker images in homedir): mkdir /home/user/docker sudo ln -s /home/user/docker /var/lib/docker @@ -28,23 +28,30 @@ Clone this Git repository and run the `build-with-docker.sh` script (Note: The ` sudo systemctl start docker git clone https://github.com/mirage/qubes-mirage-firewall.git cd qubes-mirage-firewall - sudo ./build-with-docker.sh + sudo ./build-with.sh docker + +Or + + sudo systemctl start podman + git clone https://github.com/mirage/qubes-mirage-firewall.git + cd qubes-mirage-firewall + ./build-with.sh podman This took about 15 minutes on my laptop (it will be much quicker if you run it again). -The symlink step at the start isn't needed if your build VM is standalone. -It gives Docker more disk space and avoids losing the Docker image cache when you reboot the Qube. +The symlink step at the start isn't needed if your build VM is standalone. It gives Docker more disk space and avoids losing the Docker image cache when you reboot the Qube. +It's not needed with Podman as the containers lives in your home directory by default. Note: the object files are stored in the `_build` directory to speed up incremental builds. If you change the dependencies, you will need to delete this directory before rebuilding. -It's OK to install the Docker package in a template VM if you want it to remain +It's OK to install the Docker or Podman package in a template VM if you want it to remain after a reboot, but the build of the firewall itself should be done in a regular AppVM. -You can also build without Docker, as for any normal Mirage unikernel; +You can also build without that script, as for any normal Mirage unikernel; see [the Mirage installation instructions](https://mirage.io/wiki/install) for details. -The Docker build fixes the versions of the libraries it uses, ensuring that you will get -exactly the same binary that is in the release. If you build without Docker, it will build +The build script fixes the versions of the libraries it uses, ensuring that you will get +exactly the same binary that is in the release. If you build without it, it will build against the latest versions instead (and the hash will therefore probably not match). However, it should still work fine. diff --git a/SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls b/SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls index 3f932c9..4a6641d 100644 --- a/SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls +++ b/SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls @@ -42,9 +42,9 @@ download-and-unpack-in-DownloadVM4mirage: check-checksum-in-DownloadVM: cmd.run: - names: - - qvm-run --pass-io {{ DownloadVM }} {{ "\"echo \\\"Checksum of last build on github:\\\";curl -s https://raw.githubusercontent.com/mirage/qubes-mirage-firewall/main/build-with-docker.sh | grep \\\"SHA2 last known:\\\" | cut -d\' \' -f5 | tr -d \\\\\\\"\"" }} + - qvm-run --pass-io {{ DownloadVM }} {{ "\"echo \\\"Checksum of last build on github:\\\";curl -s https://raw.githubusercontent.com/mirage/qubes-mirage-firewall/main/build-with.sh | grep \\\"SHA2 last known:\\\" | cut -d\' \' -f5 | tr -d \\\\\\\"\"" }} - qvm-run --pass-io {{ DownloadVM }} {{ "\"echo \\\"Checksum of downloaded local file:\\\";sha256sum ~/mirage-firewall/vmlinuz | cut -d\' \' -f1\"" }} - - qvm-run --pass-io {{ DownloadVM }} {{ "\"diff <(curl -s https://raw.githubusercontent.com/mirage/qubes-mirage-firewall/main/build-with-docker.sh | grep \\\"SHA2 last known:\\\" | cut -d\' \' -f5 | tr -d \\\\\\\") <(sha256sum ~/mirage-firewall/vmlinuz | cut -d\' \' -f1) && echo \\\"Checksums DO match.\\\" || (echo \\\"Checksums do NOT match.\\\";exit 101)\"" }} #~/mirage-firewall/modules.img + - qvm-run --pass-io {{ DownloadVM }} {{ "\"diff <(curl -s https://raw.githubusercontent.com/mirage/qubes-mirage-firewall/main/build-with.sh | grep \\\"SHA2 last known:\\\" | cut -d\' \' -f5 | tr -d \\\\\\\") <(sha256sum ~/mirage-firewall/vmlinuz | cut -d\' \' -f1) && echo \\\"Checksums DO match.\\\" || (echo \\\"Checksums do NOT match.\\\";exit 101)\"" }} #~/mirage-firewall/modules.img - require: - download-and-unpack-in-DownloadVM4mirage diff --git a/build-with-docker.sh b/build-with-docker.sh deleted file mode 100755 index 8daa1b0..0000000 --- a/build-with-docker.sh +++ /dev/null @@ -1,9 +0,0 @@ -#!/bin/sh -set -eu -echo Building Docker image with dependencies.. -docker build -t qubes-mirage-firewall . -echo Building Firewall... -docker run --rm -i -v `pwd`:/tmp/orb-build:Z qubes-mirage-firewall -echo "SHA2 of build: $(sha256sum ./dist/qubes-firewall.xen)" -echo "SHA2 last known: 2c3f68f49afdeaeedd2c03f8ef6d30d6bb4d6306bda0a1ff40f95f440a90034c" -echo "(hashes should match for released versions)" diff --git a/build-with.sh b/build-with.sh new file mode 100755 index 0000000..712b012 --- /dev/null +++ b/build-with.sh @@ -0,0 +1,24 @@ +#!/bin/sh +set -eu + +if [[ $# -ne 1 ]] ; then + echo "Usage: build-with.sh { docker | podman }" + exit 1 +fi + +builder=$1 +case $builder in + docker|podman) + ;; + *) + echo "You should use either docker or podman for building" + exit 2 +esac + +echo Building $builder image with dependencies.. +$builder build -t qubes-mirage-firewall . +echo Building Firewall... +$builder run --rm -i -v `pwd`:/tmp/orb-build:Z qubes-mirage-firewall +echo "SHA2 of build: $(sha256sum ./dist/qubes-firewall.xen)" +echo "SHA2 last known: 2c3f68f49afdeaeedd2c03f8ef6d30d6bb4d6306bda0a1ff40f95f440a90034c" +echo "(hashes should match for released versions)" From fc7f7f3544d5a045a9e3a5863e8bcbf7829ce6a5 Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Sun, 14 Apr 2024 18:35:52 +0200 Subject: [PATCH 217/281] packets forwarded by our client netvm are ok --- dispatcher.ml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/dispatcher.ml b/dispatcher.ml index d3c3241..d1d43d6 100644 --- a/dispatcher.ml +++ b/dispatcher.ml @@ -333,6 +333,9 @@ struct let src = ip.Ipv4_packet.src in if src = iface#other_ip then ipv4_from_client dns_client dns_servers router ~src:iface packet + else if iface#other_ip = router.config.netvm_ip then + (* This can occurs when used with *BSD as netvm (and a gateway is set) *) + ipv4_from_netvm router packet else ( Log.warn (fun f -> f "Incorrect source IP %a in IP packet from %a (dropping)" From 46deafa650cc41f23d044e19ca810b235b5951a3 Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Tue, 23 Apr 2024 17:21:51 +0200 Subject: [PATCH 218/281] update to mirage 4.5.0 --- config.ml | 51 ++++++++++++++------------------------------------- fw_utils.ml | 2 +- unikernel.ml | 34 +++++++++++++++++++++++++++------- 3 files changed, 42 insertions(+), 45 deletions(-) diff --git a/config.ml b/config.ml index f28928e..c092574 100644 --- a/config.ml +++ b/config.ml @@ -1,3 +1,4 @@ +(* mirage >= 4.5.0 *) (* Copyright (C) 2017, Thomas Leonard See the README file for details. *) @@ -5,55 +6,31 @@ open Mirage -let table_size = - let info = Key.Arg.info - ~doc:"The number of NAT entries to allocate." - ~docv:"ENTRIES" ["nat-table-size"] - in - let key = Key.Arg.opt ~stage:`Both Key.Arg.int 5_000 info in - Key.create "nat_table_size" key - -let ipv4 = - let doc = Key.Arg.info ~doc:"Manual IP setting." ["ipv4"] in - Key.(create "ipv4" Arg.(opt string "0.0.0.0" doc)) - -let ipv4_gw = - let doc = Key.Arg.info ~doc:"Manual Gateway IP setting." ["ipv4-gw"] in - Key.(create "ipv4_gw" Arg.(opt string "0.0.0.0" doc)) - -let ipv4_dns = - let doc = Key.Arg.info ~doc:"Manual DNS IP setting." ["ipv4-dns"] in - Key.(create "ipv4_dns" Arg.(opt string "10.139.1.1" doc)) - -let ipv4_dns2 = - let doc = Key.Arg.info ~doc:"Manual Second DNS IP setting." ["ipv4-dns2"] in - Key.(create "ipv4_dns2" Arg.(opt string "10.139.1.2" doc)) +let nat_table_size = runtime_arg ~pos:__POS__ "Unikernel.nat_table_size" +let ipv4 = runtime_arg ~pos:__POS__ "Unikernel.ipv4" +let ipv4_gw = runtime_arg ~pos:__POS__ "Unikernel.ipv4_gw" +let ipv4_dns = runtime_arg ~pos:__POS__ "Unikernel.ipv4_dns" +let ipv4_dns2 = runtime_arg ~pos:__POS__ "Unikernel.ipv4_dns2" let main = - foreign - ~keys:[ - Key.v table_size; - Key.v ipv4; - Key.v ipv4_gw; - Key.v ipv4_dns; - Key.v ipv4_dns2; - ] + main + ~runtime_args:[ nat_table_size; ] ~packages:[ package "vchan" ~min:"4.0.2"; package "cstruct"; package "astring"; package "tcpip" ~min:"3.7.0"; - package ~min:"2.3.0" ~sublibs:["mirage"] "arp"; - package ~min:"3.0.0" "ethernet"; + package "arp" ~min:"2.3.0" ~sublibs:["mirage"]; + package "ethernet" ~min:"3.0.0"; package "shared-memory-ring" ~min:"3.0.0"; - package ~min:"2.1.3" "netchannel"; - package ~min:"2.1.3" "mirage-net-xen"; + package "netchannel" ~min:"2.1.3"; + package "mirage-net-xen" ~min:"2.1.3"; package "ipaddr" ~min:"5.2.0"; package "mirage-qubes" ~min:"0.9.1"; - package ~min:"3.0.1" "mirage-nat"; + package "mirage-nat" ~min:"3.0.1"; package "mirage-logs"; package "mirage-xen" ~min:"8.0.0"; - package ~min:"6.4.0" "dns-client"; + package "dns-client" ~min:"6.4.0"; package "pf-qubes"; ] "Unikernel.Main" (random @-> mclock @-> time @-> job) diff --git a/fw_utils.ml b/fw_utils.ml index 4469e4d..0307810 100644 --- a/fw_utils.ml +++ b/fw_utils.ml @@ -8,7 +8,7 @@ module IpMap = struct let find x map = try Some (find x map) with Not_found -> None - | e -> Logs.err( fun f -> f "uncaught exception in find...%!"); None + | _ -> Logs.err( fun f -> f "uncaught exception in find...%!"); None end (** An Ethernet interface. *) diff --git a/unikernel.ml b/unikernel.ml index ef02620..dcbdafe 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -3,10 +3,31 @@ open Lwt open Qubes +open Cmdliner let src = Logs.Src.create "unikernel" ~doc:"Main unikernel code" module Log = (val Logs.src_log src : Logs.LOG) +let nat_table_size = + let doc = Arg.info ~doc:"The number of NAT entries to allocate." [ "nat-table-size" ] in + Arg.(value & opt int 5_000 doc) + +let ipv4 = + let doc = Arg.info ~doc:"Manual IP setting." [ "ipv4" ] in + Arg.(value & opt string "0.0.0.0" doc) + +let ipv4_gw = + let doc = Arg.info ~doc:"Manual Gateway IP setting." [ "ipv4-gw" ] in + Arg.(value & opt string "0.0.0.0" doc) + +let ipv4_dns = + let doc = Arg.info ~doc:"Manual DNS IP setting." [ "ipv4-dns" ] in + Arg.(value & opt string "10.139.1.1" doc) + +let ipv4_dns2 = + let doc = Arg.info ~doc:"Manual Second DNS IP setting." [ "ipv4-dns2" ] in + Arg.(value & opt string "10.139.1.2" doc) + module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_time.S) = struct module Dispatcher = Dispatcher.Make(R)(Clock)(Time) module Dns_transport = My_dns.Transport(R)(Clock)(Time) @@ -24,7 +45,7 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_tim ] (* Main unikernel entry point (called from auto-generated main.ml). *) - let start _random _clock _time = + let start _random _clock _time nat_table_size ipv4 ipv4_gw ipv4_dns ipv4_dns2 = let start_time = Clock.elapsed_ns () in (* Start qrexec agent and QubesDB agent in parallel *) let qrexec = RExec.connect ~domid:0 () in @@ -45,13 +66,12 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_tim Xen_os.Lifecycle.await_shutdown_request () >>= fun (`Poweroff | `Reboot) -> Lwt.return_unit in (* Set up networking *) - let max_entries = Key_gen.nat_table_size () in - let nat = My_nat.create ~max_entries in + let nat = My_nat.create ~max_entries:nat_table_size in - let netvm_ip = Ipaddr.V4.of_string_exn (Key_gen.ipv4_gw ()) in - let our_ip = Ipaddr.V4.of_string_exn (Key_gen.ipv4 ()) in - let dns = Ipaddr.V4.of_string_exn (Key_gen.ipv4_dns ()) in - let dns2 = Ipaddr.V4.of_string_exn (Key_gen.ipv4_dns2 ()) in + let netvm_ip = Ipaddr.V4.of_string_exn ipv4_gw in + let our_ip = Ipaddr.V4.of_string_exn ipv4 in + let dns = Ipaddr.V4.of_string_exn ipv4_dns in + let dns2 = Ipaddr.V4.of_string_exn ipv4_dns2 in let zero_ip = (Ipaddr.V4.make 0 0 0 0) in From 05c7a8d1d9886935ec56d80171eb01217e83801a Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Tue, 23 Apr 2024 18:09:53 +0200 Subject: [PATCH 219/281] address @hannesm comments --- config.ml | 14 +++++++------- memory_pressure.ml | 17 ----------------- 2 files changed, 7 insertions(+), 24 deletions(-) diff --git a/config.ml b/config.ml index c092574..89bb9bd 100644 --- a/config.ml +++ b/config.ml @@ -1,4 +1,4 @@ -(* mirage >= 4.5.0 *) +(* mirage >= 4.5.0 & < 5.0.0 *) (* Copyright (C) 2017, Thomas Leonard See the README file for details. *) @@ -14,23 +14,23 @@ let ipv4_dns2 = runtime_arg ~pos:__POS__ "Unikernel.ipv4_dns2" let main = main - ~runtime_args:[ nat_table_size; ] + ~runtime_args:[ nat_table_size; ipv4; ipv4_gw; ipv4_dns; ipv4_dns2; ] ~packages:[ package "vchan" ~min:"4.0.2"; package "cstruct"; package "astring"; package "tcpip" ~min:"3.7.0"; - package "arp" ~min:"2.3.0" ~sublibs:["mirage"]; - package "ethernet" ~min:"3.0.0"; + 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:"2.1.3"; + package ~min:"2.1.3" "netchannel"; package "mirage-net-xen" ~min:"2.1.3"; package "ipaddr" ~min:"5.2.0"; package "mirage-qubes" ~min:"0.9.1"; - package "mirage-nat" ~min:"3.0.1"; + package ~min:"3.0.1" "mirage-nat"; package "mirage-logs"; package "mirage-xen" ~min:"8.0.0"; - package "dns-client" ~min:"6.4.0"; + package ~min:"6.4.0" "dns-client"; package "pf-qubes"; ] "Unikernel.Main" (random @-> mclock @-> time @-> job) diff --git a/memory_pressure.ml b/memory_pressure.ml index 87289c2..bfa5c8d 100644 --- a/memory_pressure.ml +++ b/memory_pressure.ml @@ -1,8 +1,6 @@ (* Copyright (C) 2015, Thomas Leonard See the README file for details. *) -open Lwt - let src = Logs.Src.create "memory_pressure" ~doc:"Memory pressure monitor" module Log = (val Logs.src_log src : Logs.LOG) @@ -12,21 +10,6 @@ let fraction_free stats = let { Xen_os.Memory.free_words; heap_words; _ } = stats in float free_words /. float heap_words -let meminfo stats = - 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 "Writing meminfo: free %a / %a (%.2f %%)" - Fmt.bi_byte_size mem_free - Fmt.bi_byte_size mem_total - (fraction_free stats *. 100.0)); - Printf.sprintf "MemTotal: %d kB\n\ - MemFree: %d kB\n\ - Buffers: 0 kB\n\ - Cached: 0 kB\n\ - SwapTotal: 0 kB\n\ - SwapFree: 0 kB\n" (mem_total / 1024) (mem_free / 1024) - let init () = Gc.full_major () From a7a7ea4c38e297f126a2ad62704e333c68292712 Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Tue, 23 Apr 2024 18:10:32 +0200 Subject: [PATCH 220/281] update the compilation toolchain, including upgrade to mirage 4.5.0 --- Dockerfile | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/Dockerfile b/Dockerfile index f959047..6f795d7 100644 --- a/Dockerfile +++ b/Dockerfile @@ -2,14 +2,14 @@ # It will probably still work on newer images, though, unless an update # changes some compiler optimisations (unlikely). # bookworm-slim taken from https://hub.docker.com/_/debian/tags?page=1&name=bookworm-slim -FROM debian@sha256:ea5ad531efe1ac11ff69395d032909baf423b8b88e9aade07e11b40b2e5a1338 +FROM debian@sha256:3d5df92588469a4c503adbead0e4129ef3f88e223954011c2169073897547cac # install remove default packages repository RUN rm /etc/apt/sources.list.d/debian.sources # and set the package source to a specific release too # taken from https://snapshot.debian.org/archive/debian -RUN printf "deb [check-valid-until=no] http://snapshot.debian.org/archive/debian/20231107T084929Z bookworm main\n" > /etc/apt/sources.list +RUN printf "deb [check-valid-until=no] http://snapshot.debian.org/archive/debian/20240419T024211Z bookworm main\n" > /etc/apt/sources.list # taken from https://snapshot.debian.org/archive/debian-security/ -RUN printf "deb [check-valid-until=no] http://snapshot.debian.org/archive/debian-security/20231108T004541Z bookworm-security main\n" >> /etc/apt/sources.list +RUN printf "deb [check-valid-until=no] http://snapshot.debian.org/archive/debian-security/20240419T111010Z bookworm-security main\n" >> /etc/apt/sources.list RUN apt update && apt install --no-install-recommends --no-install-suggests -y wget ca-certificates git patch unzip bzip2 make gcc g++ libc-dev RUN wget -O /usr/bin/opam https://github.com/ocaml/opam/releases/download/2.1.5/opam-2.1.5-i686-linux && chmod 755 /usr/bin/opam @@ -23,13 +23,13 @@ ENV OPAMCONFIRMLEVEL=unsafe-yes # Remove this line (and the base image pin above) if you want to test with the # latest versions. # taken from https://github.com/ocaml/opam-repository -RUN opam init --disable-sandboxing -a --bare https://github.com/ocaml/opam-repository.git#d1a8bf040fbb2c81ddb2612f1a49a471a06083dc +RUN opam init --disable-sandboxing -a --bare https://github.com/ocaml/opam-repository.git#4399f486aa6edefdc96d5e206a65ce42288ebfdd RUN opam switch create myswitch 4.14.1 RUN opam exec -- opam install -y mirage opam-monorepo ocaml-solo5 RUN mkdir /tmp/orb-build ADD config.ml /tmp/orb-build/config.ml WORKDIR /tmp/orb-build CMD opam exec -- sh -exc 'mirage configure -t xen --extra-repos=\ -opam-overlays:https://github.com/dune-universe/opam-overlays.git#91a371754a2c9f4febbb6c7bb039649ad49a3c13,\ -mirage-overlays:https://github.com/dune-universe/mirage-opam-overlays.git#05f1c1823d891ce4d8adab91f5db3ac51d86dc0b \ ---allocation-policy=best-fit && make depend && make tar' +opam-overlays:https://github.com/dune-universe/opam-overlays.git#4e75ee36715b27550d5bdb87686bb4ae4c9e89c4,\ +mirage-overlays:https://github.com/dune-universe/mirage-opam-overlays.git#797cb363df3ff763c43c8fbec5cd44de2878757e \ +&& make depend && make tar' From f1a333adce78ae5f6b2c306b2c88f48ef4a210b1 Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Tue, 23 Apr 2024 20:37:11 +0200 Subject: [PATCH 221/281] fix: uplink is an option, disconnect* return Lwt.return_unit --- dispatcher.ml | 20 ++++++++++---------- memory_pressure.ml | 2 -- unikernel.ml | 2 +- 3 files changed, 11 insertions(+), 13 deletions(-) diff --git a/dispatcher.ml b/dispatcher.ml index d1d43d6..856f202 100644 --- a/dispatcher.ml +++ b/dispatcher.ml @@ -89,7 +89,7 @@ struct mutable uplink : uplink option; } - let create ~config ~clients ~nat ?uplink = + let create ~config ~clients ~nat ~uplink = { uplink_connected = Lwt_condition.create (); uplink_disconnect = Lwt_condition.create (); @@ -100,7 +100,7 @@ struct uplink; } - let update t ~config ?uplink = + let update t ~config ~uplink = t.config <- config; t.uplink <- uplink; Lwt.return_unit @@ -518,13 +518,13 @@ struct currently we delay 1s as Netif.disconnect is non-blocking... (need to fix upstream?) *) Log.info (fun f -> f "disconnecting from our uplink"); - U.disconnect uplink.udp; - I.disconnect uplink.ip; + U.disconnect uplink.udp >>= fun () -> + I.disconnect uplink.ip >>= fun () -> (* mutable fragments : Fragments.Cache.t; *) (* interface : interface; *) - Arp.disconnect uplink.arp; - UplinkEth.disconnect uplink.eth; - Netif.disconnect uplink.net; + Arp.disconnect uplink.arp >>= fun () -> + UplinkEth.disconnect uplink.eth >>= fun () -> + Netif.disconnect uplink.net >>= fun () -> Lwt_condition.broadcast router.uplink_disconnected (); Lwt.return_unit | e -> Lwt.fail e) @@ -579,7 +579,7 @@ struct Dao.read_network_config qubesDB >>= fun config -> Dao.print_network_config config; connect config >>= fun uplink -> - update router ~config ?uplink:(Some uplink) >>= fun () -> + update router ~config ~uplink:(Some uplink) >>= fun () -> Lwt_condition.broadcast router.uplink_connected (); Lwt.return_unit | None, Some _ -> @@ -588,10 +588,10 @@ struct Dao.read_network_config qubesDB >>= fun config -> Dao.print_network_config config; connect config >>= fun uplink -> - update router ~config ?uplink:(Some uplink) >>= fun () -> + update router ~config ~uplink:(Some uplink) >>= fun () -> Lwt_condition.broadcast router.uplink_connected (); Lwt.return_unit - | Some uplink, None -> + | Some _, None -> (* This currently is never triggered :( *) Log.info (fun f -> f "TODO: Our netvm disapeared, troubles are coming!%!"); diff --git a/memory_pressure.ml b/memory_pressure.ml index bfa5c8d..667bd50 100644 --- a/memory_pressure.ml +++ b/memory_pressure.ml @@ -4,8 +4,6 @@ let src = Logs.Src.create "memory_pressure" ~doc:"Memory pressure monitor" module Log = (val Logs.src_log src : Logs.LOG) -let wordsize_in_bytes = Sys.word_size / 8 - let fraction_free stats = let { Xen_os.Memory.free_words; heap_words; _ } = stats in float free_words /. float heap_words diff --git a/unikernel.ml b/unikernel.ml index dcbdafe..e0ceae8 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -100,7 +100,7 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_tim ~config ~clients ~nat - ?uplink:None + ~uplink:None in let send_dns_query = Dispatcher.send_dns_client_query None in From ba2a8731edc219d9eb39837ad66d5eef0ccb2245 Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Wed, 24 Apr 2024 10:57:37 +0200 Subject: [PATCH 222/281] update hashsum --- build-with.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/build-with.sh b/build-with.sh index 712b012..112b40f 100755 --- a/build-with.sh +++ b/build-with.sh @@ -20,5 +20,5 @@ $builder build -t qubes-mirage-firewall . echo Building Firewall... $builder run --rm -i -v `pwd`:/tmp/orb-build:Z qubes-mirage-firewall echo "SHA2 of build: $(sha256sum ./dist/qubes-firewall.xen)" -echo "SHA2 last known: 2c3f68f49afdeaeedd2c03f8ef6d30d6bb4d6306bda0a1ff40f95f440a90034c" +echo "SHA2 last known: 163991ea96842e03d378501a0be99057ad2489440aff8ae81d850624d98fd3f0" echo "(hashes should match for released versions)" From a7830aa5a1e8a56323671710bda00f7f3fab48d6 Mon Sep 17 00:00:00 2001 From: Pierre Alain <65669679+palainp@users.noreply.github.com> Date: Wed, 24 Apr 2024 12:19:17 +0200 Subject: [PATCH 223/281] Update CHANGES.md --- CHANGES.md | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index f37b080..ab776a3 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,21 @@ +### 0.9.0 (2024-04-24) + +- Fix an incorrect free memory estimation (fix in mirage/ocaml-solo5#135 + @palainp) +- Update to mirage 4.5.0, allowing openBSD to be used as netvm (#146 reported + by @Szewcson), and recover from a netvm change (#156 reported by @xaki-23) + (#178 @palainp) + +### 0.8.6 (2023-11-08) + +- Fix Docker build issue with newest SELinux policies (#183 @palainp, reported + by @Szewcson) +- Update build script (change to debian repositories, update debian image, update + opam-repository commit, set commit for opam-overlay and mirage-overlay) (#184 + @palainp, reported by @ben-grande) +- Update disk usage value during local compilation (#186 @palainp, reported by + @ben-grande) + ### 0.8.5 (2023-07-05) - Remove memreport to Xen to avoid Qubes trying to get back some memory From e36ffdb0a5edd2a24c3d0b8f2882fb6089defe46 Mon Sep 17 00:00:00 2001 From: Pierre Alain <65669679+palainp@users.noreply.github.com> Date: Tue, 7 May 2024 10:32:40 +0200 Subject: [PATCH 224/281] fix #195, a leading space was inserted by mistake --- build-with.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/build-with.sh b/build-with.sh index 112b40f..d60f9cf 100755 --- a/build-with.sh +++ b/build-with.sh @@ -20,5 +20,5 @@ $builder build -t qubes-mirage-firewall . echo Building Firewall... $builder run --rm -i -v `pwd`:/tmp/orb-build:Z qubes-mirage-firewall echo "SHA2 of build: $(sha256sum ./dist/qubes-firewall.xen)" -echo "SHA2 last known: 163991ea96842e03d378501a0be99057ad2489440aff8ae81d850624d98fd3f0" +echo "SHA2 last known: 163991ea96842e03d378501a0be99057ad2489440aff8ae81d850624d98fd3f0" echo "(hashes should match for released versions)" From 1cf272295410004f298edd661a91a8b5da188f04 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 24 Apr 2024 17:31:12 +0100 Subject: [PATCH 225/281] drop astring dependency --- config.ml | 1 - dao.ml | 9 ++++----- 2 files changed, 4 insertions(+), 6 deletions(-) diff --git a/config.ml b/config.ml index 89bb9bd..def0f87 100644 --- a/config.ml +++ b/config.ml @@ -18,7 +18,6 @@ let main = ~packages:[ package "vchan" ~min:"4.0.2"; package "cstruct"; - package "astring"; package "tcpip" ~min:"3.7.0"; package ~min:"2.3.0" ~sublibs:["mirage"] "arp"; package ~min:"3.0.0" "ethernet"; diff --git a/dao.ml b/dao.ml index 7c6eecb..2361630 100644 --- a/dao.ml +++ b/dao.ml @@ -3,7 +3,6 @@ open Lwt.Infix open Qubes -open Astring let src = Logs.Src.create "dao" ~doc:"QubesDB data access" module Log = (val Logs.src_log src : Logs.LOG) @@ -66,26 +65,26 @@ let read_rules rules client_ip = number = 0;})] let vifs client domid = - match String.to_int domid with + match int_of_string_opt 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 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 + match int_of_string_opt 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 + let client_ip' = match String.split_on_char ' ' 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); + (String.concat " " rest) ClientVif.pp vif); ip in match Ipaddr.V4.of_string client_ip' with From acac245840d262a12f6a5e040d3c477ade49c315 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Mon, 6 May 2024 16:13:17 +0200 Subject: [PATCH 226/281] update to mirage-net-xen 2.1.4 --- config.ml | 3 +-- dispatcher.ml | 2 +- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/config.ml b/config.ml index def0f87..74fa23f 100644 --- a/config.ml +++ b/config.ml @@ -22,8 +22,7 @@ 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 ~min:"2.1.3" "netchannel"; - package "mirage-net-xen" ~min:"2.1.3"; + package "mirage-net-xen" ~min:"2.1.4"; package "ipaddr" ~min:"5.2.0"; package "mirage-qubes" ~min:"0.9.1"; package ~min:"3.0.1" "mirage-nat"; diff --git a/dispatcher.ml b/dispatcher.ml index 856f202..44b8728 100644 --- a/dispatcher.ml +++ b/dispatcher.ml @@ -1,6 +1,6 @@ open Lwt.Infix open Fw_utils -module Netback = Netchannel.Backend.Make (Netchannel.Xenstore.Make (Xen_os.Xs)) +module Netback = Backend.Make (Xenstore.Make (Xen_os.Xs)) module ClientEth = Ethernet.Make (Netback) module UplinkEth = Ethernet.Make (Netif) From a37584a720cfdf63fb18308b519a2aed0a550982 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Thu, 9 May 2024 12:51:23 +0200 Subject: [PATCH 227/281] update opam-repository commit --- Dockerfile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Dockerfile b/Dockerfile index 6f795d7..300ff72 100644 --- a/Dockerfile +++ b/Dockerfile @@ -23,7 +23,7 @@ ENV OPAMCONFIRMLEVEL=unsafe-yes # Remove this line (and the base image pin above) if you want to test with the # latest versions. # taken from https://github.com/ocaml/opam-repository -RUN opam init --disable-sandboxing -a --bare https://github.com/ocaml/opam-repository.git#4399f486aa6edefdc96d5e206a65ce42288ebfdd +RUN opam init --disable-sandboxing -a --bare https://github.com/ocaml/opam-repository.git#f9f113a6bb242a13702859873fa0fcef9146eb6a RUN opam switch create myswitch 4.14.1 RUN opam exec -- opam install -y mirage opam-monorepo ocaml-solo5 RUN mkdir /tmp/orb-build From 8e4c24bfbad9d00b42f531af095ae07da9a27dfd Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Mon, 6 May 2024 19:11:23 +0200 Subject: [PATCH 228/281] allow the firewall to use the router for dns requests (in rules) --- dispatcher.ml | 6 +++--- unikernel.ml | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/dispatcher.ml b/dispatcher.ml index 44b8728..fc21cdd 100644 --- a/dispatcher.ml +++ b/dispatcher.ml @@ -446,14 +446,14 @@ struct clients := !clients |> Dao.VifMap.add key cleanup))) let send_dns_client_query t ~src_port ~dst ~dst_port buf = - match t with + match t.uplink with | None -> Log.err (fun f -> f "No uplink interface"); Lwt.return (Error (`Msg "failure")) - | Some t -> ( + | Some uplink -> ( Lwt.catch (fun () -> - U.write ~src_port ~dst ~dst_port t.udp buf >|= function + U.write ~src_port ~dst ~dst_port uplink.udp buf >|= function | Error s -> Log.err (fun f -> f "error sending udp packet: %a" U.pp_error s); Error (`Msg "failure") diff --git a/unikernel.ml b/unikernel.ml index e0ceae8..b4e92c7 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -103,7 +103,7 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_tim ~uplink:None in - let send_dns_query = Dispatcher.send_dns_client_query None in + let send_dns_query = Dispatcher.send_dns_client_query router in let dns_mvar = Lwt_mvar.create_empty () 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 From 8d67e9d47adbe589d05d8c884ce1d5aba270b596 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Thu, 9 May 2024 12:58:52 +0200 Subject: [PATCH 229/281] use OCaml 4.14.2 -- the latest LTS release --- Dockerfile | 2 +- Makefile.builder | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/Dockerfile b/Dockerfile index 300ff72..8774680 100644 --- a/Dockerfile +++ b/Dockerfile @@ -24,7 +24,7 @@ ENV OPAMCONFIRMLEVEL=unsafe-yes # latest versions. # taken from https://github.com/ocaml/opam-repository RUN opam init --disable-sandboxing -a --bare https://github.com/ocaml/opam-repository.git#f9f113a6bb242a13702859873fa0fcef9146eb6a -RUN opam switch create myswitch 4.14.1 +RUN opam switch create myswitch 4.14.2 RUN opam exec -- opam install -y mirage opam-monorepo ocaml-solo5 RUN mkdir /tmp/orb-build ADD config.ml /tmp/orb-build/config.ml diff --git a/Makefile.builder b/Makefile.builder index 5d79a54..53b860d 100644 --- a/Makefile.builder +++ b/Makefile.builder @@ -1,5 +1,5 @@ MIRAGE_KERNEL_NAME = dist/qubes-firewall.xen -OCAML_VERSION ?= 4.14.0 +OCAML_VERSION ?= 4.14.2 SOURCE_BUILD_DEP := firewall-build-dep firewall-build-dep: From 958b84430aad23c041cbe3dd7cff2bbc1f323160 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 10 May 2024 15:11:34 +0200 Subject: [PATCH 230/281] update checksum --- build-with.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/build-with.sh b/build-with.sh index d60f9cf..80f75ed 100755 --- a/build-with.sh +++ b/build-with.sh @@ -20,5 +20,5 @@ $builder build -t qubes-mirage-firewall . echo Building Firewall... $builder run --rm -i -v `pwd`:/tmp/orb-build:Z qubes-mirage-firewall echo "SHA2 of build: $(sha256sum ./dist/qubes-firewall.xen)" -echo "SHA2 last known: 163991ea96842e03d378501a0be99057ad2489440aff8ae81d850624d98fd3f0" +echo "SHA2 last known: 0cbb202c1b93e10ad115c9e988f9384005656c0855ec9deaf05a5e9ac9972984" echo "(hashes should match for released versions)" From 9058d25dcc4d347095ca4c1554ea256de53edd4f Mon Sep 17 00:00:00 2001 From: Pierre Alain <65669679+palainp@users.noreply.github.com> Date: Sat, 11 May 2024 15:01:33 +0200 Subject: [PATCH 231/281] Update CHANGES.md --- CHANGES.md | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index ab776a3..1e6224f 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,10 @@ +### 0.9.1 (2024-05-10) + +- Drop astring dependency, update mirage-net-xen, and OCaml 4.14.2 -- the + latest LTS release (#193, @hannesm) +- Allow the firewall to use domains requests in rules (#193, @palainp, + reported in the Qubes forum, fix confirmed by @neoniobium) + ### 0.9.0 (2024-04-24) - Fix an incorrect free memory estimation (fix in mirage/ocaml-solo5#135 From 6b0c18fd4e53015e59b5de88a5bf1146802ab145 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 9 Aug 2024 13:37:06 +0200 Subject: [PATCH 232/281] update opam repository in Dockerfile the reason behind this is that in the earlier commit, some urls point to unavailable urls. --- Dockerfile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Dockerfile b/Dockerfile index 8774680..f33b6e5 100644 --- a/Dockerfile +++ b/Dockerfile @@ -23,7 +23,7 @@ ENV OPAMCONFIRMLEVEL=unsafe-yes # Remove this line (and the base image pin above) if you want to test with the # latest versions. # taken from https://github.com/ocaml/opam-repository -RUN opam init --disable-sandboxing -a --bare https://github.com/ocaml/opam-repository.git#f9f113a6bb242a13702859873fa0fcef9146eb6a +RUN opam init --disable-sandboxing -a --bare https://github.com/ocaml/opam-repository.git#13acffc3de9c22953d1e08bad3e56ee6e965eeed RUN opam switch create myswitch 4.14.2 RUN opam exec -- opam install -y mirage opam-monorepo ocaml-solo5 RUN mkdir /tmp/orb-build From 5690052db49931d581a3b59e0ef47d8345e62f8c Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 9 Aug 2024 13:50:19 +0200 Subject: [PATCH 233/281] new shasum --- build-with.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/build-with.sh b/build-with.sh index 80f75ed..7d698f0 100755 --- a/build-with.sh +++ b/build-with.sh @@ -20,5 +20,5 @@ $builder build -t qubes-mirage-firewall . echo Building Firewall... $builder run --rm -i -v `pwd`:/tmp/orb-build:Z qubes-mirage-firewall echo "SHA2 of build: $(sha256sum ./dist/qubes-firewall.xen)" -echo "SHA2 last known: 0cbb202c1b93e10ad115c9e988f9384005656c0855ec9deaf05a5e9ac9972984" +echo "SHA2 last known: 5805e94755334af02fd4244b0b163c7a90fef9061d826e365db3be8adfe8abcc" echo "(hashes should match for released versions)" From 2acdd320ab754f756da72607b12d3ef60d24c016 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Mon, 14 Oct 2024 12:43:29 +0200 Subject: [PATCH 234/281] update to mirage 4.8 --- Dockerfile | 2 +- config.ml | 9 +-------- dispatcher.ml | 6 +++--- my_dns.ml | 16 +++++++++------- test/unikernel.ml | 2 +- unikernel.ml | 30 +++++++++++++++--------------- 6 files changed, 30 insertions(+), 35 deletions(-) diff --git a/Dockerfile b/Dockerfile index f33b6e5..165530f 100644 --- a/Dockerfile +++ b/Dockerfile @@ -23,7 +23,7 @@ ENV OPAMCONFIRMLEVEL=unsafe-yes # Remove this line (and the base image pin above) if you want to test with the # latest versions. # taken from https://github.com/ocaml/opam-repository -RUN opam init --disable-sandboxing -a --bare https://github.com/ocaml/opam-repository.git#13acffc3de9c22953d1e08bad3e56ee6e965eeed +RUN opam init --disable-sandboxing -a --bare https://github.com/ocaml/opam-repository.git#26c09ff1da6a07b20a0f9474e3a6ed6315c6388b RUN opam switch create myswitch 4.14.2 RUN opam exec -- opam install -y mirage opam-monorepo ocaml-solo5 RUN mkdir /tmp/orb-build diff --git a/config.ml b/config.ml index 74fa23f..808d4ec 100644 --- a/config.ml +++ b/config.ml @@ -1,4 +1,4 @@ -(* mirage >= 4.5.0 & < 5.0.0 *) +(* mirage >= 4.8.0 & < 5.0.0 *) (* Copyright (C) 2017, Thomas Leonard See the README file for details. *) @@ -6,15 +6,8 @@ open Mirage -let nat_table_size = runtime_arg ~pos:__POS__ "Unikernel.nat_table_size" -let ipv4 = runtime_arg ~pos:__POS__ "Unikernel.ipv4" -let ipv4_gw = runtime_arg ~pos:__POS__ "Unikernel.ipv4_gw" -let ipv4_dns = runtime_arg ~pos:__POS__ "Unikernel.ipv4_dns" -let ipv4_dns2 = runtime_arg ~pos:__POS__ "Unikernel.ipv4_dns2" - let main = main - ~runtime_args:[ nat_table_size; ipv4; ipv4_gw; ipv4_dns; ipv4_dns2; ] ~packages:[ package "vchan" ~min:"4.0.2"; package "cstruct"; diff --git a/dispatcher.ml b/dispatcher.ml index fc21cdd..3768863 100644 --- a/dispatcher.ml +++ b/dispatcher.ml @@ -9,7 +9,7 @@ let src = Logs.Src.create "dispatcher" ~doc:"Networking dispatch" module Log = (val Logs.src_log src : Logs.LOG) module Make - (R : Mirage_random.S) + (R : Mirage_crypto_rng_mirage.S) (Clock : Mirage_clock.MCLOCK) (Time : Mirage_time.S) = struct @@ -453,7 +453,7 @@ struct | Some uplink -> ( Lwt.catch (fun () -> - U.write ~src_port ~dst ~dst_port uplink.udp buf >|= function + U.write ~src_port ~dst ~dst_port uplink.udp (Cstruct.of_string buf) >|= function | Error s -> Log.err (fun f -> f "error sending udp packet: %a" U.pp_error s); Error (`Msg "failure") @@ -506,7 +506,7 @@ struct "found a DNS packet whose dst_port (%d) was in the list of \ dns_client ports" header.dst_port); - Lwt_mvar.put dns_responses (header, packet) + Lwt_mvar.put dns_responses (header, Cstruct.to_string packet) | _ -> ipv4_from_netvm router (`IPv4 (header, packet)) end end) diff --git a/my_dns.ml b/my_dns.ml index 849aa8d..cbfa763 100644 --- a/my_dns.ml +++ b/my_dns.ml @@ -1,10 +1,12 @@ open Lwt.Infix -module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) (Time : Mirage_time.S) = struct +module Transport (R : Mirage_crypto_rng_mirage.S) (C : Mirage_clock.MCLOCK) (Time : Mirage_time.S) = struct type +'a io = 'a Lwt.t type io_addr = Ipaddr.V4.t * int module Dispatcher = Dispatcher.Make(R)(C)(Time) - type stack = Dispatcher.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 + type stack = Dispatcher.t * + (src_port:int -> dst:Ipaddr.V4.t -> dst_port:int -> string -> (unit, [ `Msg of string ]) result Lwt.t) * + (Udp_packet.t * string) Lwt_mvar.t module IM = Map.Make(Int) @@ -13,7 +15,7 @@ module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) (Time : Mirage_ nameserver : io_addr ; stack : stack ; timeout_ns : int64 ; - mutable requests : Cstruct.t Lwt_condition.t IM.t ; + mutable requests : string Lwt_condition.t IM.t ; } type context = t @@ -24,8 +26,8 @@ module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) (Time : Mirage_ 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 + if String.length data > 2 then begin + match IM.find_opt (String.get_uint16_be data 0) t.requests with | Some cond -> Lwt_condition.broadcast cond data | None -> () end; @@ -48,13 +50,13 @@ module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) (Time : Mirage_ let connect (t : t) = Lwt.return (Ok (t.protocol, t)) - let send_recv (ctx : context) buf : (Cstruct.t, [> `Msg of string ]) result Lwt.t = + let send_recv (ctx : context) buf : (string, [> `Msg of string ]) result Lwt.t = let dst, dst_port = ctx.nameserver in let router, send_udp, _ = ctx.stack in let src_port, evict = My_nat.free_udp_port router.nat ~src:router.config.our_ip ~dst ~dst_port:53 in - let id = Cstruct.BE.get_uint16 buf 0 in + let id = String.get_uint16_be buf 0 in with_timeout ctx.timeout_ns (let cond = Lwt_condition.create () in ctx.requests <- IM.add id cond ctx.requests; diff --git a/test/unikernel.ml b/test/unikernel.ml index 9c347f3..04f7d6a 100644 --- a/test/unikernel.ml +++ b/test/unikernel.ml @@ -42,7 +42,7 @@ let netvm = "10.137.0.5" (* default "nameserver"s, which netvm redirects to whatever its real nameservers are *) let nameserver_1, nameserver_2 = "10.139.1.1", "10.139.1.2" -module Client (R: Mirage_random.S) (Time: Mirage_time.S) (Clock : Mirage_clock.MCLOCK) (NET: Mirage_net.S) (DB : Qubes.S.DB) = struct +module Client (R: Mirage_crypto_rng_mirage.S) (Time: Mirage_time.S) (Clock : Mirage_clock.MCLOCK) (NET: Mirage_net.S) (DB : Qubes.S.DB) = struct module E = Ethernet.Make(NET) module A = Arp.Make(E)(Time) module I = Qubesdb_ipv4.Make(DB)(R)(Clock)(E)(A) diff --git a/unikernel.ml b/unikernel.ml index b4e92c7..b64fd4e 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -10,25 +10,25 @@ module Log = (val Logs.src_log src : Logs.LOG) let nat_table_size = let doc = Arg.info ~doc:"The number of NAT entries to allocate." [ "nat-table-size" ] in - Arg.(value & opt int 5_000 doc) + Mirage_runtime.register_arg Arg.(value & opt int 5_000 doc) let ipv4 = let doc = Arg.info ~doc:"Manual IP setting." [ "ipv4" ] in - Arg.(value & opt string "0.0.0.0" doc) + Mirage_runtime.register_arg Arg.(value & opt string "0.0.0.0" doc) let ipv4_gw = let doc = Arg.info ~doc:"Manual Gateway IP setting." [ "ipv4-gw" ] in - Arg.(value & opt string "0.0.0.0" doc) + Mirage_runtime.register_arg Arg.(value & opt string "0.0.0.0" doc) let ipv4_dns = let doc = Arg.info ~doc:"Manual DNS IP setting." [ "ipv4-dns" ] in - Arg.(value & opt string "10.139.1.1" doc) + Mirage_runtime.register_arg Arg.(value & opt string "10.139.1.1" doc) let ipv4_dns2 = let doc = Arg.info ~doc:"Manual Second DNS IP setting." [ "ipv4-dns2" ] in - Arg.(value & opt string "10.139.1.2" doc) + Mirage_runtime.register_arg Arg.(value & opt string "10.139.1.2" doc) -module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_time.S) = struct +module Main (R : Mirage_crypto_rng_mirage.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_time.S) = struct module Dispatcher = Dispatcher.Make(R)(Clock)(Time) module Dns_transport = My_dns.Transport(R)(Clock)(Time) module Dns_client = Dns_client.Make(Dns_transport) @@ -45,7 +45,7 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_tim ] (* Main unikernel entry point (called from auto-generated main.ml). *) - let start _random _clock _time nat_table_size ipv4 ipv4_gw ipv4_dns ipv4_dns2 = + let start _random _clock _time = let start_time = Clock.elapsed_ns () in (* Start qrexec agent and QubesDB agent in parallel *) let qrexec = RExec.connect ~domid:0 () in @@ -66,15 +66,15 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_tim Xen_os.Lifecycle.await_shutdown_request () >>= fun (`Poweroff | `Reboot) -> Lwt.return_unit in (* Set up networking *) - let nat = My_nat.create ~max_entries:nat_table_size in + let nat = My_nat.create ~max_entries:(nat_table_size ()) in + + let netvm_ip = Ipaddr.V4.of_string_exn (ipv4_gw ()) in + let our_ip = Ipaddr.V4.of_string_exn (ipv4 ()) in + let dns = Ipaddr.V4.of_string_exn (ipv4_dns ()) in + let dns2 = Ipaddr.V4.of_string_exn (ipv4_dns2 ()) in + + let zero_ip = Ipaddr.V4.any in - let netvm_ip = Ipaddr.V4.of_string_exn ipv4_gw in - let our_ip = Ipaddr.V4.of_string_exn ipv4 in - let dns = Ipaddr.V4.of_string_exn ipv4_dns in - let dns2 = Ipaddr.V4.of_string_exn ipv4_dns2 in - - let zero_ip = (Ipaddr.V4.make 0 0 0 0) in - let network_config = if (netvm_ip = zero_ip && our_ip = zero_ip) then (* Read network configuration from QubesDB *) Dao.read_network_config qubesDB >>= fun config -> From b1886e308ca9016a1c3d5d21b412f7833826b75c Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Mon, 14 Oct 2024 12:54:42 +0200 Subject: [PATCH 235/281] update checksum --- build-with.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/build-with.sh b/build-with.sh index 7d698f0..c54d999 100755 --- a/build-with.sh +++ b/build-with.sh @@ -20,5 +20,5 @@ $builder build -t qubes-mirage-firewall . echo Building Firewall... $builder run --rm -i -v `pwd`:/tmp/orb-build:Z qubes-mirage-firewall echo "SHA2 of build: $(sha256sum ./dist/qubes-firewall.xen)" -echo "SHA2 last known: 5805e94755334af02fd4244b0b163c7a90fef9061d826e365db3be8adfe8abcc" +echo "SHA2 last known: 4b1f743bf4540bc8a9366cf8f23a78316e4f2d477af77962e50618753c4adf10" echo "(hashes should match for released versions)" From cf5cbc5e9014dd40be2a3ffa069504adbd1932cc Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Mon, 14 Oct 2024 17:10:11 +0200 Subject: [PATCH 236/281] restrict mirage upper bound --- config.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config.ml b/config.ml index 808d4ec..00ddc71 100644 --- a/config.ml +++ b/config.ml @@ -1,4 +1,4 @@ -(* mirage >= 4.8.0 & < 5.0.0 *) +(* mirage >= 4.8.0 & < 4.9.0 *) (* Copyright (C) 2017, Thomas Leonard See the README file for details. *) From c7d8751b1c800726ac7f8e7bdd69d1a521f0e0c2 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 22 May 2024 09:41:11 +0200 Subject: [PATCH 237/281] Use Lwt.Syntax and avoid some >>= fun () patterns --- dao.ml | 60 +++++++++++++++++++++++----------------------------- unikernel.ml | 11 ++++------ 2 files changed, 30 insertions(+), 41 deletions(-) diff --git a/dao.ml b/dao.ml index 2361630..78f0065 100644 --- a/dao.ml +++ b/dao.ml @@ -65,43 +65,35 @@ let read_rules rules client_ip = number = 0;})] let vifs client domid = + let open Lwt.Syntax in match int_of_string_opt 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 - Xen_os.Xs.immediate client (fun handle -> - directory ~handle path >>= - Lwt_list.filter_map_p (fun device_id -> - match int_of_string_opt 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.split_on_char ' ' 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 " " 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 path = Fmt.str "backend/vif/%d" domid in + let fn handle = + let* entries = directory ~handle path in + let fn device_id = match int_of_string_opt 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 + let fn () = + let* str = Xen_os.Xs.read handle (Fmt.str "%s/%d/ip" path device_id) in + let[@warning "-8"] client_ip :: _ = String.split_on_char ' ' str in + Lwt.return_some (vif, Ipaddr.V4.of_string_exn client_ip) in + Lwt.catch fn @@ function + | Xs_protocol.Enoent _ -> Lwt.return_none + | Ipaddr.Parse_error (msg, client_ip) -> + Log.err (fun f -> f "Error parsing IP address of %a from %s: %s" + ClientVif.pp vif client_ip msg); + Lwt.return_none + | exn -> + Log.err (fun f -> f "Error getting IP address of %a: %s" + ClientVif.pp vif (Printexc.to_string exn)); + Lwt.return_none in + Lwt_list.filter_map_p fn entries in + Xen_os.Xs.immediate client fn let watch_clients fn = Xen_os.Xs.make () >>= fun xs -> diff --git a/unikernel.ml b/unikernel.ml index b64fd4e..f0e12df 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -46,15 +46,12 @@ module Main (R : Mirage_crypto_rng_mirage.S)(Clock : Mirage_clock.MCLOCK)(Time : (* Main unikernel entry point (called from auto-generated main.ml). *) let start _random _clock _time = + let open Lwt.Syntax in let start_time = Clock.elapsed_ns () in (* Start qrexec agent and QubesDB agent in parallel *) - let qrexec = RExec.connect ~domid:0 () in - let qubesDB = DB.connect ~domid:0 () in - - (* Wait for clients to connect *) - qrexec >>= fun qrexec -> + let* qrexec = RExec.connect ~domid:0 () in let agent_listener = RExec.listen qrexec Command.handler in - qubesDB >>= fun qubesDB -> + let* qubesDB = DB.connect ~domid:0 () in let startup_time = let (-) = Int64.sub in let time_in_ns = Clock.elapsed_ns () - start_time in @@ -93,7 +90,7 @@ module Main (R : Mirage_crypto_rng_mirage.S)(Clock : Mirage_clock.MCLOCK)(Time : Dao.print_network_config config ; (* Set up client-side networking *) - Client_eth.create config >>= fun clients -> + let* clients = Client_eth.create config in (* Set up routing between networks and hosts *) let router = Dispatcher.create From 98506f5b1b28c8b65d5da9b368f587807400f67b Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 22 May 2024 11:37:19 +0200 Subject: [PATCH 238/281] Rename some generic fn functions to what they explicitly do --- dao.ml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/dao.ml b/dao.ml index 78f0065..0e48a21 100644 --- a/dao.ml +++ b/dao.ml @@ -70,19 +70,19 @@ let vifs client domid = | None -> Log.err (fun f -> f "Invalid domid %S" domid); Lwt.return [] | Some domid -> let path = Fmt.str "backend/vif/%d" domid in - let fn handle = - let* entries = directory ~handle path in - let fn device_id = match int_of_string_opt device_id with + let vifs_of_domain handle = + let* devices = directory ~handle path in + let ip_of_vif device_id = match int_of_string_opt 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 - let fn () = + let get_client_ip () = let* str = Xen_os.Xs.read handle (Fmt.str "%s/%d/ip" path device_id) in let[@warning "-8"] client_ip :: _ = String.split_on_char ' ' str in Lwt.return_some (vif, Ipaddr.V4.of_string_exn client_ip) in - Lwt.catch fn @@ function + Lwt.catch get_client_ip @@ function | Xs_protocol.Enoent _ -> Lwt.return_none | Ipaddr.Parse_error (msg, client_ip) -> Log.err (fun f -> f "Error parsing IP address of %a from %s: %s" @@ -92,8 +92,8 @@ let vifs client domid = Log.err (fun f -> f "Error getting IP address of %a: %s" ClientVif.pp vif (Printexc.to_string exn)); Lwt.return_none in - Lwt_list.filter_map_p fn entries in - Xen_os.Xs.immediate client fn + Lwt_list.filter_map_p ip_of_vif devices in + Xen_os.Xs.immediate client vifs_of_domain let watch_clients fn = Xen_os.Xs.make () >>= fun xs -> From e179ee36b3d33fd3286ec0401202873a31c5b480 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 22 May 2024 11:39:37 +0200 Subject: [PATCH 239/281] Use List.hd instead of [@warning "-8"] --- dao.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dao.ml b/dao.ml index 0e48a21..f008d57 100644 --- a/dao.ml +++ b/dao.ml @@ -80,7 +80,7 @@ let vifs client domid = let vif = { ClientVif.domid; device_id } in let get_client_ip () = let* str = Xen_os.Xs.read handle (Fmt.str "%s/%d/ip" path device_id) in - let[@warning "-8"] client_ip :: _ = String.split_on_char ' ' str in + let client_ip = List.hd (String.split_on_char ' ' str) in Lwt.return_some (vif, Ipaddr.V4.of_string_exn client_ip) in Lwt.catch get_client_ip @@ function | Xs_protocol.Enoent _ -> Lwt.return_none From ad1afe99eeda8d7f7ca799e6fa1b891a40a60122 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 22 May 2024 11:40:08 +0200 Subject: [PATCH 240/281] Break the line before the 'in' for a multi-line 'let ... in' --- dao.ml | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/dao.ml b/dao.ml index f008d57..3e57781 100644 --- a/dao.ml +++ b/dao.ml @@ -81,7 +81,8 @@ let vifs client domid = let get_client_ip () = let* str = Xen_os.Xs.read handle (Fmt.str "%s/%d/ip" path device_id) in let client_ip = List.hd (String.split_on_char ' ' str) in - Lwt.return_some (vif, Ipaddr.V4.of_string_exn client_ip) in + Lwt.return_some (vif, Ipaddr.V4.of_string_exn client_ip) + in Lwt.catch get_client_ip @@ function | Xs_protocol.Enoent _ -> Lwt.return_none | Ipaddr.Parse_error (msg, client_ip) -> @@ -91,8 +92,10 @@ let vifs client domid = | exn -> Log.err (fun f -> f "Error getting IP address of %a: %s" ClientVif.pp vif (Printexc.to_string exn)); - Lwt.return_none in - Lwt_list.filter_map_p ip_of_vif devices in + Lwt.return_none + in + Lwt_list.filter_map_p ip_of_vif devices + in Xen_os.Xs.immediate client vifs_of_domain let watch_clients fn = From 3dc545681de71e5df436761ad301a5770d1e5b4b Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 22 May 2024 11:47:10 +0200 Subject: [PATCH 241/281] Add a comment about our usage of List.hd (which can fail) and String.split_on_char --- dao.ml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/dao.ml b/dao.ml index 3e57781..2e94660 100644 --- a/dao.ml +++ b/dao.ml @@ -81,6 +81,8 @@ let vifs client domid = let get_client_ip () = let* str = Xen_os.Xs.read handle (Fmt.str "%s/%d/ip" path device_id) in let client_ip = List.hd (String.split_on_char ' ' str) in + (* XXX(dinosaure): it's safe to use [List.hd] here, + [String.split_on_char] can not return an empty list. *) Lwt.return_some (vif, Ipaddr.V4.of_string_exn client_ip) in Lwt.catch get_client_ip @@ function From a7cb153ee17246dc850f01b96121d868621df520 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 22 May 2024 11:54:07 +0200 Subject: [PATCH 242/281] Use Ipaddr.V4.Map instead of our own IpMap (the first is available since ipaddr.5.2.0) --- client_eth.ml | 16 ++++++++-------- fw_utils.ml | 8 -------- 2 files changed, 8 insertions(+), 16 deletions(-) diff --git a/client_eth.ml b/client_eth.ml index de41f70..fc0b01a 100644 --- a/client_eth.ml +++ b/client_eth.ml @@ -8,7 +8,7 @@ let src = Logs.Src.create "client_eth" ~doc:"Ethernet networks for NetVM clients module Log = (val Logs.src_log src : Logs.LOG) type t = { - mutable iface_of_ip : client_link IpMap.t; + mutable iface_of_ip : client_link Ipaddr.V4.Map.t; changed : unit Lwt_condition.t; (* Fires when [iface_of_ip] changes. *) my_ip : Ipaddr.V4.t; (* The IP that clients are given as their default gateway. *) } @@ -21,21 +21,21 @@ type host = let create config = let changed = Lwt_condition.create () in let my_ip = config.Dao.our_ip in - Lwt.return { iface_of_ip = IpMap.empty; my_ip; changed } + Lwt.return { iface_of_ip = Ipaddr.V4.Map.empty; my_ip; changed } let client_gw t = t.my_ip let add_client t iface = let ip = iface#other_ip in let rec aux () = - match IpMap.find ip t.iface_of_ip with + match Ipaddr.V4.Map.find_opt ip t.iface_of_ip with | Some old -> (* Wait for old client to disappear before adding one with the same IP address. Otherwise, its [remove_client] call will remove the new client instead. *) Log.info (fun f -> f ~header:iface#log_header "Waiting for old client %s to go away before accepting new one" old#log_header); Lwt_condition.wait t.changed >>= aux | None -> - t.iface_of_ip <- t.iface_of_ip |> IpMap.add ip iface; + t.iface_of_ip <- t.iface_of_ip |> Ipaddr.V4.Map.add ip iface; Lwt_condition.broadcast t.changed (); Lwt.return_unit in @@ -43,11 +43,11 @@ let add_client t iface = let remove_client t iface = let ip = iface#other_ip in - assert (IpMap.mem ip t.iface_of_ip); - t.iface_of_ip <- t.iface_of_ip |> IpMap.remove ip; + assert (Ipaddr.V4.Map.mem ip t.iface_of_ip); + t.iface_of_ip <- t.iface_of_ip |> Ipaddr.V4.Map.remove ip; Lwt_condition.broadcast t.changed () -let lookup t ip = IpMap.find ip t.iface_of_ip +let lookup t ip = Ipaddr.V4.Map.find_opt ip t.iface_of_ip let classify t ip = match ip with @@ -79,7 +79,7 @@ module ARP = struct (* We're now treating client networks as point-to-point links, so we no longer respond on behalf of other clients. *) (* - else match IpMap.find ip t.net.iface_of_ip with + else match Ipaddr.V4.Map.find_opt ip t.net.iface_of_ip with | Some client_iface -> Some client_iface#other_mac | None -> None *) diff --git a/fw_utils.ml b/fw_utils.ml index 0307810..f20c63a 100644 --- a/fw_utils.ml +++ b/fw_utils.ml @@ -3,14 +3,6 @@ (** General utility functions. *) -module IpMap = struct - include Map.Make(Ipaddr.V4) - let find x map = - try Some (find x map) - with Not_found -> None - | _ -> Logs.err( fun f -> f "uncaught exception in find...%!"); None -end - (** An Ethernet interface. *) class type interface = object method my_mac : Macaddr.t From 12ed2b268dbf672a4771bc3b04c133a3ea9a79c4 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 22 May 2024 16:05:29 +0200 Subject: [PATCH 243/281] Replace the Lwt.async into the right context and localize the global clients map We currently try to spawn 2 fibers [qubes_updated] and [listener] per clients and we already finalise them correctly if the client is disconnected. However, the Lwt.async is localized into add_client instead of where we attach a finalisers for these tasks. The first objective of this patch is to be sure that the Lwt.async is near where we registerd cancellation of these tasks. The second part is to localize the global clients to avoid the ability to read/write on it somewhere else. Only Dispatcher.watch_clients uses it - so it corresponds to a free variable of the Dispatcher.watch_clients closure. --- dao.ml | 2 +- dao.mli | 2 +- dispatcher.ml | 77 ++++++++++++++++++++++++++++----------------------- 3 files changed, 44 insertions(+), 37 deletions(-) diff --git a/dao.ml b/dao.ml index 2e94660..27b8bda 100644 --- a/dao.ml +++ b/dao.ml @@ -113,7 +113,7 @@ let watch_clients fn = end >>= fun items -> Xen_os.Xs.make () >>= fun xs -> Lwt_list.map_p (vifs xs) items >>= fun items -> - fn (List.concat items |> VifMap.of_list); + fn (List.concat items |> VifMap.of_list) >>= fun () -> (* Wait for further updates *) Lwt.fail Xs_protocol.Eagain ) diff --git a/dao.mli b/dao.mli index bff4cbf..c278d16 100644 --- a/dao.mli +++ b/dao.mli @@ -15,7 +15,7 @@ module VifMap : sig val find : key -> 'a t -> 'a option end -val watch_clients : (Ipaddr.V4.t VifMap.t -> unit) -> 'a Lwt.t +val watch_clients : (Ipaddr.V4.t VifMap.t -> unit Lwt.t) -> 'a Lwt.t (** [watch_clients fn] calls [fn clients] with the list of backend clients in XenStore, and again each time XenStore updates. *) diff --git a/dispatcher.ml b/dispatcher.ml index 3768863..9ffcc5b 100644 --- a/dispatcher.ml +++ b/dispatcher.ml @@ -17,8 +17,6 @@ struct module I = Static_ipv4.Make (R) (Clock) (UplinkEth) (Arp) module U = Udp.Make (I) (R) - let clients : Cleanup.t Dao.VifMap.t ref = ref Dao.VifMap.empty - class client_iface eth ~domid ~gateway_ip ~client_ip client_mac : client_link = let log_header = Fmt.str "dom%d:%a" domid Ipaddr.V4.pp client_ip in @@ -344,11 +342,12 @@ struct (** 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 dns_servers - ~client_ip ~router ~cleanup_tasks qubesDB = - Netback.make ~domid ~device_id >>= fun backend -> + ~client_ip ~router ~cleanup_tasks qubesDB () = + let open Lwt.Syntax in + let* backend = Netback.make ~domid ~device_id in Log.info (fun f -> f "Client %d (IP: %s) ready" domid (Ipaddr.V4.to_string client_ip)); - ClientEth.connect backend >>= fun eth -> + let* eth = ClientEth.connect backend in let client_mac = Netback.frontend_mac backend in let client_eth = router.clients in let gateway_ip = Client_eth.client_gw client_eth in @@ -404,46 +403,54 @@ struct (function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e) in Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel listener); - Lwt.pick [ qubesdb_updater; listener ] + (* XXX(dinosaure): [qubes_updater] and [listener] can be forgotten, our [cleanup_task] + will cancel them if the client is disconnected. *) + Lwt.async (fun () -> Lwt.pick [ qubesdb_updater; listener ]); + Lwt.return_unit (** A new client VM has been found in XenStore. Find its interface and connect to it. *) let add_client get_ts dns_client dns_servers ~router vif client_ip qubesDB = + let open Lwt.Syntax in 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 dns_servers ~client_ip ~router - ~cleanup_tasks qubesDB) - (fun ex -> - Log.warn (fun f -> - f "Error with client %a: %s" Dao.ClientVif.pp vif - (Printexc.to_string ex)); - Lwt.return_unit)); - cleanup_tasks + let* () = + Lwt.catch (add_vif get_ts vif dns_client dns_servers ~client_ip ~router + ~cleanup_tasks qubesDB) + @@ fun exn -> + Log.warn (fun f -> + f "Error with client %a: %s" Dao.ClientVif.pp vif + (Printexc.to_string exn)); + Lwt.return_unit + in + Lwt.return cleanup_tasks (** Watch XenStore for notifications of new clients. *) let wait_clients 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 -> - if not (Dao.VifMap.mem key new_set) then ( - clients := !clients |> Dao.VifMap.remove key; - Log.info (fun f -> f "client %a has gone" Dao.ClientVif.pp key); - Cleanup.cleanup cleanup)); - (* 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 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))) + let open Lwt.Syntax in + let clients : Cleanup.t Dao.VifMap.t ref = ref Dao.VifMap.empty in + Dao.watch_clients @@ fun new_set -> + (* Check for removed clients *) + let clean_up_clients key cleanup = + if not (Dao.VifMap.mem key new_set) then begin + clients := !clients |> Dao.VifMap.remove key; + Log.info (fun f -> f "client %a has gone" Dao.ClientVif.pp key); + Cleanup.cleanup cleanup + end + in + Dao.VifMap.iter clean_up_clients !clients; + (* Check for added clients *) + let rec go seq = match Seq.uncons seq with + | None -> Lwt.return_unit + | Some ((key, ipaddr), seq) when not (Dao.VifMap.mem key !clients) -> + let* cleanup = add_client get_ts dns_client dns_servers ~router key ipaddr qubesDB in + Log.debug (fun f -> f "client %a arrived" Dao.ClientVif.pp key); + clients := Dao.VifMap.add key cleanup !clients; + go seq + | Some (_, seq) -> go seq + in + go (Dao.VifMap.to_seq new_set) let send_dns_client_query t ~src_port ~dst ~dst_port buf = match t.uplink with From 9156d580df8487d8a18a679797a8ee5850828c53 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 15 Oct 2024 21:37:50 +0200 Subject: [PATCH 244/281] cleanup whitespace --- dispatcher.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dispatcher.ml b/dispatcher.ml index 9ffcc5b..9dd374e 100644 --- a/dispatcher.ml +++ b/dispatcher.ml @@ -447,7 +447,7 @@ struct let* cleanup = add_client get_ts dns_client dns_servers ~router key ipaddr qubesDB in Log.debug (fun f -> f "client %a arrived" Dao.ClientVif.pp key); clients := Dao.VifMap.add key cleanup !clients; - go seq + go seq | Some (_, seq) -> go seq in go (Dao.VifMap.to_seq new_set) From ceb712ec60c621453a042045d57fa72ed9217b98 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 15 Oct 2024 21:39:35 +0200 Subject: [PATCH 245/281] minor: reword XXX to NOTE --- dao.ml | 2 +- dispatcher.ml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/dao.ml b/dao.ml index 27b8bda..9344c1f 100644 --- a/dao.ml +++ b/dao.ml @@ -81,7 +81,7 @@ let vifs client domid = let get_client_ip () = let* str = Xen_os.Xs.read handle (Fmt.str "%s/%d/ip" path device_id) in let client_ip = List.hd (String.split_on_char ' ' str) in - (* XXX(dinosaure): it's safe to use [List.hd] here, + (* NOTE(dinosaure): it's safe to use [List.hd] here, [String.split_on_char] can not return an empty list. *) Lwt.return_some (vif, Ipaddr.V4.of_string_exn client_ip) in diff --git a/dispatcher.ml b/dispatcher.ml index 9dd374e..60927f6 100644 --- a/dispatcher.ml +++ b/dispatcher.ml @@ -403,7 +403,7 @@ struct (function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e) in Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel listener); - (* XXX(dinosaure): [qubes_updater] and [listener] can be forgotten, our [cleanup_task] + (* NOTE(dinosaure): [qubes_updater] and [listener] can be forgotten, our [cleanup_task] will cancel them if the client is disconnected. *) Lwt.async (fun () -> Lwt.pick [ qubesdb_updater; listener ]); Lwt.return_unit From e2a0b333520a86eef91673588de114770494a1ca Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 15 Oct 2024 21:44:31 +0200 Subject: [PATCH 246/281] use a newer opam, 2.2.1, instead of 2.1.5 --- Dockerfile | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Dockerfile b/Dockerfile index 165530f..2cecb45 100644 --- a/Dockerfile +++ b/Dockerfile @@ -12,10 +12,10 @@ RUN printf "deb [check-valid-until=no] http://snapshot.debian.org/archive/debian RUN printf "deb [check-valid-until=no] http://snapshot.debian.org/archive/debian-security/20240419T111010Z bookworm-security main\n" >> /etc/apt/sources.list RUN apt update && apt install --no-install-recommends --no-install-suggests -y wget ca-certificates git patch unzip bzip2 make gcc g++ libc-dev -RUN wget -O /usr/bin/opam https://github.com/ocaml/opam/releases/download/2.1.5/opam-2.1.5-i686-linux && chmod 755 /usr/bin/opam +RUN wget -O /usr/bin/opam https://github.com/ocaml/opam/releases/download/2.2.1/opam-2.2.1-i686-linux && chmod 755 /usr/bin/opam # taken from https://raw.githubusercontent.com/ocaml/opam/master/shell/install.sh RUN test `sha512sum /usr/bin/opam | cut -d' ' -f1` = \ -"38802b3079eeceb27aab3465bfd0f9f05a710dccf9487eb35fa2c02fbaf9a0659e1447aa19dd36df9cd01f760229de28c523c08c1c86a3aa3f5e25dbe7b551dd" || exit +"bf16d573137835ce9abbcf6b99cb94a1da69ab58804a4de7c90233f0b354d5e68e9c47ee16670ca9d59866d58c7db345d9723e6eb5fc3a1cb8dca371f0e90225" || exit ENV OPAMROOT=/tmp ENV OPAMCONFIRMLEVEL=unsafe-yes From 3bb13f4c2115809c85ce355f9854f0810c2fe886 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 15 Oct 2024 21:48:14 +0200 Subject: [PATCH 247/281] update opam repository commit to use solo5 0.9 and mirage 4.8.1 --- Dockerfile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Dockerfile b/Dockerfile index 165530f..c693045 100644 --- a/Dockerfile +++ b/Dockerfile @@ -23,7 +23,7 @@ ENV OPAMCONFIRMLEVEL=unsafe-yes # Remove this line (and the base image pin above) if you want to test with the # latest versions. # taken from https://github.com/ocaml/opam-repository -RUN opam init --disable-sandboxing -a --bare https://github.com/ocaml/opam-repository.git#26c09ff1da6a07b20a0f9474e3a6ed6315c6388b +RUN opam init --disable-sandboxing -a --bare https://github.com/ocaml/opam-repository.git#5d3f0d1d655199e596a1e785e69fae8fad78cad3 RUN opam switch create myswitch 4.14.2 RUN opam exec -- opam install -y mirage opam-monorepo ocaml-solo5 RUN mkdir /tmp/orb-build From 1406855a9e901aa4a71a5ba0a333e5368a33a970 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 15 Oct 2024 21:49:57 +0200 Subject: [PATCH 248/281] update checksum --- build-with.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/build-with.sh b/build-with.sh index c54d999..5252f23 100755 --- a/build-with.sh +++ b/build-with.sh @@ -20,5 +20,5 @@ $builder build -t qubes-mirage-firewall . echo Building Firewall... $builder run --rm -i -v `pwd`:/tmp/orb-build:Z qubes-mirage-firewall echo "SHA2 of build: $(sha256sum ./dist/qubes-firewall.xen)" -echo "SHA2 last known: 4b1f743bf4540bc8a9366cf8f23a78316e4f2d477af77962e50618753c4adf10" +echo "SHA2 last known: 2392386d9056b17a648f26b0c5d1c72b93f8a197964c670b2b45e71707727317" echo "(hashes should match for released versions)" From fc75cce37cc1a84381f9a55328f7384571f7677a Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Wed, 16 Oct 2024 14:51:38 +0200 Subject: [PATCH 249/281] update shasum --- build-with.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/build-with.sh b/build-with.sh index 5252f23..eba233e 100755 --- a/build-with.sh +++ b/build-with.sh @@ -20,5 +20,5 @@ $builder build -t qubes-mirage-firewall . echo Building Firewall... $builder run --rm -i -v `pwd`:/tmp/orb-build:Z qubes-mirage-firewall echo "SHA2 of build: $(sha256sum ./dist/qubes-firewall.xen)" -echo "SHA2 last known: 2392386d9056b17a648f26b0c5d1c72b93f8a197964c670b2b45e71707727317" +echo "SHA2 last known: 78a1ee52574b9a4fc5eda265922bcbcface90f7c43ed7a68dc8e201a2ac0a7dc" echo "(hashes should match for released versions)" From c738753045d5df9dec862b0f714b991a24f1254b Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Thu, 17 Oct 2024 07:30:20 +0200 Subject: [PATCH 250/281] update CHANGES --- CHANGES.md | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index 1e6224f..dac6405 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,9 @@ +### 0.9.2 (2024-10-16) + +- Code refactoring and improvements (#197, @dinosaure) +- Build tooling updates: opam 2.2.1, solo5 0.9, mirage 4.8.1 (#199, #201, #202, + #203, @hannesm) + ### 0.9.1 (2024-05-10) - Drop astring dependency, update mirage-net-xen, and OCaml 4.14.2 -- the From de9a6ccc86c525a3dbe290f2f5984e18af7e97d5 Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Thu, 17 Oct 2024 07:45:42 +0200 Subject: [PATCH 251/281] WIP: update the salt script + releases files --- .github/workflows/docker.yml | 2 +- .github/workflows/podman.yml | 2 +- Dockerfile | 2 +- Makefile.user | 11 +++-------- ...DownloadAndInstallMirageFirewallInQubes.sls | 18 ++++++++++-------- build-with.sh | 7 ++++--- qubes-firewall-release.sha256 | 1 + qubes-firewall.sha256 | 1 + 8 files changed, 22 insertions(+), 22 deletions(-) create mode 100644 qubes-firewall-release.sha256 create mode 100644 qubes-firewall.sha256 diff --git a/.github/workflows/docker.yml b/.github/workflows/docker.yml index 53b3324..fdf17d7 100644 --- a/.github/workflows/docker.yml +++ b/.github/workflows/docker.yml @@ -23,7 +23,7 @@ jobs: - run: ./build-with.sh docker - - run: sh -exc 'if [ $(sha256sum dist/qubes-firewall.xen | cut -d " " -f 1) = $(grep "SHA2 last known" build-with.sh | rev | cut -d ":" -f 1 | rev | cut -d "\"" -f 1 | tr -d " ") ]; then echo "SHA256 MATCHES"; else exit 42; fi' + - run: sh -exc 'if [ $(sha256sum dist/qubes-firewall.xen) = $(cat qubes-firewall.sha256) ]; then echo "SHA256 MATCHES"; else exit 42; fi' - name: Upload Artifact uses: actions/upload-artifact@v3 diff --git a/.github/workflows/podman.yml b/.github/workflows/podman.yml index fba19eb..f8f8c3f 100644 --- a/.github/workflows/podman.yml +++ b/.github/workflows/podman.yml @@ -23,7 +23,7 @@ jobs: - run: ./build-with.sh podman - - run: sh -exc 'if [ $(sha256sum dist/qubes-firewall.xen | cut -d " " -f 1) = $(grep "SHA2 last known" build-with.sh | rev | cut -d ":" -f 1 | rev | cut -d "\"" -f 1 | tr -d " ") ]; then echo "SHA256 MATCHES"; else exit 42; fi' + - run: sh -exc 'if [ $(sha256sum dist/qubes-firewall.xen) = $(cat qubes-firewall.sha256) ]; then echo "SHA256 MATCHES"; else exit 42; fi' - name: Upload Artifact uses: actions/upload-artifact@v3 diff --git a/Dockerfile b/Dockerfile index 2c2f732..edf9e96 100644 --- a/Dockerfile +++ b/Dockerfile @@ -32,4 +32,4 @@ WORKDIR /tmp/orb-build CMD opam exec -- sh -exc 'mirage configure -t xen --extra-repos=\ opam-overlays:https://github.com/dune-universe/opam-overlays.git#4e75ee36715b27550d5bdb87686bb4ae4c9e89c4,\ mirage-overlays:https://github.com/dune-universe/mirage-opam-overlays.git#797cb363df3ff763c43c8fbec5cd44de2878757e \ -&& make depend && make tar' +&& make depend && make unikernel' diff --git a/Makefile.user b/Makefile.user index 00890f6..7188982 100644 --- a/Makefile.user +++ b/Makefile.user @@ -1,13 +1,8 @@ -tar: build - rm -rf _build/mirage-firewall - mkdir _build/mirage-firewall +unikernel: build cp dist/qubes-firewall.xen dist/qubes-firewall.xen.debug strip dist/qubes-firewall.xen - cp dist/qubes-firewall.xen _build/mirage-firewall/vmlinuz - touch _build/mirage-firewall/modules.img - cat /dev/null | gzip -n > _build/mirage-firewall/initramfs - tar cjf mirage-firewall.tar.bz2 -C _build --mtime=./build-with.sh mirage-firewall - sha256sum mirage-firewall.tar.bz2 > mirage-firewall.sha256 + cp dist/qubes-firewall.xen . + sha256sum qubes-firewall.xen fetchmotron: qubes_firewall.xen test-mirage qubes_firewall.xen mirage-fw-test & diff --git a/SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls b/SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls index dc83f20..cfb4a0e 100644 --- a/SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls +++ b/SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls @@ -10,7 +10,8 @@ {% set DownloadVM = "DownloadVmMirage" %} {% set MirageFW = "sys-mirage-fw" %} {% set GithubUrl = "https://github.com/mirage/qubes-mirage-firewall" %} -{% set Filename = "mirage-firewall.tar.bz2" %} +{% set Kernel = "qubes-firewall.xen" %} +{% set Shasum = "qubes-firewall-release.sha256" %} {% set MirageInstallDir = "/var/lib/qubes/vm-kernels/mirage-firewall" %} #download and install the latest version @@ -28,13 +29,14 @@ create-downloader-VM: - template: {{ DownloadVMTemplate }} - include-in-backups: false -{% set DownloadBinary = GithubUrl ~ "/releases/download/" ~ Release ~ "/" ~ Filename %} +{% set DownloadBinary = GithubUrl ~ "/releases/download/" ~ Release ~ "/" ~ Kernel %} +{% set DownloadShasum = GithubUrl ~ "/releases/download/" ~ Release ~ "/" ~ Shasum %} download-and-unpack-in-DownloadVM4mirage: cmd.run: - names: - qvm-run --pass-io {{ DownloadVM }} {{ "curl -L -O " ~ DownloadBinary }} - - qvm-run --pass-io {{ DownloadVM }} {{ "tar -xvjf " ~ Filename }} + - qvm-run --pass-io {{ DownloadVM }} {{ "curl -L -O " ~ DownloadShasum }} - require: - create-downloader-VM @@ -42,15 +44,15 @@ download-and-unpack-in-DownloadVM4mirage: check-checksum-in-DownloadVM: cmd.run: - names: - - qvm-run --pass-io {{ DownloadVM }} {{ "\"echo \\\"Checksum of last build on github:\\\";curl -s https://raw.githubusercontent.com/mirage/qubes-mirage-firewall/main/build-with.sh | grep \\\"SHA2 last known:\\\" | cut -d\' \' -f5 | tr -d \\\\\\\"\"" }} - - qvm-run --pass-io {{ DownloadVM }} {{ "\"echo \\\"Checksum of downloaded local file:\\\";sha256sum ~/mirage-firewall/vmlinuz | cut -d\' \' -f1\"" }} - - qvm-run --pass-io {{ DownloadVM }} {{ "\"diff <(curl -s https://raw.githubusercontent.com/mirage/qubes-mirage-firewall/main/build-with.sh | grep \\\"SHA2 last known:\\\" | cut -d\' \' -f5 | tr -d \\\\\\\") <(sha256sum ~/mirage-firewall/vmlinuz | cut -d\' \' -f1) && echo \\\"Checksums DO match.\\\" || (echo \\\"Checksums do NOT match.\\\";exit 101)\"" }} #~/mirage-firewall/modules.img + - qvm-run --pass-io {{ DownloadVM }} {{ "\"echo \\\"Checksum of release on github:\\\";cat " ~ Shasum ~ " | cut -d\' \' -f1\"" }} + - qvm-run --pass-io {{ DownloadVM }} {{ "\"echo \\\"Checksum of downloaded local file:\\\";sha256sum " ~ Kernel ~ " | cut -d\' \' -f1\"" }} + - qvm-run --pass-io {{ DownloadVM }} {{ "\"diff <(cat " ~ Shasum ~ " | cut -d\' \' -f1) <(sha256sum " ~ Kernel ~ " | cut -d\' \' -f1) && echo \\\"Checksums DO match.\\\" || (echo \\\"Checksums do NOT match.\\\";exit 101)\"" }} - require: - download-and-unpack-in-DownloadVM4mirage copy-mirage-kernel-to-dom0: cmd.run: - - name: mkdir -p {{ MirageInstallDir }}; qvm-run --pass-io --no-gui {{ DownloadVM }} "cat ~/mirage-firewall/vmlinuz" > {{ MirageInstallDir ~ "/vmlinuz" }} + - name: mkdir -p {{ MirageInstallDir }}; qvm-run --pass-io --no-gui {{ DownloadVM }} "cat " ~ Kernel > {{ MirageInstallDir ~ "/" ~ Kernel }} - require: - download-and-unpack-in-DownloadVM4mirage - check-checksum-in-DownloadVM @@ -90,7 +92,7 @@ create-sys-mirage-fw: cleanup-in-DownloadVM: cmd.run: - names: - - qvm-run -a --pass-io --no-gui {{ DownloadVM }} "{{ "rm " ~ Filename ~ "; rm -R ~/mirage-firewall" }}" + - qvm-run -a --pass-io --no-gui {{ DownloadVM }} "{{ "rm " ~ Kernel ~ " " ~ Shasum }}" - require: - create-initramfs diff --git a/build-with.sh b/build-with.sh index eba233e..728ab1f 100755 --- a/build-with.sh +++ b/build-with.sh @@ -19,6 +19,7 @@ echo Building $builder image with dependencies.. $builder build -t qubes-mirage-firewall . echo Building Firewall... $builder run --rm -i -v `pwd`:/tmp/orb-build:Z qubes-mirage-firewall -echo "SHA2 of build: $(sha256sum ./dist/qubes-firewall.xen)" -echo "SHA2 last known: 78a1ee52574b9a4fc5eda265922bcbcface90f7c43ed7a68dc8e201a2ac0a7dc" -echo "(hashes should match for released versions)" +echo "SHA2 of build: $(sha256sum ./dist/qubes-firewall.xen | cut -d' ' -f1)" +echo "SHA2 current head: $(cat qubes-firewall.sha256 | cut -d' ' -f1)" +echo "SHA2 last release: $(cat qubes-firewall-release.sha256 | cut -d' ' -f1)" +echo "(hashes should match for head versions)" diff --git a/qubes-firewall-release.sha256 b/qubes-firewall-release.sha256 new file mode 100644 index 0000000..b89e36f --- /dev/null +++ b/qubes-firewall-release.sha256 @@ -0,0 +1 @@ +78a1ee52574b9a4fc5eda265922bcbcface90f7c43ed7a68dc8e201a2ac0a7dc dist/qubes-firewall.xen diff --git a/qubes-firewall.sha256 b/qubes-firewall.sha256 new file mode 100644 index 0000000..b89e36f --- /dev/null +++ b/qubes-firewall.sha256 @@ -0,0 +1 @@ +78a1ee52574b9a4fc5eda265922bcbcface90f7c43ed7a68dc8e201a2ac0a7dc dist/qubes-firewall.xen From 887f2d524c5c9843487b921cf769ee5c746e01b0 Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Thu, 17 Oct 2024 08:09:35 +0200 Subject: [PATCH 252/281] fix string comparison in github actions --- .github/workflows/docker.yml | 2 +- .github/workflows/podman.yml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/docker.yml b/.github/workflows/docker.yml index fdf17d7..4b18223 100644 --- a/.github/workflows/docker.yml +++ b/.github/workflows/docker.yml @@ -23,7 +23,7 @@ jobs: - run: ./build-with.sh docker - - run: sh -exc 'if [ $(sha256sum dist/qubes-firewall.xen) = $(cat qubes-firewall.sha256) ]; then echo "SHA256 MATCHES"; else exit 42; fi' + - run: sh -exc 'if [ "$(sha256sum dist/qubes-firewall.xen)" = "$(cat qubes-firewall.sha256)" ]; then echo "SHA256 MATCHES"; else exit 42; fi' - name: Upload Artifact uses: actions/upload-artifact@v3 diff --git a/.github/workflows/podman.yml b/.github/workflows/podman.yml index f8f8c3f..6f6b8f5 100644 --- a/.github/workflows/podman.yml +++ b/.github/workflows/podman.yml @@ -23,7 +23,7 @@ jobs: - run: ./build-with.sh podman - - run: sh -exc 'if [ $(sha256sum dist/qubes-firewall.xen) = $(cat qubes-firewall.sha256) ]; then echo "SHA256 MATCHES"; else exit 42; fi' + - run: sh -exc 'if [ "$(sha256sum dist/qubes-firewall.xen)" = "$(cat qubes-firewall.sha256)" ]; then echo "SHA256 MATCHES"; else exit 42; fi' - name: Upload Artifact uses: actions/upload-artifact@v3 From e7eb1f2e3b2d5fd707d0893aae0feccf653c6b70 Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Thu, 17 Oct 2024 08:21:49 +0200 Subject: [PATCH 253/281] fix artifact uploads --- .github/workflows/docker.yml | 4 ++-- .github/workflows/podman.yml | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/.github/workflows/docker.yml b/.github/workflows/docker.yml index 4b18223..1f1dcda 100644 --- a/.github/workflows/docker.yml +++ b/.github/workflows/docker.yml @@ -28,5 +28,5 @@ jobs: - name: Upload Artifact uses: actions/upload-artifact@v3 with: - name: mirage-firewall.tar.bz2 - path: mirage-firewall.tar.bz2 + name: qubes-firewall.xen + path: qubes-firewall.xen diff --git a/.github/workflows/podman.yml b/.github/workflows/podman.yml index 6f6b8f5..0fdab2a 100644 --- a/.github/workflows/podman.yml +++ b/.github/workflows/podman.yml @@ -28,5 +28,5 @@ jobs: - name: Upload Artifact uses: actions/upload-artifact@v3 with: - name: mirage-firewall.tar.bz2 - path: mirage-firewall.tar.bz2 + name: qubes-firewall.xen + path: qubes-firewall.xen From 493608111256569f1485d1c947bf5a78de5cbd70 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Thu, 17 Oct 2024 13:14:53 +0200 Subject: [PATCH 254/281] add a LICENSE file (ISC) --- LICENSE.md | 15 +++++++++++++++ 1 file changed, 15 insertions(+) create mode 100644 LICENSE.md diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 index 0000000..ff93dbd --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,15 @@ +ISC License + +Copyright (X) 2015-2024, the Qubes Mirage Firewall authors + +Permission to use, copy, modify, and distribute this software for any +purpose with or without fee is hereby granted, provided that the above +copyright notice and this permission notice appear in all copies. + +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF +OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. From 07f05f14085542c9da71ea228ce53f2f8f1b0d1c Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Thu, 17 Oct 2024 13:56:28 +0200 Subject: [PATCH 255/281] use a BSD 2 clause license remove the LICENSE section from the README --- LICENSE.md | 32 ++++++++++++++++++++------------ README.md | 13 ------------- 2 files changed, 20 insertions(+), 25 deletions(-) diff --git a/LICENSE.md b/LICENSE.md index ff93dbd..23ec3d0 100644 --- a/LICENSE.md +++ b/LICENSE.md @@ -1,15 +1,23 @@ -ISC License - Copyright (X) 2015-2024, the Qubes Mirage Firewall authors +All rights reserved. -Permission to use, copy, modify, and distribute this software for any -purpose with or without fee is hereby granted, provided that the above -copyright notice and this permission notice appear in all copies. +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: -THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, this + list of conditions and the following disclaimer in the documentation and/or + other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON +ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. \ No newline at end of file diff --git a/README.md b/README.md index 2a37c53..fa83f2a 100644 --- a/README.md +++ b/README.md @@ -210,19 +210,6 @@ To use it, run `test.sh` and follow the instructions to set up the test environm See [issues tagged "security"](https://github.com/mirage/qubes-mirage-firewall/issues?utf8=%E2%9C%93&q=label%3Asecurity+) for security advisories affecting the firewall. -# LICENSE - -Copyright (c) 2019, Thomas Leonard -All rights reserved. - -Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - -1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - -2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - [test-mirage]: https://github.com/talex5/qubes-test-mirage [mirage-qubes]: https://github.com/mirage/mirage-qubes [A Unikernel Firewall for QubesOS]: http://roscidus.com/blog/blog/2016/01/01/a-unikernel-firewall-for-qubesos/ From 64b45e8be6fb4e57171d188e771aa82e0366a611 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Thu, 17 Oct 2024 14:01:31 +0200 Subject: [PATCH 256/281] README.md: refer to LICENSE.md --- README.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/README.md b/README.md index fa83f2a..8f2c00f 100644 --- a/README.md +++ b/README.md @@ -210,6 +210,10 @@ To use it, run `test.sh` and follow the instructions to set up the test environm See [issues tagged "security"](https://github.com/mirage/qubes-mirage-firewall/issues?utf8=%E2%9C%93&q=label%3Asecurity+) for security advisories affecting the firewall. +# LICENSE + +See [LICENSE.md](https://github.com/mirage/qubes-mirage-firewall/blob/main/LICENSE.md) + [test-mirage]: https://github.com/talex5/qubes-test-mirage [mirage-qubes]: https://github.com/mirage/mirage-qubes [A Unikernel Firewall for QubesOS]: http://roscidus.com/blog/blog/2016/01/01/a-unikernel-firewall-for-qubesos/ From 8817893c62eb77aaf6ea567d4851c04e887f1f41 Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Thu, 17 Oct 2024 13:37:12 +0200 Subject: [PATCH 257/281] update GH action checkout version update salt script --- .github/workflows/docker.yml | 2 +- .github/workflows/podman.yml | 2 +- SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls | 9 ++++----- 3 files changed, 6 insertions(+), 7 deletions(-) diff --git a/.github/workflows/docker.yml b/.github/workflows/docker.yml index 1f1dcda..9a8216d 100644 --- a/.github/workflows/docker.yml +++ b/.github/workflows/docker.yml @@ -19,7 +19,7 @@ jobs: steps: - name: Checkout code - uses: actions/checkout@v2 + uses: actions/checkout@v4 - run: ./build-with.sh docker diff --git a/.github/workflows/podman.yml b/.github/workflows/podman.yml index 0fdab2a..f62e075 100644 --- a/.github/workflows/podman.yml +++ b/.github/workflows/podman.yml @@ -19,7 +19,7 @@ jobs: steps: - name: Checkout code - uses: actions/checkout@v2 + uses: actions/checkout@v4 - run: ./build-with.sh podman diff --git a/SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls b/SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls index cfb4a0e..f9886b9 100644 --- a/SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls +++ b/SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls @@ -17,7 +17,7 @@ #download and install the latest version {% set Release = salt['cmd.shell']("qvm-run --dispvm " ~ DispVM ~ " --pass-io \"curl --silent --location -o /dev/null -w %{url_effective} " ~ GithubUrl ~ "/releases/latest | rev | cut -d \"/\" -f 1 | rev\"") %} -{% if Release != salt['cmd.shell']("[ ! -f " ~ MirageInstallDir ~ "/version.txt" ~ " ] && touch " ~ MirageInstallDir ~ "/version.txt" ~ ";cat " ~ MirageInstallDir ~ "/version.txt") %} +{% if Release != salt['cmd.shell']("test -e " ~ MirageInstallDir ~ "/version.txt" ~ " || mkdir " ~ MirageInstallDir ~ " ; touch " ~ MirageInstallDir ~ "/version.txt" ~ " ; cat " ~ MirageInstallDir ~ "/version.txt") %} create-downloader-VM: qvm.vm: @@ -52,15 +52,14 @@ check-checksum-in-DownloadVM: copy-mirage-kernel-to-dom0: cmd.run: - - name: mkdir -p {{ MirageInstallDir }}; qvm-run --pass-io --no-gui {{ DownloadVM }} "cat " ~ Kernel > {{ MirageInstallDir ~ "/" ~ Kernel }} + - name: mkdir -p {{ MirageInstallDir }}; qvm-run --pass-io --no-gui {{ DownloadVM }} {{ "cat " ~ Kernel }} > {{ MirageInstallDir ~ "/vmlinuz" }} - require: - download-and-unpack-in-DownloadVM4mirage - check-checksum-in-DownloadVM -create-initramfs: +update-version: cmd.run: - names: - - gzip -n9 < /dev/null > {{ MirageInstallDir ~ "/initramfs" }} - echo {{ Release }} > {{ MirageInstallDir ~ "/version.txt" }} - require: - copy-mirage-kernel-to-dom0 @@ -94,7 +93,7 @@ cleanup-in-DownloadVM: - names: - qvm-run -a --pass-io --no-gui {{ DownloadVM }} "{{ "rm " ~ Kernel ~ " " ~ Shasum }}" - require: - - create-initramfs + - update-version remove-DownloadVM4mirage: qvm.absent: From 923719f306ad653060dd5c1395e20495839ef7d0 Mon Sep 17 00:00:00 2001 From: Pierre Alain <65669679+palainp@users.noreply.github.com> Date: Wed, 27 Nov 2024 17:05:39 +0100 Subject: [PATCH 258/281] Update installation instructions in README.md This commit clarify the installation instructions for the first time (for context: https://github.com/mirage/qubes-mirage-firewall/commit/54a964e446207d7954634dd712452e9d10eb430e#commitcomment-149513774) --- README.md | 17 ++++++----------- 1 file changed, 6 insertions(+), 11 deletions(-) diff --git a/README.md b/README.md index 8f2c00f..40e65bd 100644 --- a/README.md +++ b/README.md @@ -58,20 +58,15 @@ However, it should still work fine. ## Deploy ### Manual deployment -If you want to deploy manually, unpack `mirage-firewall.tar.bz2` in domU. The tarball contains `vmlinuz`, -which is the unikernel itself, plus a dummy initramfs file that Qubes requires: - - [user@dev ~]$ tar xjf mirage-firewall.tar.bz2 - -Copy `vmlinuz` to `/var/lib/qubes/vm-kernels/mirage-firewall` directory in dom0, e.g. (if `dev` is the AppVM where you built it): +If you want to deploy manually, you just need to download `qubes-firewall.xen` and +`qubes-firewall.sha256` in domU and check that the `.xen` file has a corresponding +hashsum. `qubes-firewall.xen` is the unikernel itself and should be copied to +`vmlinuz` in the `/var/lib/qubes/vm-kernels/mirage-firewall` directory in dom0, e.g. +(if `dev` is the AppVM where you built it): [tal@dom0 ~]$ mkdir -p /var/lib/qubes/vm-kernels/mirage-firewall/ [tal@dom0 ~]$ cd /var/lib/qubes/vm-kernels/mirage-firewall/ - [tal@dom0 mirage-firewall]$ qvm-run -p dev 'cat mirage-firewall/vmlinuz' > vmlinuz - -Finally, create [a dummy file required by Qubes OS](https://github.com/QubesOS/qubes-issues/issues/5516): - - [tal@dom0 mirage-firewall]$ gzip -n9 < /dev/null > initramfs + [tal@dom0 mirage-firewall]$ qvm-run -p dev 'cat mirage-firewall/qubes-firewall.xen' > vmlinuz Run this command in dom0 to create a `mirage-firewall` VM using the `mirage-firewall` kernel you added above From a5d61cb034c1ffe4aaee6b692ef75d85baf7a89f Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Fri, 20 Dec 2024 08:25:36 +0100 Subject: [PATCH 259/281] revert client connexion management --- dispatcher.ml | 70 +++++++++++++++++++++++++-------------------------- 1 file changed, 34 insertions(+), 36 deletions(-) diff --git a/dispatcher.ml b/dispatcher.ml index 60927f6..4803679 100644 --- a/dispatcher.ml +++ b/dispatcher.ml @@ -17,6 +17,8 @@ struct module I = Static_ipv4.Make (R) (Clock) (UplinkEth) (Arp) module U = Udp.Make (I) (R) + let clients : Cleanup.t Dao.VifMap.t ref = ref Dao.VifMap.empty + class client_iface eth ~domid ~gateway_ip ~client_ip client_mac : client_link = let log_header = Fmt.str "dom%d:%a" domid Ipaddr.V4.pp client_ip in @@ -342,7 +344,7 @@ struct (** 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 dns_servers - ~client_ip ~router ~cleanup_tasks qubesDB () = + ~client_ip ~router ~cleanup_tasks qubesDB = let open Lwt.Syntax in let* backend = Netback.make ~domid ~device_id in Log.info (fun f -> @@ -405,8 +407,7 @@ struct Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel listener); (* NOTE(dinosaure): [qubes_updater] and [listener] can be forgotten, our [cleanup_task] will cancel them if the client is disconnected. *) - Lwt.async (fun () -> Lwt.pick [ qubesdb_updater; listener ]); - Lwt.return_unit + 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 dns_servers ~router vif client_ip qubesDB = @@ -415,42 +416,39 @@ struct Log.info (fun f -> f "add client vif %a with IP %a" Dao.ClientVif.pp vif Ipaddr.V4.pp client_ip); - let* () = - Lwt.catch (add_vif get_ts vif dns_client dns_servers ~client_ip ~router - ~cleanup_tasks qubesDB) - @@ fun exn -> - Log.warn (fun f -> - f "Error with client %a: %s" Dao.ClientVif.pp vif - (Printexc.to_string exn)); - Lwt.return_unit - in - Lwt.return cleanup_tasks + Lwt.async (fun () -> + Lwt.catch + (fun () -> + 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" Dao.ClientVif.pp vif + (Printexc.to_string ex)); + Lwt.return_unit)); + cleanup_tasks (** Watch XenStore for notifications of new clients. *) let wait_clients get_ts dns_client dns_servers qubesDB router = - let open Lwt.Syntax in - let clients : Cleanup.t Dao.VifMap.t ref = ref Dao.VifMap.empty in - Dao.watch_clients @@ fun new_set -> - (* Check for removed clients *) - let clean_up_clients key cleanup = - if not (Dao.VifMap.mem key new_set) then begin - clients := !clients |> Dao.VifMap.remove key; - Log.info (fun f -> f "client %a has gone" Dao.ClientVif.pp key); - Cleanup.cleanup cleanup - end - in - Dao.VifMap.iter clean_up_clients !clients; - (* Check for added clients *) - let rec go seq = match Seq.uncons seq with - | None -> Lwt.return_unit - | Some ((key, ipaddr), seq) when not (Dao.VifMap.mem key !clients) -> - let* cleanup = add_client get_ts dns_client dns_servers ~router key ipaddr qubesDB in - Log.debug (fun f -> f "client %a arrived" Dao.ClientVif.pp key); - clients := Dao.VifMap.add key cleanup !clients; - go seq - | Some (_, seq) -> go seq - in - go (Dao.VifMap.to_seq new_set) + Dao.watch_clients (fun new_set -> + (* Check for removed clients *) + !clients + |> Dao.VifMap.iter (fun key cleanup -> + if not (Dao.VifMap.mem key new_set) then ( + clients := !clients |> Dao.VifMap.remove key; + Log.info (fun f -> f "client %a has gone" Dao.ClientVif.pp key); + Cleanup.cleanup cleanup)); + (* 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 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)); + Lwt.return_unit) let send_dns_client_query t ~src_port ~dst ~dst_port buf = match t.uplink with From d8a20eadc8c43e153130737cfda854eeae6e71f9 Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Sun, 22 Dec 2024 19:15:36 +0100 Subject: [PATCH 260/281] get back add_client with local clients map --- dispatcher.ml | 44 ++++++++++++++++++++++---------------------- 1 file changed, 22 insertions(+), 22 deletions(-) diff --git a/dispatcher.ml b/dispatcher.ml index 4803679..45db140 100644 --- a/dispatcher.ml +++ b/dispatcher.ml @@ -17,8 +17,6 @@ struct module I = Static_ipv4.Make (R) (Clock) (UplinkEth) (Arp) module U = Udp.Make (I) (R) - let clients : Cleanup.t Dao.VifMap.t ref = ref Dao.VifMap.empty - class client_iface eth ~domid ~gateway_ip ~client_ip client_mac : client_link = let log_header = Fmt.str "dom%d:%a" domid Ipaddr.V4.pp client_ip in @@ -411,7 +409,6 @@ struct (** A new client VM has been found in XenStore. Find its interface and connect to it. *) let add_client get_ts dns_client dns_servers ~router vif client_ip qubesDB = - let open Lwt.Syntax in 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 @@ -430,25 +427,28 @@ struct (** Watch XenStore for notifications of new clients. *) let wait_clients 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 -> - if not (Dao.VifMap.mem key new_set) then ( - clients := !clients |> Dao.VifMap.remove key; - Log.info (fun f -> f "client %a has gone" Dao.ClientVif.pp key); - Cleanup.cleanup cleanup)); - (* 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 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)); - Lwt.return_unit) + let clients : Cleanup.t Dao.VifMap.t ref = ref Dao.VifMap.empty in + Dao.watch_clients @@ fun new_set -> + (* Check for removed clients *) + let clean_up_clients key cleanup = + if not (Dao.VifMap.mem key new_set) then begin + clients := !clients |> Dao.VifMap.remove key; + Log.info (fun f -> f "client %a has gone" Dao.ClientVif.pp key); + Cleanup.cleanup cleanup + end + in + Dao.VifMap.iter clean_up_clients !clients; + (* Check for added clients *) + let rec go seq = match Seq.uncons seq with + | None -> Lwt.return_unit + | Some ((key, ipaddr), seq) when not (Dao.VifMap.mem key !clients) -> + let cleanup = add_client get_ts dns_client dns_servers ~router key ipaddr qubesDB in + Log.debug (fun f -> f "client %a arrived" Dao.ClientVif.pp key); + clients := Dao.VifMap.add key cleanup !clients; + go seq + | Some (_, seq) -> go seq + in + go (Dao.VifMap.to_seq new_set) let send_dns_client_query t ~src_port ~dst ~dst_port buf = match t.uplink with From 3bc01998a6bcc50990a95f9050e1321cd0c2c854 Mon Sep 17 00:00:00 2001 From: palainp Date: Tue, 31 Dec 2024 11:23:06 -0500 Subject: [PATCH 261/281] add_client can return a Lwt promise --- dispatcher.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/dispatcher.ml b/dispatcher.ml index 45db140..be12aa3 100644 --- a/dispatcher.ml +++ b/dispatcher.ml @@ -423,10 +423,11 @@ struct f "Error with client %a: %s" Dao.ClientVif.pp vif (Printexc.to_string ex)); Lwt.return_unit)); - cleanup_tasks + Lwt.return cleanup_tasks (** Watch XenStore for notifications of new clients. *) let wait_clients get_ts dns_client dns_servers qubesDB router = + let open Lwt.Syntax in let clients : Cleanup.t Dao.VifMap.t ref = ref Dao.VifMap.empty in Dao.watch_clients @@ fun new_set -> (* Check for removed clients *) @@ -442,7 +443,7 @@ struct let rec go seq = match Seq.uncons seq with | None -> Lwt.return_unit | Some ((key, ipaddr), seq) when not (Dao.VifMap.mem key !clients) -> - let cleanup = add_client get_ts dns_client dns_servers ~router key ipaddr qubesDB in + let* cleanup = add_client get_ts dns_client dns_servers ~router key ipaddr qubesDB in Log.debug (fun f -> f "client %a arrived" Dao.ClientVif.pp key); clients := Dao.VifMap.add key cleanup !clients; go seq From 763a3de57a2476e6e5581d5c8b80eda33a7b71ed Mon Sep 17 00:00:00 2001 From: palainp Date: Tue, 31 Dec 2024 12:11:42 -0500 Subject: [PATCH 262/281] remove note as the code has changed --- dispatcher.ml | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/dispatcher.ml b/dispatcher.ml index be12aa3..6837555 100644 --- a/dispatcher.ml +++ b/dispatcher.ml @@ -341,9 +341,10 @@ struct Lwt.return_unit) (** 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 dns_servers + let add_vif get_ts vif dns_client dns_servers ~client_ip ~router ~cleanup_tasks qubesDB = let open Lwt.Syntax in + let { Dao.ClientVif.domid; device_id } = vif in let* backend = Netback.make ~domid ~device_id in Log.info (fun f -> f "Client %d (IP: %s) ready" domid (Ipaddr.V4.to_string client_ip)); @@ -403,8 +404,6 @@ struct (function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e) in Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel listener); - (* NOTE(dinosaure): [qubes_updater] and [listener] can be forgotten, our [cleanup_task] - will cancel them if the client is disconnected. *) Lwt.pick [ qubesdb_updater; listener ] (** A new client VM has been found in XenStore. Find its interface and connect to it. *) From 85de608392eebf57535d02d5fc078643945c6ad5 Mon Sep 17 00:00:00 2001 From: palainp Date: Sat, 4 Jan 2025 04:45:29 -0500 Subject: [PATCH 263/281] in Dispatcher.add_client: keep Client_eth.add_client into Lwt.async --- dispatcher.ml | 46 ++++++++++++++++++++++++++++++---------------- 1 file changed, 30 insertions(+), 16 deletions(-) diff --git a/dispatcher.ml b/dispatcher.ml index 6837555..7e6f10e 100644 --- a/dispatcher.ml +++ b/dispatcher.ml @@ -341,18 +341,12 @@ struct Lwt.return_unit) (** Connect to a new client's interface and listen for incoming frames and firewall rule changes. *) - let add_vif get_ts vif dns_client dns_servers - ~client_ip ~router ~cleanup_tasks qubesDB = - let open Lwt.Syntax in + let conf_vif get_ts vif backend client_eth dns_client dns_servers + ~client_ip ~iface ~router ~cleanup_tasks qubesDB = let { Dao.ClientVif.domid; device_id } = vif in - let* backend = Netback.make ~domid ~device_id in Log.info (fun f -> - f "Client %d (IP: %s) ready" domid (Ipaddr.V4.to_string client_ip)); - let* eth = ClientEth.connect backend in - let client_mac = Netback.frontend_mac backend in - let client_eth = router.clients in - let gateway_ip = Client_eth.client_gw client_eth in - let iface = new client_iface eth ~domid ~gateway_ip ~client_ip client_mac in + f "Client %d:%d (IP: %s) ready" domid device_id (Ipaddr.V4.to_string client_ip)); + (* update the rules whenever QubesDB notices a change for this IP *) let qubesdb_updater = Lwt.catch @@ -380,8 +374,7 @@ struct (function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e) in Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel qubesdb_updater); - add_client router iface >>= fun () -> - Cleanup.on_cleanup cleanup_tasks (fun () -> remove_client router iface); + let fixed_arp = Client_eth.ARP.create ~net:client_eth iface in let fragment_cache = ref (Fragments.Cache.empty (256 * 1024)) in let listener = @@ -404,24 +397,45 @@ struct (function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e) in Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel listener); - Lwt.pick [ qubesdb_updater; listener ] + Lwt.async (fun () -> + Lwt.catch + (fun () -> + Lwt.pick [ qubesdb_updater; listener ]) + (fun ex -> + Log.warn (fun f -> + f "Error with client %a: %s" Dao.ClientVif.pp vif + (Printexc.to_string ex)); + Lwt.return_unit)) ; + Lwt.return_unit (** A new client VM has been found in XenStore. Find its interface and connect to it. *) let add_client get_ts dns_client dns_servers ~router vif client_ip qubesDB = + let open Lwt.Syntax in 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); + let { Dao.ClientVif.domid; device_id } = vif in + let* backend = Netback.make ~domid ~device_id in + let* eth = ClientEth.connect backend in + let client_mac = Netback.frontend_mac backend in + let client_eth = router.clients in + let gateway_ip = Client_eth.client_gw client_eth in + let iface = new client_iface eth ~domid ~gateway_ip ~client_ip client_mac in + + Cleanup.on_cleanup cleanup_tasks (fun () -> remove_client router iface); Lwt.async (fun () -> Lwt.catch (fun () -> - add_vif get_ts vif dns_client dns_servers ~client_ip ~router - ~cleanup_tasks qubesDB) + add_client router iface) (fun ex -> Log.warn (fun f -> f "Error with client %a: %s" Dao.ClientVif.pp vif (Printexc.to_string ex)); - Lwt.return_unit)); + Lwt.return_unit)) ; + + conf_vif get_ts vif backend client_eth dns_client dns_servers ~client_ip ~iface ~router + ~cleanup_tasks qubesDB >>= fun () -> Lwt.return cleanup_tasks (** Watch XenStore for notifications of new clients. *) From 812b99842f431937866bf7e4779190422463e64a Mon Sep 17 00:00:00 2001 From: palainp Date: Sat, 4 Jan 2025 04:55:47 -0500 Subject: [PATCH 264/281] get catch back into add_client --- dispatcher.ml | 26 ++++++++++++++------------ 1 file changed, 14 insertions(+), 12 deletions(-) diff --git a/dispatcher.ml b/dispatcher.ml index 7e6f10e..f6c29c4 100644 --- a/dispatcher.ml +++ b/dispatcher.ml @@ -342,7 +342,7 @@ struct (** Connect to a new client's interface and listen for incoming frames and firewall rule changes. *) let conf_vif get_ts vif backend client_eth dns_client dns_servers - ~client_ip ~iface ~router ~cleanup_tasks qubesDB = + ~client_ip ~iface ~router ~cleanup_tasks qubesDB () = let { Dao.ClientVif.domid; device_id } = vif in Log.info (fun f -> f "Client %d:%d (IP: %s) ready" domid device_id (Ipaddr.V4.to_string client_ip)); @@ -397,15 +397,9 @@ struct (function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e) in Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel listener); - Lwt.async (fun () -> - Lwt.catch - (fun () -> - Lwt.pick [ qubesdb_updater; listener ]) - (fun ex -> - Log.warn (fun f -> - f "Error with client %a: %s" Dao.ClientVif.pp vif - (Printexc.to_string ex)); - Lwt.return_unit)) ; + (* NOTE(dinosaure): [qubes_updater] and [listener] can be forgotten, our [cleanup_task] + will cancel them if the client is disconnected. *) + Lwt.async (fun () -> Lwt.pick [ qubesdb_updater; listener ]); Lwt.return_unit (** A new client VM has been found in XenStore. Find its interface and connect to it. *) @@ -434,8 +428,16 @@ struct (Printexc.to_string ex)); Lwt.return_unit)) ; - conf_vif get_ts vif backend client_eth dns_client dns_servers ~client_ip ~iface ~router - ~cleanup_tasks qubesDB >>= fun () -> + let* () = + Lwt.catch ( + conf_vif get_ts vif backend client_eth dns_client dns_servers ~client_ip ~iface ~router + ~cleanup_tasks qubesDB) + @@ fun exn -> + Log.warn (fun f -> + f "Error with client %a: %s" Dao.ClientVif.pp vif + (Printexc.to_string exn)); + Lwt.return_unit + in Lwt.return cleanup_tasks (** Watch XenStore for notifications of new clients. *) From 6d0cc1cf9decf4f02c3b1e4823210a50a23ffa12 Mon Sep 17 00:00:00 2001 From: palainp Date: Sat, 4 Jan 2025 06:02:40 -0500 Subject: [PATCH 265/281] add hashsum --- qubes-firewall.sha256 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/qubes-firewall.sha256 b/qubes-firewall.sha256 index b89e36f..c02b661 100644 --- a/qubes-firewall.sha256 +++ b/qubes-firewall.sha256 @@ -1 +1 @@ -78a1ee52574b9a4fc5eda265922bcbcface90f7c43ed7a68dc8e201a2ac0a7dc dist/qubes-firewall.xen +b78d6711b502f8babcc5c4083b0352b78be8e8a6bef044189ce7a00e6e564612 dist/qubes-firewall.xen From 32394c79e17fa979a7e7a0c1bdbff3bddd85c16e Mon Sep 17 00:00:00 2001 From: palainp Date: Sat, 4 Jan 2025 06:18:01 -0500 Subject: [PATCH 266/281] release v0.9.3 --- CHANGES.md | 5 +++++ qubes-firewall-release.sha256 | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/CHANGES.md b/CHANGES.md index dac6405..0aaa61a 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,8 @@ +### 0.9.3 (2025-01-04) + +- Fix an issue when qubes-mirage-firewall is used along with *BSD sys-net + (#209, @palainp, reported in the Qubes forum #208, reviewed by @dinosaure) + ### 0.9.2 (2024-10-16) - Code refactoring and improvements (#197, @dinosaure) diff --git a/qubes-firewall-release.sha256 b/qubes-firewall-release.sha256 index b89e36f..c02b661 100644 --- a/qubes-firewall-release.sha256 +++ b/qubes-firewall-release.sha256 @@ -1 +1 @@ -78a1ee52574b9a4fc5eda265922bcbcface90f7c43ed7a68dc8e201a2ac0a7dc dist/qubes-firewall.xen +b78d6711b502f8babcc5c4083b0352b78be8e8a6bef044189ce7a00e6e564612 dist/qubes-firewall.xen From b3bc2afc581e74ad698095c5064274d39d7bb8c3 Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Mon, 3 Feb 2025 08:00:21 +0100 Subject: [PATCH 267/281] update gh action upload artifact --- .github/workflows/docker.yml | 2 +- .github/workflows/podman.yml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/docker.yml b/.github/workflows/docker.yml index 9a8216d..a5720ca 100644 --- a/.github/workflows/docker.yml +++ b/.github/workflows/docker.yml @@ -26,7 +26,7 @@ jobs: - run: sh -exc 'if [ "$(sha256sum dist/qubes-firewall.xen)" = "$(cat qubes-firewall.sha256)" ]; then echo "SHA256 MATCHES"; else exit 42; fi' - name: Upload Artifact - uses: actions/upload-artifact@v3 + uses: actions/upload-artifact@v4 with: name: qubes-firewall.xen path: qubes-firewall.xen diff --git a/.github/workflows/podman.yml b/.github/workflows/podman.yml index f62e075..21f2bd2 100644 --- a/.github/workflows/podman.yml +++ b/.github/workflows/podman.yml @@ -26,7 +26,7 @@ jobs: - run: sh -exc 'if [ "$(sha256sum dist/qubes-firewall.xen)" = "$(cat qubes-firewall.sha256)" ]; then echo "SHA256 MATCHES"; else exit 42; fi' - name: Upload Artifact - uses: actions/upload-artifact@v3 + uses: actions/upload-artifact@v4 with: name: qubes-firewall.xen path: qubes-firewall.xen From 2b2ac42ebcb248c8291d95c8d623901a9b17be65 Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Thu, 6 Feb 2025 12:07:29 +0100 Subject: [PATCH 268/281] fallback to Qubes netvm_mac=fe:ff:ff:ff:ff:ff is our netvm does not reply to us --- dispatcher.ml | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/dispatcher.ml b/dispatcher.ml index f6c29c4..d929822 100644 --- a/dispatcher.ml +++ b/dispatcher.ml @@ -571,7 +571,14 @@ struct I.connect ~cidr ~gateway eth arp >>= fun ip -> U.connect ip >>= fun udp -> let netvm_mac = - Arp.query arp gateway >|= or_raise "Getting MAC of our NetVM" Arp.pp_error + Arp.query arp gateway >>= function + | Error e -> + Log.err(fun f -> f "Getting MAC of our NetVM: %a" Arp.pp_error e); + (* This mac address is a special address used by Qubes when the device + is not managed by Qubes itself. This can occurs inside a service + AppVM (e.g. VPN) when the service creates a new interface. *) + Lwt.return (Macaddr.of_string_exn "fe:ff:ff:ff:ff:ff") + | Ok mac -> Lwt.return mac in let interface = new netvm_iface eth netvm_mac ~my_ip ~other_ip:config.Dao.netvm_ip From cf181026a8f21388298a0937a5b8eadc37c0eb02 Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Thu, 6 Feb 2025 14:39:34 +0100 Subject: [PATCH 269/281] update hashsum --- qubes-firewall.sha256 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/qubes-firewall.sha256 b/qubes-firewall.sha256 index c02b661..220644c 100644 --- a/qubes-firewall.sha256 +++ b/qubes-firewall.sha256 @@ -1 +1 @@ -b78d6711b502f8babcc5c4083b0352b78be8e8a6bef044189ce7a00e6e564612 dist/qubes-firewall.xen +0c3c2c0e62a834112c69d7cddc5dd6f70ecb93afa988768fb860ed26e423b1f8 dist/qubes-firewall.xen From 5f5fe82b9b5ca0c673a28edac46147fd7bcbbb86 Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Mon, 10 Feb 2025 11:25:57 +0100 Subject: [PATCH 270/281] release v0.9.4 --- CHANGES.md | 8 ++++++++ qubes-firewall-release.sha256 | 2 +- 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/CHANGES.md b/CHANGES.md index 0aaa61a..41d0026 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,11 @@ +### 0.9.4 (2025-02-10) + +- Fix an issue when qubes-mirage-firewall is used a a mullvad AppVM client. If + our netvm does not reply to our ARP requests we can not construct the ethernet + header. However in Linux VMs, Qubes adds a default netvm address associated to + `fe:ff:ff:ff:ff:ff`, so if ARP fails, we fall back on that address. + (#213, @palainp, reported in the Qubes forum #212, reviewed by @hannesm) + ### 0.9.3 (2025-01-04) - Fix an issue when qubes-mirage-firewall is used along with *BSD sys-net diff --git a/qubes-firewall-release.sha256 b/qubes-firewall-release.sha256 index c02b661..220644c 100644 --- a/qubes-firewall-release.sha256 +++ b/qubes-firewall-release.sha256 @@ -1 +1 @@ -b78d6711b502f8babcc5c4083b0352b78be8e8a6bef044189ce7a00e6e564612 dist/qubes-firewall.xen +0c3c2c0e62a834112c69d7cddc5dd6f70ecb93afa988768fb860ed26e423b1f8 dist/qubes-firewall.xen From 592f53777ee9435b654bfcffb5a35c88a76ccfb4 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Mon, 10 Mar 2025 13:51:20 +0100 Subject: [PATCH 271/281] update to mirage 4.9.0 --- config.ml | 6 +++--- dispatcher.ml | 12 +++--------- my_dns.ml | 10 +++------- unikernel.ml | 18 +++++++----------- 4 files changed, 16 insertions(+), 30 deletions(-) diff --git a/config.ml b/config.ml index 00ddc71..5c06a4b 100644 --- a/config.ml +++ b/config.ml @@ -1,4 +1,4 @@ -(* mirage >= 4.8.0 & < 4.9.0 *) +(* mirage >= 4.9.0 & < 4.10.0 *) (* Copyright (C) 2017, Thomas Leonard See the README file for details. *) @@ -24,7 +24,7 @@ let main = package ~min:"6.4.0" "dns-client"; package "pf-qubes"; ] - "Unikernel.Main" (random @-> mclock @-> time @-> job) + "Unikernel" job let () = - register "qubes-firewall" [main $ default_random $ default_monotonic_clock $ default_time] + register "qubes-firewall" [main] diff --git a/dispatcher.ml b/dispatcher.ml index d929822..9f6db7f 100644 --- a/dispatcher.ml +++ b/dispatcher.ml @@ -8,14 +8,9 @@ let src = Logs.Src.create "dispatcher" ~doc:"Networking dispatch" module Log = (val Logs.src_log src : Logs.LOG) -module Make - (R : Mirage_crypto_rng_mirage.S) - (Clock : Mirage_clock.MCLOCK) - (Time : Mirage_time.S) = -struct - module Arp = Arp.Make (UplinkEth) (Time) - module I = Static_ipv4.Make (R) (Clock) (UplinkEth) (Arp) - module U = Udp.Make (I) (R) + module Arp = Arp.Make (UplinkEth) + module I = Static_ipv4.Make (UplinkEth) (Arp) + module U = Udp.Make (I) class client_iface eth ~domid ~gateway_ip ~client_ip client_mac : client_link = @@ -632,4 +627,3 @@ struct >>= fun () -> aux new_db in aux Qubes.DB.KeyMap.empty -end diff --git a/my_dns.ml b/my_dns.ml index cbfa763..6000e80 100644 --- a/my_dns.ml +++ b/my_dns.ml @@ -1,9 +1,7 @@ open Lwt.Infix -module Transport (R : Mirage_crypto_rng_mirage.S) (C : Mirage_clock.MCLOCK) (Time : Mirage_time.S) = struct type +'a io = 'a Lwt.t type io_addr = Ipaddr.V4.t * int - module Dispatcher = Dispatcher.Make(R)(C)(Time) type stack = Dispatcher.t * (src_port:int -> dst:Ipaddr.V4.t -> dst_port:int -> string -> (unit, [ `Msg of string ]) result Lwt.t) * (Udp_packet.t * string) Lwt_mvar.t @@ -20,8 +18,8 @@ module Transport (R : Mirage_crypto_rng_mirage.S) (C : Mirage_clock.MCLOCK) (Tim type context = t let nameservers { protocol ; nameserver ; _ } = protocol, [ nameserver ] - let rng = R.generate ?g:None - let clock = C.elapsed_ns + let rng = Mirage_crypto_rng.generate ?g:None + let clock = Mirage_mtime.elapsed_ns let rec read t = let _, _, answer = t.stack in @@ -45,7 +43,7 @@ module Transport (R : Mirage_crypto_rng_mirage.S) (C : Mirage_clock.MCLOCK) (Tim t let with_timeout timeout_ns f = - let timeout = Time.sleep_ns timeout_ns >|= fun () -> Error (`Msg "DNS request timeout") in + let timeout = Mirage_sleep.ns timeout_ns >|= fun () -> Error (`Msg "DNS request timeout") in Lwt.pick [ f ; timeout ] let connect (t : t) = Lwt.return (Ok (t.protocol, t)) @@ -72,5 +70,3 @@ module Transport (R : Mirage_crypto_rng_mirage.S) (C : Mirage_clock.MCLOCK) (Tim let bind = Lwt.bind let lift = Lwt.return -end - diff --git a/unikernel.ml b/unikernel.ml index f0e12df..28115d1 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -28,10 +28,7 @@ let ipv4_dns2 = let doc = Arg.info ~doc:"Manual Second DNS IP setting." [ "ipv4-dns2" ] in Mirage_runtime.register_arg Arg.(value & opt string "10.139.1.2" doc) -module Main (R : Mirage_crypto_rng_mirage.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_time.S) = struct - module Dispatcher = Dispatcher.Make(R)(Clock)(Time) - module Dns_transport = My_dns.Transport(R)(Clock)(Time) - module Dns_client = Dns_client.Make(Dns_transport) + module Dns_client = Dns_client.Make(My_dns) (* Set up networking and listen for incoming packets. *) let network dns_client dns_responses dns_servers qubesDB router = @@ -39,22 +36,22 @@ module Main (R : Mirage_crypto_rng_mirage.S)(Clock : Mirage_clock.MCLOCK)(Time : Dao.set_iptables_error qubesDB "" >>= fun () -> (* Handle packets from both networks *) Lwt.choose [ - Dispatcher.wait_clients Clock.elapsed_ns dns_client dns_servers qubesDB router ; + Dispatcher.wait_clients Mirage_mtime.elapsed_ns dns_client dns_servers qubesDB router ; Dispatcher.uplink_wait_update qubesDB router ; - Dispatcher.uplink_listen Clock.elapsed_ns dns_responses router + Dispatcher.uplink_listen Mirage_mtime.elapsed_ns dns_responses router ] (* Main unikernel entry point (called from auto-generated main.ml). *) - let start _random _clock _time = + let start () = let open Lwt.Syntax in - let start_time = Clock.elapsed_ns () in + let start_time = Mirage_mtime.elapsed_ns () in (* Start qrexec agent and QubesDB agent in parallel *) let* qrexec = RExec.connect ~domid:0 () in let agent_listener = RExec.listen qrexec Command.handler in let* qubesDB = DB.connect ~domid:0 () in let startup_time = let (-) = Int64.sub in - let time_in_ns = Clock.elapsed_ns () - start_time in + let time_in_ns = Mirage_mtime.elapsed_ns () - start_time in Int64.to_float time_in_ns /. 1e9 in Log.info (fun f -> f "QubesDB and qrexec agents connected in %.3f s" startup_time); @@ -113,5 +110,4 @@ module Main (R : Mirage_crypto_rng_mirage.S)(Clock : Mirage_clock.MCLOCK)(Time : (* Run until something fails or we get a shutdown request. *) Lwt.choose [agent_listener; net_listener; shutdown_rq] >>= fun () -> (* Give the console daemon time to show any final log messages. *) - Time.sleep_ns (1.0 *. 1e9 |> Int64.of_float) -end + Mirage_sleep.ns (1.0 *. 1e9 |> Int64.of_float) From 5d515c360de5c1a5f9e4526fb06b838d3022e835 Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Wed, 12 Mar 2025 11:56:33 +0100 Subject: [PATCH 272/281] update opam version, opam-repository and overlays hash --- Dockerfile | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/Dockerfile b/Dockerfile index edf9e96..bd6e343 100644 --- a/Dockerfile +++ b/Dockerfile @@ -12,10 +12,10 @@ RUN printf "deb [check-valid-until=no] http://snapshot.debian.org/archive/debian RUN printf "deb [check-valid-until=no] http://snapshot.debian.org/archive/debian-security/20240419T111010Z bookworm-security main\n" >> /etc/apt/sources.list RUN apt update && apt install --no-install-recommends --no-install-suggests -y wget ca-certificates git patch unzip bzip2 make gcc g++ libc-dev -RUN wget -O /usr/bin/opam https://github.com/ocaml/opam/releases/download/2.2.1/opam-2.2.1-i686-linux && chmod 755 /usr/bin/opam +RUN wget -O /usr/bin/opam https://github.com/ocaml/opam/releases/download/2.3.0/opam-2.3.0-i686-linux && chmod 755 /usr/bin/opam # taken from https://raw.githubusercontent.com/ocaml/opam/master/shell/install.sh RUN test `sha512sum /usr/bin/opam | cut -d' ' -f1` = \ -"bf16d573137835ce9abbcf6b99cb94a1da69ab58804a4de7c90233f0b354d5e68e9c47ee16670ca9d59866d58c7db345d9723e6eb5fc3a1cb8dca371f0e90225" || exit +"4c0e8771889a36bad4d5f964e2e662d5b611e6f112777d3d4eea3eea919d109cd17826beba38e6cfa1ad9553a0a989d9268f911ea5485968da04b1e08efc7de2" || exit ENV OPAMROOT=/tmp ENV OPAMCONFIRMLEVEL=unsafe-yes @@ -23,13 +23,13 @@ ENV OPAMCONFIRMLEVEL=unsafe-yes # Remove this line (and the base image pin above) if you want to test with the # latest versions. # taken from https://github.com/ocaml/opam-repository -RUN opam init --disable-sandboxing -a --bare https://github.com/ocaml/opam-repository.git#5d3f0d1d655199e596a1e785e69fae8fad78cad3 +RUN opam init --disable-sandboxing -a --bare https://github.com/ocaml/opam-repository.git#8f63148a9025a7b775a069a6c0b0385c22ad51d3 RUN opam switch create myswitch 4.14.2 RUN opam exec -- opam install -y mirage opam-monorepo ocaml-solo5 RUN mkdir /tmp/orb-build ADD config.ml /tmp/orb-build/config.ml WORKDIR /tmp/orb-build CMD opam exec -- sh -exc 'mirage configure -t xen --extra-repos=\ -opam-overlays:https://github.com/dune-universe/opam-overlays.git#4e75ee36715b27550d5bdb87686bb4ae4c9e89c4,\ +opam-overlays:https://github.com/dune-universe/opam-overlays.git#f2bec38beca4aea9e481f2fd3ee319c519124649,\ mirage-overlays:https://github.com/dune-universe/mirage-opam-overlays.git#797cb363df3ff763c43c8fbec5cd44de2878757e \ && make depend && make unikernel' From a756effb14905e404164c6769d9c9eac660c0390 Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Wed, 12 Mar 2025 11:56:51 +0100 Subject: [PATCH 273/281] update hashsum --- qubes-firewall.sha256 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/qubes-firewall.sha256 b/qubes-firewall.sha256 index 220644c..067b2d6 100644 --- a/qubes-firewall.sha256 +++ b/qubes-firewall.sha256 @@ -1 +1 @@ -0c3c2c0e62a834112c69d7cddc5dd6f70ecb93afa988768fb860ed26e423b1f8 dist/qubes-firewall.xen +1cc5664d48a80b96162e14a0d8a17aafa52175cc2043ecf6b834c4bc8fe656f6 dist/qubes-firewall.xen From 85c8b7a661e503f974e311d4ae5a06b68a1ad50b Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Wed, 12 Mar 2025 11:57:13 +0100 Subject: [PATCH 274/281] add ocamlformat and autoformat in github action --- .github/workflows/format.yml | 45 ++++++++++++++++++++++++++++++++++++ .ocamlformat | 3 +++ 2 files changed, 48 insertions(+) create mode 100644 .github/workflows/format.yml create mode 100644 .ocamlformat diff --git a/.github/workflows/format.yml b/.github/workflows/format.yml new file mode 100644 index 0000000..f5ebd58 --- /dev/null +++ b/.github/workflows/format.yml @@ -0,0 +1,45 @@ +name: ocamlformat + +on: [pull_request] + +jobs: + format: + name: ocamlformat + + strategy: + fail-fast: false + matrix: + ocaml-version: ["4.14.2"] + operating-system: [ubuntu-latest] + + runs-on: ${{ matrix.operating-system }} + + steps: + - name: Checkout code + uses: actions/checkout@v2 + with: + ref: ${{ github.event.pull_request.head.ref }} + + - name: Use OCaml ${{ matrix.ocaml-version }} + uses: ocaml/setup-ocaml@v3 + with: + ocaml-compiler: ${{ matrix.ocaml-version }} + + - name: Install ocamlformat + run: grep ^version .ocamlformat | cut -d '=' -f 2 | xargs -I V opam install ocamlformat=V + + - name: Format code + run: git ls-files '*.ml' '*.mli' | xargs opam exec -- ocamlformat --inplace + + - name: Check for modified files + id: git-check + run: echo "modified=$(if git diff-index --quiet HEAD --; then echo "false"; else echo "true"; fi)" >> $GITHUB_OUTPUT + + - name: Commit and push changes + if: steps.git-check.outputs.modified == 'true' + run: | + git config --global user.name "Automated ocamlformat GitHub action, developed by robur.coop" + git config --global user.email "autoformat@robur.coop" + git add -A + git commit -m "formatted code" + git push diff --git a/.ocamlformat b/.ocamlformat new file mode 100644 index 0000000..d6d9647 --- /dev/null +++ b/.ocamlformat @@ -0,0 +1,3 @@ +version = 0.27.0 +profile = conventional +parse-docstrings = true From bc3fdaf3d5e5407f2f3c81ed693bcb3c2bf9cca7 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Mon, 17 Mar 2025 12:23:10 +0100 Subject: [PATCH 275/281] fix formatting action --- .github/workflows/format.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/format.yml b/.github/workflows/format.yml index f5ebd58..e57f74e 100644 --- a/.github/workflows/format.yml +++ b/.github/workflows/format.yml @@ -16,9 +16,9 @@ jobs: steps: - name: Checkout code - uses: actions/checkout@v2 + uses: actions/checkout@v4 with: - ref: ${{ github.event.pull_request.head.ref }} + ref: ${{ github.head_ref }} - name: Use OCaml ${{ matrix.ocaml-version }} uses: ocaml/setup-ocaml@v3 From 4de45e2f6794f9dca890ab4eb40239710e09c26c Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Mon, 17 Mar 2025 12:25:34 +0100 Subject: [PATCH 276/281] try --- .github/workflows/format.yml | 2 -- 1 file changed, 2 deletions(-) diff --git a/.github/workflows/format.yml b/.github/workflows/format.yml index e57f74e..e5c4a21 100644 --- a/.github/workflows/format.yml +++ b/.github/workflows/format.yml @@ -17,8 +17,6 @@ jobs: steps: - name: Checkout code uses: actions/checkout@v4 - with: - ref: ${{ github.head_ref }} - name: Use OCaml ${{ matrix.ocaml-version }} uses: ocaml/setup-ocaml@v3 From edba36b97b5e7842269ac7986a00a1dc230df7e1 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Mon, 17 Mar 2025 12:35:47 +0100 Subject: [PATCH 277/281] another try --- .github/workflows/format.yml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/.github/workflows/format.yml b/.github/workflows/format.yml index e5c4a21..7e2d227 100644 --- a/.github/workflows/format.yml +++ b/.github/workflows/format.yml @@ -38,6 +38,5 @@ jobs: run: | git config --global user.name "Automated ocamlformat GitHub action, developed by robur.coop" git config --global user.email "autoformat@robur.coop" - git add -A - git commit -m "formatted code" + git commit -m "formatted code" . git push From 17941c7fbc98664c09dab19135b67a69bb72cdae Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Mon, 17 Mar 2025 12:59:22 +0100 Subject: [PATCH 278/281] minor change --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 40e65bd..ce64ba6 100644 --- a/README.md +++ b/README.md @@ -48,7 +48,7 @@ It's OK to install the Docker or Podman package in a template VM if you want it after a reboot, but the build of the firewall itself should be done in a regular AppVM. You can also build without that script, as for any normal Mirage unikernel; -see [the Mirage installation instructions](https://mirage.io/wiki/install) for details. +see [the Mirage installation instructions](https://mirageos.org/wiki/install) for details. The build script fixes the versions of the libraries it uses, ensuring that you will get exactly the same binary that is in the release. If you build without it, it will build From 511ac0adfb707f591b88ade9af5dbc5225046652 Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Tue, 18 Mar 2025 09:10:17 +0100 Subject: [PATCH 279/281] trigger format on push rather than pull_request --- .github/workflows/format.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/format.yml b/.github/workflows/format.yml index 7e2d227..7970630 100644 --- a/.github/workflows/format.yml +++ b/.github/workflows/format.yml @@ -1,6 +1,6 @@ name: ocamlformat -on: [pull_request] +on: [push] jobs: format: From 4d89b858922556c13a5be2f9797fc6159a791263 Mon Sep 17 00:00:00 2001 From: "Automated ocamlformat GitHub action, developed by robur.coop" Date: Tue, 18 Mar 2025 08:16:13 +0000 Subject: [PATCH 280/281] formatted code --- cleanup.ml | 4 +- cleanup.mli | 4 +- client_eth.ml | 115 +++-- client_eth.mli | 36 +- command.ml | 20 +- config.ml | 38 +- dao.ml | 193 ++++---- dao.mli | 35 +- dispatcher.ml | 1128 ++++++++++++++++++++++--------------------- fw_utils.ml | 12 +- memory_pressure.ml | 8 +- memory_pressure.mli | 4 +- my_dns.ml | 127 ++--- my_nat.ml | 72 ++- my_nat.mli | 22 +- packet.ml | 46 +- packet.mli | 30 +- rules.ml | 120 +++-- test/config.ml | 36 +- test/unikernel.ml | 460 +++++++++++------- unikernel.ml | 159 +++--- 21 files changed, 1433 insertions(+), 1236 deletions(-) diff --git a/cleanup.ml b/cleanup.ml index cbe9ebc..ecd3c78 100644 --- a/cleanup.ml +++ b/cleanup.ml @@ -4,9 +4,7 @@ type t = (unit -> unit) list ref let create () = ref [] - -let on_cleanup t fn = - t := fn :: !t +let on_cleanup t fn = t := fn :: !t let cleanup t = let tasks = !t in diff --git a/cleanup.mli b/cleanup.mli index d43661b..1358c07 100644 --- a/cleanup.mli +++ b/cleanup.mli @@ -1,8 +1,8 @@ (* Copyright (C) 2015, Thomas Leonard See the README file for details. *) -(** Register actions to take when a resource is finished. - Like [Lwt_switch], but synchronous. *) +(** Register actions to take when a resource is finished. Like [Lwt_switch], but + synchronous. *) type t diff --git a/client_eth.ml b/client_eth.ml index fc0b01a..bd9d931 100644 --- a/client_eth.ml +++ b/client_eth.ml @@ -4,19 +4,19 @@ open Fw_utils open Lwt.Infix -let src = Logs.Src.create "client_eth" ~doc:"Ethernet networks for NetVM clients" +let src = + Logs.Src.create "client_eth" ~doc:"Ethernet networks for NetVM clients" + module Log = (val Logs.src_log src : Logs.LOG) type t = { mutable iface_of_ip : client_link Ipaddr.V4.Map.t; - changed : unit Lwt_condition.t; (* Fires when [iface_of_ip] changes. *) - my_ip : Ipaddr.V4.t; (* The IP that clients are given as their default gateway. *) + changed : unit Lwt_condition.t; (* Fires when [iface_of_ip] changes. *) + my_ip : Ipaddr.V4.t; + (* The IP that clients are given as their default gateway. *) } -type host = - [ `Client of client_link - | `Firewall - | `External of Ipaddr.t ] +type host = [ `Client of client_link | `Firewall | `External of Ipaddr.t ] let create config = let changed = Lwt_condition.create () in @@ -30,14 +30,17 @@ let add_client t iface = let rec aux () = match Ipaddr.V4.Map.find_opt ip t.iface_of_ip with | Some old -> - (* Wait for old client to disappear before adding one with the same IP address. + (* Wait for old client to disappear before adding one with the same IP address. Otherwise, its [remove_client] call will remove the new client instead. *) - Log.info (fun f -> f ~header:iface#log_header "Waiting for old client %s to go away before accepting new one" old#log_header); - Lwt_condition.wait t.changed >>= aux + Log.info (fun f -> + f ~header:iface#log_header + "Waiting for old client %s to go away before accepting new one" + old#log_header); + Lwt_condition.wait t.changed >>= aux | None -> - t.iface_of_ip <- t.iface_of_ip |> Ipaddr.V4.Map.add ip iface; - Lwt_condition.broadcast t.changed (); - Lwt.return_unit + t.iface_of_ip <- t.iface_of_ip |> Ipaddr.V4.Map.add ip iface; + Lwt_condition.broadcast t.changed (); + Lwt.return_unit in aux () @@ -52,11 +55,12 @@ let lookup t ip = Ipaddr.V4.Map.find_opt ip t.iface_of_ip let classify t ip = match ip with | Ipaddr.V6 _ -> `External ip - | Ipaddr.V4 ip4 -> - if ip4 = t.my_ip then `Firewall - else match lookup t ip4 with - | Some client_link -> `Client client_link - | None -> `External ip + | Ipaddr.V4 ip4 -> ( + if ip4 = t.my_ip then `Firewall + else + match lookup t ip4 with + | Some client_link -> `Client client_link + | None -> `External ip) let resolve t : host -> Ipaddr.t = function | `Client client_link -> Ipaddr.V4 client_link#other_ip @@ -64,50 +68,53 @@ let resolve t : host -> Ipaddr.t = function | `External addr -> addr module ARP = struct - type arp = { - net : t; - client_link : client_link; - } + type arp = { net : t; client_link : client_link } let lookup t ip = if ip = t.net.my_ip then Some t.client_link#my_mac else if (Ipaddr.V4.to_octets ip).[3] = '\x01' then ( - Log.info (fun f -> f ~header:t.client_link#log_header - "Request for %a is invalid, but pretending it's me (see Qubes issue #5022)" Ipaddr.V4.pp ip); - Some t.client_link#my_mac - ) else None + Log.info (fun f -> + f ~header:t.client_link#log_header + "Request for %a is invalid, but pretending it's me (see Qubes \ + issue #5022)" + Ipaddr.V4.pp ip); + Some t.client_link#my_mac) + else None (* We're now treating client networks as point-to-point links, so we no longer respond on behalf of other clients. *) - (* + (* else match Ipaddr.V4.Map.find_opt ip t.net.iface_of_ip with | Some client_iface -> Some client_iface#other_mac | None -> None *) - let create ~net client_link = {net; client_link} + let create ~net client_link = { net; client_link } let input_query t arp = let req_ipv4 = arp.Arp_packet.target_ip in let pf (f : ?header:string -> ?tags:_ -> _) fmt = - f ~header:t.client_link#log_header ("who-has %a? " ^^ fmt) Ipaddr.V4.pp req_ipv4 + f ~header:t.client_link#log_header ("who-has %a? " ^^ fmt) Ipaddr.V4.pp + req_ipv4 in if req_ipv4 = t.client_link#other_ip then ( Log.info (fun f -> pf f "ignoring request for client's own IP"); - None - ) else match lookup t req_ipv4 with + None) + else + match lookup t req_ipv4 with | None -> - Log.info (fun f -> pf f "unknown address; not responding"); - None + Log.info (fun f -> pf f "unknown address; not responding"); + None | Some req_mac -> - Log.info (fun f -> pf f "responding with %a" Macaddr.pp req_mac); - Some { Arp_packet. - operation = Arp_packet.Reply; - (* The Target Hardware Address and IP are copied from the request *) - target_ip = arp.Arp_packet.source_ip; - target_mac = arp.Arp_packet.source_mac; - source_ip = req_ipv4; - source_mac = req_mac; - } + Log.info (fun f -> pf f "responding with %a" Macaddr.pp req_mac); + Some + { + Arp_packet.operation = Arp_packet.Reply; + (* The Target Hardware Address and IP are copied from the request *) + target_ip = arp.Arp_packet.source_ip; + target_mac = arp.Arp_packet.source_mac; + source_ip = req_ipv4; + source_mac = req_mac; + } let input_gratuitous t arp = let source_ip = arp.Arp_packet.source_ip in @@ -115,18 +122,28 @@ module ARP = struct let header = t.client_link#log_header in match lookup t source_ip with | Some real_mac when Macaddr.compare source_mac real_mac = 0 -> - Log.info (fun f -> f ~header "client suggests updating %s -> %s (as expected)" - (Ipaddr.V4.to_string source_ip) (Macaddr.to_string source_mac)); + Log.info (fun f -> + f ~header "client suggests updating %s -> %s (as expected)" + (Ipaddr.V4.to_string source_ip) + (Macaddr.to_string source_mac)) | Some other_mac -> - Log.warn (fun f -> f ~header "client suggests incorrect update %s -> %s (should be %s)" - (Ipaddr.V4.to_string source_ip) (Macaddr.to_string source_mac) (Macaddr.to_string other_mac)); + Log.warn (fun f -> + f ~header "client suggests incorrect update %s -> %s (should be %s)" + (Ipaddr.V4.to_string source_ip) + (Macaddr.to_string source_mac) + (Macaddr.to_string other_mac)) | None -> - Log.warn (fun f -> f ~header "client suggests incorrect update %s -> %s (unexpected IP)" - (Ipaddr.V4.to_string source_ip) (Macaddr.to_string source_mac)) + Log.warn (fun f -> + f ~header + "client suggests incorrect update %s -> %s (unexpected IP)" + (Ipaddr.V4.to_string source_ip) + (Macaddr.to_string source_mac)) let input t arp = let op = arp.Arp_packet.operation in match op with | Arp_packet.Request -> input_query t arp - | Arp_packet.Reply -> input_gratuitous t arp; None + | Arp_packet.Reply -> + input_gratuitous t arp; + None end diff --git a/client_eth.mli b/client_eth.mli index 02ccee9..d7ecb55 100644 --- a/client_eth.mli +++ b/client_eth.mli @@ -1,34 +1,32 @@ (* Copyright (C) 2016, Thomas Leonard See the README file for details. *) -(** The ethernet networks connecting us to our client AppVMs. - Note: each AppVM is on a point-to-point link, each link being considered to be a separate Ethernet network. *) +(** The ethernet networks connecting us to our client AppVMs. Note: each AppVM + is on a point-to-point link, each link being considered to be a separate + Ethernet network. *) open Fw_utils type t (** A collection of clients. *) -type host = - [ `Client of client_link - | `Firewall - | `External of Ipaddr.t ] +type host = [ `Client of client_link | `Firewall | `External of Ipaddr.t ] (* Note: Qubes does not allow us to distinguish between an external address and a disconnected client. See: https://github.com/talex5/qubes-mirage-firewall/issues/9#issuecomment-246956850 *) val create : Dao.network_config -> t Lwt.t -(** [create ~client_gw] is a network of client machines. - Qubes will have configured the client machines to use [client_gw] as their default gateway. *) +(** [create ~client_gw] is a network of client machines. Qubes will have + configured the client machines to use [client_gw] as their default gateway. +*) val add_client : t -> client_link -> unit Lwt.t -(** [add_client t client] registers a new client. If a client with this IP address is already registered, - it waits for [remove_client] to be called on that before adding the new client and returning. *) +(** [add_client t client] registers a new client. If a client with this IP + address is already registered, it waits for [remove_client] to be called on + that before adding the new client and returning. *) val remove_client : t -> client_link -> unit - val client_gw : t -> Ipaddr.V4.t - val classify : t -> Ipaddr.t -> host val resolve : t -> host -> Ipaddr.t @@ -36,18 +34,18 @@ val lookup : t -> Ipaddr.V4.t -> client_link option (** [lookup t addr] is the client with IP address [addr], if connected. *) module ARP : sig - (** We already know the correct mapping of IP addresses to MAC addresses, so we never - allow clients to update it. We log a warning if a client attempts to set incorrect - information. *) + (** We already know the correct mapping of IP addresses to MAC addresses, so + we never allow clients to update it. We log a warning if a client attempts + to set incorrect information. *) type arp (** An ARP-responder for one client. *) val create : net:t -> client_link -> arp - (** [create ~net client_link] is an ARP responder for [client_link]. - It answers only for the client's gateway address. *) + (** [create ~net client_link] is an ARP responder for [client_link]. It + answers only for the client's gateway address. *) val input : arp -> Arp_packet.t -> Arp_packet.t option - (** Process one ethernet frame containing an ARP message. - Returns a response frame, if one is needed. *) + (** Process one ethernet frame containing an ARP message. Returns a response + frame, if one is needed. *) end diff --git a/command.ml b/command.ml index da70727..0661bfc 100644 --- a/command.ml +++ b/command.ml @@ -4,24 +4,30 @@ (** Commands we provide via qvm-run. *) open Lwt - module Flow = Qubes.RExec.Flow let src = Logs.Src.create "command" ~doc:"qrexec command handler" + module Log = (val Logs.src_log src : Logs.LOG) let set_date_time flow = Flow.read_line flow >|= function - | `Eof -> Log.warn (fun f -> f "EOF reading time from dom0"); 1 - | `Ok line -> Log.info (fun f -> f "TODO: set time to %S" line); 0 + | `Eof -> + Log.warn (fun f -> f "EOF reading time from dom0"); + 1 + | `Ok line -> + Log.info (fun f -> f "TODO: set time to %S" line); + 0 let handler ~user:_ cmd flow = (* Write a message to the client and return an exit status of 1. *) let error fmt = - fmt |> Printf.ksprintf @@ fun s -> - Log.warn (fun f -> f "<< %s" s); - Flow.ewritef flow "%s [while processing %S]" s cmd >|= fun () -> 1 in + fmt + |> Printf.ksprintf @@ fun s -> + Log.warn (fun f -> f "<< %s" s); + Flow.ewritef flow "%s [while processing %S]" s cmd >|= fun () -> 1 + in match cmd with | "QUBESRPC qubes.SetDateTime dom0" -> set_date_time flow - | "QUBESRPC qubes.WaitForSession none" -> return 0 (* Always ready! *) + | "QUBESRPC qubes.WaitForSession none" -> return 0 (* Always ready! *) | cmd -> error "Unknown command %S" cmd diff --git a/config.ml b/config.ml index 5c06a4b..b663813 100644 --- a/config.ml +++ b/config.ml @@ -7,24 +7,24 @@ open Mirage let main = - main - ~packages:[ - package "vchan" ~min:"4.0.2"; - package "cstruct"; - package "tcpip" ~min:"3.7.0"; - package ~min:"2.3.0" ~sublibs:["mirage"] "arp"; - package ~min:"3.0.0" "ethernet"; - package "shared-memory-ring" ~min:"3.0.0"; - package "mirage-net-xen" ~min:"2.1.4"; - package "ipaddr" ~min:"5.2.0"; - package "mirage-qubes" ~min:"0.9.1"; - package ~min:"3.0.1" "mirage-nat"; - package "mirage-logs"; - package "mirage-xen" ~min:"8.0.0"; - package ~min:"6.4.0" "dns-client"; - package "pf-qubes"; - ] + main + ~packages: + [ + package "vchan" ~min:"4.0.2"; + package "cstruct"; + package "tcpip" ~min:"3.7.0"; + package ~min:"2.3.0" ~sublibs:[ "mirage" ] "arp"; + package ~min:"3.0.0" "ethernet"; + package "shared-memory-ring" ~min:"3.0.0"; + package "mirage-net-xen" ~min:"2.1.4"; + package "ipaddr" ~min:"5.2.0"; + package "mirage-qubes" ~min:"0.9.1"; + package ~min:"3.0.1" "mirage-nat"; + package "mirage-logs"; + package "mirage-xen" ~min:"8.0.0"; + package ~min:"6.4.0" "dns-client"; + package "pf-qubes"; + ] "Unikernel" job -let () = - register "qubes-firewall" [main] +let () = register "qubes-firewall" [ main ] diff --git a/dao.ml b/dao.ml index 9344c1f..9219fa6 100644 --- a/dao.ml +++ b/dao.ml @@ -5,35 +5,34 @@ open Lwt.Infix open Qubes let src = Logs.Src.create "dao" ~doc:"QubesDB data access" + module Log = (val Logs.src_log src : Logs.LOG) module ClientVif = struct - type t = { - domid : int; - device_id : int; - } + type t = { domid : int; device_id : int } - let pp f { domid; device_id } = Fmt.pf f "{domid=%d;device_id=%d}" domid device_id + let pp f { domid; device_id } = + Fmt.pf f "{domid=%d;device_id=%d}" domid device_id let compare = compare end + module VifMap = struct - include Map.Make(ClientVif) + include Map.Make (ClientVif) + let rec of_list = function | [] -> empty | (k, v) :: rest -> add k v (of_list rest) - let find key t = - try Some (find key t) - with Not_found -> None + + let find key t = try Some (find key t) with Not_found -> None end let directory ~handle dir = Xen_os.Xs.directory handle dir >|= function - | [""] -> [] (* XenStore client bug *) + | [ "" ] -> [] (* XenStore client bug *) | items -> items -let db_root client_ip = - "/qubes-firewall/" ^ (Ipaddr.V4.to_string client_ip) +let db_root client_ip = "/qubes-firewall/" ^ Ipaddr.V4.to_string client_ip let read_rules rules client_ip = let root = db_root client_ip in @@ -42,86 +41,101 @@ let read_rules rules client_ip = Log.debug (fun f -> f "reading %s" pattern); match Qubes.DB.KeyMap.find_opt pattern rules with | None -> - Log.debug (fun f -> f "rule %d does not exist; won't look for more" n); - Ok (List.rev l) - | Some rule -> - Log.debug (fun f -> f "rule %d: %s" n rule); - match Pf_qubes.Parse_qubes.parse_qubes ~number:n rule with - | Error e -> Log.warn (fun f -> f "Error parsing rule %d: %s" n e); Error e - | Ok rule -> - Log.debug (fun f -> f "parsed rule: %a" Pf_qubes.Parse_qubes.pp_rule rule); - get_rule (n+1) (rule :: l) + Log.debug (fun f -> f "rule %d does not exist; won't look for more" n); + Ok (List.rev l) + | Some rule -> ( + Log.debug (fun f -> f "rule %d: %s" n rule); + match Pf_qubes.Parse_qubes.parse_qubes ~number:n rule with + | Error e -> + Log.warn (fun f -> f "Error parsing rule %d: %s" n e); + Error e + | Ok rule -> + Log.debug (fun f -> + f "parsed rule: %a" Pf_qubes.Parse_qubes.pp_rule rule); + get_rule (n + 1) (rule :: l)) in 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 = None; - icmp_type = None; - number = 0;})] + 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 = None; + icmp_type = None; + number = 0; + }; + ] let vifs client domid = let open Lwt.Syntax in match int_of_string_opt domid with - | None -> Log.err (fun f -> f "Invalid domid %S" domid); Lwt.return [] + | None -> + Log.err (fun f -> f "Invalid domid %S" domid); + Lwt.return [] | Some domid -> - let path = Fmt.str "backend/vif/%d" domid in - let vifs_of_domain handle = - let* devices = directory ~handle path in - let ip_of_vif device_id = match int_of_string_opt 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 - let get_client_ip () = - let* str = Xen_os.Xs.read handle (Fmt.str "%s/%d/ip" path device_id) in - let client_ip = List.hd (String.split_on_char ' ' str) in - (* NOTE(dinosaure): it's safe to use [List.hd] here, + let path = Fmt.str "backend/vif/%d" domid in + let vifs_of_domain handle = + let* devices = directory ~handle path in + let ip_of_vif device_id = + match int_of_string_opt 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 + let get_client_ip () = + let* str = + Xen_os.Xs.read handle (Fmt.str "%s/%d/ip" path device_id) + in + let client_ip = List.hd (String.split_on_char ' ' str) in + (* NOTE(dinosaure): it's safe to use [List.hd] here, [String.split_on_char] can not return an empty list. *) - Lwt.return_some (vif, Ipaddr.V4.of_string_exn client_ip) - in - Lwt.catch get_client_ip @@ function - | Xs_protocol.Enoent _ -> Lwt.return_none - | Ipaddr.Parse_error (msg, client_ip) -> - Log.err (fun f -> f "Error parsing IP address of %a from %s: %s" - ClientVif.pp vif client_ip msg); - Lwt.return_none - | exn -> - Log.err (fun f -> f "Error getting IP address of %a: %s" - ClientVif.pp vif (Printexc.to_string exn)); - Lwt.return_none + Lwt.return_some (vif, Ipaddr.V4.of_string_exn client_ip) + in + Lwt.catch get_client_ip @@ function + | Xs_protocol.Enoent _ -> Lwt.return_none + | Ipaddr.Parse_error (msg, client_ip) -> + Log.err (fun f -> + f "Error parsing IP address of %a from %s: %s" + ClientVif.pp vif client_ip msg); + Lwt.return_none + | exn -> + Log.err (fun f -> + f "Error getting IP address of %a: %s" ClientVif.pp vif + (Printexc.to_string exn)); + Lwt.return_none) + in + Lwt_list.filter_map_p ip_of_vif devices in - Lwt_list.filter_map_p ip_of_vif devices - in - Xen_os.Xs.immediate client vifs_of_domain + Xen_os.Xs.immediate client vifs_of_domain let watch_clients fn = Xen_os.Xs.make () >>= fun xs -> let backend_vifs = "backend/vif" in Log.info (fun f -> f "Watching %s" backend_vifs); Xen_os.Xs.wait xs (fun handle -> - begin Lwt.catch - (fun () -> directory ~handle backend_vifs) - (function - | Xs_protocol.Enoent _ -> Lwt.return [] - | ex -> Lwt.fail ex) - end >>= fun items -> - Xen_os.Xs.make () >>= fun xs -> - Lwt_list.map_p (vifs xs) items >>= fun items -> - fn (List.concat items |> VifMap.of_list) >>= fun () -> - (* Wait for further updates *) - Lwt.fail Xs_protocol.Eagain - ) + Lwt.catch + (fun () -> directory ~handle backend_vifs) + (function Xs_protocol.Enoent _ -> Lwt.return [] | ex -> Lwt.fail ex) + >>= fun items -> + Xen_os.Xs.make () >>= fun xs -> + Lwt_list.map_p (vifs xs) items >>= fun items -> + fn (List.concat items |> VifMap.of_list) >>= fun () -> + (* Wait for further updates *) + Lwt.fail Xs_protocol.Eagain) type network_config = { - from_cmdline : bool; (* Specify if we have network configuration from command line or from qubesDB*) - netvm_ip : Ipaddr.V4.t; (* The IP address of NetVM (our gateway) *) - our_ip : Ipaddr.V4.t; (* The IP address of our interface to NetVM *) + from_cmdline : bool; + (* Specify if we have network configuration from command line or from qubesDB*) + netvm_ip : Ipaddr.V4.t; (* The IP address of NetVM (our gateway) *) + our_ip : Ipaddr.V4.t; (* The IP address of our interface to NetVM *) dns : Ipaddr.V4.t; dns2 : Ipaddr.V4.t; } @@ -132,31 +146,36 @@ let try_read_network_config db = let get name = match DB.KeyMap.find_opt name db with | None -> raise (Missing_key name) - | Some value -> Ipaddr.V4.of_string_exn value in - let our_ip = get "/qubes-ip" in (* - IP address for this VM (only when VM has netvm set) *) - let netvm_ip = get "/qubes-gateway" in (* - default gateway IP (only when VM has netvm set); VM should add host route to this address directly via eth0 (or whatever default interface name is) *) + | Some value -> Ipaddr.V4.of_string_exn value + in + let our_ip = get "/qubes-ip" in + (* - IP address for this VM (only when VM has netvm set) *) + let netvm_ip = get "/qubes-gateway" in + (* - default gateway IP (only when VM has netvm set); VM should add host route to this address directly via eth0 (or whatever default interface name is) *) let dns = get "/qubes-primary-dns" in let dns2 = get "/qubes-secondary-dns" in - { from_cmdline=false; netvm_ip ; our_ip ; dns ; dns2 } + { from_cmdline = false; netvm_ip; our_ip; dns; dns2 } let read_network_config qubesDB = let rec aux bindings = try Lwt.return (try_read_network_config bindings) with Missing_key key -> - Log.warn (fun f -> f "QubesDB key %S not (yet) present; waiting for QubesDB to change..." key); + Log.warn (fun f -> + f "QubesDB key %S not (yet) present; waiting for QubesDB to change..." + key); DB.after qubesDB bindings >>= aux in aux (DB.bindings qubesDB) let print_network_config config = - Log.info (fun f -> f "@[Current network configuration (QubesDB or command line):@,\ - NetVM IP on uplink network: %a@,\ - Our IP on client networks: %a@,\ - DNS primary resolver: %a@,\ - DNS secondary resolver: %a@]" - Ipaddr.V4.pp config.netvm_ip - Ipaddr.V4.pp config.our_ip - Ipaddr.V4.pp config.dns - Ipaddr.V4.pp config.dns2) + Log.info (fun f -> + f + "@[Current network configuration (QubesDB or command line):@,\ + NetVM IP on uplink network: %a@,\ + Our IP on client networks: %a@,\ + DNS primary resolver: %a@,\ + DNS secondary resolver: %a@]" + Ipaddr.V4.pp config.netvm_ip Ipaddr.V4.pp config.our_ip Ipaddr.V4.pp + config.dns Ipaddr.V4.pp config.dns2) let set_iptables_error db = Qubes.DB.write db "/qubes-iptables-error" diff --git a/dao.mli b/dao.mli index c278d16..85f8912 100644 --- a/dao.mli +++ b/dao.mli @@ -4,40 +4,43 @@ (** Wrapper for XenStore and QubesDB databases. *) module ClientVif : sig - type t = { - domid : int; - device_id : int; - } + type t = { domid : int; device_id : int } + val pp : t Fmt.t end + module VifMap : sig include Map.S with type key = ClientVif.t + val find : key -> 'a t -> 'a option end val watch_clients : (Ipaddr.V4.t VifMap.t -> unit Lwt.t) -> 'a Lwt.t -(** [watch_clients fn] calls [fn clients] with the list of backend clients - in XenStore, and again each time XenStore updates. *) +(** [watch_clients fn] calls [fn clients] with the list of backend clients in + XenStore, and again each time XenStore updates. *) type network_config = { - from_cmdline : bool; (* Specify if we have network configuration from command line or from qubesDB*) - netvm_ip : Ipaddr.V4.t; (* The IP address of NetVM (our gateway) *) - our_ip : Ipaddr.V4.t; (* The IP address of our interface to NetVM *) + from_cmdline : bool; + (* Specify if we have network configuration from command line or from qubesDB*) + netvm_ip : Ipaddr.V4.t; (* The IP address of NetVM (our gateway) *) + our_ip : Ipaddr.V4.t; (* The IP address of our interface to NetVM *) dns : Ipaddr.V4.t; dns2 : Ipaddr.V4.t; } 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. *) +(** [read_network_config db] fetches the configuration from QubesDB. If it isn't + there yet, it waits until it is. *) val db_root : Ipaddr.V4.t -> string -(** Returns the root path of the firewall rules in the QubesDB for a given IP address. *) +(** Returns the root path of the firewall rules in the QubesDB for a given IP + address. *) -val read_rules : string Qubes.DB.KeyMap.t -> Ipaddr.V4.t -> Pf_qubes.Parse_qubes.rule list -(** [read_rules bindings ip] extracts firewall rule information for [ip] from [bindings]. - If any rules fail to parse, it will return only one rule denying all traffic. *) +val read_rules : + string Qubes.DB.KeyMap.t -> Ipaddr.V4.t -> Pf_qubes.Parse_qubes.rule list +(** [read_rules bindings ip] extracts firewall rule information for [ip] from + [bindings]. If any rules fail to parse, it will return only one rule denying + all traffic. *) val print_network_config : network_config -> unit - val set_iptables_error : Qubes.DB.t -> string -> unit Lwt.t diff --git a/dispatcher.ml b/dispatcher.ml index 9f6db7f..9d67f88 100644 --- a/dispatcher.ml +++ b/dispatcher.ml @@ -7,158 +7,161 @@ module UplinkEth = Ethernet.Make (Netif) let src = Logs.Src.create "dispatcher" ~doc:"Networking dispatch" module Log = (val Logs.src_log src : Logs.LOG) +module Arp = Arp.Make (UplinkEth) +module I = Static_ipv4.Make (UplinkEth) (Arp) +module U = Udp.Make (I) - module Arp = Arp.Make (UplinkEth) - module I = Static_ipv4.Make (UplinkEth) (Arp) - module U = Udp.Make (I) +class client_iface eth ~domid ~gateway_ip ~client_ip client_mac : client_link = + let log_header = Fmt.str "dom%d:%a" domid Ipaddr.V4.pp client_ip in + object + val mutable rules = [] + method get_rules = rules + method set_rules new_db = rules <- Dao.read_rules new_db client_ip + method my_mac = ClientEth.mac eth + method other_mac = client_mac + method my_ip = gateway_ip + method other_ip = client_ip - class client_iface eth ~domid ~gateway_ip ~client_ip client_mac : client_link - = - let log_header = Fmt.str "dom%d:%a" domid Ipaddr.V4.pp client_ip in - object - val mutable rules = [] - method get_rules = rules - method set_rules new_db = rules <- Dao.read_rules new_db client_ip - method my_mac = ClientEth.mac eth - method other_mac = client_mac - method my_ip = gateway_ip - method other_ip = client_ip + method writev proto fillfn = + Lwt.catch + (fun () -> + ClientEth.write eth client_mac proto fillfn >|= function + | Ok () -> () + | Error e -> + Log.err (fun f -> + f "error trying to send to client: @[%a@]" ClientEth.pp_error + e)) + (fun ex -> + (* Usually Netback_shutdown, because the client disconnected *) + Log.err (fun f -> + f "uncaught exception trying to send to client: @[%s@]" + (Printexc.to_string ex)); + Lwt.return_unit) - method writev proto fillfn = - Lwt.catch - (fun () -> - ClientEth.write eth client_mac proto fillfn >|= function - | Ok () -> () - | Error e -> - Log.err (fun f -> - f "error trying to send to client: @[%a@]" - ClientEth.pp_error e)) - (fun ex -> - (* Usually Netback_shutdown, because the client disconnected *) - Log.err (fun f -> - f "uncaught exception trying to send to client: @[%s@]" - (Printexc.to_string ex)); - Lwt.return_unit) + method log_header = log_header + end - method log_header = log_header - end +class netvm_iface eth mac ~my_ip ~other_ip : interface = + object + method my_mac = UplinkEth.mac eth + method my_ip = my_ip + method other_ip = other_ip - class netvm_iface eth mac ~my_ip ~other_ip : interface = - object - method my_mac = UplinkEth.mac eth - method my_ip = my_ip - method other_ip = other_ip + method writev ethertype fillfn = + Lwt.catch + (fun () -> + mac >>= fun dst -> + UplinkEth.write eth dst ethertype fillfn + >|= or_raise "Write to uplink" UplinkEth.pp_error) + (fun ex -> + Log.err (fun f -> + f "uncaught exception trying to send to uplink: @[%s@]" + (Printexc.to_string ex)); + Lwt.return_unit) + end - method writev ethertype fillfn = - Lwt.catch - (fun () -> - mac >>= fun dst -> - UplinkEth.write eth dst ethertype fillfn - >|= or_raise "Write to uplink" UplinkEth.pp_error) - (fun ex -> - Log.err (fun f -> - f "uncaught exception trying to send to uplink: @[%s@]" - (Printexc.to_string ex)); - Lwt.return_unit) - end +type uplink = { + net : Netif.t; + eth : UplinkEth.t; + arp : Arp.t; + interface : interface; + mutable fragments : Fragments.Cache.t; + ip : I.t; + udp : U.t; +} - type uplink = { - net : Netif.t; - eth : UplinkEth.t; - arp : Arp.t; - interface : interface; - mutable fragments : Fragments.Cache.t; - ip : I.t; - udp : U.t; +type t = { + uplink_connected : unit Lwt_condition.t; + uplink_disconnect : unit Lwt_condition.t; + uplink_disconnected : unit Lwt_condition.t; + mutable config : Dao.network_config; + clients : Client_eth.t; + nat : My_nat.t; + mutable uplink : uplink option; +} + +let create ~config ~clients ~nat ~uplink = + { + uplink_connected = Lwt_condition.create (); + uplink_disconnect = Lwt_condition.create (); + uplink_disconnected = Lwt_condition.create (); + config; + clients; + nat; + uplink; } - type t = { - uplink_connected : unit Lwt_condition.t; - uplink_disconnect : unit Lwt_condition.t; - uplink_disconnected : unit Lwt_condition.t; - mutable config : Dao.network_config; - clients : Client_eth.t; - nat : My_nat.t; - mutable uplink : uplink option; - } +let update t ~config ~uplink = + t.config <- config; + t.uplink <- uplink; + Lwt.return_unit - let create ~config ~clients ~nat ~uplink = - { - uplink_connected = Lwt_condition.create (); - uplink_disconnect = Lwt_condition.create (); - uplink_disconnected = Lwt_condition.create (); - config; - clients; - nat; - uplink; - } - - let update t ~config ~uplink = - t.config <- config; - t.uplink <- uplink; - Lwt.return_unit - - let target t buf = - let dst_ip = buf.Ipv4_packet.dst in - match Client_eth.lookup t.clients dst_ip with - | Some client_link -> Some (client_link :> interface) - | None -> ( (* if dest is not a client, transfer it to our uplink *) - match t.uplink with - | None -> ( - match Client_eth.lookup t.clients t.config.netvm_ip with - | Some uplink -> - Some (uplink :> interface) - | None -> - Log.err (fun f -> f "We have a command line configuration %a but it's currently not connected to us (please check its netvm property)...%!" Ipaddr.V4.pp t.config.netvm_ip); +let target t buf = + let dst_ip = buf.Ipv4_packet.dst in + match Client_eth.lookup t.clients dst_ip with + | Some client_link -> Some (client_link :> interface) + | None -> ( + (* if dest is not a client, transfer it to our uplink *) + match t.uplink with + | None -> ( + match Client_eth.lookup t.clients t.config.netvm_ip with + | Some uplink -> Some (uplink :> interface) + | None -> + Log.err (fun f -> + f + "We have a command line configuration %a but it's \ + currently not connected to us (please check its netvm \ + property)...%!" + Ipaddr.V4.pp t.config.netvm_ip); None) - | Some uplink -> Some uplink.interface) + | Some uplink -> Some uplink.interface) - let add_client t = Client_eth.add_client t.clients - let remove_client t = Client_eth.remove_client t.clients +let add_client t = Client_eth.add_client t.clients +let remove_client t = Client_eth.remove_client t.clients - let classify t ip = - if ip = Ipaddr.V4 t.config.our_ip then `Firewall - else if ip = Ipaddr.V4 t.config.netvm_ip then `NetVM - else (Client_eth.classify t.clients ip :> Packet.host) +let classify t ip = + if ip = Ipaddr.V4 t.config.our_ip then `Firewall + else if ip = Ipaddr.V4 t.config.netvm_ip then `NetVM + else (Client_eth.classify t.clients ip :> Packet.host) - let resolve t = function - | `Firewall -> Ipaddr.V4 t.config.our_ip - | `NetVM -> Ipaddr.V4 t.config.netvm_ip - | #Client_eth.host as host -> Client_eth.resolve t.clients host +let resolve t = function + | `Firewall -> Ipaddr.V4 t.config.our_ip + | `NetVM -> Ipaddr.V4 t.config.netvm_ip + | #Client_eth.host as host -> Client_eth.resolve t.clients host - (* Transmission *) +(* Transmission *) - let transmit_ipv4 packet iface = - Lwt.catch - (fun () -> - let fragments = ref [] in - iface#writev `IPv4 (fun b -> - match Nat_packet.into_cstruct packet b with - | Error e -> - Log.warn (fun f -> - f "Failed to write packet to %a: %a" Ipaddr.V4.pp - iface#other_ip Nat_packet.pp_error e); - 0 - | Ok (n, frags) -> - fragments := frags; - n) - >>= fun () -> - Lwt_list.iter_s - (fun f -> - let size = Cstruct.length f in - iface#writev `IPv4 (fun b -> - Cstruct.blit f 0 b 0 size; - size)) - !fragments) - (fun ex -> - Log.warn (fun f -> - f "Failed to write packet to %a: %s" Ipaddr.V4.pp iface#other_ip - (Printexc.to_string ex)); - Lwt.return_unit) +let transmit_ipv4 packet iface = + Lwt.catch + (fun () -> + let fragments = ref [] in + iface#writev `IPv4 (fun b -> + match Nat_packet.into_cstruct packet b with + | Error e -> + Log.warn (fun f -> + f "Failed to write packet to %a: %a" Ipaddr.V4.pp + iface#other_ip Nat_packet.pp_error e); + 0 + | Ok (n, frags) -> + fragments := frags; + n) + >>= fun () -> + Lwt_list.iter_s + (fun f -> + let size = Cstruct.length f in + iface#writev `IPv4 (fun b -> + Cstruct.blit f 0 b 0 size; + size)) + !fragments) + (fun ex -> + Log.warn (fun f -> + f "Failed to write packet to %a: %s" Ipaddr.V4.pp iface#other_ip + (Printexc.to_string ex)); + Lwt.return_unit) - let forward_ipv4 t packet = - let (`IPv4 (ip, _)) = packet in - Lwt.catch +let forward_ipv4 t packet = + let (`IPv4 (ip, _)) = packet in + Lwt.catch (fun () -> match target t ip with | Some iface -> transmit_ipv4 packet iface @@ -170,460 +173,463 @@ module Log = (val Logs.src_log src : Logs.LOG) (Printexc.to_string ex)); Lwt.return_unit) - (* NAT *) +(* NAT *) - let translate t packet = My_nat.translate t.nat packet +let translate t packet = My_nat.translate t.nat packet - (* Add a NAT rule for the endpoints in this frame, via a random port on the firewall. *) - let add_nat_and_forward_ipv4 t packet = - let xl_host = t.config.our_ip in - match My_nat.add_nat_rule_and_translate t.nat ~xl_host `NAT packet with - | Ok packet -> forward_ipv4 t packet - | Error e -> - Log.warn (fun f -> - f "Failed to add NAT rewrite rule: %s (%a)" e Nat_packet.pp packet); - Lwt.return_unit +(* Add a NAT rule for the endpoints in this frame, via a random port on the firewall. *) +let add_nat_and_forward_ipv4 t packet = + let xl_host = t.config.our_ip in + match My_nat.add_nat_rule_and_translate t.nat ~xl_host `NAT packet with + | Ok packet -> forward_ipv4 t packet + | Error e -> + Log.warn (fun f -> + f "Failed to add NAT rewrite rule: %s (%a)" e Nat_packet.pp packet); + Lwt.return_unit - (* Add a NAT rule to redirect this conversation to [host:port] instead of us. *) - let nat_to t ~host ~port packet = - match resolve t host with - | Ipaddr.V6 _ -> - Log.warn (fun f -> f "Cannot NAT with IPv6"); - Lwt.return_unit - | Ipaddr.V4 target -> ( - let xl_host = t.config.our_ip in - match - My_nat.add_nat_rule_and_translate t.nat ~xl_host - (`Redirect (target, port)) - packet - with - | Ok packet -> forward_ipv4 t packet - | Error e -> - Log.warn (fun f -> - f "Failed to add NAT redirect rule: %s (%a)" e Nat_packet.pp - packet); - Lwt.return_unit) +(* Add a NAT rule to redirect this conversation to [host:port] instead of us. *) +let nat_to t ~host ~port packet = + match resolve t host with + | Ipaddr.V6 _ -> + Log.warn (fun f -> f "Cannot NAT with IPv6"); + Lwt.return_unit + | Ipaddr.V4 target -> ( + let xl_host = t.config.our_ip in + match + My_nat.add_nat_rule_and_translate t.nat ~xl_host + (`Redirect (target, port)) + packet + with + | Ok packet -> forward_ipv4 t packet + | Error e -> + Log.warn (fun f -> + f "Failed to add NAT redirect rule: %s (%a)" e Nat_packet.pp + packet); + Lwt.return_unit) - let apply_rules t (rules : ('a, 'b) Packet.t -> Packet.action Lwt.t) ~dst - (annotated_packet : ('a, 'b) Packet.t) : unit Lwt.t = - let packet = Packet.to_mirage_nat_packet annotated_packet in - rules annotated_packet >>= fun action -> - match (action, dst) with - | `Accept, `Client client_link -> transmit_ipv4 packet client_link - | `Accept, (`External _ | `NetVM) -> ( - match t.uplink with - | Some uplink -> transmit_ipv4 packet uplink.interface - | None -> ( - match Client_eth.lookup t.clients t.config.netvm_ip with - | Some iface -> transmit_ipv4 packet iface - | None -> - Log.warn (fun f -> - f "No output interface for %a : drop" Nat_packet.pp packet); - Lwt.return_unit)) - | `Accept, `Firewall -> - Log.warn (fun f -> - f "Bad rule: firewall can't accept packets %a" Nat_packet.pp packet); - Lwt.return_unit - | `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.debug (fun f -> - f "Dropped packet (%s) %a" reason Nat_packet.pp packet); - Lwt.return_unit +let apply_rules t (rules : ('a, 'b) Packet.t -> Packet.action Lwt.t) ~dst + (annotated_packet : ('a, 'b) Packet.t) : unit Lwt.t = + let packet = Packet.to_mirage_nat_packet annotated_packet in + rules annotated_packet >>= fun action -> + match (action, dst) with + | `Accept, `Client client_link -> transmit_ipv4 packet client_link + | `Accept, (`External _ | `NetVM) -> ( + match t.uplink with + | Some uplink -> transmit_ipv4 packet uplink.interface + | None -> ( + match Client_eth.lookup t.clients t.config.netvm_ip with + | Some iface -> transmit_ipv4 packet iface + | None -> + Log.warn (fun f -> + f "No output interface for %a : drop" Nat_packet.pp packet); + Lwt.return_unit)) + | `Accept, `Firewall -> + Log.warn (fun f -> + f "Bad rule: firewall can't accept packets %a" Nat_packet.pp packet); + Lwt.return_unit + | `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.debug (fun f -> + f "Dropped packet (%s) %a" reason Nat_packet.pp packet); + Lwt.return_unit - let ipv4_from_netvm t packet = - match Memory_pressure.status () with - | `Memory_critical -> Lwt.return_unit - | `Ok -> ( - let (`IPv4 (ip, _transport)) = packet in - let src = classify t (Ipaddr.V4 ip.Ipv4_packet.src) in - let dst = classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in - match Packet.of_mirage_nat_packet ~src ~dst packet with - | None -> Lwt.return_unit - | Some _ -> ( - match src with - | `Client _ | `Firewall -> - Log.warn (fun f -> - f "Frame from NetVM has internal source IP address! %a" - Nat_packet.pp packet); - Lwt.return_unit - | (`External _ | `NetVM) as src -> ( - match translate t packet with - | Some frame -> forward_ipv4 t frame - | None -> ( - match Packet.of_mirage_nat_packet ~src ~dst packet with - | None -> Lwt.return_unit - | Some packet -> apply_rules t Rules.from_netvm ~dst packet) - ))) +let ipv4_from_netvm t packet = + match Memory_pressure.status () with + | `Memory_critical -> Lwt.return_unit + | `Ok -> ( + let (`IPv4 (ip, _transport)) = packet in + let src = classify t (Ipaddr.V4 ip.Ipv4_packet.src) in + let dst = classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in + match Packet.of_mirage_nat_packet ~src ~dst packet with + | None -> Lwt.return_unit + | Some _ -> ( + match src with + | `Client _ | `Firewall -> + Log.warn (fun f -> + f "Frame from NetVM has internal source IP address! %a" + Nat_packet.pp packet); + Lwt.return_unit + | (`External _ | `NetVM) as src -> ( + match translate t packet with + | Some frame -> forward_ipv4 t frame + | None -> ( + match Packet.of_mirage_nat_packet ~src ~dst packet with + | None -> Lwt.return_unit + | Some packet -> apply_rules t Rules.from_netvm ~dst packet))) + ) - let ipv4_from_client resolver dns_servers t ~src packet = - match Memory_pressure.status () with - | `Memory_critical -> Lwt.return_unit - | `Ok -> ( - (* Check for existing NAT entry for this packet *) - match translate t packet with - | Some frame -> - forward_ipv4 t frame (* Some existing connection or redirect *) - | None -> ( - (* No existing NAT entry. Check the firewall rules. *) - let (`IPv4 (ip, _transport)) = packet in - match classify t (Ipaddr.V4 ip.Ipv4_packet.src) with - | `Client _ | `Firewall -> ( - let dst = classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in - match - Packet.of_mirage_nat_packet ~src:(`Client src) ~dst packet - with - | None -> Lwt.return_unit - | Some firewall_packet -> - apply_rules t - (Rules.from_client resolver dns_servers) - ~dst firewall_packet) - | `NetVM -> ipv4_from_netvm t packet - | `External _ -> - Log.warn (fun f -> - f "Frame from Inside has external source IP address! %a" - Nat_packet.pp packet); - Lwt.return_unit)) +let ipv4_from_client resolver dns_servers t ~src packet = + match Memory_pressure.status () with + | `Memory_critical -> Lwt.return_unit + | `Ok -> ( + (* Check for existing NAT entry for this packet *) + match translate t packet with + | Some frame -> + forward_ipv4 t frame (* Some existing connection or redirect *) + | None -> ( + (* No existing NAT entry. Check the firewall rules. *) + let (`IPv4 (ip, _transport)) = packet in + match classify t (Ipaddr.V4 ip.Ipv4_packet.src) with + | `Client _ | `Firewall -> ( + let dst = classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in + match + Packet.of_mirage_nat_packet ~src:(`Client src) ~dst packet + with + | None -> Lwt.return_unit + | Some firewall_packet -> + apply_rules t + (Rules.from_client resolver dns_servers) + ~dst firewall_packet) + | `NetVM -> ipv4_from_netvm t packet + | `External _ -> + Log.warn (fun f -> + f "Frame from Inside has external source IP address! %a" + Nat_packet.pp packet); + Lwt.return_unit)) - (** Handle an ARP message from the client. *) - let client_handle_arp ~fixed_arp ~iface request = - match Arp_packet.decode request with - | Error e -> - Log.warn (fun f -> - f "Ignored unknown ARP message: %a" Arp_packet.pp_error e); - Lwt.return_unit - | Ok arp -> ( - match Client_eth.ARP.input fixed_arp arp with - | None -> Lwt.return_unit - | Some response -> +(** Handle an ARP message from the client. *) +let client_handle_arp ~fixed_arp ~iface request = + match Arp_packet.decode request with + | Error e -> + Log.warn (fun f -> + f "Ignored unknown ARP message: %a" Arp_packet.pp_error e); + Lwt.return_unit + | Ok arp -> ( + match Client_eth.ARP.input fixed_arp arp with + | None -> Lwt.return_unit + | Some response -> Lwt.catch (fun () -> - iface#writev `ARP (fun b -> - Arp_packet.encode_into response b; - Arp_packet.size)) + iface#writev `ARP (fun b -> + Arp_packet.encode_into response b; + Arp_packet.size)) (fun ex -> Log.warn (fun f -> f "Failed to write APR to %a: %s" Ipaddr.V4.pp iface#other_ip (Printexc.to_string ex)); - Lwt.return_unit) - ) + Lwt.return_unit)) - (** Handle an IPv4 packet from the client. *) - let client_handle_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 - | Error e -> +(** Handle an IPv4 packet from the client. *) +let client_handle_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 + | Error e -> + Log.warn (fun f -> + f "Ignored unknown IPv4 message: %a" Nat_packet.pp_error e); + Lwt.return_unit + | Ok None -> Lwt.return_unit + | Ok (Some packet) -> + let (`IPv4 (ip, _)) = packet in + let src = ip.Ipv4_packet.src in + if src = iface#other_ip then + ipv4_from_client dns_client dns_servers router ~src:iface packet + else if iface#other_ip = router.config.netvm_ip then + (* This can occurs when used with *BSD as netvm (and a gateway is set) *) + ipv4_from_netvm router packet + else ( Log.warn (fun f -> - f "Ignored unknown IPv4 message: %a" Nat_packet.pp_error e); - Lwt.return_unit - | Ok None -> Lwt.return_unit - | Ok (Some packet) -> - let (`IPv4 (ip, _)) = packet in - let src = ip.Ipv4_packet.src in - if src = iface#other_ip then - ipv4_from_client dns_client dns_servers router ~src:iface packet - else if iface#other_ip = router.config.netvm_ip then - (* This can occurs when used with *BSD as netvm (and a gateway is set) *) - ipv4_from_netvm router 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); - Lwt.return_unit) + f "Incorrect source IP %a in IP packet from %a (dropping)" + Ipaddr.V4.pp src Ipaddr.V4.pp iface#other_ip); + Lwt.return_unit) - (** Connect to a new client's interface and listen for incoming frames and firewall rule changes. *) - let conf_vif get_ts vif backend client_eth dns_client dns_servers - ~client_ip ~iface ~router ~cleanup_tasks qubesDB () = - let { Dao.ClientVif.domid; device_id } = vif in - Log.info (fun f -> - f "Client %d:%d (IP: %s) ready" domid device_id (Ipaddr.V4.to_string client_ip)); +(** Connect to a new client's interface and listen for incoming frames and + firewall rule changes. *) +let conf_vif get_ts vif backend client_eth dns_client dns_servers ~client_ip + ~iface ~router ~cleanup_tasks qubesDB () = + let { Dao.ClientVif.domid; device_id } = vif in + Log.info (fun f -> + f "Client %d:%d (IP: %s) ready" domid device_id + (Ipaddr.V4.to_string client_ip)); - (* update the rules whenever QubesDB notices a change for this IP *) - let qubesdb_updater = - Lwt.catch - (fun () -> - let rec update current_db current_rules = - Qubes.DB.got_new_commit qubesDB (Dao.db_root client_ip) current_db - >>= fun new_db -> - iface#set_rules new_db; - let new_rules = iface#get_rules in - if current_rules = new_rules then - Log.info (fun m -> - m "Rules did not change for %s" - (Ipaddr.V4.to_string client_ip)) - else ( - Log.info (fun m -> - m "New firewall rules for %s@.%a" - (Ipaddr.V4.to_string client_ip) - Fmt.(list ~sep:(any "@.") Pf_qubes.Parse_qubes.pp_rule) - new_rules); - (* empty NAT table if rules are updated: they might deny old connections *) - My_nat.remove_connections router.nat client_ip); - update new_db new_rules - in - update Qubes.DB.KeyMap.empty []) - (function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e) - in - Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel qubesdb_updater); + (* update the rules whenever QubesDB notices a change for this IP *) + let qubesdb_updater = + Lwt.catch + (fun () -> + let rec update current_db current_rules = + Qubes.DB.got_new_commit qubesDB (Dao.db_root client_ip) current_db + >>= fun new_db -> + iface#set_rules new_db; + let new_rules = iface#get_rules in + if current_rules = new_rules then + Log.info (fun m -> + m "Rules did not change for %s" (Ipaddr.V4.to_string client_ip)) + else ( + Log.info (fun m -> + m "New firewall rules for %s@.%a" + (Ipaddr.V4.to_string client_ip) + Fmt.(list ~sep:(any "@.") Pf_qubes.Parse_qubes.pp_rule) + new_rules); + (* empty NAT table if rules are updated: they might deny old connections *) + My_nat.remove_connections router.nat client_ip); + update new_db new_rules + in + update Qubes.DB.KeyMap.empty []) + (function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e) + in + Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel qubesdb_updater); - let fixed_arp = Client_eth.ARP.create ~net:client_eth iface in - let fragment_cache = ref (Fragments.Cache.empty (256 * 1024)) in - let listener = - Lwt.catch - (fun () -> - Netback.listen backend ~header_size:Ethernet.Packet.sizeof_ethernet - (fun frame -> - match Ethernet.Packet.of_cstruct frame with - | Error err -> - Log.warn (fun f -> f "Invalid Ethernet frame: %s" err); - Lwt.return_unit - | Ok (eth, payload) -> ( - match eth.Ethernet.Packet.ethertype with - | `ARP -> client_handle_arp ~fixed_arp ~iface payload - | `IPv4 -> - client_handle_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) - (function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e) - in - Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel listener); - (* NOTE(dinosaure): [qubes_updater] and [listener] can be forgotten, our [cleanup_task] + let fixed_arp = Client_eth.ARP.create ~net:client_eth iface in + let fragment_cache = ref (Fragments.Cache.empty (256 * 1024)) in + let listener = + Lwt.catch + (fun () -> + Netback.listen backend ~header_size:Ethernet.Packet.sizeof_ethernet + (fun frame -> + match Ethernet.Packet.of_cstruct frame with + | Error err -> + Log.warn (fun f -> f "Invalid Ethernet frame: %s" err); + Lwt.return_unit + | Ok (eth, payload) -> ( + match eth.Ethernet.Packet.ethertype with + | `ARP -> client_handle_arp ~fixed_arp ~iface payload + | `IPv4 -> + client_handle_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) + (function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e) + in + Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel listener); + (* NOTE(dinosaure): [qubes_updater] and [listener] can be forgotten, our [cleanup_task] will cancel them if the client is disconnected. *) - Lwt.async (fun () -> Lwt.pick [ qubesdb_updater; listener ]); + Lwt.async (fun () -> Lwt.pick [ qubesdb_updater; listener ]); + Lwt.return_unit + +(** A new client VM has been found in XenStore. Find its interface and connect + to it. *) +let add_client get_ts dns_client dns_servers ~router vif client_ip qubesDB = + let open Lwt.Syntax in + 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); + let { Dao.ClientVif.domid; device_id } = vif in + let* backend = Netback.make ~domid ~device_id in + let* eth = ClientEth.connect backend in + let client_mac = Netback.frontend_mac backend in + let client_eth = router.clients in + let gateway_ip = Client_eth.client_gw client_eth in + let iface = new client_iface eth ~domid ~gateway_ip ~client_ip client_mac in + + Cleanup.on_cleanup cleanup_tasks (fun () -> remove_client router iface); + Lwt.async (fun () -> + Lwt.catch + (fun () -> add_client router iface) + (fun ex -> + Log.warn (fun f -> + f "Error with client %a: %s" Dao.ClientVif.pp vif + (Printexc.to_string ex)); + Lwt.return_unit)); + + let* () = + Lwt.catch + (conf_vif get_ts vif backend client_eth dns_client dns_servers ~client_ip + ~iface ~router ~cleanup_tasks qubesDB) + @@ fun exn -> + Log.warn (fun f -> + f "Error with client %a: %s" Dao.ClientVif.pp vif + (Printexc.to_string exn)); Lwt.return_unit + in + Lwt.return cleanup_tasks - (** A new client VM has been found in XenStore. Find its interface and connect to it. *) - let add_client get_ts dns_client dns_servers ~router vif client_ip qubesDB = - let open Lwt.Syntax in - 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); - let { Dao.ClientVif.domid; device_id } = vif in - let* backend = Netback.make ~domid ~device_id in - let* eth = ClientEth.connect backend in - let client_mac = Netback.frontend_mac backend in - let client_eth = router.clients in - let gateway_ip = Client_eth.client_gw client_eth in - let iface = new client_iface eth ~domid ~gateway_ip ~client_ip client_mac in - - Cleanup.on_cleanup cleanup_tasks (fun () -> remove_client router iface); - Lwt.async (fun () -> - Lwt.catch - (fun () -> - add_client router iface) - (fun ex -> - Log.warn (fun f -> - f "Error with client %a: %s" Dao.ClientVif.pp vif - (Printexc.to_string ex)); - Lwt.return_unit)) ; - - let* () = - Lwt.catch ( - conf_vif get_ts vif backend client_eth dns_client dns_servers ~client_ip ~iface ~router - ~cleanup_tasks qubesDB) - @@ fun exn -> - Log.warn (fun f -> - f "Error with client %a: %s" Dao.ClientVif.pp vif - (Printexc.to_string exn)); - Lwt.return_unit - in - Lwt.return cleanup_tasks - - (** Watch XenStore for notifications of new clients. *) - let wait_clients get_ts dns_client dns_servers qubesDB router = - let open Lwt.Syntax in - let clients : Cleanup.t Dao.VifMap.t ref = ref Dao.VifMap.empty in - Dao.watch_clients @@ fun new_set -> - (* Check for removed clients *) - let clean_up_clients key cleanup = - if not (Dao.VifMap.mem key new_set) then begin - clients := !clients |> Dao.VifMap.remove key; - Log.info (fun f -> f "client %a has gone" Dao.ClientVif.pp key); - Cleanup.cleanup cleanup - end - in - Dao.VifMap.iter clean_up_clients !clients; - (* Check for added clients *) - let rec go seq = match Seq.uncons seq with - | None -> Lwt.return_unit - | Some ((key, ipaddr), seq) when not (Dao.VifMap.mem key !clients) -> - let* cleanup = add_client get_ts dns_client dns_servers ~router key ipaddr qubesDB in +(** Watch XenStore for notifications of new clients. *) +let wait_clients get_ts dns_client dns_servers qubesDB router = + let open Lwt.Syntax in + let clients : Cleanup.t Dao.VifMap.t ref = ref Dao.VifMap.empty in + Dao.watch_clients @@ fun new_set -> + (* Check for removed clients *) + let clean_up_clients key cleanup = + if not (Dao.VifMap.mem key new_set) then ( + clients := !clients |> Dao.VifMap.remove key; + Log.info (fun f -> f "client %a has gone" Dao.ClientVif.pp key); + Cleanup.cleanup cleanup) + in + Dao.VifMap.iter clean_up_clients !clients; + (* Check for added clients *) + let rec go seq = + match Seq.uncons seq with + | None -> Lwt.return_unit + | Some ((key, ipaddr), seq) when not (Dao.VifMap.mem key !clients) -> + let* cleanup = + add_client get_ts dns_client dns_servers ~router key ipaddr qubesDB + in Log.debug (fun f -> f "client %a arrived" Dao.ClientVif.pp key); clients := Dao.VifMap.add key cleanup !clients; go seq - | Some (_, seq) -> go seq - in - go (Dao.VifMap.to_seq new_set) + | Some (_, seq) -> go seq + in + go (Dao.VifMap.to_seq new_set) - let send_dns_client_query t ~src_port ~dst ~dst_port buf = - match t.uplink with - | None -> - Log.err (fun f -> f "No uplink interface"); - Lwt.return (Error (`Msg "failure")) - | Some uplink -> ( - Lwt.catch - (fun () -> - U.write ~src_port ~dst ~dst_port uplink.udp (Cstruct.of_string buf) >|= function - | Error s -> - Log.err (fun f -> f "error sending udp packet: %a" U.pp_error s); - Error (`Msg "failure") - | Ok () -> Ok ()) - (fun ex -> - Log.err (fun f -> - f "uncaught exception trying to send DNS request to uplink: @[%s@]" - (Printexc.to_string ex)); - Lwt.return (Error (`Msg "DNS request not sent")))) - - (** Wait for packet from our uplink (we must have an uplink here...). *) - let rec uplink_listen get_ts dns_responses router = - Lwt_condition.wait router.uplink_connected >>= fun () -> - match router.uplink with - | None -> +let send_dns_client_query t ~src_port ~dst ~dst_port buf = + match t.uplink with + | None -> + Log.err (fun f -> f "No uplink interface"); + Lwt.return (Error (`Msg "failure")) + | Some uplink -> + Lwt.catch + (fun () -> + U.write ~src_port ~dst ~dst_port uplink.udp (Cstruct.of_string buf) + >|= function + | Error s -> + Log.err (fun f -> f "error sending udp packet: %a" U.pp_error s); + Error (`Msg "failure") + | Ok () -> Ok ()) + (fun ex -> Log.err (fun f -> f - "Uplink is connected but not found in the router, retrying...%!"); - uplink_listen get_ts dns_responses router - | Some uplink -> - let listen = - Lwt.catch - (fun () -> - Netif.listen uplink.net ~header_size:Ethernet.Packet.sizeof_ethernet - (fun frame -> - (* Handle one Ethernet frame from NetVM *) - UplinkEth.input uplink.eth ~arpv4:(Arp.input uplink.arp) - ~ipv4:(fun ip -> - let cache, r = - Nat_packet.of_ipv4_packet uplink.fragments ~now:(get_ts ()) - ip - in - uplink.fragments <- cache; - begin match r with - | Error e -> - Log.warn (fun f -> - f "Ignored unknown IPv4 message from uplink: %a" - Nat_packet.pp_error e); - Lwt.return () - | Ok None -> Lwt.return_unit - | Ok (Some (`IPv4 (header, packet))) -> - let open Udp_packet in - Log.debug (fun f -> - f "received ipv4 packet from %a on uplink" Ipaddr.V4.pp - header.Ipv4_packet.src); - begin match packet with - | `UDP (header, packet) when My_nat.dns_port router.nat header.dst_port -> - Log.debug (fun f -> - f - "found a DNS packet whose dst_port (%d) was in the list of \ - dns_client ports" - header.dst_port); - Lwt_mvar.put dns_responses (header, Cstruct.to_string packet) - | _ -> ipv4_from_netvm router (`IPv4 (header, packet)) - end - end) - ~ipv6:(fun _ip -> Lwt.return_unit) - frame) - >|= or_raise "Uplink listen loop" Netif.pp_error) - (function Lwt.Canceled -> - (* We can be cancelled if reconnect_uplink is achieved (via the Lwt_condition), so we need to disconnect and broadcast when it's done - currently we delay 1s as Netif.disconnect is non-blocking... (need to fix upstream?) *) - Log.info (fun f -> - f "disconnecting from our uplink"); - U.disconnect uplink.udp >>= fun () -> - I.disconnect uplink.ip >>= fun () -> - (* mutable fragments : Fragments.Cache.t; *) - (* interface : interface; *) - Arp.disconnect uplink.arp >>= fun () -> - UplinkEth.disconnect uplink.eth >>= fun () -> - Netif.disconnect uplink.net >>= fun () -> - Lwt_condition.broadcast router.uplink_disconnected (); - Lwt.return_unit - | e -> Lwt.fail e) - in - let reconnect_uplink = - Lwt_condition.wait router.uplink_disconnect >>= fun () -> - Log.info (fun f -> - f "we need to reconnect to the new uplink"); - Lwt.return_unit - in - Lwt.pick [ listen ; reconnect_uplink ] >>= fun () -> - uplink_listen get_ts dns_responses router + "uncaught exception trying to send DNS request to uplink: \ + @[%s@]" + (Printexc.to_string ex)); + Lwt.return (Error (`Msg "DNS request not sent"))) - (** Connect to our uplink backend (we must have an uplink here...). *) - let connect config = - let my_ip = config.Dao.our_ip in - let gateway = config.Dao.netvm_ip in - Netif.connect "0" >>= fun net -> - UplinkEth.connect net >>= fun eth -> - Arp.connect eth >>= fun arp -> - Arp.add_ip arp my_ip >>= fun () -> - let cidr = Ipaddr.V4.Prefix.make 0 my_ip in - I.connect ~cidr ~gateway eth arp >>= fun ip -> - U.connect ip >>= fun udp -> - let netvm_mac = - Arp.query arp gateway >>= function - | Error e -> - Log.err(fun f -> f "Getting MAC of our NetVM: %a" Arp.pp_error e); - (* This mac address is a special address used by Qubes when the device +(** Wait for packet from our uplink (we must have an uplink here...). *) +let rec uplink_listen get_ts dns_responses router = + Lwt_condition.wait router.uplink_connected >>= fun () -> + match router.uplink with + | None -> + Log.err (fun f -> + f "Uplink is connected but not found in the router, retrying...%!"); + uplink_listen get_ts dns_responses router + | Some uplink -> + let listen = + Lwt.catch + (fun () -> + Netif.listen uplink.net ~header_size:Ethernet.Packet.sizeof_ethernet + (fun frame -> + (* Handle one Ethernet frame from NetVM *) + UplinkEth.input uplink.eth ~arpv4:(Arp.input uplink.arp) + ~ipv4:(fun ip -> + let cache, r = + Nat_packet.of_ipv4_packet uplink.fragments + ~now:(get_ts ()) ip + in + uplink.fragments <- cache; + match r with + | Error e -> + Log.warn (fun f -> + f "Ignored unknown IPv4 message from uplink: %a" + Nat_packet.pp_error e); + Lwt.return () + | Ok None -> Lwt.return_unit + | Ok (Some (`IPv4 (header, packet))) -> ( + let open Udp_packet in + Log.debug (fun f -> + f "received ipv4 packet from %a on uplink" + Ipaddr.V4.pp header.Ipv4_packet.src); + match packet with + | `UDP (header, packet) + when My_nat.dns_port router.nat header.dst_port -> + Log.debug (fun f -> + f + "found a DNS packet whose dst_port (%d) was \ + in the list of dns_client ports" + header.dst_port); + Lwt_mvar.put dns_responses + (header, Cstruct.to_string packet) + | _ -> ipv4_from_netvm router (`IPv4 (header, packet)))) + ~ipv6:(fun _ip -> Lwt.return_unit) + frame) + >|= or_raise "Uplink listen loop" Netif.pp_error) + (function + | Lwt.Canceled -> + (* We can be cancelled if reconnect_uplink is achieved (via the Lwt_condition), so we need to disconnect and broadcast when it's done + currently we delay 1s as Netif.disconnect is non-blocking... (need to fix upstream?) *) + Log.info (fun f -> f "disconnecting from our uplink"); + U.disconnect uplink.udp >>= fun () -> + I.disconnect uplink.ip >>= fun () -> + (* mutable fragments : Fragments.Cache.t; *) + (* interface : interface; *) + Arp.disconnect uplink.arp >>= fun () -> + UplinkEth.disconnect uplink.eth >>= fun () -> + Netif.disconnect uplink.net >>= fun () -> + Lwt_condition.broadcast router.uplink_disconnected (); + Lwt.return_unit + | e -> Lwt.fail e) + in + let reconnect_uplink = + Lwt_condition.wait router.uplink_disconnect >>= fun () -> + Log.info (fun f -> f "we need to reconnect to the new uplink"); + Lwt.return_unit + in + Lwt.pick [ listen; reconnect_uplink ] >>= fun () -> + uplink_listen get_ts dns_responses router + +(** Connect to our uplink backend (we must have an uplink here...). *) +let connect config = + let my_ip = config.Dao.our_ip in + let gateway = config.Dao.netvm_ip in + Netif.connect "0" >>= fun net -> + UplinkEth.connect net >>= fun eth -> + Arp.connect eth >>= fun arp -> + Arp.add_ip arp my_ip >>= fun () -> + let cidr = Ipaddr.V4.Prefix.make 0 my_ip in + I.connect ~cidr ~gateway eth arp >>= fun ip -> + U.connect ip >>= fun udp -> + let netvm_mac = + Arp.query arp gateway >>= function + | Error e -> + Log.err (fun f -> f "Getting MAC of our NetVM: %a" Arp.pp_error e); + (* This mac address is a special address used by Qubes when the device is not managed by Qubes itself. This can occurs inside a service AppVM (e.g. VPN) when the service creates a new interface. *) - Lwt.return (Macaddr.of_string_exn "fe:ff:ff:ff:ff:ff") - | Ok mac -> Lwt.return mac - in - let interface = - new netvm_iface eth netvm_mac ~my_ip ~other_ip:config.Dao.netvm_ip - in - let fragments = Fragments.Cache.empty (256 * 1024) in - Lwt.return { net; eth; arp; interface; fragments; ip; udp } + Lwt.return (Macaddr.of_string_exn "fe:ff:ff:ff:ff:ff") + | Ok mac -> Lwt.return mac + in + let interface = + new netvm_iface eth netvm_mac ~my_ip ~other_ip:config.Dao.netvm_ip + in + let fragments = Fragments.Cache.empty (256 * 1024) in + Lwt.return { net; eth; arp; interface; fragments; ip; udp } - (** Wait Xenstore for our uplink changes (we must have an uplink here...). *) - let uplink_wait_update qubesDB router = - let rec aux current_db = - let netvm = "/qubes-gateway" in - Log.info (fun f -> f "Waiting for netvm changes to %S...%!" netvm); - Qubes.DB.after qubesDB current_db >>= fun new_db -> - (match (router.uplink, Qubes.DB.KeyMap.find_opt netvm new_db) with - | Some uplink, Some netvm - when not - (String.equal netvm - (Ipaddr.V4.to_string uplink.interface#other_ip)) -> - Log.info (fun f -> - f "Our netvm IP has changed, before it was %s, now it's: %s%!" - (Ipaddr.V4.to_string uplink.interface#other_ip) - netvm); - Lwt_condition.broadcast router.uplink_disconnect (); - (* wait for uplink disconnexion *) - Lwt_condition.wait router.uplink_disconnected >>= fun () -> - Dao.read_network_config qubesDB >>= fun config -> - Dao.print_network_config config; - connect config >>= fun uplink -> - update router ~config ~uplink:(Some uplink) >>= fun () -> - Lwt_condition.broadcast router.uplink_connected (); - Lwt.return_unit - | None, Some _ -> - (* a new interface is attributed to qubes-mirage-firewall *) - Log.info (fun f -> f "Going from netvm not connected to %s%!" netvm); - Dao.read_network_config qubesDB >>= fun config -> - Dao.print_network_config config; - connect config >>= fun uplink -> - update router ~config ~uplink:(Some uplink) >>= fun () -> - Lwt_condition.broadcast router.uplink_connected (); - Lwt.return_unit - | Some _, None -> - (* This currently is never triggered :( *) - Log.info (fun f -> - f "TODO: Our netvm disapeared, troubles are coming!%!"); - Lwt.return_unit - | Some _, Some _ (* The new netvm IP is unchanged (it's our old netvm IP) *) - | None, None -> - Log.info (fun f -> - f "QubesDB has changed but not the situation of our netvm!%!"); - Lwt.return_unit) - >>= fun () -> aux new_db - in - aux Qubes.DB.KeyMap.empty +(** Wait Xenstore for our uplink changes (we must have an uplink here...). *) +let uplink_wait_update qubesDB router = + let rec aux current_db = + let netvm = "/qubes-gateway" in + Log.info (fun f -> f "Waiting for netvm changes to %S...%!" netvm); + Qubes.DB.after qubesDB current_db >>= fun new_db -> + (match (router.uplink, Qubes.DB.KeyMap.find_opt netvm new_db) with + | Some uplink, Some netvm + when not + (String.equal netvm + (Ipaddr.V4.to_string uplink.interface#other_ip)) -> + Log.info (fun f -> + f "Our netvm IP has changed, before it was %s, now it's: %s%!" + (Ipaddr.V4.to_string uplink.interface#other_ip) + netvm); + Lwt_condition.broadcast router.uplink_disconnect (); + (* wait for uplink disconnexion *) + Lwt_condition.wait router.uplink_disconnected >>= fun () -> + Dao.read_network_config qubesDB >>= fun config -> + Dao.print_network_config config; + connect config >>= fun uplink -> + update router ~config ~uplink:(Some uplink) >>= fun () -> + Lwt_condition.broadcast router.uplink_connected (); + Lwt.return_unit + | None, Some _ -> + (* a new interface is attributed to qubes-mirage-firewall *) + Log.info (fun f -> f "Going from netvm not connected to %s%!" netvm); + Dao.read_network_config qubesDB >>= fun config -> + Dao.print_network_config config; + connect config >>= fun uplink -> + update router ~config ~uplink:(Some uplink) >>= fun () -> + Lwt_condition.broadcast router.uplink_connected (); + Lwt.return_unit + | Some _, None -> + (* This currently is never triggered :( *) + Log.info (fun f -> + f "TODO: Our netvm disapeared, troubles are coming!%!"); + Lwt.return_unit + | Some _, Some _ (* The new netvm IP is unchanged (it's our old netvm IP) *) + | None, None -> + Log.info (fun f -> + f "QubesDB has changed but not the situation of our netvm!%!"); + Lwt.return_unit) + >>= fun () -> aux new_db + in + aux Qubes.DB.KeyMap.empty diff --git a/fw_utils.ml b/fw_utils.ml index f20c63a..53fddb0 100644 --- a/fw_utils.ml +++ b/fw_utils.ml @@ -15,14 +15,16 @@ end class type client_link = object inherit interface method other_mac : Macaddr.t - method log_header : string (* For log messages *) - method get_rules: Pf_qubes.Parse_qubes.rule list - method set_rules: string Qubes.DB.KeyMap.t -> unit + method log_header : string (* For log messages *) + method get_rules : Pf_qubes.Parse_qubes.rule list + method set_rules : string Qubes.DB.KeyMap.t -> unit end -(** An Ethernet header from [src]'s MAC address to [dst]'s with an IPv4 payload. *) +(** An Ethernet header from [src]'s MAC address to [dst]'s with an IPv4 payload. +*) let eth_header ethertype ~src ~dst = - Ethernet.Packet.make_cstruct { Ethernet.Packet.source = src; destination = dst; ethertype } + Ethernet.Packet.make_cstruct + { Ethernet.Packet.source = src; destination = dst; ethertype } let error fmt = let err s = Failure s in diff --git a/memory_pressure.ml b/memory_pressure.ml index 667bd50..fe04bca 100644 --- a/memory_pressure.ml +++ b/memory_pressure.ml @@ -2,14 +2,14 @@ See the README file for details. *) let src = Logs.Src.create "memory_pressure" ~doc:"Memory pressure monitor" + module Log = (val Logs.src_log src : Logs.LOG) let fraction_free stats = let { Xen_os.Memory.free_words; heap_words; _ } = stats in float free_words /. float heap_words -let init () = - Gc.full_major () +let init () = Gc.full_major () let status () = let stats = Xen_os.Memory.quick_stat () in @@ -18,6 +18,4 @@ let status () = Gc.full_major (); Xen_os.Memory.trim (); let stats = Xen_os.Memory.quick_stat () in - if fraction_free stats < 0.6 then `Memory_critical - else `Ok - ) + if fraction_free stats < 0.6 then `Memory_critical else `Ok) diff --git a/memory_pressure.mli b/memory_pressure.mli index c0d9f49..f0d7df8 100644 --- a/memory_pressure.mli +++ b/memory_pressure.mli @@ -8,5 +8,5 @@ val status : unit -> [ `Ok | `Memory_critical ] (** Check the memory situation. If we're running low, do a GC (work-around for http://caml.inria.fr/mantis/view.php?id=7100 and OCaml GC needing to malloc extra space to run finalisers). Returns [`Memory_critical] if memory is - still low - caller should take action to reduce memory use. - After GC, updates meminfo in XenStore. *) + still low - caller should take action to reduce memory use. After GC, + updates meminfo in XenStore. *) diff --git a/my_dns.ml b/my_dns.ml index 6000e80..e3bb267 100644 --- a/my_dns.ml +++ b/my_dns.ml @@ -1,72 +1,81 @@ open Lwt.Infix - type +'a io = 'a Lwt.t - type io_addr = Ipaddr.V4.t * int - type stack = Dispatcher.t * - (src_port:int -> dst:Ipaddr.V4.t -> dst_port:int -> string -> (unit, [ `Msg of string ]) result Lwt.t) * - (Udp_packet.t * string) Lwt_mvar.t +type +'a io = 'a Lwt.t +type io_addr = Ipaddr.V4.t * int - module IM = Map.Make(Int) +type stack = + Dispatcher.t + * (src_port:int -> + dst:Ipaddr.V4.t -> + dst_port:int -> + string -> + (unit, [ `Msg of string ]) result Lwt.t) + * (Udp_packet.t * string) Lwt_mvar.t - type t = { - protocol : Dns.proto ; - nameserver : io_addr ; - stack : stack ; - timeout_ns : int64 ; - mutable requests : string Lwt_condition.t IM.t ; - } - type context = t +module IM = Map.Make (Int) - let nameservers { protocol ; nameserver ; _ } = protocol, [ nameserver ] - let rng = Mirage_crypto_rng.generate ?g:None - let clock = Mirage_mtime.elapsed_ns +type t = { + protocol : Dns.proto; + nameserver : io_addr; + stack : stack; + timeout_ns : int64; + mutable requests : string Lwt_condition.t IM.t; +} - let rec read t = - let _, _, answer = t.stack in - Lwt_mvar.take answer >>= fun (_, data) -> - if String.length data > 2 then begin - match IM.find_opt (String.get_uint16_be data 0) t.requests with - | Some cond -> Lwt_condition.broadcast cond data - | None -> () - end; - read t +type context = 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 - let t = - { protocol ; nameserver ; stack ; timeout_ns = timeout ; requests = IM.empty } - in - Lwt.async (fun () -> read t); - t +let nameservers { protocol; nameserver; _ } = (protocol, [ nameserver ]) +let rng = Mirage_crypto_rng.generate ?g:None +let clock = Mirage_mtime.elapsed_ns - let with_timeout timeout_ns f = - let timeout = Mirage_sleep.ns timeout_ns >|= fun () -> Error (`Msg "DNS request timeout") in - Lwt.pick [ f ; timeout ] +let rec read t = + let _, _, answer = t.stack in + Lwt_mvar.take answer >>= fun (_, data) -> + (if String.length data > 2 then + match IM.find_opt (String.get_uint16_be data 0) t.requests with + | Some cond -> Lwt_condition.broadcast cond data + | None -> ()); + read t - let connect (t : t) = Lwt.return (Ok (t.protocol, 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 + let t = + { protocol; nameserver; stack; timeout_ns = timeout; requests = IM.empty } + in + Lwt.async (fun () -> read t); + t - let send_recv (ctx : context) buf : (string, [> `Msg of string ]) result Lwt.t = - let dst, dst_port = ctx.nameserver in - let router, send_udp, _ = ctx.stack in - let src_port, evict = - My_nat.free_udp_port router.nat ~src:router.config.our_ip ~dst ~dst_port:53 - in - let id = String.get_uint16_be buf 0 in - with_timeout ctx.timeout_ns - (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 +let with_timeout timeout_ns f = + let timeout = + Mirage_sleep.ns timeout_ns >|= fun () -> Error (`Msg "DNS request timeout") + in + Lwt.pick [ f; timeout ] - let close _ = Lwt.return_unit +let connect (t : t) = Lwt.return (Ok (t.protocol, t)) - let bind = Lwt.bind +let send_recv (ctx : context) buf : (string, [> `Msg of string ]) result Lwt.t = + let dst, dst_port = ctx.nameserver in + let router, send_udp, _ = ctx.stack in + let src_port, evict = + My_nat.free_udp_port router.nat ~src:router.config.our_ip ~dst ~dst_port:53 + in + let id = String.get_uint16_be buf 0 in + with_timeout ctx.timeout_ns + (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 - let lift = Lwt.return +let close _ = Lwt.return_unit +let bind = Lwt.bind +let lift = Lwt.return diff --git a/my_nat.ml b/my_nat.ml index 1e86c2d..e6b70e6 100644 --- a/my_nat.ml +++ b/my_nat.ml @@ -2,65 +2,57 @@ See the README file for details. *) let src = Logs.Src.create "my-nat" ~doc:"NAT shim" + module Log = (val Logs.src_log src : Logs.LOG) -type action = [ - | `NAT - | `Redirect of Mirage_nat.endpoint -] +type action = [ `NAT | `Redirect of Mirage_nat.endpoint ] module Nat = Mirage_nat_lru -module S = - Set.Make(struct type t = int let compare (a : int) (b : int) = compare a b end) +module S = Set.Make (struct + type t = int -type t = { - table : Nat.t; - mutable udp_dns : S.t; - last_resort_port : int -} + let compare (a : int) (b : int) = compare a b +end) -let pick_port () = - 1024 + Random.int (0xffff - 1024) +type t = { table : Nat.t; mutable udp_dns : S.t; last_resort_port : int } + +let pick_port () = 1024 + Random.int (0xffff - 1024) let create ~max_entries = let tcp_size = 7 * max_entries / 8 in let udp_size = max_entries - tcp_size in let table = Nat.empty ~tcp_size ~udp_size ~icmp_size:100 in let last_resort_port = pick_port () in - { table ; udp_dns = S.empty ; last_resort_port } + { table; udp_dns = S.empty; last_resort_port } let pick_free_port t proto = let rec go retries = - if retries = 0 then - None + if retries = 0 then None else let p = 1024 + Random.int (0xffff - 1024) in match proto with - | `Udp when S.mem p t.udp_dns || p = t.last_resort_port -> - go (retries - 1) + | `Udp when S.mem p t.udp_dns || p = t.last_resort_port -> go (retries - 1) | _ -> Some p in go 10 let free_udp_port t ~src ~dst ~dst_port = let rec go retries = - if retries = 0 then - t.last_resort_port, Fun.id + 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 - if Nat.is_port_free t.table `Udp ~src ~dst ~src_port ~dst_port then begin + if Nat.is_port_free t.table `Udp ~src ~dst ~src_port ~dst_port then let remove = - if src_port <> t.last_resort_port then begin + if src_port <> t.last_resort_port then ( 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 + fun () -> t.udp_dns <- S.remove src_port t.udp_dns) + else Fun.id in - src_port, remove - end else - go (retries - 1) + (src_port, remove) + else go (retries - 1) in go 10 @@ -68,27 +60,27 @@ let dns_port t port = S.mem port t.udp_dns || port = t.last_resort_port let translate t packet = match Nat.translate t.table packet with - | Error (`Untranslated | `TTL_exceeded as e) -> - Log.debug (fun f -> f "Failed to NAT %a: %a" - Nat_packet.pp packet - Mirage_nat.pp_error e - ); - None + | Error ((`Untranslated | `TTL_exceeded) as e) -> + Log.debug (fun f -> + f "Failed to NAT %a: %a" Nat_packet.pp packet Mirage_nat.pp_error e); + None | Ok packet -> Some packet -let remove_connections t ip = - ignore (Nat.remove_connections t.table ip) +let remove_connections t ip = ignore (Nat.remove_connections t.table ip) let add_nat_rule_and_translate t ~xl_host action packet = - let proto = match packet with + let proto = + match packet with | `IPv4 (_, `TCP _) -> `Tcp | `IPv4 (_, `UDP _) -> `Udp | `IPv4 (_, `ICMP _) -> `Icmp in - match Nat.add t.table packet xl_host (fun () -> pick_free_port t proto) action with + match + Nat.add t.table packet xl_host (fun () -> pick_free_port t proto) action + with | Error `Overlap -> Error "Too many retries" | Error `Cannot_NAT -> Error "Cannot NAT this packet" | Ok () -> - Log.debug (fun f -> f "Updated NAT table: %a" Nat.pp_summary t.table); - Option.to_result ~none:"No NAT entry, even after adding one!" - (translate t packet) + Log.debug (fun f -> f "Updated NAT table: %a" Nat.pp_summary t.table); + Option.to_result ~none:"No NAT entry, even after adding one!" + (translate t packet) diff --git a/my_nat.mli b/my_nat.mli index eab1a34..a9d3829 100644 --- a/my_nat.mli +++ b/my_nat.mli @@ -4,17 +4,23 @@ (* Abstract over NAT interface (todo: remove this) *) type t +type action = [ `NAT | `Redirect of Mirage_nat.endpoint ] -type action = [ - | `NAT - | `Redirect of Mirage_nat.endpoint -] - -val free_udp_port : t -> src:Ipaddr.V4.t -> dst:Ipaddr.V4.t -> dst_port:int -> +val free_udp_port : + t -> + src:Ipaddr.V4.t -> + dst:Ipaddr.V4.t -> + dst_port:int -> int * (unit -> unit) + val dns_port : t -> int -> bool val create : max_entries:int -> t val remove_connections : t -> Ipaddr.V4.t -> unit val translate : t -> Nat_packet.t -> Nat_packet.t option -val add_nat_rule_and_translate : t -> - xl_host:Ipaddr.V4.t -> action -> Nat_packet.t -> (Nat_packet.t, string) result + +val add_nat_rule_and_translate : + t -> + xl_host:Ipaddr.V4.t -> + action -> + Nat_packet.t -> + (Nat_packet.t, string) result diff --git a/packet.ml b/packet.ml index 7d8c3c4..d6d4f92 100644 --- a/packet.ml +++ b/packet.ml @@ -8,9 +8,8 @@ type port = int type host = [ `Client of client_link | `Firewall | `NetVM | `External of Ipaddr.t ] -type transport_header = [`TCP of Tcp.Tcp_packet.t - |`UDP of Udp_packet.t - |`ICMP of Icmpv4_packet.t] +type transport_header = + [ `TCP of Tcp.Tcp_packet.t | `UDP of Udp_packet.t | `ICMP of Icmpv4_packet.t ] type ('src, 'dst) t = { ipv4_header : Ipv4_packet.t; @@ -19,13 +18,14 @@ type ('src, 'dst) t = { src : 'src; dst : 'dst; } + let pp_transport_header f = function | `ICMP h -> Icmpv4_packet.pp f h | `TCP h -> Tcp.Tcp_packet.pp f h | `UDP h -> Udp_packet.pp f h let pp_host fmt = function - | `Client c -> Ipaddr.V4.pp fmt (c#other_ip) + | `Client c -> Ipaddr.V4.pp fmt c#other_ip | `Unknown_client ip -> Format.fprintf fmt "unknown-client(%a)" Ipaddr.pp ip | `NetVM -> Format.pp_print_string fmt "net-vm" | `External ip -> Format.fprintf fmt "external(%a)" Ipaddr.pp ip @@ -33,32 +33,28 @@ let pp_host fmt = function let to_mirage_nat_packet t : Nat_packet.t = match t.transport_header with - | `TCP h -> `IPv4 (t.ipv4_header, (`TCP (h, t.transport_payload))) - | `UDP h -> `IPv4 (t.ipv4_header, (`UDP (h, t.transport_payload))) - | `ICMP h -> `IPv4 (t.ipv4_header, (`ICMP (h, t.transport_payload))) + | `TCP h -> `IPv4 (t.ipv4_header, `TCP (h, t.transport_payload)) + | `UDP h -> `IPv4 (t.ipv4_header, `UDP (h, t.transport_payload)) + | `ICMP h -> `IPv4 (t.ipv4_header, `ICMP (h, t.transport_payload)) let of_mirage_nat_packet ~src ~dst packet : ('a, 'b) t option = - let `IPv4 (ipv4_header, ipv4_payload) = packet in - let transport_header, transport_payload = match ipv4_payload with - | `TCP (h, p) -> `TCP h, p - | `UDP (h, p) -> `UDP h, p - | `ICMP (h, p) -> `ICMP h, p + let (`IPv4 (ipv4_header, ipv4_payload)) = packet in + let transport_header, transport_payload = + match ipv4_payload with + | `TCP (h, p) -> (`TCP h, p) + | `UDP (h, p) -> (`UDP h, p) + | `ICMP (h, p) -> (`ICMP h, p) in - Some { - ipv4_header; - transport_header; - transport_payload; - src; - dst; - } + Some { ipv4_header; transport_header; transport_payload; src; dst } (* possible actions to take for a packet: *) -type action = [ - | `Accept (* Send to destination, unmodified. *) - | `NAT (* Rewrite source field to the firewall's IP, with a fresh source port. +type action = + [ `Accept (* Send to destination, unmodified. *) + | `NAT + (* Rewrite source field to the firewall's IP, with a fresh source port. Also, add translation rules for future traffic in both directions, between these hosts on these ports, and corresponding ICMP error traffic. *) - | `NAT_to of host * port (* As for [`NAT], but also rewrite the packet's + | `NAT_to of host * port + (* As for [`NAT], but also rewrite the packet's destination fields so it will be sent to [host:port]. *) - | `Drop of string (* Drop packet for this reason. *) -] + | `Drop of string (* Drop packet for this reason. *) ] diff --git a/packet.mli b/packet.mli index f7d2876..af8ee43 100644 --- a/packet.mli +++ b/packet.mli @@ -1,15 +1,13 @@ type port = int type host = - [ `Client of Fw_utils.client_link (** an IP address on the private network *) - | `Firewall (** the firewall's IP on the private network *) - | `NetVM (** the IP of the firewall's default route *) - | `External of Ipaddr.t (** an IP on the public network *) - ] + [ `Client of Fw_utils.client_link (** an IP address on the private network *) + | `Firewall (** the firewall's IP on the private network *) + | `NetVM (** the IP of the firewall's default route *) + | `External of Ipaddr.t (** an IP on the public network *) ] -type transport_header = [`TCP of Tcp.Tcp_packet.t - |`UDP of Udp_packet.t - |`ICMP of Icmpv4_packet.t] +type transport_header = + [ `TCP of Tcp.Tcp_packet.t | `UDP of Udp_packet.t | `ICMP of Icmpv4_packet.t ] type ('src, 'dst) t = { ipv4_header : Ipv4_packet.t; @@ -20,20 +18,18 @@ type ('src, 'dst) t = { } val pp_transport_header : Format.formatter -> transport_header -> unit - val pp_host : Format.formatter -> host -> unit - val to_mirage_nat_packet : ('a, 'b) t -> Nat_packet.t - val of_mirage_nat_packet : src:'a -> dst:'b -> Nat_packet.t -> ('a, 'b) t option (* possible actions to take for a packet: *) -type action = [ - | `Accept (* Send to destination, unmodified. *) - | `NAT (* Rewrite source field to the firewall's IP, with a fresh source port. +type action = + [ `Accept (* Send to destination, unmodified. *) + | `NAT + (* Rewrite source field to the firewall's IP, with a fresh source port. Also, add translation rules for future traffic in both directions, between these hosts on these ports, and corresponding ICMP error traffic. *) - | `NAT_to of host * port (* As for [`NAT], but also rewrite the packet's + | `NAT_to of host * port + (* As for [`NAT], but also rewrite the packet's destination fields so it will be sent to [host:port]. *) - | `Drop of string (* Drop packet for this reason. *) -] + | `Drop of string (* Drop packet for this reason. *) ] diff --git a/rules.ml b/rules.ml index 9210b47..c85a596 100644 --- a/rules.ml +++ b/rules.ml @@ -8,93 +8,115 @@ open Lwt.Infix 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 module Classifier = struct - - let matches_port dstports (port : int) = match dstports with + let matches_port dstports (port : int) = + match dstports with | None -> true | Some (Q.Range_inclusive (min, max)) -> min <= port && port <= max - let matches_proto rule dns_servers 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 dns_servers -> begin - (* specialtarget=dns applies only to the specialtarget destination IPs, and + | None, Some `dns + when List.mem packet.ipv4_header.Ipv4_packet.dst dns_servers -> ( + (* specialtarget=dns applies only to the specialtarget destination IPs, and specialtarget=dns is also implicitly tcp/udp port 53 *) - match packet.transport_header with + match packet.transport_header with | `TCP header -> header.Tcp.Tcp_packet.dst_port = dns_port | `UDP header -> header.Udp_packet.dst_port = dns_port - | _ -> false - end - (* DNS rules can only match traffic headed to the specialtarget hosts, so any other destination + | _ -> false) + (* DNS rules can only match traffic headed to the specialtarget hosts, so any other destination isn't a match for DNS rules *) | None, Some `dns -> false - | Some rule_proto, _ -> match rule_proto, packet.transport_header with - | `tcp, `TCP header -> matches_port rule.Q.dstports header.Tcp.Tcp_packet.dst_port - | `udp, `UDP header -> matches_port rule.Q.dstports header.Udp_packet.dst_port - | `icmp, `ICMP header -> - begin - match rule.Q.icmp_type with - | None -> true - | Some rule_icmp_type -> - 0 = compare rule_icmp_type @@ Icmpv4_wire.ty_to_int header.Icmpv4_packet.ty - end - | _, _ -> false + | Some rule_proto, _ -> ( + match (rule_proto, packet.transport_header) with + | `tcp, `TCP header -> + matches_port rule.Q.dstports header.Tcp.Tcp_packet.dst_port + | `udp, `UDP header -> + matches_port rule.Q.dstports header.Udp_packet.dst_port + | `icmp, `ICMP header -> ( + match rule.Q.icmp_type with + | None -> true + | Some rule_icmp_type -> + 0 + = compare rule_icmp_type + @@ Icmpv4_wire.ty_to_int header.Icmpv4_packet.ty) + | _, _ -> false) let matches_dest dns_client rule packet = let ip = packet.ipv4_header.Ipv4_packet.dst in match rule.Q.dst with - | `any -> Lwt.return @@ `Match rule + | `any -> Lwt.return @@ `Match rule | `hosts subnet -> - Lwt.return @@ if (Ipaddr.Prefix.mem Ipaddr.(V4 ip) subnet) then `Match rule else `No_match - | `dnsname name -> - Log.debug (fun f -> f "Resolving %a" Domain_name.pp name); - dns_client name >|= function - | Ok (_ttl, found_ips) -> - if Ipaddr.V4.Set.mem ip found_ips - then `Match rule + Lwt.return + @@ + if Ipaddr.Prefix.mem Ipaddr.(V4 ip) subnet then `Match rule else `No_match - | Error (`Msg m) -> - Log.warn (fun f -> f "Ignoring rule %a, could not resolve" Q.pp_rule rule); - Log.debug (fun f -> f "%s" m); - `No_match - | Error _ -> assert false (* TODO: fix type of dns_client so that this case can go *) - + | `dnsname name -> ( + Log.debug (fun f -> f "Resolving %a" Domain_name.pp name); + dns_client name >|= function + | Ok (_ttl, found_ips) -> + if Ipaddr.V4.Set.mem ip found_ips then `Match rule else `No_match + | Error (`Msg m) -> + Log.warn (fun f -> + f "Ignoring rule %a, could not resolve" Q.pp_rule rule); + Log.debug (fun f -> f "%s" m); + `No_match + | Error _ -> + assert + false (* TODO: fix type of dns_client so that this case can go *)) end let find_first_match dns_client dns_servers packet acc rule = match acc with | `No_match -> - if Classifier.matches_proto rule dns_servers packet - then Classifier.matches_dest dns_client rule packet - else Lwt.return `No_match + 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 dns_servers (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 dns_servers 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) + | `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 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 dns_servers (packet : ([`Client of Fw_utils.client_link], _) Packet.t) : Packet.action Lwt.t = +(** 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 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 dns_servers packet - | { dst = `Firewall ; _ } -> Lwt.return @@ `Drop "packet addressed to firewall itself" - | { dst = `Client _ ; _ } -> classify_client_packet dns_client dns_servers 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 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 *) -let from_netvm (_packet : ([`NetVM | `External of _], _) Packet.t) : Packet.action Lwt.t = +(** Packets from the outside world that don't match any NAT table entry are + being dropped by default *) +let from_netvm (_packet : ([ `NetVM | `External of _ ], _) Packet.t) : + Packet.action Lwt.t = Lwt.return @@ `Drop "drop by default" diff --git a/test/config.ml b/test/config.ml index d8695e4..d5589d5 100644 --- a/test/config.ml +++ b/test/config.ml @@ -2,26 +2,32 @@ open Mirage let pin = "git+https://github.com/roburio/alcotest.git#mirage" -let packages = [ - package "ethernet"; - package "arp"; - package "arp-mirage"; - package "ipaddr"; - package "tcpip" ~sublibs:["stack-direct"; "icmpv4"; "ipv4"; "udp"; "tcp"]; - package "mirage-qubes"; - package "mirage-qubes-ipv4"; - package "dns-client" ~sublibs:["mirage"]; - package ~pin "alcotest"; - package ~pin "alcotest-mirage"; -] +let packages = + [ + package "ethernet"; + package "arp"; + package "arp-mirage"; + package "ipaddr"; + package "tcpip" ~sublibs:[ "stack-direct"; "icmpv4"; "ipv4"; "udp"; "tcp" ]; + package "mirage-qubes"; + package "mirage-qubes-ipv4"; + package "dns-client" ~sublibs:[ "mirage" ]; + package ~pin "alcotest"; + package ~pin "alcotest-mirage"; + ] let client = - foreign ~packages - "Unikernel.Client" @@ random @-> time @-> mclock @-> network @-> qubesdb @-> job + foreign ~packages "Unikernel.Client" + @@ random @-> time @-> mclock @-> network @-> qubesdb @-> job let db = default_qubesdb let network = default_network let () = - let job = [ client $ default_random $ default_time $ default_monotonic_clock $ network $ db ] in + let job = + [ + client $ default_random $ default_time $ default_monotonic_clock $ network + $ db; + ] + in register "http-fetch" job diff --git a/test/unikernel.ml b/test/unikernel.ml index 04f7d6a..2a0c23a 100644 --- a/test/unikernel.ml +++ b/test/unikernel.ml @@ -1,6 +1,8 @@ open Lwt.Infix + (* https://www.qubes-os.org/doc/vm-interface/#firewall-rules-in-4x *) let src = Logs.Src.create "firewall test" ~doc:"Firewalltest" + module Log = (val Logs.src_log src : Logs.LOG) (* TODO @@ -39,18 +41,24 @@ module Log = (val Logs.src_log src : Logs.LOG) (* Point-to-point links out of a netvm always have this IP TODO clarify with Marek *) let netvm = "10.137.0.5" + (* default "nameserver"s, which netvm redirects to whatever its real nameservers are *) -let nameserver_1, nameserver_2 = "10.139.1.1", "10.139.1.2" +let nameserver_1, nameserver_2 = ("10.139.1.1", "10.139.1.2") -module Client (R: Mirage_crypto_rng_mirage.S) (Time: Mirage_time.S) (Clock : Mirage_clock.MCLOCK) (NET: Mirage_net.S) (DB : Qubes.S.DB) = struct - module E = Ethernet.Make(NET) - module A = Arp.Make(E)(Time) - module I = Qubesdb_ipv4.Make(DB)(R)(Clock)(E)(A) - module Icmp = Icmpv4.Make(I) - module U = Udp.Make(I)(R) - module T = Tcp.Flow.Make(I)(Time)(Clock)(R) - - module Alcotest = Alcotest_mirage.Make(Clock) +module Client + (R : Mirage_crypto_rng_mirage.S) + (Time : Mirage_time.S) + (Clock : Mirage_clock.MCLOCK) + (NET : Mirage_net.S) + (DB : Qubes.S.DB) = +struct + module E = Ethernet.Make (NET) + module A = Arp.Make (E) (Time) + module I = Qubesdb_ipv4.Make (DB) (R) (Clock) (E) (A) + module Icmp = Icmpv4.Make (I) + module U = Udp.Make (I) (R) + module T = Tcp.Flow.Make (I) (Time) (Clock) (R) + module Alcotest = Alcotest_mirage.Make (Clock) module Stack = struct (* A Mirage_stack.V4 implementation which diverts DHCP messages to a DHCP @@ -66,67 +74,77 @@ module Client (R: Mirage_crypto_rng_mirage.S) (Time: Mirage_time.S) (Clock : Mir module IPV4 = I type t = { - net : NET.t ; eth : E.t ; arp : A.t ; - ip : I.t ; icmp : Icmp.t ; udp : U.t ; tcp : T.t ; - udp_listeners : (int, U.callback) Hashtbl.t ; - tcp_listeners : (int, T.listener) Hashtbl.t ; - mutable icmp_listener : (src:Ipaddr.V4.t -> dst:Ipaddr.V4.t -> Cstruct.t -> unit Lwt.t) option ; + net : NET.t; + eth : E.t; + arp : A.t; + ip : I.t; + icmp : Icmp.t; + udp : U.t; + tcp : T.t; + udp_listeners : (int, U.callback) Hashtbl.t; + tcp_listeners : (int, T.listener) Hashtbl.t; + mutable icmp_listener : + (src:Ipaddr.V4.t -> dst:Ipaddr.V4.t -> Cstruct.t -> unit Lwt.t) option; } - let ipv4 { ip ; _ } = ip - let udpv4 { udp ; _ } = udp - let tcpv4 { tcp ; _ } = tcp - let icmpv4 { icmp ; _ } = icmp - + let ipv4 { ip; _ } = ip + let udpv4 { udp; _ } = udp + let tcpv4 { tcp; _ } = tcp + let icmpv4 { icmp; _ } = icmp let listener h port = Hashtbl.find_opt h port let udp_listener h ~dst_port = listener h dst_port - let listen_udpv4 { udp_listeners ; _ } ~port cb = + let listen_udpv4 { udp_listeners; _ } ~port cb = Hashtbl.replace udp_listeners port cb - let stop_listen_udpv4 { udp_listeners ; _ } ~port = + let stop_listen_udpv4 { udp_listeners; _ } ~port = Hashtbl.remove udp_listeners port - let listen_tcpv4 ?keepalive { tcp_listeners ; _ } ~port cb = - Hashtbl.replace tcp_listeners port { T.process = cb ; T.keepalive } + let listen_tcpv4 ?keepalive { tcp_listeners; _ } ~port cb = + Hashtbl.replace tcp_listeners port { T.process = cb; T.keepalive } - let stop_listen_tcpv4 { tcp_listeners ; _ } ~port = + let stop_listen_tcpv4 { tcp_listeners; _ } ~port = Hashtbl.remove tcp_listeners port let listen_icmp t cb = t.icmp_listener <- cb let listen t = let ethif_listener = - E.input - ~arpv4:(A.input t.arp) - ~ipv4:( - I.input - ~tcp:(T.input t.tcp ~listeners:(listener t.tcp_listeners)) - ~udp:(U.input t.udp ~listeners:(udp_listener t.udp_listeners)) - ~default:(fun ~proto ~src ~dst buf -> - match proto with - | 1 -> - begin match t.icmp_listener with + E.input ~arpv4:(A.input t.arp) + ~ipv4: + (I.input + ~tcp:(T.input t.tcp ~listeners:(listener t.tcp_listeners)) + ~udp:(U.input t.udp ~listeners:(udp_listener t.udp_listeners)) + ~default:(fun ~proto ~src ~dst buf -> + match proto with + | 1 -> ( + match t.icmp_listener with | None -> Icmp.input t.icmp ~src ~dst buf - | Some cb -> cb ~src ~dst buf - end - | _ -> Lwt.return_unit) - t.ip) + | Some cb -> cb ~src ~dst buf) + | _ -> Lwt.return_unit) + t.ip) ~ipv6:(fun _ -> Lwt.return_unit) t.eth in NET.listen t.net ~header_size:Ethernet_wire.sizeof_ethernet ethif_listener >>= function | Error e -> - Logs.warn (fun p -> p "%a" NET.pp_error e) ; - Lwt.return_unit + Logs.warn (fun p -> p "%a" NET.pp_error e); + Lwt.return_unit | Ok _res -> Lwt.return_unit let connect net eth arp ip icmp udp tcp = - { net ; eth ; arp ; ip ; icmp ; udp ; tcp ; - udp_listeners = Hashtbl.create 2 ; - tcp_listeners = Hashtbl.create 2 ; - icmp_listener = None ; + { + net; + eth; + arp; + ip; + icmp; + udp; + tcp; + udp_listeners = Hashtbl.create 2; + tcp_listeners = Hashtbl.create 2; + icmp_listener = None; } let disconnect _ = @@ -134,31 +152,39 @@ module Client (R: Mirage_crypto_rng_mirage.S) (Time: Mirage_time.S) (Clock : Mir Lwt.return_unit end - module Dns = Dns_client_mirage.Make(R)(Time)(Clock)(Stack) + module Dns = Dns_client_mirage.Make (R) (Time) (Clock) (Stack) let make_ping_packet payload = - let echo_request = { Icmpv4_packet.code = 0; (* constant for echo request/reply *) - ty = Icmpv4_wire.Echo_request; - subheader = Icmpv4_packet.(Id_and_seq (0, 0)); } in + let echo_request = + { + Icmpv4_packet.code = 0; + (* constant for echo request/reply *) + ty = Icmpv4_wire.Echo_request; + subheader = Icmpv4_packet.(Id_and_seq (0, 0)); + } + in Icmpv4_packet.Marshal.make_cstruct echo_request ~payload let is_ping_reply src server packet = - 0 = Ipaddr.V4.(compare src @@ of_string_exn server) && - packet.Icmpv4_packet.code = 0 && - packet.Icmpv4_packet.ty = Icmpv4_wire.Echo_reply && - packet.Icmpv4_packet.subheader = Icmpv4_packet.(Id_and_seq (0, 0)) + (0 = Ipaddr.V4.(compare src @@ of_string_exn server)) + && packet.Icmpv4_packet.code = 0 + && packet.Icmpv4_packet.ty = Icmpv4_wire.Echo_reply + && packet.Icmpv4_packet.subheader = Icmpv4_packet.(Id_and_seq (0, 0)) let ping_denied_listener server resp_received stack = let icmp_listener ~src ~dst:_ buf = (* hopefully this is a reply to an ICMP echo request we sent *) - Log.info (fun f -> f "ping test: ICMP message received from %a: %a" I.pp_ipaddr src Cstruct.hexdump_pp buf); + Log.info (fun f -> + f "ping test: ICMP message received from %a: %a" I.pp_ipaddr src + Cstruct.hexdump_pp buf); match Icmpv4_packet.Unmarshal.of_cstruct buf with - | Error e -> Log.err (fun f -> f "couldn't parse ICMP packet: %s" e); - Lwt.return_unit + | Error e -> + Log.err (fun f -> f "couldn't parse ICMP packet: %s" e); + Lwt.return_unit | Ok (packet, _payload) -> - Log.info (fun f -> f "ICMP message: %a" Icmpv4_packet.pp packet); - if is_ping_reply src server packet then resp_received := true; - Lwt.return_unit + Log.info (fun f -> f "ICMP message: %a" Icmpv4_packet.pp packet); + if is_ping_reply src server packet then resp_received := true; + Lwt.return_unit in Stack.listen_icmp stack (Some icmp_listener) @@ -166,49 +192,68 @@ module Client (R: Mirage_crypto_rng_mirage.S) (Time: Mirage_time.S) (Clock : Mir let resp_received = ref false in Log.info (fun f -> f "Entering ping test: %s" server); ping_denied_listener server resp_received stack; - Icmp.write (Stack.icmpv4 stack) ~dst:(Ipaddr.V4.of_string_exn server) (make_ping_packet (Cstruct.of_string "hi")) >>= function - | Error e -> Log.err (fun f -> f "ping test: error sending ping: %a" Icmp.pp_error e); Lwt.return_unit + Icmp.write (Stack.icmpv4 stack) + ~dst:(Ipaddr.V4.of_string_exn server) + (make_ping_packet (Cstruct.of_string "hi")) + >>= function + | Error e -> + Log.err (fun f -> f "ping test: error sending ping: %a" Icmp.pp_error e); + Lwt.return_unit | Ok () -> - Log.info (fun f -> f "ping test: sent ping to %s" server); - Time.sleep_ns 2_000_000_000L >>= fun () -> - (if !resp_received then - Log.err (fun f -> f "ping test failed: server %s got a response, block expected :(" server) - else - Log.err (fun f -> f "ping test passed: successfully blocked :)") - ); - Stack.listen_icmp stack None; - Lwt.return_unit + Log.info (fun f -> f "ping test: sent ping to %s" server); + Time.sleep_ns 2_000_000_000L >>= fun () -> + if !resp_received then + Log.err (fun f -> + f "ping test failed: server %s got a response, block expected :(" + server) + else Log.err (fun f -> f "ping test passed: successfully blocked :)"); + Stack.listen_icmp stack None; + Lwt.return_unit let icmp_error_type stack () = let resp_correct = ref false in let echo_server = Ipaddr.V4.of_string_exn netvm in let icmp_callback ~src ~dst:_ buf = - if Ipaddr.V4.compare src echo_server = 0 then begin - (* TODO: check that packet is error packet *) - match Icmpv4_packet.Unmarshal.of_cstruct buf with - | Error e -> Log.err (fun f -> f "Error parsing icmp packet %s" e) - | Ok (packet, _) -> + (if Ipaddr.V4.compare src echo_server = 0 then + (* TODO: check that packet is error packet *) + match Icmpv4_packet.Unmarshal.of_cstruct buf with + | Error e -> Log.err (fun f -> f "Error parsing icmp packet %s" e) + | Ok (packet, _) -> (* TODO don't hardcode the numbers, make a datatype *) - if packet.Icmpv4_packet.code = 10 (* unreachable, admin prohibited *) + if + packet.Icmpv4_packet.code + = 10 (* unreachable, admin prohibited *) then resp_correct := true - else Log.debug (fun f -> f "Unrelated icmp packet %a" Icmpv4_packet.pp packet) - end; + else + Log.debug (fun f -> + f "Unrelated icmp packet %a" Icmpv4_packet.pp packet)); Lwt.return_unit in let content = Cstruct.of_string "important data" in Stack.listen_icmp stack (Some icmp_callback); - U.write ~src_port:1337 ~dst:echo_server ~dst_port:1338 (Stack.udpv4 stack) content >>= function - | Ok () -> (* .. listener: test with accept rule, if we get reply we're good *) - Time.sleep_ns 1_000_000_000L >>= fun () -> - if !resp_correct - then Log.info (fun m -> m "UDP fetch test to port %d succeeded :)" 1338) - else Log.err (fun f -> f "UDP fetch test to port %d: failed. :( correct response not received" 1338); - Stack.listen_icmp stack None; - Lwt.return_unit + U.write ~src_port:1337 ~dst:echo_server ~dst_port:1338 (Stack.udpv4 stack) + content + >>= function + | Ok () -> + (* .. listener: test with accept rule, if we get reply we're good *) + Time.sleep_ns 1_000_000_000L >>= fun () -> + if !resp_correct then + Log.info (fun m -> m "UDP fetch test to port %d succeeded :)" 1338) + else + Log.err (fun f -> + f + "UDP fetch test to port %d: failed. :( correct response not \ + received" + 1338); + Stack.listen_icmp stack None; + Lwt.return_unit | Error e -> - Log.err (fun f -> f "UDP fetch test to port %d failed: :( couldn't write the packet: %a" - 1338 U.pp_error e); - Lwt.return_unit + Log.err (fun f -> + f + "UDP fetch test to port %d failed: :( couldn't write the packet: \ + %a" + 1338 U.pp_error e); + Lwt.return_unit let tcp_connect msg server port tcp () = Log.info (fun f -> f "Entering tcp connect test: %s:%d" server port); @@ -216,98 +261,141 @@ module Client (R: Mirage_crypto_rng_mirage.S) (Time: Mirage_time.S) (Clock : Mir let msg' = Printf.sprintf "TCP connect test %s to %s:%d" msg server port in T.create_connection tcp (ip, port) >>= function | Ok flow -> - Log.info (fun f -> f "%s passed :)" msg'); - T.close flow - | Error e -> Log.err (fun f -> f "%s failed: Connection failed (%a) :(" msg' T.pp_error e); - Lwt.return_unit + Log.info (fun f -> f "%s passed :)" msg'); + T.close flow + | Error e -> + Log.err (fun f -> + f "%s failed: Connection failed (%a) :(" msg' T.pp_error e); + Lwt.return_unit let tcp_connect_denied msg server port tcp () = let ip = Ipaddr.V4.of_string_exn server in - let msg' = Printf.sprintf "TCP connect denied test %s to %s:%d" msg server port in - let connect = (T.create_connection tcp (ip, port) >>= function - | Ok flow -> - Log.err (fun f -> f "%s failed: Connection should be denied, but was not. :(" msg'); - T.close flow - | Error e -> Log.info (fun f -> f "%s passed (error text: %a) :)" msg' T.pp_error e); - Lwt.return_unit) + let msg' = + Printf.sprintf "TCP connect denied test %s to %s:%d" msg server port in - let timeout = ( + let connect = + T.create_connection tcp (ip, port) >>= function + | Ok flow -> + Log.err (fun f -> + f "%s failed: Connection should be denied, but was not. :(" msg'); + T.close flow + | Error e -> + Log.info (fun f -> + f "%s passed (error text: %a) :)" msg' T.pp_error e); + Lwt.return_unit + in + let timeout = Time.sleep_ns 1_000_000_000L >>= fun () -> Log.info (fun f -> f "%s passed :)" msg'); - Lwt.return_unit) + Lwt.return_unit in - Lwt.pick [ connect ; timeout ] + Lwt.pick [ connect; timeout ] let udp_fetch ~src_port ~echo_server_port stack () = - Log.info (fun f -> f "Entering udp fetch test: %d -> %s:%d" - src_port netvm echo_server_port); + Log.info (fun f -> + f "Entering udp fetch test: %d -> %s:%d" src_port netvm echo_server_port); let resp_correct = ref false in let echo_server = Ipaddr.V4.of_string_exn netvm in let content = Cstruct.of_string "important data" in - let udp_listener : U.callback = (fun ~src ~dst:_ ~src_port buf -> - Log.debug (fun f -> f "listen_udpv4 function invoked for packet: %a" Cstruct.hexdump_pp buf); - if ((0 = Ipaddr.V4.compare echo_server src) && src_port = echo_server_port) then - match Cstruct.equal buf content with - | true -> (* yay *) - Log.info (fun f -> f "UDP fetch test to port %d: passed :)" echo_server_port); + let udp_listener : U.callback = + fun ~src ~dst:_ ~src_port buf -> + Log.debug (fun f -> + f "listen_udpv4 function invoked for packet: %a" Cstruct.hexdump_pp + buf); + if 0 = Ipaddr.V4.compare echo_server src && src_port = echo_server_port + then ( + match Cstruct.equal buf content with + | true -> + (* yay *) + Log.info (fun f -> + f "UDP fetch test to port %d: passed :)" echo_server_port); resp_correct := true; Lwt.return_unit - | false -> (* oh no *) - Log.err (fun f -> f "UDP fetch test to port %d: failed. :( Packet corrupted; expected %a but got %a" - echo_server_port Cstruct.hexdump_pp content Cstruct.hexdump_pp buf); - Lwt.return_unit - else - begin - (* disregard this packet *) - Log.debug (fun f -> f "packet is not from the echo server or has the wrong source port (%d but we wanted %d)" - src_port echo_server_port); - (* don't cancel the listener, since we want to keep listening *) - Lwt.return_unit - end - ) + | false -> + (* oh no *) + Log.err (fun f -> + f + "UDP fetch test to port %d: failed. :( Packet corrupted; \ + expected %a but got %a" + echo_server_port Cstruct.hexdump_pp content Cstruct.hexdump_pp + buf); + Lwt.return_unit) + else ( + (* disregard this packet *) + Log.debug (fun f -> + f + "packet is not from the echo server or has the wrong source port \ + (%d but we wanted %d)" + src_port echo_server_port); + (* don't cancel the listener, since we want to keep listening *) + Lwt.return_unit) in Stack.listen_udpv4 stack ~port:src_port udp_listener; - U.write ~src_port ~dst:echo_server ~dst_port:echo_server_port (Stack.udpv4 stack) content >>= function - | Ok () -> (* .. listener: test with accept rule, if we get reply we're good *) - Time.sleep_ns 1_000_000_000L >>= fun () -> - Stack.stop_listen_udpv4 stack ~port:src_port; - if !resp_correct then Lwt.return_unit else begin - Log.err (fun f -> f "UDP fetch test to port %d: failed. :( correct response not received" echo_server_port); - Lwt.return_unit - end + U.write ~src_port ~dst:echo_server ~dst_port:echo_server_port + (Stack.udpv4 stack) content + >>= function + | Ok () -> + (* .. listener: test with accept rule, if we get reply we're good *) + Time.sleep_ns 1_000_000_000L >>= fun () -> + Stack.stop_listen_udpv4 stack ~port:src_port; + if !resp_correct then Lwt.return_unit + else ( + Log.err (fun f -> + f + "UDP fetch test to port %d: failed. :( correct response not \ + received" + echo_server_port); + Lwt.return_unit) | Error e -> - Log.err (fun f -> f "UDP fetch test to port %d failed: :( couldn't write the packet: %a" - echo_server_port U.pp_error e); - Lwt.return_unit + Log.err (fun f -> + f + "UDP fetch test to port %d failed: :( couldn't write the packet: \ + %a" + echo_server_port U.pp_error e); + Lwt.return_unit let dns_expect_failure ~nameserver ~hostname stack () = let lookup = Domain_name.(of_string_exn hostname |> host_exn) in - let nameserver' = `UDP, (Ipaddr.V4.of_string_exn nameserver, 53) in + let nameserver' = (`UDP, (Ipaddr.V4.of_string_exn nameserver, 53)) in let dns = Dns.create ~nameserver:nameserver' stack in Dns.gethostbyname dns lookup >>= function - | Error (`Msg s) when String.compare s "Truncated UDP response" <> 0 -> Log.debug (fun f -> f "DNS test to %s failed as expected: %s" - nameserver s); - Log.info (fun f -> f "DNS traffic to %s correctly blocked :)" nameserver); - Lwt.return_unit + | Error (`Msg s) when String.compare s "Truncated UDP response" <> 0 -> + Log.debug (fun f -> + f "DNS test to %s failed as expected: %s" nameserver s); + Log.info (fun f -> + f "DNS traffic to %s correctly blocked :)" nameserver); + Lwt.return_unit | Error (`Msg s) -> - Log.debug (fun f -> f "DNS test to %s failed unexpectedly (truncated response): %s :(" - nameserver s); - Lwt.return_unit - | Ok addr -> Log.err (fun f -> f "DNS test to %s should have been blocked, but looked up %s:%a" nameserver hostname Ipaddr.V4.pp addr); - Lwt.return_unit + Log.debug (fun f -> + f "DNS test to %s failed unexpectedly (truncated response): %s :(" + nameserver s); + Lwt.return_unit + | Ok addr -> + Log.err (fun f -> + f "DNS test to %s should have been blocked, but looked up %s:%a" + nameserver hostname Ipaddr.V4.pp addr); + Lwt.return_unit let dns_then_tcp_denied server stack () = let parsed_server = Domain_name.(of_string_exn server |> host_exn) in (* ask dns about server *) - Log.debug (fun f -> f "going to make a dns thing using nameserver %s" nameserver_1); - let dns = Dns.create ~nameserver:(`UDP, ((Ipaddr.V4.of_string_exn nameserver_1), 53)) stack in + Log.debug (fun f -> + f "going to make a dns thing using nameserver %s" nameserver_1); + let dns = + Dns.create + ~nameserver:(`UDP, (Ipaddr.V4.of_string_exn nameserver_1, 53)) + stack + in Log.debug (fun f -> f "OK, going to look up %s now" server); Dns.gethostbyname dns parsed_server >>= function - | Error (`Msg s) -> Log.err (fun f -> f "couldn't look up ip for %s: %s" server s); Lwt.return_unit + | Error (`Msg s) -> + Log.err (fun f -> f "couldn't look up ip for %s: %s" server s); + Lwt.return_unit | Ok addr -> - Log.debug (fun f -> f "looked up ip for %s: %a" server Ipaddr.V4.pp addr); - Log.err (fun f -> f "Do more stuff here!!!! :("); - Lwt.return_unit + Log.debug (fun f -> + f "looked up ip for %s: %a" server Ipaddr.V4.pp addr); + Log.err (fun f -> f "Do more stuff here!!!! :("); + Lwt.return_unit let start _random _time _clock network db = E.connect network >>= fun ethernet -> @@ -316,42 +404,64 @@ module Client (R: Mirage_crypto_rng_mirage.S) (Time: Mirage_time.S) (Clock : Mir Icmp.connect ipv4 >>= fun icmp -> U.connect ipv4 >>= fun udp -> T.connect ipv4 >>= fun tcp -> - - let stack = Stack.connect network ethernet arp ipv4 icmp udp tcp in + let stack = Stack.connect network ethernet arp ipv4 icmp udp tcp in Lwt.async (fun () -> Stack.listen stack); (* put this first because tcp_connect_denied tests also generate icmp messages *) - let general_tests : unit Alcotest.test = ("firewall tests", [ - ("UDP fetch", `Quick, udp_fetch ~src_port:9090 ~echo_server_port:1235 stack); - ("Ping expect failure", `Quick, ping_expect_failure "8.8.8.8" stack ); - (* TODO: ping_expect_success to the netvm, for which we have an icmptype rule in update-firewall.sh *) - ("ICMP error type", `Quick, icmp_error_type stack) - ] ) in + let general_tests : unit Alcotest.test = + ( "firewall tests", + [ + ( "UDP fetch", + `Quick, + udp_fetch ~src_port:9090 ~echo_server_port:1235 stack ); + ("Ping expect failure", `Quick, ping_expect_failure "8.8.8.8" stack); + (* TODO: ping_expect_success to the netvm, for which we have an icmptype rule in update-firewall.sh *) + ("ICMP error type", `Quick, icmp_error_type stack); + ] ) + in Alcotest.run ~and_exit:false "name" [ general_tests ] >>= fun () -> - let tcp_tests : unit Alcotest.test = ("tcp tests", [ - (* this test fails on 4.0R3 + let tcp_tests : unit Alcotest.test = + ( "tcp tests", + [ + (* this test fails on 4.0R3 ("TCP connect", `Quick, tcp_connect "when trying specialtarget" nameserver_1 53 tcp); *) - ("TCP connect", `Quick, tcp_connect_denied "" netvm 53 tcp); - ("TCP connect", `Quick, tcp_connect_denied "when trying below range" netvm 6667 tcp); - ("TCP connect", `Quick, tcp_connect "when trying lower bound in range" netvm 6668 tcp); - ("TCP connect", `Quick, tcp_connect "when trying upper bound in range" netvm 6670 tcp); - ("TCP connect", `Quick, tcp_connect_denied "when trying above range" netvm 6671 tcp); - ("TCP connect", `Quick, tcp_connect_denied "" netvm 8082 tcp); - ] ) in + ("TCP connect", `Quick, tcp_connect_denied "" netvm 53 tcp); + ( "TCP connect", + `Quick, + tcp_connect_denied "when trying below range" netvm 6667 tcp ); + ( "TCP connect", + `Quick, + tcp_connect "when trying lower bound in range" netvm 6668 tcp ); + ( "TCP connect", + `Quick, + tcp_connect "when trying upper bound in range" netvm 6670 tcp ); + ( "TCP connect", + `Quick, + tcp_connect_denied "when trying above range" netvm 6671 tcp ); + ("TCP connect", `Quick, tcp_connect_denied "" netvm 8082 tcp); + ] ) + in (* replace the udp-related listeners with the right one for tcp *) Alcotest.run "name" [ tcp_tests ] >>= fun () -> (* use the stack abstraction only after the other tests have run, since it's not friendly with outside use of its modules *) - let stack_tests = "stack tests", [ - ("DNS expect failure", `Quick, dns_expect_failure ~nameserver:"8.8.8.8" ~hostname:"mirage.io" stack); - - (* the test below won't work on @linse's internet, + let stack_tests = + ( "stack tests", + [ + ( "DNS expect failure", + `Quick, + dns_expect_failure ~nameserver:"8.8.8.8" ~hostname:"mirage.io" stack + ); + (* the test below won't work on @linse's internet, * because the nameserver there doesn't answer on TCP port 53, * only UDP port 53. Dns_mirage_client.ml disregards our request * to use UDP and uses TCP anyway, so this request can never work there. *) - (* If we can figure out a way to have this test unikernel do a UDP lookup with minimal pain, + (* If we can figure out a way to have this test unikernel do a UDP lookup with minimal pain, * we should re-enable this test. *) - ("DNS lookup + TCP connect", `Quick, dns_then_tcp_denied "google.com" stack); - ] in + ( "DNS lookup + TCP connect", + `Quick, + dns_then_tcp_denied "google.com" stack ); + ] ) + in Alcotest.run "name" [ stack_tests ] end diff --git a/unikernel.ml b/unikernel.ml index 28115d1..51841ae 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -6,10 +6,13 @@ open Qubes open Cmdliner let src = Logs.Src.create "unikernel" ~doc:"Main unikernel code" + module Log = (val Logs.src_log src : Logs.LOG) let nat_table_size = - let doc = Arg.info ~doc:"The number of NAT entries to allocate." [ "nat-table-size" ] in + let doc = + Arg.info ~doc:"The number of NAT entries to allocate." [ "nat-table-size" ] + in Mirage_runtime.register_arg Arg.(value & opt int 5_000 doc) let ipv4 = @@ -28,86 +31,96 @@ let ipv4_dns2 = let doc = Arg.info ~doc:"Manual Second DNS IP setting." [ "ipv4-dns2" ] in Mirage_runtime.register_arg Arg.(value & opt string "10.139.1.2" doc) - module Dns_client = Dns_client.Make(My_dns) +module Dns_client = Dns_client.Make (My_dns) - (* Set up networking and listen for incoming packets. *) - let network dns_client dns_responses dns_servers qubesDB router = - (* Report success *) - Dao.set_iptables_error qubesDB "" >>= fun () -> - (* Handle packets from both networks *) - Lwt.choose [ - Dispatcher.wait_clients Mirage_mtime.elapsed_ns dns_client dns_servers qubesDB router ; - Dispatcher.uplink_wait_update qubesDB router ; - Dispatcher.uplink_listen Mirage_mtime.elapsed_ns dns_responses router +(* Set up networking and listen for incoming packets. *) +let network dns_client dns_responses dns_servers qubesDB router = + (* Report success *) + Dao.set_iptables_error qubesDB "" >>= fun () -> + (* Handle packets from both networks *) + Lwt.choose + [ + Dispatcher.wait_clients Mirage_mtime.elapsed_ns dns_client dns_servers + qubesDB router; + Dispatcher.uplink_wait_update qubesDB router; + Dispatcher.uplink_listen Mirage_mtime.elapsed_ns dns_responses router; ] - (* Main unikernel entry point (called from auto-generated main.ml). *) - let start () = - let open Lwt.Syntax in - let start_time = Mirage_mtime.elapsed_ns () in - (* Start qrexec agent and QubesDB agent in parallel *) - let* qrexec = RExec.connect ~domid:0 () in - let agent_listener = RExec.listen qrexec Command.handler in - let* qubesDB = DB.connect ~domid:0 () in - let startup_time = - let (-) = Int64.sub in - let time_in_ns = Mirage_mtime.elapsed_ns () - start_time in - Int64.to_float time_in_ns /. 1e9 - in - Log.info (fun f -> f "QubesDB and qrexec agents connected in %.3f s" startup_time); - (* Watch for shutdown requests from Qubes *) - let shutdown_rq = - Xen_os.Lifecycle.await_shutdown_request () >>= fun (`Poweroff | `Reboot) -> - Lwt.return_unit in - (* Set up networking *) - let nat = My_nat.create ~max_entries:(nat_table_size ()) in +(* Main unikernel entry point (called from auto-generated main.ml). *) +let start () = + let open Lwt.Syntax in + let start_time = Mirage_mtime.elapsed_ns () in + (* Start qrexec agent and QubesDB agent in parallel *) + let* qrexec = RExec.connect ~domid:0 () in + let agent_listener = RExec.listen qrexec Command.handler in + let* qubesDB = DB.connect ~domid:0 () in + let startup_time = + let ( - ) = Int64.sub in + let time_in_ns = Mirage_mtime.elapsed_ns () - start_time in + Int64.to_float time_in_ns /. 1e9 + in + Log.info (fun f -> + f "QubesDB and qrexec agents connected in %.3f s" startup_time); + (* Watch for shutdown requests from Qubes *) + let shutdown_rq = + Xen_os.Lifecycle.await_shutdown_request () >>= fun (`Poweroff | `Reboot) -> + Lwt.return_unit + in + (* Set up networking *) + let nat = My_nat.create ~max_entries:(nat_table_size ()) in - let netvm_ip = Ipaddr.V4.of_string_exn (ipv4_gw ()) in - let our_ip = Ipaddr.V4.of_string_exn (ipv4 ()) in - let dns = Ipaddr.V4.of_string_exn (ipv4_dns ()) in - let dns2 = Ipaddr.V4.of_string_exn (ipv4_dns2 ()) in + let netvm_ip = Ipaddr.V4.of_string_exn (ipv4_gw ()) in + let our_ip = Ipaddr.V4.of_string_exn (ipv4 ()) in + let dns = Ipaddr.V4.of_string_exn (ipv4_dns ()) in + let dns2 = Ipaddr.V4.of_string_exn (ipv4_dns2 ()) in - let zero_ip = Ipaddr.V4.any in + let zero_ip = Ipaddr.V4.any in - let network_config = - if (netvm_ip = zero_ip && our_ip = zero_ip) then (* Read network configuration from QubesDB *) - Dao.read_network_config qubesDB >>= fun config -> - if config.netvm_ip = zero_ip || config.our_ip = zero_ip then - Log.info (fun f -> f "We currently have no netvm nor command line for setting it up, aborting..."); - assert (config.netvm_ip <> zero_ip && config.our_ip <> zero_ip); - Lwt.return config - else begin - let config:Dao.network_config = {from_cmdline=true; netvm_ip; our_ip; dns; dns2} in - Lwt.return config - end - in - network_config >>= fun config -> + let network_config = + if netvm_ip = zero_ip && our_ip = zero_ip then ( + (* Read network configuration from QubesDB *) + Dao.read_network_config qubesDB + >>= fun config -> + if config.netvm_ip = zero_ip || config.our_ip = zero_ip then + Log.info (fun f -> + f + "We currently have no netvm nor command line for setting it up, \ + aborting..."); + assert (config.netvm_ip <> zero_ip && config.our_ip <> zero_ip); + Lwt.return config) + else + let config : Dao.network_config = + { from_cmdline = true; netvm_ip; our_ip; dns; dns2 } + in + Lwt.return config + in + network_config >>= fun config -> + (* We now must have a valid netvm IP address and our IP address or crash *) + Dao.print_network_config config; - (* We now must have a valid netvm IP address and our IP address or crash *) - Dao.print_network_config config ; + (* Set up client-side networking *) + let* clients = Client_eth.create config in - (* Set up client-side networking *) - let* clients = Client_eth.create config in + (* Set up routing between networks and hosts *) + let router = Dispatcher.create ~config ~clients ~nat ~uplink:None in - (* Set up routing between networks and hosts *) - let router = Dispatcher.create - ~config - ~clients - ~nat - ~uplink:None - in + let send_dns_query = Dispatcher.send_dns_client_query router in + let dns_mvar = Lwt_mvar.create_empty () 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 send_dns_query = Dispatcher.send_dns_client_query router in - let dns_mvar = Lwt_mvar.create_empty () 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 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 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 qubesDB router in - - (* Report memory usage to XenStore *) - Memory_pressure.init (); - (* Run until something fails or we get a shutdown request. *) - Lwt.choose [agent_listener; net_listener; shutdown_rq] >>= fun () -> - (* Give the console daemon time to show any final log messages. *) - Mirage_sleep.ns (1.0 *. 1e9 |> Int64.of_float) + (* Report memory usage to XenStore *) + Memory_pressure.init (); + (* Run until something fails or we get a shutdown request. *) + Lwt.choose [ agent_listener; net_listener; shutdown_rq ] >>= fun () -> + (* Give the console daemon time to show any final log messages. *) + Mirage_sleep.ns (1.0 *. 1e9 |> Int64.of_float) From 64d2b16c3a021b189a0ac3a80e9ae4106f0491a4 Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Tue, 18 Mar 2025 15:52:32 +0100 Subject: [PATCH 281/281] fix hashsum --- qubes-firewall.sha256 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/qubes-firewall.sha256 b/qubes-firewall.sha256 index 067b2d6..f6c0982 100644 --- a/qubes-firewall.sha256 +++ b/qubes-firewall.sha256 @@ -1 +1 @@ -1cc5664d48a80b96162e14a0d8a17aafa52175cc2043ecf6b834c4bc8fe656f6 dist/qubes-firewall.xen +ac049069b35f786fa11b18a2261d7dbecd588301af0363ef6888ec9d924dc989 dist/qubes-firewall.xen