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

Read firewall rules from QubesDB. The module Rules contains a rule matcher instead of hardcoded rules now.

Browse Source 
Co-Authored-By: Mindy Preston <yomimono@users.noreply.github.com>
This commit is contained in:
linse 2020-04-29 15:58:01 +02:00
parent 02e515d27c
commit 87df5bdcc0
23 changed files with 928 additions and 206 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
Dockerfile
View File

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

2
Makefile.builder
View File

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

5
Makefile.user
View File

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

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 [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.

51
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
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,10 +86,36 @@ 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
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
@ -96,15 +125,20 @@ let add_vif get_ts { Dao.ClientVif.domid; device_id } ~client_ip ~router ~cleanu
| `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
>|= 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
)
)

10
client_net.mli
View File

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

9
config.ml
View File

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

32
dao.ml
View File

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

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

12
diagrams/components.txt
View File

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

103
firewall.ml
View File

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

2
fw_utils.ml
View File

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

8
my_nat.ml
View File

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

5
my_nat.mli
View File

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

63
packet.ml
View File

@ -5,33 +5,60 @@ open Fw_utils
type port = int
type ports = {
sport : port; (* Source port *)
dport : port; (* Destination *)
}
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. *)
]

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

3
router.mli
View File

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

133
rules.ml
View File

@ -1,62 +1,101 @@
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
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"

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

41
unikernel.ml
View File

@ -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,12 +37,13 @@ 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
@ -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. *)