Git-Mirrors/qubes-mirage-firewall
1
0
Fork 0
mirror of https://github.com/mirage/qubes-mirage-firewall.git synced 2025-03-03 12:29:15 -05:00
Code Issues Packages Projects Releases Wiki Activity

Merge pull request #96 from roburio/squash

Browse Source 
QubesOS 4.0 support
This commit is contained in:
Hannes Mehnert 2020-05-15 17:33:23 +02:00 committed by GitHub
commit d34842e31a
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
31 changed files with 1159 additions and 256 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
CHANGES.md
View File

@ -1,3 +1,18 @@
### master branch
This version adapts qubes-mirage-firewall with
- dynamic rulesets via QubesDB (as defined in Qubes 4.0), and
- adds support for DNS hostnames in rules, using the pf-qubes library for parsing.
The DNS client is provided by DNS (>= 4.2.0) which uses a cache for name lookups. Not every packet will lead to a DNS lookup if DNS rules are in place.
A test unikernel is available in the test subdirectory.
This project was done by @linse and @yomimono in summer 2019, see PR #96.
Additional changes and bugfixes:
TODO: describe based on commit log de7d05e .. 02e515d
### 0.6 ### 0.6
Changes to rules language: Changes to rules language:

4
Dockerfile
View File

@ -7,9 +7,9 @@ FROM ocurrent/opam@sha256:3f3ce7e577a94942c7f9c63cbdd1ecbfe0ea793f581f69047f3155
# Pin last known-good version for reproducible builds. # Pin last known-good version for reproducible builds.
# Remove this line (and the base image pin above) if you want to test with the # Remove this line (and the base image pin above) if you want to test with the
# latest versions. # 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 RUN mkdir /home/opam/qubes-mirage-firewall
ADD config.ml /home/opam/qubes-mirage-firewall/config.ml ADD config.ml /home/opam/qubes-mirage-firewall/config.ml
WORKDIR /home/opam/qubes-mirage-firewall WORKDIR /home/opam/qubes-mirage-firewall

2
Makefile.builder
View File

@ -4,5 +4,5 @@ SOURCE_BUILD_DEP := firewall-build-dep
firewall-build-dep: firewall-build-dep:
opam install -y depext 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

5
Makefile.user
View File

@ -5,3 +5,8 @@ tar: build
touch _build/mirage-firewall/modules.img touch _build/mirage-firewall/modules.img
cat /dev/null | gzip -n > _build/mirage-firewall/initramfs cat /dev/null | gzip -n > _build/mirage-firewall/initramfs
tar cjf mirage-firewall.tar.bz2 -C _build --mtime=./build-with-docker.sh mirage-firewall tar cjf mirage-firewall.tar.bz2 -C _build --mtime=./build-with-docker.sh mirage-firewall
fetchmotron: qubes_firewall.xen
test-mirage qubes_firewall.xen mirage-fw-test &
sleep 1
boot-mirage fetchmotron

7
README.md
View File

@ -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 [dao] Watching backend/vif
2017-03-18 11:32:38 -00:00: INF [qubes.db] got update: "/qubes-netvm-domid" = "1" 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 # 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. 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.

2
build-with-docker.sh
View File

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

73
client_net.ml
View File

@ -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 let log_header = Fmt.strf "dom%d:%a" domid Ipaddr.V4.pp client_ip in
object object
val queue = FrameQ.create (Ipaddr.V4.to_string client_ip) 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 my_mac = ClientEth.mac eth
method other_mac = client_mac method other_mac = client_mac
method my_ip = gateway_ip method my_ip = gateway_ip
@ -56,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 packet = let input_ipv4 get_ts cache ~iface ~router dns_client packet =
let cache', r = Nat_packet.of_ipv4_packet !cache ~now:(get_ts ()) packet in let cache', r = Nat_packet.of_ipv4_packet !cache ~now:(get_ts ()) packet in
cache := cache'; cache := cache';
match r with match r with
@ -67,15 +70,15 @@ let input_ipv4 get_ts cache ~iface ~router 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 router ~src:iface packet if src = iface#other_ip then Firewall.ipv4_from_client dns_client 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);
Lwt.return_unit Lwt.return_unit
) )
(** Connect to a new client's interface and listen for incoming frames. *) (** 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 = let add_vif get_ts { Dao.ClientVif.domid; device_id } dns_client ~client_ip ~router ~cleanup_tasks qubesDB =
Netback.make ~domid ~device_id >>= fun backend -> 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 ->
@ -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 client_eth = router.Router.client_eth in
let gateway_ip = Client_eth.client_gw 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 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 router.Router.ports 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 () -> Router.add_client router iface >>= fun () ->
Cleanup.on_cleanup cleanup_tasks (fun () -> Router.remove_client router iface); Cleanup.on_cleanup cleanup_tasks (fun () -> Router.remove_client router iface);
let fixed_arp = Client_eth.ARP.create ~net:client_eth iface in let fixed_arp = Client_eth.ARP.create ~net:client_eth iface in
let fragment_cache = ref (Fragments.Cache.empty (256 * 1024)) in let fragment_cache = ref (Fragments.Cache.empty (256 * 1024)) in
Netback.listen backend ~header_size:Ethernet_wire.sizeof_ethernet (fun frame -> let listener =
match Ethernet_packet.Unmarshal.of_cstruct frame with Lwt.catch
| Error err -> Log.warn (fun f -> f "Invalid Ethernet frame: %s" err); Lwt.return_unit (fun () ->
| Ok (eth, payload) -> Netback.listen backend ~header_size:Ethernet_wire.sizeof_ethernet (fun frame ->
match eth.Ethernet_packet.ethertype with match Ethernet_packet.Unmarshal.of_cstruct frame with
| `ARP -> input_arp ~fixed_arp ~iface payload | Error err -> Log.warn (fun f -> f "Invalid Ethernet frame: %s" err); Lwt.return_unit
| `IPv4 -> input_ipv4 get_ts fragment_cache ~iface ~router payload | Ok (eth, payload) ->
| `IPv6 -> Lwt.return_unit (* TODO: oh no! *) match eth.Ethernet_packet.ethertype with
) | `ARP -> input_arp ~fixed_arp ~iface payload
>|= or_raise "Listen on client interface" Netback.pp_error | `IPv4 -> input_ipv4 get_ts fragment_cache ~iface ~router dns_client payload
| `IPv6 -> Lwt.return_unit (* TODO: oh no! *)
)
>|= or_raise "Listen on client interface" Netback.pp_error)
(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. *) (** 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 dns_client ~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" 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.async (fun () ->
Lwt.catch (fun () -> Lwt.catch (fun () ->
add_vif get_ts vif ~client_ip ~router ~cleanup_tasks add_vif get_ts vif dns_client ~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"
@ -115,7 +149,7 @@ let add_client get_ts ~router vif client_ip =
cleanup_tasks cleanup_tasks
(** Watch XenStore for notifications of new clients. *) (** Watch XenStore for notifications of new clients. *)
let listen get_ts router = let listen get_ts dns_client 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 ->
@ -128,7 +162,8 @@ let listen get_ts 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 ~router key ip_addr in let cleanup = add_client get_ts dns_client ~router key ip_addr qubesDB in
Log.debug (fun f -> f "client %a arrived" Dao.ClientVif.pp key);
clients := !clients |> Dao.VifMap.add key cleanup clients := !clients |> Dao.VifMap.add key cleanup
) )
) )

12
client_net.mli
View File

@ -3,8 +3,10 @@
(** Handling client VMs. *) (** Handling client VMs. *)
val listen : (unit -> int64) -> Router.t -> 'a Lwt.t val listen : (unit -> int64) ->
(** [listen get_timestamp router] is a thread that watches for clients being ([ `host ] Domain_name.t -> (int32 * Dns.Rr_map.Ipv4_set.t, [> `Msg of string ]) result Lwt.t) ->
added to and removed from XenStore. Clients are connected to the client Qubes.DB.t -> Router.t -> 'a Lwt.t
network and packets are sent via [router]. We ensure the source IP address (** [listen get_timestamp resolver db router] is a thread that watches for clients being added to and
is correct before routing a packet. *) 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
config.ml
View File

@ -30,13 +30,15 @@ let main =
package "netchannel" ~min:"1.11.0"; package "netchannel" ~min:"1.11.0";
package "mirage-net-xen"; package "mirage-net-xen";
package "ipaddr" ~min:"4.0.0"; package "ipaddr" ~min:"4.0.0";
package "mirage-qubes" ~min:"0.8.0"; package "mirage-qubes" ~min:"0.8.2";
package "mirage-nat" ~min:"2.1.0"; package "mirage-nat" ~min:"2.2.1";
package "mirage-logs"; package "mirage-logs";
package "mirage-xen" ~min:"5.0.0"; package "mirage-xen" ~min:"5.0.0";
package ~min:"4.5.0" "dns-client";
package "pf-qubes";
] ]
"Unikernel.Main" (mclock @-> job) "Unikernel.Main" (random @-> mclock @-> job)
let () = let () =
register "qubes-firewall" [main $ default_monotonic_clock] register "qubes-firewall" [main $ default_random $ default_monotonic_clock]
~argv:no_argv ~argv:no_argv

32
dao.ml
View File

@ -33,6 +33,38 @@ let directory ~handle dir =
| [""] -> [] (* XenStore client bug *) | [""] -> [] (* XenStore client bug *)
| items -> items | 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 = let vifs ~handle domid =
match String.to_int domid with match String.to_int domid with
| None -> Log.err (fun f -> f "Invalid domid %S" domid); Lwt.return [] | None -> Log.err (fun f -> f "Invalid domid %S" domid); Lwt.return []

7
dao.mli
View File

@ -30,4 +30,11 @@ val read_network_config : Qubes.DB.t -> network_config Lwt.t
(** [read_network_config db] fetches the configuration from QubesDB. (** [read_network_config db] fetches the configuration from QubesDB.
If it isn't there yet, it waits until it is. *) 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 val set_iptables_error : Qubes.DB.t -> string -> unit Lwt.t

12
diagrams/components.txt
View File

@ -1,6 +1,12 @@
+----------+ +--------------------+
| rules | | rules from QubesDB |
+----------+ +--------------------+
^
if-not-in-nat | then check
|
+-----------+
| nat-table |
+-----------+
^ ^
|checks |checks
| |

119
firewall.ml
View File

@ -16,7 +16,7 @@ let transmit_ipv4 packet iface =
iface#writev `IPv4 (fun b -> iface#writev `IPv4 (fun b ->
match Nat_packet.into_cstruct packet b with match Nat_packet.into_cstruct packet b with
| Error e -> | 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 Ipaddr.V4.pp iface#other_ip
Nat_packet.pp_error e); Nat_packet.pp_error e);
0 0
@ -38,72 +38,6 @@ let forward_ipv4 t packet =
| Some iface -> transmit_ipv4 packet iface | Some iface -> transmit_ipv4 packet iface
| None -> Lwt.return_unit | 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 *) (* NAT *)
let translate t packet = let translate t packet =
@ -111,50 +45,53 @@ let translate t packet =
(* Add a NAT rule for the endpoints in this frame, via a random port on the firewall. *) (* Add a NAT rule for the endpoints in this frame, via a random port on the firewall. *)
let add_nat_and_forward_ipv4 t packet = let add_nat_and_forward_ipv4 t packet =
let xl_host = t.Router.uplink#my_ip in let open Router in
My_nat.add_nat_rule_and_translate t.Router.nat ~xl_host `NAT packet >>= function let xl_host = t.uplink#my_ip in
My_nat.add_nat_rule_and_translate t.nat t.ports ~xl_host `NAT packet >>= function
| Ok packet -> forward_ipv4 t packet | Ok packet -> forward_ipv4 t packet
| Error e -> | 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 Lwt.return_unit
(* Add a NAT rule to redirect this conversation to [host:port] instead of us. *) (* Add a NAT rule to redirect this conversation to [host:port] instead of us. *)
let nat_to t ~host ~port packet = let nat_to t ~host ~port packet =
match Router.resolve t host with let open Router in
match resolve t host with
| Ipaddr.V6 _ -> Log.warn (fun f -> f "Cannot NAT with IPv6"); Lwt.return_unit | Ipaddr.V6 _ -> Log.warn (fun f -> f "Cannot NAT with IPv6"); Lwt.return_unit
| Ipaddr.V4 target -> | Ipaddr.V4 target ->
let xl_host = t.Router.uplink#my_ip in let xl_host = t.uplink#my_ip in
My_nat.add_nat_rule_and_translate t.Router.nat ~xl_host (`Redirect (target, port)) packet >>= function My_nat.add_nat_rule_and_translate t.nat t.ports ~xl_host (`Redirect (target, port)) packet >>= function
| Ok packet -> forward_ipv4 t packet | Ok packet -> forward_ipv4 t packet
| Error e -> | 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 Lwt.return_unit
(* Handle incoming packets *) 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
let apply_rules t rules ~dst info = rules annotated_packet >>= fun action ->
let packet = info.packet in match action, dst with
match rules info, dst with
| `Accept, `Client client_link -> transmit_ipv4 packet client_link | `Accept, `Client client_link -> transmit_ipv4 packet client_link
| `Accept, (`External _ | `NetVM) -> transmit_ipv4 packet t.Router.uplink | `Accept, (`External _ | `NetVM) -> transmit_ipv4 packet t.Router.uplink
| `Accept, `Firewall -> | `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 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 | `NAT_to (host, port), _ -> nat_to t packet ~host ~port
| `Drop reason, _ -> | `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 Lwt.return_unit
let handle_low_memory t = let handle_low_memory t =
match Memory_pressure.status () with match Memory_pressure.status () with
| `Memory_critical -> (* TODO: should happen before copying and async *) | `Memory_critical -> (* TODO: should happen before copying and async *)
Log.warn (fun f -> f "Memory low - dropping packet and resetting NAT table"); Log.warn (fun f -> f "Memory low - dropping packet and resetting NAT table");
My_nat.reset t.Router.nat >|= fun () -> My_nat.reset t.Router.nat t.Router.ports >|= fun () ->
`Memory_critical `Memory_critical
| `Ok -> Lwt.return `Ok | `Ok -> Lwt.return `Ok
let ipv4_from_client t ~src packet = let ipv4_from_client resolver 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 ->
@ -165,9 +102,9 @@ let ipv4_from_client t ~src packet =
(* No existing NAT entry. Check the firewall rules. *) (* No existing NAT entry. Check the firewall rules. *)
let `IPv4 (ip, _transport) = packet in let `IPv4 (ip, _transport) = packet in
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 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 | None -> Lwt.return_unit
| Some info -> apply_rules t Rules.from_client ~dst info | Some firewall_packet -> apply_rules t (Rules.from_client resolver) ~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
@ -176,15 +113,17 @@ let ipv4_from_netvm t packet =
let `IPv4 (ip, _transport) = packet in let `IPv4 (ip, _transport) = packet in
let src = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.src) 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 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 | None -> Lwt.return_unit
| Some info -> | Some _ ->
match src with match src with
| `Client _ | `Firewall -> | `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 Lwt.return_unit
| `External _ | `NetVM as src -> | `External _ | `NetVM as src ->
translate t packet >>= function translate t packet >>= function
| Some frame -> forward_ipv4 t frame | Some frame -> forward_ipv4 t frame
| None -> | 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

4
firewall.mli
View File

@ -6,6 +6,8 @@
val ipv4_from_netvm : Router.t -> Nat_packet.t -> unit Lwt.t val ipv4_from_netvm : Router.t -> Nat_packet.t -> unit Lwt.t
(** Handle a packet from the outside world (this module will validate the source IP). *) (** Handle a packet from the outside world (this module will validate the source IP). *)
val ipv4_from_client : Router.t -> src:Fw_utils.client_link -> Nat_packet.t -> unit Lwt.t (* TODO the function type is a workaround, rework the module dependencies / functors to get rid of it *)
val ipv4_from_client : ([ `host ] Domain_name.t -> (int32 * Dns.Rr_map.Ipv4_set.t, [> `Msg of string ]) result Lwt.t) ->
Router.t -> src:Fw_utils.client_link -> Nat_packet.t -> unit Lwt.t
(** Handle a packet from a client. Caller must check the source IP matches the client's (** Handle a packet from a client. Caller must check the source IP matches the client's
before calling this. *) before calling this. *)

2
fw_utils.ml
View File

@ -31,6 +31,8 @@ class type client_link = object
inherit interface inherit interface
method other_mac : Macaddr.t method other_mac : Macaddr.t
method log_header : string (* For log messages *) 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 end
(** An Ethernet header from [src]'s MAC address to [dst]'s with an IPv4 payload. *) (** An Ethernet header from [src]'s MAC address to [dst]'s with an IPv4 payload. *)

57
my_dns.ml Normal file
View File

@ -0,0 +1,57 @@
open Lwt.Infix
module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) = struct
type +'a io = 'a Lwt.t
type io_addr = Ipaddr.V4.t * int
type ns_addr = [ `TCP | `UDP ] * io_addr
type stack = Router.t * (src_port:int -> dst:Ipaddr.V4.t -> dst_port:int -> Cstruct.t -> (unit, [ `Msg of string ]) result Lwt.t) * (Udp_packet.t * Cstruct.t) Lwt_mvar.t
type t = {
nameserver : ns_addr ;
stack : stack ;
timeout_ns : int64 ;
}
type context = { t : t ; timeout_ns : int64 ref; mutable src_port : int }
let nameserver t = t.nameserver
let rng = R.generate ?g:None
let clock = C.elapsed_ns
let create ?(nameserver = `UDP, (Ipaddr.V4.of_string_exn "91.239.100.100", 53)) ~timeout stack =
{ nameserver ; stack ; timeout_ns = timeout }
let with_timeout ctx f =
let timeout = OS.Time.sleep_ns !(ctx.timeout_ns) >|= fun () -> Error (`Msg "DNS request timeout") in
let start = clock () in
Lwt.pick [ f ; timeout ] >|= fun result ->
let stop = clock () in
ctx.timeout_ns := Int64.sub !(ctx.timeout_ns) (Int64.sub stop start);
result
let connect ?nameserver:_ (t : t) = Lwt.return (Ok { t ; timeout_ns = ref t.timeout_ns ; src_port = 0 })
let send (ctx : context) buf : (unit, [> `Msg of string ]) result Lwt.t =
let open Router in
let open My_nat in
let dst, dst_port = snd ctx.t.nameserver in
let router, send_udp, _ = ctx.t.stack in
let src_port = Ports.pick_free_port ~consult:router.ports.nat_udp router.ports.dns_udp in
ctx.src_port <- src_port;
with_timeout ctx (send_udp ~src_port ~dst ~dst_port buf >|= Rresult.R.open_error_msg)
let recv ctx =
let open Router in
let open My_nat in
let router, _, answers = ctx.t.stack in
with_timeout ctx
(Lwt_mvar.take answers >|= fun (_, dns_response) -> Ok dns_response) >|= fun result ->
router.ports.dns_udp := Ports.remove ctx.src_port !(router.ports.dns_udp);
result
let close _ = Lwt.return_unit
let bind = Lwt.bind
let lift = Lwt.return
end

44
my_nat.ml
View File

@ -11,6 +11,20 @@ type action = [
| `Redirect of Mirage_nat.endpoint | `Redirect of Mirage_nat.endpoint
] ]
type ports = {
nat_tcp : Ports.t ref;
nat_udp : Ports.t ref;
nat_icmp : Ports.t ref;
dns_udp : Ports.t ref;
}
let empty_ports () =
let nat_tcp = ref Ports.empty in
let nat_udp = ref Ports.empty in
let nat_icmp = ref Ports.empty in
let dns_udp = ref Ports.empty in
{ nat_tcp ; nat_udp ; nat_icmp ; dns_udp }
module Nat = Mirage_nat_lru module Nat = Mirage_nat_lru
type t = { type t = {
@ -33,13 +47,23 @@ let translate t packet =
None None
| Ok packet -> Some packet | Ok packet -> Some packet
let random_user_port () = let pick_free_port ~nat_ports ~dns_ports =
1024 + Random.int (0xffff - 1024) Ports.pick_free_port ~consult:dns_ports nat_ports
let reset t = (* just clears the nat ports, dns ports stay as is *)
let reset t ports =
ports.nat_tcp := Ports.empty;
ports.nat_udp := Ports.empty;
ports.nat_icmp := Ports.empty;
Nat.reset t.table Nat.reset t.table
let add_nat_rule_and_translate t ~xl_host action packet = let remove_connections t ports ip =
let freed_ports = Nat.remove_connections t.table ip in
ports.nat_tcp := Ports.diff !(ports.nat_tcp) (Ports.of_list freed_ports.Mirage_nat.tcp);
ports.nat_udp := Ports.diff !(ports.nat_udp) (Ports.of_list freed_ports.Mirage_nat.udp);
ports.nat_icmp := Ports.diff !(ports.nat_icmp) (Ports.of_list freed_ports.Mirage_nat.icmp)
let add_nat_rule_and_translate t ports ~xl_host action packet =
let apply_action xl_port = let apply_action xl_port =
Lwt.catch (fun () -> Lwt.catch (fun () ->
Nat.add t.table packet (xl_host, xl_port) action Nat.add t.table packet (xl_host, xl_port) action
@ -50,19 +74,25 @@ let add_nat_rule_and_translate t ~xl_host action packet =
) )
in in
let rec aux ~retries = let rec aux ~retries =
let xl_port = random_user_port () in let nat_ports, dns_ports =
match packet with
| `IPv4 (_, `TCP _) -> ports.nat_tcp, ref Ports.empty
| `IPv4 (_, `UDP _) -> ports.nat_udp, ports.dns_udp
| `IPv4 (_, `ICMP _) -> ports.nat_icmp, ref Ports.empty
in
let xl_port = pick_free_port ~nat_ports ~dns_ports in
apply_action xl_port >>= function apply_action xl_port >>= function
| Error `Out_of_memory -> | Error `Out_of_memory ->
(* Because hash tables resize in big steps, this can happen even if we have a fair (* Because hash tables resize in big steps, this can happen even if we have a fair
chunk of free memory. *) chunk of free memory. *)
Log.warn (fun f -> f "Out_of_memory adding NAT rule. Dropping NAT table..."); Log.warn (fun f -> f "Out_of_memory adding NAT rule. Dropping NAT table...");
Nat.reset t.table >>= fun () -> reset t ports >>= fun () ->
aux ~retries:(retries - 1) aux ~retries:(retries - 1)
| Error `Overlap when retries < 0 -> Lwt.return (Error "Too many retries") | Error `Overlap when retries < 0 -> Lwt.return (Error "Too many retries")
| Error `Overlap -> | Error `Overlap ->
if retries = 0 then ( if retries = 0 then (
Log.warn (fun f -> f "Failed to find a free port; resetting NAT table"); Log.warn (fun f -> f "Failed to find a free port; resetting NAT table");
Nat.reset t.table >>= fun () -> reset t ports >>= fun () ->
aux ~retries:(retries - 1) aux ~retries:(retries - 1)
) else ( ) else (
aux ~retries:(retries - 1) aux ~retries:(retries - 1)

16
my_nat.mli
View File

@ -3,6 +3,15 @@
(* Abstract over NAT interface (todo: remove this) *) (* Abstract over NAT interface (todo: remove this) *)
type ports = private {
nat_tcp : Ports.t ref;
nat_udp : Ports.t ref;
nat_icmp : Ports.t ref;
dns_udp : Ports.t ref;
}
val empty_ports : unit -> ports
type t type t
type action = [ type action = [
@ -11,7 +20,8 @@ type action = [
] ]
val create : max_entries:int -> t Lwt.t val create : max_entries:int -> t Lwt.t
val reset : t -> unit Lwt.t val reset : t -> ports -> unit Lwt.t
val remove_connections : t -> ports -> Ipaddr.V4.t -> unit
val translate : t -> Nat_packet.t -> Nat_packet.t option Lwt.t val translate : t -> Nat_packet.t -> Nat_packet.t option Lwt.t
val add_nat_rule_and_translate : t -> xl_host:Ipaddr.V4.t -> val add_nat_rule_and_translate : t -> ports ->
action -> Nat_packet.t -> (Nat_packet.t, string) result Lwt.t xl_host:Ipaddr.V4.t -> action -> Nat_packet.t -> (Nat_packet.t, string) result Lwt.t

65
packet.ml
View File

@ -5,33 +5,60 @@ open Fw_utils
type port = int type port = int
type ports = { type host =
sport : port; (* Source port *)
dport : port; (* Destination *)
}
type host =
[ `Client of client_link | `Firewall | `NetVM | `External of Ipaddr.t ] [ `Client of client_link | `Firewall | `NetVM | `External of Ipaddr.t ]
type ('src, 'dst) info = { type transport_header = [`TCP of Tcp.Tcp_packet.t
packet : Nat_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; src : 'src;
dst : 'dst; 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 pp_host fmt = function
let is_tcp_start = function | `Client c -> Ipaddr.V4.pp fmt (c#other_ip)
| `IPv4 (_ip, `TCP (hdr, _body)) -> Tcp.Tcp_packet.(hdr.syn && not hdr.ack) | `Unknown_client ip -> Format.fprintf fmt "unknown-client(%a)" Ipaddr.pp ip
| _ -> false | `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 = [ type action = [
| `Accept (* Send the packet to its destination. *) | `Accept (* Send to destination, unmodified. *)
| `NAT (* Rewrite the packet's source field so packet appears to | `NAT (* Rewrite source field to the firewall's IP, with a fresh source port.
have come from the firewall, via an unused port. Also, add translation rules for future traffic in both directions,
Also, add NAT rules so related packets will be translated accordingly. *) between these hosts on these ports, and corresponding ICMP error traffic. *)
| `NAT_to of host * port (* As for [`NAT], but also rewrite the packet's | `NAT_to of host * port (* As for [`NAT], but also rewrite the packet's
destination fields so it will be sent to [host:port]. *) 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. *)
] ]

39
packet.mli Normal file
View File

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

16
ports.ml Normal file
View File

@ -0,0 +1,16 @@
module Set = Set.Make(struct
type t = int
let compare a b = compare a b
end)
include Set
let rec pick_free_port ?(retries = 10) ~consult add_to =
let p = 1024 + Random.int (0xffff - 1024) in
if (mem p !consult || mem p !add_to) && retries <> 0
then pick_free_port ~retries:(retries - 1) ~consult add_to
else
begin
add_to := add p !add_to;
p
end

5
router.ml
View File

@ -9,10 +9,13 @@ type t = {
client_eth : Client_eth.t; client_eth : Client_eth.t;
nat : My_nat.t; nat : My_nat.t;
uplink : interface; uplink : interface;
(* NOTE: do not try to make this pure, it relies on mvars / side effects *)
ports : My_nat.ports;
} }
let create ~client_eth ~uplink ~nat = let create ~client_eth ~uplink ~nat =
{ client_eth; nat; uplink } let ports = My_nat.empty_ports () in
{ client_eth; nat; uplink; ports }
let target t buf = let target t buf =
let dst_ip = buf.Ipv4_packet.dst in let dst_ip = buf.Ipv4_packet.dst in

4
router.mli
View File

@ -9,15 +9,15 @@ type t = private {
client_eth : Client_eth.t; client_eth : Client_eth.t;
nat : My_nat.t; nat : My_nat.t;
uplink : interface; uplink : interface;
ports : My_nat.ports;
} }
(** A routing table. *)
val create : val create :
client_eth:Client_eth.t -> client_eth:Client_eth.t ->
uplink:interface -> uplink:interface ->
nat:My_nat.t -> nat:My_nat.t ->
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]. *) that routes packets outside of [client_eth] via [uplink]. *)
val target : t -> Ipv4_packet.t -> interface option val target : t -> Ipv4_packet.t -> interface option

142
rules.ml
View File

@ -1,62 +1,110 @@
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com> (* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
See the README file for details. *) 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. let src = Logs.Src.create "rules" ~doc:"Firewall rules"
Any client not listed here will appear as [`Client `Unknown]. *) module Log = (val Logs.src_log src : Logs.LOG)
let clients = [
(* (* the upstream NetVM will redirect TCP and UDP port 53 traffic with
"10.137.0.12", `Dev; these destination IPs to its upstream nameserver. *)
"10.137.0.14", `Untrusted; 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. module Classifier = struct
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. *) let matches_port dstports (port : int) = match dstports with
[@@@ocaml.warning "-9"] | 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 let matches_dest dns_client rule packet =
packet, and returns an action (of type [Packet.action]) to perform. 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.debug (fun f -> f "Resolving %a" Domain_name.pp name);
dns_client name >|= function
| Ok (_ttl, found_ips) ->
if Dns.Rr_map.Ipv4_set.mem ip found_ips
then `Match rule
else `No_match
| Error (`Msg m) ->
Log.warn (fun f -> f "Ignoring rule %a, could not resolve" Q.pp_rule rule);
Log.debug (fun f -> f "%s" m);
`No_match
| Error _ -> assert false (* TODO: fix type of dns_client so that this case can go *)
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 find_first_match dns_client packet acc rule =
let from_client (info : ([`Client of _], _) Packet.info) : Packet.action = match acc with
match info with | `No_match ->
(* Examples (add your own rules here): if Classifier.matches_proto rule packet
then Classifier.matches_dest dns_client rule packet
else Lwt.return `No_match
| q -> Lwt.return q
1. Allows Dev to send SSH packets to Untrusted. (* Does the packet match our rules? *)
Note: responses are not covered by this! let classify_client_packet dns_client (packet : ([`Client of Fw_utils.client_link], _) Packet.t) =
2. Allows Untrusted to reply to Dev. let (`Client client_link) = packet.src in
3. Blocks an external site. let rules = client_link#get_rules in
Lwt_list.fold_left_s (find_first_match dns_client packet) `No_match rules >|= function
| `No_match -> `Drop "No matching rule; assuming default drop"
| `Match {Q.action = Q.Accept; _} -> `Accept
| `Match ({Q.action = Q.Drop; _} as rule) ->
`Drop (Format.asprintf "rule number %a explicitly drops this packet" Q.pp_rule rule)
In all cases, make sure you've added the VM name to [clients] or [externals] above, or it won't let translate_accepted_packets dns_client packet =
match anything! *) classify_client_packet dns_client packet >|= function
(* | `Accept -> `NAT
| { src = `Client `Dev; dst = `Client `Untrusted; proto = `TCP { dport = 22 } } -> `Accept | `Drop s -> `Drop s
| { 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"
(** Decide what to do with a packet received from the outside world. (** Packets from the private interface that don't match any NAT table entry are being checked against the fw rules here *)
Note: If the packet matched an existing NAT rule then this isn't called. *) let from_client dns_client (packet : ([`Client of Fw_utils.client_link], _) Packet.t) : Packet.action Lwt.t =
let from_netvm (info : ([`NetVM | `External of _], _) Packet.info) : Packet.action = match packet with
match info with | { dst = `Firewall; transport_header = `UDP header; _ } ->
| _ -> `Drop "drop by default" if header.Udp_packet.dst_port = dns_port
then Lwt.return @@ `NAT_to (`NetVM, dns_port)
else Lwt.return @@ `Drop "packet addressed to client gateway"
| { dst = `External _ ; _ } | { dst = `NetVM; _ } -> translate_accepted_packets dns_client packet
| { dst = `Firewall ; _ } -> Lwt.return @@ `Drop "packet addressed to firewall itself"
| { dst = `Client _ ; _ } -> classify_client_packet dns_client packet
| _ -> 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"

27
test/config.ml Normal file
View File

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

138
test/test.sh Executable file
View File

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

357
test/unikernel.ml Normal file
View File

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

54
test/update-firewall.sh Normal file
View File

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

52
unikernel.ml
View File

@ -7,28 +7,19 @@ open Qubes
let src = Logs.Src.create "unikernel" ~doc:"Main unikernel code" let src = Logs.Src.create "unikernel" ~doc:"Main unikernel code"
module Log = (val Logs.src_log src : Logs.LOG) 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
module Uplink = Uplink.Make(R)(Clock)
module Dns_transport = My_dns.Transport(R)(Clock)
module Dns_client = Dns_client.Make(Dns_transport)
(* Set up networking and listen for incoming packets. *) (* Set up networking and listen for incoming packets. *)
let network nat qubesDB = let network dns_client dns_responses uplink qubesDB router =
(* Read configuration from QubesDB *)
Dao.read_network_config qubesDB >>= fun config ->
(* Initialise connection to NetVM *)
Uplink.connect config >>= fun uplink ->
(* Report success *) (* Report success *)
Dao.set_iptables_error qubesDB "" >>= fun () -> 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 *) (* Handle packets from both networks *)
Lwt.choose [ Lwt.choose [
Client_net.listen Clock.elapsed_ns router; Client_net.listen Clock.elapsed_ns dns_client qubesDB router;
Uplink.listen uplink Clock.elapsed_ns 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. (* We don't use the GUI, but it's interesting to keep an eye on it.
@ -49,17 +40,18 @@ module Main (Clock : Mirage_clock.MCLOCK) = struct
) )
(* Main unikernel entry point (called from auto-generated main.ml). *) (* Main unikernel entry point (called from auto-generated main.ml). *)
let start _clock = let start _random _clock =
let start_time = Clock.elapsed_ns () in let start_time = Clock.elapsed_ns () in
(* Start qrexec agent, GUI agent and QubesDB agent in parallel *) (* Start qrexec agent, GUI agent and QubesDB agent in parallel *)
let qrexec = RExec.connect ~domid:0 () in let qrexec = RExec.connect ~domid:0 () in
GUI.connect ~domid:0 () |> watch_gui; GUI.connect ~domid:0 () |> watch_gui;
let qubesDB = DB.connect ~domid:0 () in let qubesDB = DB.connect ~domid:0 () in
(* Wait for clients to connect *) (* Wait for clients to connect *)
qrexec >>= fun qrexec -> qrexec >>= fun qrexec ->
let agent_listener = RExec.listen qrexec Command.handler in let agent_listener = RExec.listen qrexec Command.handler in
qubesDB >>= fun qubesDB -> qubesDB >>= fun qubesDB ->
let startup_time = let startup_time =
let (-) = Int64.sub in let (-) = Int64.sub in
let time_in_ns = Clock.elapsed_ns () - start_time in let time_in_ns = Clock.elapsed_ns () - start_time in
Int64.to_float time_in_ns /. 1e9 Int64.to_float time_in_ns /. 1e9
@ -72,7 +64,27 @@ module Main (Clock : Mirage_clock.MCLOCK) = struct
(* Set up networking *) (* Set up networking *)
let max_entries = Key_gen.nat_table_size () in let max_entries = Key_gen.nat_table_size () in
My_nat.create ~max_entries >>= fun nat -> 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 send_dns_query = Uplink.send_dns_client_query uplink in
let dns_mvar = Lwt_mvar.create_empty () in
let dns_client = Dns_client.create (router, send_dns_query, dns_mvar) in
let net_listener = network (Dns_client.getaddrinfo dns_client Dns.Rr_map.A) dns_mvar uplink qubesDB router in
(* Report memory usage to XenStore *) (* Report memory usage to XenStore *)
Memory_pressure.init (); Memory_pressure.init ();
(* Run until something fails or we get a shutdown request. *) (* Run until something fails or we get a shutdown request. *)

74
uplink.ml
View File

@ -9,15 +9,20 @@ module Eth = Ethernet.Make(Netif)
let src = Logs.Src.create "uplink" ~doc:"Network connection to NetVM" let src = Logs.Src.create "uplink" ~doc:"Network connection to NetVM"
module Log = (val Logs.src_log src : Logs.LOG) module Log = (val Logs.src_log src : Logs.LOG)
module Arp = Arp.Make(Eth)(OS.Time) module Make (R:Mirage_random.S) (Clock : Mirage_clock.MCLOCK) = struct
module Arp = Arp.Make(Eth)(OS.Time)
module I = Static_ipv4.Make(R)(Clock)(Eth)(Arp)
module U = Udp.Make(I)(R)
type t = { type t = {
net : Netif.t; net : Netif.t;
eth : Eth.t; eth : Eth.t;
arp : Arp.t; arp : Arp.t;
interface : interface; interface : interface;
mutable fragments : Fragments.Cache.t; mutable fragments : Fragments.Cache.t;
} ip : I.t;
udp: U.t;
}
class netvm_iface eth mac ~my_ip ~other_ip : interface = object class netvm_iface eth mac ~my_ip ~other_ip : interface = object
val queue = FrameQ.create (Ipaddr.V4.to_string other_ip) val queue = FrameQ.create (Ipaddr.V4.to_string other_ip)
@ -31,10 +36,26 @@ class netvm_iface eth mac ~my_ip ~other_ip : interface = object
) )
end end
let listen t get_ts router = let send_dns_client_query t ~src_port ~dst ~dst_port buf =
Netif.listen t.net ~header_size:Ethernet_wire.sizeof_ethernet (fun frame -> U.write ~src_port ~dst ~dst_port t.udp buf >|= function
(* Handle one Ethernet frame from NetVM *) | Error s -> Log.err (fun f -> f "error sending udp packet: %a" U.pp_error s); Error (`Msg "failure")
Eth.input t.eth | Ok () -> Ok ()
let listen t get_ts dns_responses router =
let handle_packet ip_header ip_packet =
let open Udp_packet in
Log.debug (fun f -> f "received ipv4 packet from %a on uplink" Ipaddr.V4.pp ip_header.Ipv4_packet.src);
match ip_packet with
| `UDP (header, packet) when Ports.mem header.dst_port !(router.Router.ports.My_nat.dns_udp) ->
Log.debug (fun f -> f "found a DNS packet whose dst_port (%d) was in the list of dns_client ports" header.dst_port);
Lwt_mvar.put dns_responses (header, packet)
| _ ->
Firewall.ipv4_from_netvm router (`IPv4 (ip_header, ip_packet))
in
Netif.listen t.net ~header_size:Ethernet_wire.sizeof_ethernet (fun frame ->
(* Handle one Ethernet frame from NetVM *)
Eth.input t.eth
~arpv4:(Arp.input t.arp) ~arpv4:(Arp.input t.arp)
~ipv4:(fun ip -> ~ipv4:(fun ip ->
let cache, r = let cache, r =
@ -42,30 +63,35 @@ let listen t get_ts router =
in in
t.fragments <- cache; t.fragments <- cache;
match r with match r with
| Error e -> | Error e ->
Log.warn (fun f -> f "Ignored unknown IPv4 message from uplink: %a" Nat_packet.pp_error e); Log.warn (fun f -> f "Ignored unknown IPv4 message from uplink: %a" Nat_packet.pp_error e);
Lwt.return_unit Lwt.return ()
| Ok None -> Lwt.return_unit | Ok None -> Lwt.return_unit
| Ok (Some packet) -> | Ok (Some (`IPv4 (header, packet))) -> handle_packet header packet
Firewall.ipv4_from_netvm router packet )
)
~ipv6:(fun _ip -> Lwt.return_unit) ~ipv6:(fun _ip -> Lwt.return_unit)
frame frame
) >|= or_raise "Uplink listen loop" Netif.pp_error ) >|= or_raise "Uplink listen loop" Netif.pp_error
let interface t = t.interface let interface t = t.interface
let connect config = let connect config =
let ip = config.Dao.uplink_our_ip in let my_ip = config.Dao.uplink_our_ip in
let gateway = config.Dao.uplink_netvm_ip in
Netif.connect "0" >>= fun net -> Netif.connect "0" >>= fun net ->
Eth.connect net >>= fun eth -> Eth.connect net >>= fun eth ->
Arp.connect eth >>= fun arp -> Arp.connect eth >>= fun arp ->
Arp.add_ip arp ip >>= fun () -> Arp.add_ip arp my_ip >>= fun () ->
let network = Ipaddr.V4.Prefix.make 0 Ipaddr.V4.any in
I.connect ~ip:(network, my_ip) ~gateway eth arp >>= fun ip ->
U.connect ip >>= fun udp ->
let netvm_mac = let netvm_mac =
Arp.query arp config.Dao.uplink_netvm_ip Arp.query arp gateway
>|= or_raise "Getting MAC of our NetVM" Arp.pp_error in >|= or_raise "Getting MAC of our NetVM" Arp.pp_error in
let interface = new netvm_iface eth netvm_mac let interface = new netvm_iface eth netvm_mac
~my_ip:ip ~my_ip
~other_ip:config.Dao.uplink_netvm_ip in ~other_ip:config.Dao.uplink_netvm_ip in
let fragments = Fragments.Cache.empty (256 * 1024) in let fragments = Fragments.Cache.empty (256 * 1024) in
Lwt.return { net; eth; arp; interface ; fragments } Lwt.return { net; eth; arp; interface ; fragments ; ip ; udp }
end

19
uplink.mli
View File

@ -5,13 +5,18 @@
open Fw_utils open Fw_utils
type t [@@@ocaml.warning "-67"]
module Make (R: Mirage_random.S)(Clock : Mirage_clock.MCLOCK) : sig
type t
val connect : Dao.network_config -> t Lwt.t val connect : Dao.network_config -> t Lwt.t
(** Connect to our NetVM (gateway). *) (** Connect to our NetVM (gateway). *)
val interface : t -> interface val interface : t -> interface
(** The network interface to NetVM. *) (** The network interface to NetVM. *)
val listen : t -> (unit -> int64) -> Router.t -> unit Lwt.t val listen : t -> (unit -> int64) -> (Udp_packet.t * Cstruct.t) Lwt_mvar.t -> Router.t -> unit Lwt.t
(** Handle incoming frames from NetVM. *) (** Handle incoming frames from NetVM. *)
val send_dns_client_query: t -> src_port:int-> dst:Ipaddr.V4.t -> dst_port:int -> Cstruct.t -> (unit, [`Msg of string]) result Lwt.t
end