in rules, instead of hardcoding IPv4 addresses of name servers, use those present in QubesDB

This commit is contained in:
Hannes Mehnert 2022-09-07 16:53:45 +02:00
parent 5fdcaae7e8
commit c643f97700
8 changed files with 37 additions and 37 deletions

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) iface#writev `ARP (fun b -> Arp_packet.encode_into response b; Arp_packet.size)
(** Handle an IPv4 packet from the client. *) (** 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 let cache', r = Nat_packet.of_ipv4_packet !cache ~now:(get_ts ()) packet in
cache := cache'; cache := cache';
match r with match r with
@ -70,7 +70,7 @@ let input_ipv4 get_ts cache ~iface ~router dns_client packet =
| Ok (Some packet) -> | Ok (Some packet) ->
let `IPv4 (ip, _) = packet in let `IPv4 (ip, _) = packet in
let src = ip.Ipv4_packet.src 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 ( else (
Log.warn (fun f -> f "Incorrect source IP %a in IP packet from %a (dropping)" 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); 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. *) (** 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 -> Netback.make ~domid ~device_id >>= fun backend ->
Log.info (fun f -> f "Client %d (IP: %s) ready" domid (Ipaddr.V4.to_string client_ip)); Log.info (fun f -> f "Client %d (IP: %s) ready" domid (Ipaddr.V4.to_string client_ip));
ClientEth.connect backend >>= fun eth -> 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) -> | Ok (eth, payload) ->
match eth.Ethernet.Packet.ethertype with match eth.Ethernet.Packet.ethertype with
| `ARP -> input_arp ~fixed_arp ~iface payload | `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! *) | `IPv6 -> Lwt.return_unit (* TODO: oh no! *)
) )
>|= or_raise "Listen on client interface" Netback.pp_error) >|= 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 ] Lwt.pick [ qubesdb_updater ; listener ]
(** A new client VM has been found in XenStore. Find its interface and connect to it. *) (** 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 let cleanup_tasks = Cleanup.create () in
Log.info (fun f -> f "add client vif %a with IP %a" Log.info (fun f -> f "add client vif %a with IP %a"
Dao.ClientVif.pp vif Ipaddr.V4.pp client_ip); Dao.ClientVif.pp vif Ipaddr.V4.pp client_ip);
Lwt.async (fun () -> Lwt.async (fun () ->
Lwt.catch (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 -> (fun ex ->
Log.warn (fun f -> f "Error with client %a: %s" 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 cleanup_tasks
(** Watch XenStore for notifications of new clients. *) (** 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 -> Dao.watch_clients (fun new_set ->
(* Check for removed clients *) (* Check for removed clients *)
!clients |> Dao.VifMap.iter (fun key cleanup -> !clients |> Dao.VifMap.iter (fun key cleanup ->
@ -162,7 +162,7 @@ let listen get_ts dns_client qubesDB router =
(* Check for added clients *) (* Check for added clients *)
new_set |> Dao.VifMap.iter (fun key ip_addr -> new_set |> Dao.VifMap.iter (fun key ip_addr ->
if not (Dao.VifMap.mem key !clients) then ( 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); Log.debug (fun f -> f "client %a arrived" Dao.ClientVif.pp key);
clients := !clients |> Dao.VifMap.add key cleanup clients := !clients |> Dao.VifMap.add key cleanup
) )

View File

@ -5,8 +5,8 @@
val listen : (unit -> int64) -> val listen : (unit -> int64) ->
([ `host ] Domain_name.t -> (int32 * Ipaddr.V4.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 Ipaddr.V4.t list -> 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 (** [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 removed from XenStore. Clients are connected to the client network and
packets are sent via [router]. We ensure the source IP address is correct packets are sent via [router]. We ensure the source IP address is correct
before routing a packet. *) 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) *) clients_our_ip : Ipaddr.V4.t; (* The IP address of our interface to our client VMs (their gateway) *)
dns : Ipaddr.V4.t; dns : Ipaddr.V4.t;
dns2 : Ipaddr.V4.t;
} }
exception Missing_key of string 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 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 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 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:@,\ Log.info (fun f -> f "@[<v2>Got network configuration from QubesDB:@,\
NetVM IP on uplink network: %a@,\ NetVM IP on uplink network: %a@,\
Our IP on uplink network: %a@,\ Our IP on uplink network: %a@,\
Our IP on client networks: %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_netvm_ip
Ipaddr.V4.pp uplink_our_ip Ipaddr.V4.pp uplink_our_ip
Ipaddr.V4.pp clients_our_ip Ipaddr.V4.pp clients_our_ip
Ipaddr.V4.pp dns); Ipaddr.V4.pp dns
{ uplink_netvm_ip; uplink_our_ip; clients_our_ip ; dns } Ipaddr.V4.pp dns2);
{ uplink_netvm_ip; uplink_our_ip; clients_our_ip ; dns ; dns2 }
let read_network_config qubesDB = let read_network_config qubesDB =
let rec aux bindings = let rec aux bindings =

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) *) clients_our_ip : Ipaddr.V4.t; (* The IP address of our interface to our client VMs (their gateway) *)
dns : Ipaddr.V4.t; dns : Ipaddr.V4.t;
dns2 : Ipaddr.V4.t;
} }
val read_network_config : Qubes.DB.t -> network_config Lwt.t val read_network_config : Qubes.DB.t -> network_config Lwt.t

View File

@ -91,7 +91,7 @@ let handle_low_memory t =
`Memory_critical `Memory_critical
| `Ok -> Lwt.return `Ok | `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 handle_low_memory t >>= function
| `Memory_critical -> Lwt.return_unit | `Memory_critical -> Lwt.return_unit
| `Ok -> | `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 let dst = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in
match of_mirage_nat_packet ~src:(`Client src) ~dst packet with match of_mirage_nat_packet ~src:(`Client src) ~dst packet with
| None -> Lwt.return_unit | 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 = let ipv4_from_netvm t packet =
handle_low_memory t >>= function handle_low_memory t >>= function

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 *) (* 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) -> 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 (** Handle a packet from a client. Caller must check the source IP matches the client's
before calling this. *) before calling this. *)

View File

@ -10,12 +10,6 @@ module Q = Pf_qubes.Parse_qubes
let src = Logs.Src.create "rules" ~doc:"Firewall rules" let src = Logs.Src.create "rules" ~doc:"Firewall rules"
module Log = (val Logs.src_log src : Logs.LOG) 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 let dns_port = 53
module Classifier = struct module Classifier = struct
@ -24,9 +18,9 @@ module Classifier = struct
| None -> true | None -> true
| Some (Q.Range_inclusive (min, max)) -> min <= port && port <= max | 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, 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 applies only to the specialtarget destination IPs, and
specialtarget=dns is also implicitly tcp/udp port 53 *) specialtarget=dns is also implicitly tcp/udp port 53 *)
match packet.transport_header with match packet.transport_header with
@ -70,35 +64,35 @@ module Classifier = struct
end end
let find_first_match dns_client packet acc rule = let find_first_match dns_client dns_servers packet acc rule =
match acc with match acc with
| `No_match -> | `No_match ->
if Classifier.matches_proto rule packet if Classifier.matches_proto rule dns_servers packet
then Classifier.matches_dest dns_client rule packet then Classifier.matches_dest dns_client rule packet
else Lwt.return `No_match else Lwt.return `No_match
| q -> Lwt.return q | q -> Lwt.return q
(* Does the packet match our rules? *) (* 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 (`Client client_link) = packet.src in
let rules = client_link#get_rules 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" | `No_match -> `Drop "No matching rule; assuming default drop"
| `Match {Q.action = Q.Accept; _} -> `Accept | `Match {Q.action = Q.Accept; _} -> `Accept
| `Match ({Q.action = Q.Drop; _} as rule) -> | `Match ({Q.action = Q.Drop; _} as rule) ->
`Drop (Format.asprintf "rule number %a explicitly drops this packet" Q.pp_rule rule) `Drop (Format.asprintf "rule number %a explicitly drops this packet" Q.pp_rule rule)
let translate_accepted_packets dns_client packet = let translate_accepted_packets dns_client dns_servers packet =
classify_client_packet dns_client packet >|= function classify_client_packet dns_client dns_servers packet >|= function
| `Accept -> `NAT | `Accept -> `NAT
| `Drop s -> `Drop s | `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 *) (** 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 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 = `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" | _ -> 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 *) (** Packets from the outside world that don't match any NAT table entry are being dropped by default *)

View File

@ -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) module Dns_client = Dns_client.Make(Dns_transport)
(* Set up networking and listen for incoming packets. *) (* 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 *) (* Report success *)
Dao.set_iptables_error qubesDB "" >>= fun () -> Dao.set_iptables_error qubesDB "" >>= fun () ->
(* Handle packets from both networks *) (* Handle packets from both networks *)
Lwt.choose [ 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 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 send_dns_query = Uplink.send_dns_client_query uplink in
let dns_mvar = Lwt_mvar.create_empty () 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 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 *) (* Report memory usage to XenStore *)
Memory_pressure.init (); Memory_pressure.init ();