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