diff --git a/client_net.ml b/client_net.ml index 8772444..c62afcf 100644 --- a/client_net.ml +++ b/client_net.ml @@ -31,6 +31,7 @@ class client_iface eth ~domid ~gateway_ip ~client_ip client_mac rules : client_l object val queue = FrameQ.create (Ipaddr.V4.to_string client_ip) val rules = rules + method get_rules = rules method my_mac = ClientEth.mac eth method other_mac = client_mac method my_ip = gateway_ip @@ -103,7 +104,8 @@ 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 rules = 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 and %d firewall rules" + Dao.ClientVif.pp vif Ipaddr.V4.pp client_ip (List.length rules)); Lwt.async (fun () -> Lwt.catch (fun () -> add_vif vif ~client_ip ~router ~cleanup_tasks rules @@ -138,6 +140,7 @@ let listen qubesDB router = new_set |> Dao.VifMap.iter (fun key (ip_addr, rules) -> if not (Dao.VifMap.mem key !clients) then ( let cleanup = add_client ~router key ip_addr rules in + Log.debug (fun f -> f "client %a arrived with %d rules" Dao.ClientVif.pp key (List.length rules)); clients := !clients |> Dao.VifMap.add key cleanup ) ) diff --git a/dao.ml b/dao.ml index e35dfcc..10d472f 100644 --- a/dao.ml +++ b/dao.ml @@ -36,20 +36,32 @@ let directory ~handle dir = let read_rules qubesDB client_ip = let root = "/qubes-firewall/" ^ (Ipaddr.V4.to_string client_ip) ^ "/" in - let rec get_rule n l = + let rec get_rule n l : (Pf_qubes.Parse_qubes.rule list, string) result = let pattern = root ^ Printf.sprintf "%04d" n in - Log.info (fun f -> f "reading %s" pattern); + Log.debug (fun f -> f "reading %s" pattern); match Qubes.DB.read qubesDB pattern with | None -> - Log.info (fun f -> f "rule %d was empty " n); - List.rev l + Log.debug (fun f -> f "rule %d does not exist; won't look for more" n); + Ok (List.rev l) | Some rule -> - Log.info (fun f -> f "rule %d: %s" n rule); + Log.debug (fun f -> f "rule %d: %s" n rule); match Pf_qubes.Parse_qubes.parse_qubes ~number:n rule with - | Error e -> (* TODOOOOOOO!! Traffic should be dropped!!*) l - | Ok rule -> get_rule (n+1) (rule :: l) + | 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 - get_rule 0 [] + 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 = []; + icmp_type = None; + number = 0;})] let vifs qubesDB ~handle domid = match String.to_int domid with @@ -131,7 +143,4 @@ let read_network_config qubesDB = in aux (DB.bindings qubesDB) -let read_fw_rules qubesDB domid = - [] - let set_iptables_error db = Qubes.DB.write db "/qubes-iptables-error" diff --git a/dao.mli b/dao.mli index 3a4082d..2c5343b 100644 --- a/dao.mli +++ b/dao.mli @@ -30,6 +30,4 @@ 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 read_fw_rules: Qubes.DB.t -> int -> Pf_qubes.Parse_qubes.rule list - val set_iptables_error : Qubes.DB.t -> string -> unit Lwt.t diff --git a/firewall.ml b/firewall.ml index 31cb816..2fe8323 100644 --- a/firewall.ml +++ b/firewall.ml @@ -50,17 +50,6 @@ let forward_ipv4 t packet = 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 - (* NAT *) let translate t packet = @@ -97,7 +86,9 @@ let apply_rules t (rules : ('a, 'b) Packet.t -> Packet.action) ~dst (annotated_p | `Accept, (`Firewall_uplink | `Client_gateway) -> Log.warn (fun f -> f "Bad rule: firewall can't accept packets %a" Nat_packet.pp packet); return () - | `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 Nat_packet.pp packet); @@ -122,11 +113,7 @@ 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 - let src = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.src) in - match of_mirage_nat_packet - ~src:(src) - ~dst:(resolve_host dst) - packet with + match of_mirage_nat_packet ~src:(`Client src) ~dst packet with | None -> return () | Some firewall_packet -> apply_rules t Rules.from_client ~dst firewall_packet @@ -137,7 +124,7 @@ 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 Packet.of_mirage_nat_packet ~src ~dst:(resolve_host dst) packet with + match Packet.of_mirage_nat_packet ~src ~dst packet with | None -> Lwt.return_unit | Some _ -> match src with diff --git a/rules.ml b/rules.ml index 273eea5..69c635f 100644 --- a/rules.ml +++ b/rules.ml @@ -1,34 +1,19 @@ (* Copyright (C) 2015, Thomas Leonard See the README file for details. *) -(** Put your firewall rules in this file. *) +(** Enforce firewall rules from QubesDB. *) -open Packet (* Allow us to use definitions in packet.ml *) +open Packet +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 -(* 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; - *) -] - (* OCaml normally warns if you don't match all fields, but that's OK here. *) [@@@ocaml.warning "-9"] -module Q = Pf_qubes.Parse_qubes - (* we want to replace this list with a structure including rules from QubesDB. we need: 1) code for reading the rules (we have some for noticing new clients: dao.ml) @@ -40,19 +25,11 @@ module Q = Pf_qubes.Parse_qubes - initially we can set them up with a list, and then look for faster/better/clearer structures later 4) code for applying the rules to incoming traffic (below, already in this file) *) -let dummy_rules = - Pf_qubes.Parse_qubes.([{ action = Drop ; - proto = None ; - specialtarget = None ; - dst = `any ; - dstports = [] ; - icmp_type = None ; - number = 0 ; - }]) (* Does the packet match our rules? *) -let classify_client_packet (packet : ([`Client of _], _) Packet.t) (client_link : Fw_utils.client_link) : Packet.action = +let classify_client_packet (packet : ([`Client of Fw_utils.client_link], _) Packet.t) : Packet.action = let matches_port dstports (port : int) = + List.length dstports = 0 || List.exists (fun (Q.Range_inclusive (min, max)) -> (min <= port && port <= max)) dstports in let matches_proto rule packet = match rule.Pf_qubes.Parse_qubes.proto with @@ -74,15 +51,25 @@ let classify_client_packet (packet : ([`Client of _], _) Packet.t) (client_link | `hosts subnet -> Ipaddr.Prefix.mem (V4 packet.ipv4_header.Ipv4_packet.dst) subnet in - let action = List.fold_left (fun found rule -> match found with - | Some action -> Some action - | None -> if matches_proto rule packet && matches_dest rule packet then Some rule.action else None) None client_link#get_rules - in - match action with - | None -> `Drop "No matching rule" - | Some Accept -> `Accept - | Some Drop -> `Drop "Drop rule matched" - + let (`Client client_link) = packet.src in + Log.debug (fun f -> f "checking %d rules for a match" (List.length client_link#get_rules)); + List.find_opt (fun rule -> + if not (matches_proto rule packet) then begin + Log.debug (fun f -> f "rule %d is not a match - proto" rule.Q.number); + false + end else if not (matches_dest rule packet) then begin + Log.debug (fun f -> f "rule %d is not a match - dest" rule.Q.number); + false + end else begin + Log.debug (fun f -> f "rule %d is a match" rule.Q.number); + true + end) client_link#get_rules |> function + | None -> `Drop "No matching rule; assuming default drop" + | Some {Q.action = Accept; number; _} -> + Log.debug (fun f -> f "allowing packet matching rule %d" number); + `Accept + | Some {Q.action = Drop; number; _} -> + `Drop (Printf.sprintf "rule %d explicitly drops this packet" number) (** This function decides what to do with a packet from a client VM. @@ -94,28 +81,19 @@ let classify_client_packet (packet : ([`Client of _], _) Packet.t) (client_link Note: If the packet matched an existing NAT rule then this isn't called. *) let from_client (packet : ([`Client of Fw_utils.client_link], _) Packet.t) : Packet.action = match packet with - (* Examples (add your own rules here): - - 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. - - 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 = (`External _ | `NetVM) } -> begin + (* see whether this traffic is allowed *) + match classify_client_packet packet with + | `Accept -> `NAT + | `Drop s -> `Drop s + end | { dst = `Client_gateway; transport_header = `UDP header; _ } -> + (* TODO: this is where we should implement specialtarget dns rules? *) if header.dst_port = dns_port then `NAT_to (`NetVM, dns_port) else `Drop "packet addressed to client gateway" | { dst = (`Client_gateway | `Firewall_uplink) } -> `Drop "packet addressed to firewall itself" - | { dst = `Client client_link } -> classify_client_packet packet client_link + | { dst = `Client _ } -> classify_client_packet packet (** 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/test/test.sh b/test/test.sh index 21eda1c..446e730 100755 --- a/test/test.sh +++ b/test/test.sh @@ -76,7 +76,7 @@ fi echo "We're gonna set up a unikernel for the mirage-fw-test qube" cd .. -mirage configure -t xen && \ +mirage configure -t xen -l "*:debug" && \ make depend && \ make if [ $? -ne 0 ]; then