Git-Mirrors/qubes-mirage-firewall
1
0
Fork 0
mirror of https://github.com/mirage/qubes-mirage-firewall.git synced 2024-10-01 01:05:39 -04:00
Code Issues Packages Projects Releases Wiki Activity

Merge pull request #149 from hannesm/next

Browse Source 
Next release
This commit is contained in:
Hannes Mehnert 2022-09-14 10:57:49 +02:00 committed by GitHub
commit 47562749b2
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
11 changed files with 58 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Dockerfile
View File

@ -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

2
build-with-docker.sh
View File

@ -5,5 +5,5 @@ docker build -t qubes-mirage-firewall .
echo Building Firewall...
docker run --rm -i -v `pwd`:/home/opam/qubes-mirage-firewall qubes-mirage-firewall
echo "SHA2 of build: $(sha256sum ./dist/qubes-firewall.xen)"
echo "SHA2 last known: 588e921b9d78a99f6f49d468a7b68284c50dabeba95698648ea52e99b381723b"
echo "SHA2 last known: d0ec19d5b392509955edccf100852bcc9c0e05bf31f1ec25c9cc9c9e74c3b7bf"
echo "(hashes should match for released versions)"

16
client_net.ml
View File

@ -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
)

4
client_net.mli
View File

@ -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. *)

10
dao.ml
View File

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

1
dao.mli
View File

@ -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

4
firewall.ml
View File

@ -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

2
firewall.mli
View File

@ -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. *)

20
memory_pressure.ml
View File

@ -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
)

32
rules.ml
View File

@ -10,12 +10,6 @@ module Q = Pf_qubes.Parse_qubes
let src = Logs.Src.create "rules" ~doc:"Firewall rules"
module Log = (val Logs.src_log src : Logs.LOG)
(* the upstream NetVM will redirect TCP and UDP port 53 traffic with
these destination IPs to its upstream nameserver. *)
let default_dns_servers = [
Ipaddr.V4.of_string_exn "10.139.1.1";
Ipaddr.V4.of_string_exn "10.139.1.2";
]
let dns_port = 53
module Classifier = struct
@ -24,9 +18,9 @@ module Classifier = struct
| None -> true
| Some (Q.Range_inclusive (min, max)) -> min <= port && port <= max
let matches_proto rule packet = match rule.Q.proto, rule.Q.specialtarget with
let matches_proto rule dns_servers packet = match rule.Q.proto, rule.Q.specialtarget with
| None, None -> true
| None, Some `dns when List.mem packet.ipv4_header.Ipv4_packet.dst default_dns_servers -> begin
| None, Some `dns when List.mem packet.ipv4_header.Ipv4_packet.dst dns_servers -> begin
(* specialtarget=dns applies only to the specialtarget destination IPs, and
specialtarget=dns is also implicitly tcp/udp port 53 *)
match packet.transport_header with
@ -70,39 +64,35 @@ module Classifier = struct
end
let find_first_match dns_client packet acc rule =
let find_first_match dns_client dns_servers packet acc rule =
match acc with
| `No_match ->
if Classifier.matches_proto rule packet
if Classifier.matches_proto rule dns_servers packet
then Classifier.matches_dest dns_client rule packet
else Lwt.return `No_match
| q -> Lwt.return q
(* Does the packet match our rules? *)
let classify_client_packet dns_client (packet : ([`Client of Fw_utils.client_link], _) Packet.t) =
let classify_client_packet dns_client dns_servers (packet : ([`Client of Fw_utils.client_link], _) Packet.t) =
let (`Client client_link) = packet.src in
let rules = client_link#get_rules in
Lwt_list.fold_left_s (find_first_match dns_client packet) `No_match rules >|= function
Lwt_list.fold_left_s (find_first_match dns_client dns_servers packet) `No_match rules >|= function
| `No_match -> `Drop "No matching rule; assuming default drop"
| `Match {Q.action = Q.Accept; _} -> `Accept
| `Match ({Q.action = Q.Drop; _} as rule) ->
`Drop (Format.asprintf "rule number %a explicitly drops this packet" Q.pp_rule rule)
let translate_accepted_packets dns_client packet =
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 = `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 = `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 *)

29
unikernel.ml
View File

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