Git-Mirrors/qubes-mirage-firewall
1
0
Fork 0
mirror of https://github.com/mirage/qubes-mirage-firewall.git synced 2025-01-13 16:19:27 -05:00
Code Issues Packages Projects Releases Wiki Activity

Merge pull request #178 from palainp/common-vif

Browse Source 
manage a dynamic uplink
This commit is contained in:
Pierre Alain 2024-04-24 11:18:34 +02:00 committed by GitHub
commit a49c358a4c
No known key found for this signature in database
GPG Key ID: B5690EEEBB952194
21 changed files with 733 additions and 585 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
Dockerfile
View File

@ -2,14 +2,14 @@
# It will probably still work on newer images, though, unless an update
# changes some compiler optimisations (unlikely).
# bookworm-slim taken from https://hub.docker.com/_/debian/tags?page=1&name=bookworm-slim
FROM debian@sha256:ea5ad531efe1ac11ff69395d032909baf423b8b88e9aade07e11b40b2e5a1338
FROM debian@sha256:3d5df92588469a4c503adbead0e4129ef3f88e223954011c2169073897547cac
# install remove default packages repository
RUN rm /etc/apt/sources.list.d/debian.sources
# and set the package source to a specific release too
# taken from https://snapshot.debian.org/archive/debian
RUN printf "deb [check-valid-until=no] http://snapshot.debian.org/archive/debian/20231107T084929Z bookworm main\n" > /etc/apt/sources.list
RUN printf "deb [check-valid-until=no] http://snapshot.debian.org/archive/debian/20240419T024211Z bookworm main\n" > /etc/apt/sources.list
# taken from https://snapshot.debian.org/archive/debian-security/
RUN printf "deb [check-valid-until=no] http://snapshot.debian.org/archive/debian-security/20231108T004541Z bookworm-security main\n" >> /etc/apt/sources.list
RUN printf "deb [check-valid-until=no] http://snapshot.debian.org/archive/debian-security/20240419T111010Z bookworm-security main\n" >> /etc/apt/sources.list
RUN apt update && apt install --no-install-recommends --no-install-suggests -y wget ca-certificates git patch unzip bzip2 make gcc g++ libc-dev
RUN wget -O /usr/bin/opam https://github.com/ocaml/opam/releases/download/2.1.5/opam-2.1.5-i686-linux && chmod 755 /usr/bin/opam
@ -23,13 +23,13 @@ ENV OPAMCONFIRMLEVEL=unsafe-yes
# Remove this line (and the base image pin above) if you want to test with the
# latest versions.
# taken from https://github.com/ocaml/opam-repository
RUN opam init --disable-sandboxing -a --bare https://github.com/ocaml/opam-repository.git#d1a8bf040fbb2c81ddb2612f1a49a471a06083dc
RUN opam init --disable-sandboxing -a --bare https://github.com/ocaml/opam-repository.git#4399f486aa6edefdc96d5e206a65ce42288ebfdd
RUN opam switch create myswitch 4.14.1
RUN opam exec -- opam install -y mirage opam-monorepo ocaml-solo5
RUN mkdir /tmp/orb-build
ADD config.ml /tmp/orb-build/config.ml
WORKDIR /tmp/orb-build
CMD opam exec -- sh -exc 'mirage configure -t xen --extra-repos=\
opam-overlays:https://github.com/dune-universe/opam-overlays.git#91a371754a2c9f4febbb6c7bb039649ad49a3c13,\
mirage-overlays:https://github.com/dune-universe/mirage-opam-overlays.git#05f1c1823d891ce4d8adab91f5db3ac51d86dc0b \
--allocation-policy=best-fit && make depend && make tar'
opam-overlays:https://github.com/dune-universe/opam-overlays.git#4e75ee36715b27550d5bdb87686bb4ae4c9e89c4,\
mirage-overlays:https://github.com/dune-universe/mirage-opam-overlays.git#797cb363df3ff763c43c8fbec5cd44de2878757e \
&& make depend && make tar'

11
README.md
View File

@ -121,6 +121,17 @@ https://www.qubes-os.org/doc/software-update-dom0/ says:
> there are no significant security implications in this choice. By default,
> this role is assigned to the firewallvm.
### Configure firewall with OpenBSD-like netvm
OpenBSD is currently unable to be used as netvm, so if you want to use a BSD as your sys-net VM, you'll need to set its netvm to qubes-mirage-firewall (see https://github.com/mirage/qubes-mirage-firewall/issues/146 for more information).
That means you'll have `AppVMs -> qubes-mirage-firewall <- OpenBSD` with the arrow standing for the netvm property setting.
In that case you'll have to tell qubes-mirage-firewall which AppVM client should be used as uplink:
```
qvm-prefs --set mirage-firewall -- kernelopts '--ipv4=X.X.X.X --ipv4-gw=Y.Y.Y.Y'
```
with `X.X.X.X` the IP address for mirage-firewall and `Y.Y.Y.Y` the IP address of your OpenBSD HVM.
### Components
This diagram show the main components (each box corresponds to a source `.ml` file with the same name):

2
build-with.sh
View File

@ -20,5 +20,5 @@ $builder build -t qubes-mirage-firewall .
echo Building Firewall...
$builder run --rm -i -v `pwd`:/tmp/orb-build:Z qubes-mirage-firewall
echo "SHA2 of build: $(sha256sum ./dist/qubes-firewall.xen)"
echo "SHA2 last known: 2c3f68f49afdeaeedd2c03f8ef6d30d6bb4d6306bda0a1ff40f95f440a90034c"
echo "SHA2 last known: 163991ea96842e03d378501a0be99057ad2489440aff8ae81d850624d98fd3f0"
echo "(hashes should match for released versions)"

15
client_eth.ml
View File

@ -10,7 +10,7 @@ module Log = (val Logs.src_log src : Logs.LOG)
type t = {
mutable iface_of_ip : client_link IpMap.t;
changed : unit Lwt_condition.t; (* Fires when [iface_of_ip] changes. *)
client_gw : Ipaddr.V4.t; (* The IP that clients are given as their default gateway. *)
my_ip : Ipaddr.V4.t; (* The IP that clients are given as their default gateway. *)
}
type host =
@ -18,11 +18,12 @@ type host =
| `Firewall
| `External of Ipaddr.t ]
let create ~client_gw =
let create config =
let changed = Lwt_condition.create () in
{ iface_of_ip = IpMap.empty; client_gw; changed }
let my_ip = config.Dao.our_ip in
Lwt.return { iface_of_ip = IpMap.empty; my_ip; changed }
let client_gw t = t.client_gw
let client_gw t = t.my_ip
let add_client t iface =
let ip = iface#other_ip in
@ -52,14 +53,14 @@ let classify t ip =
match ip with
| Ipaddr.V6 _ -> `External ip
| Ipaddr.V4 ip4 ->
if ip4 = t.client_gw then `Firewall
if ip4 = t.my_ip then `Firewall
else match lookup t ip4 with
| Some client_link -> `Client client_link
| None -> `External ip
let resolve t : host -> Ipaddr.t = function
| `Client client_link -> Ipaddr.V4 client_link#other_ip
| `Firewall -> Ipaddr.V4 t.client_gw
| `Firewall -> Ipaddr.V4 t.my_ip
| `External addr -> addr
module ARP = struct
@ -69,7 +70,7 @@ module ARP = struct
}
let lookup t ip =
if ip = t.net.client_gw then Some t.client_link#my_mac
if ip = t.net.my_ip then Some t.client_link#my_mac
else if (Ipaddr.V4.to_octets ip).[3] = '\x01' then (
Log.info (fun f -> f ~header:t.client_link#log_header
"Request for %a is invalid, but pretending it's me (see Qubes issue #5022)" Ipaddr.V4.pp ip);

2
client_eth.mli
View File

@ -17,7 +17,7 @@ type host =
disconnected client.
See: https://github.com/talex5/qubes-mirage-firewall/issues/9#issuecomment-246956850 *)
val create : client_gw:Ipaddr.V4.t -> t
val create : Dao.network_config -> t Lwt.t
(** [create ~client_gw] is a network of client machines.
Qubes will have configured the client machines to use [client_gw] as their default gateway. *)

167
client_net.ml
View File

@ -1,167 +0,0 @@
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
See the README file for details. *)
open Lwt.Infix
open Fw_utils
module Netback = Netchannel.Backend.Make(Netchannel.Xenstore.Make(Xen_os.Xs))
module ClientEth = Ethernet.Make(Netback)
let src = Logs.Src.create "client_net" ~doc:"Client networking"
module Log = (val Logs.src_log src : Logs.LOG)
let writev eth dst proto fillfn =
Lwt.catch
(fun () ->
ClientEth.write eth dst proto fillfn >|= function
| Ok () -> ()
| Error e ->
Log.err (fun f -> f "error trying to send to client: @[%a@]"
ClientEth.pp_error e);
)
(fun ex ->
(* Usually Netback_shutdown, because the client disconnected *)
Log.err (fun f -> f "uncaught exception trying to send to client: @[%s@]"
(Printexc.to_string ex));
Lwt.return_unit
)
class client_iface eth ~domid ~gateway_ip ~client_ip client_mac : client_link =
let log_header = Fmt.str "dom%d:%a" domid Ipaddr.V4.pp client_ip in
object
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
method other_ip = client_ip
method writev proto fillfn =
writev eth client_mac proto fillfn
method log_header = log_header
end
let clients : Cleanup.t Dao.VifMap.t ref = ref Dao.VifMap.empty
(** Handle an ARP message from the client. *)
let input_arp ~fixed_arp ~iface request =
match Arp_packet.decode request with
| Error e ->
Log.warn (fun f -> f "Ignored unknown ARP message: %a" Arp_packet.pp_error e);
Lwt.return_unit
| Ok arp ->
match Client_eth.ARP.input fixed_arp arp with
| None -> Lwt.return_unit
| Some response ->
iface#writev `ARP (fun b -> Arp_packet.encode_into response b; Arp_packet.size)
(** Handle an IPv4 packet from the client. *)
let input_ipv4 get_ts cache ~iface ~router dns_client dns_servers packet =
let cache', r = Nat_packet.of_ipv4_packet !cache ~now:(get_ts ()) packet in
cache := cache';
match r with
| Error e ->
Log.warn (fun f -> f "Ignored unknown IPv4 message: %a" Nat_packet.pp_error e);
Lwt.return_unit
| Ok None -> Lwt.return_unit
| Ok (Some packet) ->
let `IPv4 (ip, _) = packet in
let src = ip.Ipv4_packet.src in
if src = iface#other_ip then Firewall.ipv4_from_client dns_client dns_servers router ~src:iface packet
else (
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);
Lwt.return_unit
)
(** Connect to a new client's interface and listen for incoming frames and firewall rule changes. *)
let add_vif get_ts { Dao.ClientVif.domid; device_id } dns_client dns_servers ~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 ->
let client_mac = Netback.frontend_mac backend in
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:(any "@.") 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.Packet.sizeof_ethernet (fun frame ->
match Ethernet.Packet.of_cstruct frame with
| Error err -> Log.warn (fun f -> f "Invalid Ethernet frame: %s" err); Lwt.return_unit
| Ok (eth, payload) ->
match eth.Ethernet.Packet.ethertype with
| `ARP -> input_arp ~fixed_arp ~iface payload
| `IPv4 -> input_ipv4 get_ts fragment_cache ~iface ~router dns_client dns_servers payload
| `IPv6 -> Lwt.return_unit (* TODO: oh no! *)
)
>|= or_raise "Listen on client interface" Netback.pp_error)
(function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e)
in
Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel listener);
Lwt.pick [ qubesdb_updater ; listener ]
(** A new client VM has been found in XenStore. Find its interface and connect to it. *)
let add_client get_ts dns_client dns_servers ~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);
Lwt.async (fun () ->
Lwt.catch (fun () ->
add_vif get_ts vif dns_client dns_servers ~client_ip ~router ~cleanup_tasks qubesDB
)
(fun ex ->
Log.warn (fun f -> f "Error with client %a: %s"
Dao.ClientVif.pp vif (Printexc.to_string ex));
Lwt.return_unit
)
);
cleanup_tasks
(** Watch XenStore for notifications of new clients. *)
let listen get_ts dns_client dns_servers qubesDB router =
Dao.watch_clients (fun new_set ->
(* Check for removed clients *)
!clients |> Dao.VifMap.iter (fun key cleanup ->
if not (Dao.VifMap.mem key new_set) then (
clients := !clients |> Dao.VifMap.remove key;
Log.info (fun f -> f "client %a has gone" Dao.ClientVif.pp key);
Cleanup.cleanup cleanup
)
);
(* 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 dns_client dns_servers ~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
)
)
)

12
client_net.mli
View File

@ -1,12 +0,0 @@
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
See the README file for details. *)
(** Handling client VMs. *)
val listen : (unit -> int64) ->
([ `host ] Domain_name.t -> (int32 * Ipaddr.V4.Set.t, [> `Msg of string ]) result Lwt.t) ->
Ipaddr.V4.t list -> Qubes.DB.t -> Router.t -> 'a Lwt.t
(** [listen get_timestamp resolver dns_servers db router] is a thread that watches for clients being added to and
removed from XenStore. Clients are connected to the client network and
packets are sent via [router]. We ensure the source IP address is correct
before routing a packet. *)

21
config.ml
View File

@ -1,3 +1,4 @@
(* mirage >= 4.5.0 & < 5.0.0 *)
(* Copyright (C) 2017, Thomas Leonard <thomas.leonard@unikernel.com>
See the README file for details. *)
@ -5,17 +6,15 @@
open Mirage
let table_size =
let info = Key.Arg.info
~doc:"The number of NAT entries to allocate."
~docv:"ENTRIES" ["nat-table-size"]
in
let key = Key.Arg.opt ~stage:`Both Key.Arg.int 5_000 info in
Key.create "nat_table_size" key
let nat_table_size = runtime_arg ~pos:__POS__ "Unikernel.nat_table_size"
let ipv4 = runtime_arg ~pos:__POS__ "Unikernel.ipv4"
let ipv4_gw = runtime_arg ~pos:__POS__ "Unikernel.ipv4_gw"
let ipv4_dns = runtime_arg ~pos:__POS__ "Unikernel.ipv4_dns"
let ipv4_dns2 = runtime_arg ~pos:__POS__ "Unikernel.ipv4_dns2"
let main =
foreign
~keys:[Key.v table_size]
main
~runtime_args:[ nat_table_size; ipv4; ipv4_gw; ipv4_dns; ipv4_dns2; ]
~packages:[
package "vchan" ~min:"4.0.2";
package "cstruct";
@ -24,8 +23,8 @@ let main =
package ~min:"2.3.0" ~sublibs:["mirage"] "arp";
package ~min:"3.0.0" "ethernet";
package "shared-memory-ring" ~min:"3.0.0";
package ~min:"2.1.2" "netchannel";
package "mirage-net-xen";
package ~min:"2.1.3" "netchannel";
package "mirage-net-xen" ~min:"2.1.3";
package "ipaddr" ~min:"5.2.0";
package "mirage-qubes" ~min:"0.9.1";
package ~min:"3.0.1" "mirage-nat";

42
dao.ml
View File

@ -123,10 +123,9 @@ let watch_clients fn =
)
type network_config = {
uplink_netvm_ip : Ipaddr.V4.t; (* The IP address of NetVM (our gateway) *)
uplink_our_ip : Ipaddr.V4.t; (* The IP address of our interface to NetVM *)
clients_our_ip : Ipaddr.V4.t; (* The IP address of our interface to our client VMs (their gateway) *)
from_cmdline : bool; (* Specify if we have network configuration from command line or from qubesDB*)
netvm_ip : Ipaddr.V4.t; (* The IP address of NetVM (our gateway) *)
our_ip : Ipaddr.V4.t; (* The IP address of our interface to NetVM *)
dns : Ipaddr.V4.t;
dns2 : Ipaddr.V4.t;
}
@ -137,24 +136,12 @@ let try_read_network_config db =
let get name =
match DB.KeyMap.find_opt name db with
| None -> raise (Missing_key name)
| Some value -> value in
let uplink_our_ip = get "/qubes-ip" |> Ipaddr.V4.of_string_exn in
let uplink_netvm_ip = get "/qubes-gateway" |> Ipaddr.V4.of_string_exn in
let clients_our_ip = get "/qubes-netvm-gateway" |> Ipaddr.V4.of_string_exn in
let dns = get "/qubes-primary-dns" |> Ipaddr.V4.of_string_exn in
let dns2 = get "/qubes-secondary-dns" |> Ipaddr.V4.of_string_exn in
Log.info (fun f -> f "@[<v2>Got network configuration from QubesDB:@,\
NetVM IP on uplink network: %a@,\
Our IP on uplink network: %a@,\
Our IP on client networks: %a@,\
DNS primary resolver: %a@,\
DNS secondary resolver: %a@]"
Ipaddr.V4.pp uplink_netvm_ip
Ipaddr.V4.pp uplink_our_ip
Ipaddr.V4.pp clients_our_ip
Ipaddr.V4.pp dns
Ipaddr.V4.pp dns2);
{ uplink_netvm_ip; uplink_our_ip; clients_our_ip ; dns ; dns2 }
| Some value -> Ipaddr.V4.of_string_exn value in
let our_ip = get "/qubes-ip" in (* - IP address for this VM (only when VM has netvm set) *)
let netvm_ip = get "/qubes-gateway" in (* - default gateway IP (only when VM has netvm set); VM should add host route to this address directly via eth0 (or whatever default interface name is) *)
let dns = get "/qubes-primary-dns" in
let dns2 = get "/qubes-secondary-dns" in
{ from_cmdline=false; netvm_ip ; our_ip ; dns ; dns2 }
let read_network_config qubesDB =
let rec aux bindings =
@ -165,4 +152,15 @@ let read_network_config qubesDB =
in
aux (DB.bindings qubesDB)
let print_network_config config =
Log.info (fun f -> f "@[<v2>Current network configuration (QubesDB or command line):@,\
NetVM IP on uplink network: %a@,\
Our IP on client networks: %a@,\
DNS primary resolver: %a@,\
DNS secondary resolver: %a@]"
Ipaddr.V4.pp config.netvm_ip
Ipaddr.V4.pp config.our_ip
Ipaddr.V4.pp config.dns
Ipaddr.V4.pp config.dns2)
let set_iptables_error db = Qubes.DB.write db "/qubes-iptables-error"

9
dao.mli
View File

@ -20,10 +20,9 @@ val watch_clients : (Ipaddr.V4.t VifMap.t -> unit) -> 'a Lwt.t
in XenStore, and again each time XenStore updates. *)
type network_config = {
uplink_netvm_ip : Ipaddr.V4.t; (* The IP address of NetVM (our gateway) *)
uplink_our_ip : Ipaddr.V4.t; (* The IP address of our interface to NetVM *)
clients_our_ip : Ipaddr.V4.t; (* The IP address of our interface to our client VMs (their gateway) *)
from_cmdline : bool; (* Specify if we have network configuration from command line or from qubesDB*)
netvm_ip : Ipaddr.V4.t; (* The IP address of NetVM (our gateway) *)
our_ip : Ipaddr.V4.t; (* The IP address of our interface to NetVM *)
dns : Ipaddr.V4.t;
dns2 : Ipaddr.V4.t;
}
@ -39,4 +38,6 @@ val read_rules : string Qubes.DB.KeyMap.t -> Ipaddr.V4.t -> Pf_qubes.Parse_qubes
(** [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 print_network_config : network_config -> unit
val set_iptables_error : Qubes.DB.t -> string -> unit Lwt.t

607
dispatcher.ml Normal file
View File

@ -0,0 +1,607 @@
open Lwt.Infix
open Fw_utils
module Netback = Netchannel.Backend.Make (Netchannel.Xenstore.Make (Xen_os.Xs))
module ClientEth = Ethernet.Make (Netback)
module UplinkEth = Ethernet.Make (Netif)
let src = Logs.Src.create "dispatcher" ~doc:"Networking dispatch"
module Log = (val Logs.src_log src : Logs.LOG)
module Make
(R : Mirage_random.S)
(Clock : Mirage_clock.MCLOCK)
(Time : Mirage_time.S) =
struct
module Arp = Arp.Make (UplinkEth) (Time)
module I = Static_ipv4.Make (R) (Clock) (UplinkEth) (Arp)
module U = Udp.Make (I) (R)
let clients : Cleanup.t Dao.VifMap.t ref = ref Dao.VifMap.empty
class client_iface eth ~domid ~gateway_ip ~client_ip client_mac : client_link
=
let log_header = Fmt.str "dom%d:%a" domid Ipaddr.V4.pp client_ip in
object
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
method other_ip = client_ip
method writev proto fillfn =
Lwt.catch
(fun () ->
ClientEth.write eth client_mac proto fillfn >|= function
| Ok () -> ()
| Error e ->
Log.err (fun f ->
f "error trying to send to client: @[%a@]"
ClientEth.pp_error e))
(fun ex ->
(* Usually Netback_shutdown, because the client disconnected *)
Log.err (fun f ->
f "uncaught exception trying to send to client: @[%s@]"
(Printexc.to_string ex));
Lwt.return_unit)
method log_header = log_header
end
class netvm_iface eth mac ~my_ip ~other_ip : interface =
object
method my_mac = UplinkEth.mac eth
method my_ip = my_ip
method other_ip = other_ip
method writev ethertype fillfn =
Lwt.catch
(fun () ->
mac >>= fun dst ->
UplinkEth.write eth dst ethertype fillfn
>|= or_raise "Write to uplink" UplinkEth.pp_error)
(fun ex ->
Log.err (fun f ->
f "uncaught exception trying to send to uplink: @[%s@]"
(Printexc.to_string ex));
Lwt.return_unit)
end
type uplink = {
net : Netif.t;
eth : UplinkEth.t;
arp : Arp.t;
interface : interface;
mutable fragments : Fragments.Cache.t;
ip : I.t;
udp : U.t;
}
type t = {
uplink_connected : unit Lwt_condition.t;
uplink_disconnect : unit Lwt_condition.t;
uplink_disconnected : unit Lwt_condition.t;
mutable config : Dao.network_config;
clients : Client_eth.t;
nat : My_nat.t;
mutable uplink : uplink option;
}
let create ~config ~clients ~nat ~uplink =
{
uplink_connected = Lwt_condition.create ();
uplink_disconnect = Lwt_condition.create ();
uplink_disconnected = Lwt_condition.create ();
config;
clients;
nat;
uplink;
}
let update t ~config ~uplink =
t.config <- config;
t.uplink <- uplink;
Lwt.return_unit
let target t buf =
let dst_ip = buf.Ipv4_packet.dst in
match Client_eth.lookup t.clients dst_ip with
| Some client_link -> Some (client_link :> interface)
| None -> ( (* if dest is not a client, transfer it to our uplink *)
match t.uplink with
| None -> (
match Client_eth.lookup t.clients t.config.netvm_ip with
| Some uplink ->
Some (uplink :> interface)
| None ->
Log.err (fun f -> f "We have a command line configuration %a but it's currently not connected to us (please check its netvm property)...%!" Ipaddr.V4.pp t.config.netvm_ip);
None)
| Some uplink -> Some uplink.interface)
let add_client t = Client_eth.add_client t.clients
let remove_client t = Client_eth.remove_client t.clients
let classify t ip =
if ip = Ipaddr.V4 t.config.our_ip then `Firewall
else if ip = Ipaddr.V4 t.config.netvm_ip then `NetVM
else (Client_eth.classify t.clients ip :> Packet.host)
let resolve t = function
| `Firewall -> Ipaddr.V4 t.config.our_ip
| `NetVM -> Ipaddr.V4 t.config.netvm_ip
| #Client_eth.host as host -> Client_eth.resolve t.clients host
(* Transmission *)
let transmit_ipv4 packet iface =
Lwt.catch
(fun () ->
let fragments = ref [] in
iface#writev `IPv4 (fun b ->
match Nat_packet.into_cstruct packet b with
| Error e ->
Log.warn (fun f ->
f "Failed to write packet to %a: %a" Ipaddr.V4.pp
iface#other_ip Nat_packet.pp_error e);
0
| Ok (n, frags) ->
fragments := frags;
n)
>>= fun () ->
Lwt_list.iter_s
(fun f ->
let size = Cstruct.length f in
iface#writev `IPv4 (fun b ->
Cstruct.blit f 0 b 0 size;
size))
!fragments)
(fun ex ->
Log.warn (fun f ->
f "Failed to write packet to %a: %s" Ipaddr.V4.pp iface#other_ip
(Printexc.to_string ex));
Lwt.return_unit)
let forward_ipv4 t packet =
let (`IPv4 (ip, _)) = packet in
Lwt.catch
(fun () ->
match target t ip with
| Some iface -> transmit_ipv4 packet iface
| None -> Lwt.return_unit)
(fun ex ->
let dst_ip = ip.Ipv4_packet.dst in
Log.warn (fun f ->
f "Failed to lookup for target %a: %s" Ipaddr.V4.pp dst_ip
(Printexc.to_string ex));
Lwt.return_unit)
(* NAT *)
let translate t packet = My_nat.translate t.nat packet
(* 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 xl_host = t.config.our_ip in
match My_nat.add_nat_rule_and_translate t.nat ~xl_host `NAT packet with
| Ok packet -> forward_ipv4 t packet
| Error e ->
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. *)
let nat_to t ~host ~port packet =
match resolve t host with
| Ipaddr.V6 _ ->
Log.warn (fun f -> f "Cannot NAT with IPv6");
Lwt.return_unit
| Ipaddr.V4 target -> (
let xl_host = t.config.our_ip in
match
My_nat.add_nat_rule_and_translate t.nat ~xl_host
(`Redirect (target, port))
packet
with
| Ok packet -> forward_ipv4 t packet
| Error e ->
Log.warn (fun f ->
f "Failed to add NAT redirect rule: %s (%a)" e Nat_packet.pp
packet);
Lwt.return_unit)
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 = 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) -> (
match t.uplink with
| Some uplink -> transmit_ipv4 packet uplink.interface
| None -> (
match Client_eth.lookup t.clients t.config.netvm_ip with
| Some iface -> transmit_ipv4 packet iface
| None ->
Log.warn (fun f ->
f "No output interface for %a : drop" Nat_packet.pp packet);
Lwt.return_unit))
| `Accept, `Firewall ->
Log.warn (fun f ->
f "Bad rule: firewall can't accept packets %a" Nat_packet.pp packet);
Lwt.return_unit
| `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.debug (fun f ->
f "Dropped packet (%s) %a" reason Nat_packet.pp packet);
Lwt.return_unit
let ipv4_from_netvm t packet =
match Memory_pressure.status () with
| `Memory_critical -> Lwt.return_unit
| `Ok -> (
let (`IPv4 (ip, _transport)) = packet in
let src = classify t (Ipaddr.V4 ip.Ipv4_packet.src) in
let dst = classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in
match Packet.of_mirage_nat_packet ~src ~dst packet with
| None -> Lwt.return_unit
| Some _ -> (
match src with
| `Client _ | `Firewall ->
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 -> (
match translate t packet with
| Some frame -> forward_ipv4 t frame
| None -> (
match Packet.of_mirage_nat_packet ~src ~dst packet with
| None -> Lwt.return_unit
| Some packet -> apply_rules t Rules.from_netvm ~dst packet)
)))
let ipv4_from_client resolver dns_servers t ~src packet =
match Memory_pressure.status () with
| `Memory_critical -> Lwt.return_unit
| `Ok -> (
(* Check for existing NAT entry for this packet *)
match translate t packet with
| Some frame ->
forward_ipv4 t frame (* Some existing connection or redirect *)
| None -> (
(* No existing NAT entry. Check the firewall rules. *)
let (`IPv4 (ip, _transport)) = packet in
match classify t (Ipaddr.V4 ip.Ipv4_packet.src) with
| `Client _ | `Firewall -> (
let dst = classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in
match
Packet.of_mirage_nat_packet ~src:(`Client src) ~dst packet
with
| None -> Lwt.return_unit
| Some firewall_packet ->
apply_rules t
(Rules.from_client resolver dns_servers)
~dst firewall_packet)
| `NetVM -> ipv4_from_netvm t packet
| `External _ ->
Log.warn (fun f ->
f "Frame from Inside has external source IP address! %a"
Nat_packet.pp packet);
Lwt.return_unit))
(** Handle an ARP message from the client. *)
let client_handle_arp ~fixed_arp ~iface request =
match Arp_packet.decode request with
| Error e ->
Log.warn (fun f ->
f "Ignored unknown ARP message: %a" Arp_packet.pp_error e);
Lwt.return_unit
| Ok arp -> (
match Client_eth.ARP.input fixed_arp arp with
| None -> Lwt.return_unit
| Some response ->
Lwt.catch
(fun () ->
iface#writev `ARP (fun b ->
Arp_packet.encode_into response b;
Arp_packet.size))
(fun ex ->
Log.warn (fun f ->
f "Failed to write APR to %a: %s" Ipaddr.V4.pp iface#other_ip
(Printexc.to_string ex));
Lwt.return_unit)
)
(** Handle an IPv4 packet from the client. *)
let client_handle_ipv4 get_ts cache ~iface ~router dns_client dns_servers
packet =
let cache', r = Nat_packet.of_ipv4_packet !cache ~now:(get_ts ()) packet in
cache := cache';
match r with
| Error e ->
Log.warn (fun f ->
f "Ignored unknown IPv4 message: %a" Nat_packet.pp_error e);
Lwt.return_unit
| Ok None -> Lwt.return_unit
| Ok (Some packet) ->
let (`IPv4 (ip, _)) = packet in
let src = ip.Ipv4_packet.src in
if src = iface#other_ip then
ipv4_from_client dns_client dns_servers router ~src:iface packet
else if iface#other_ip = router.config.netvm_ip then
(* This can occurs when used with *BSD as netvm (and a gateway is set) *)
ipv4_from_netvm router packet
else (
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);
Lwt.return_unit)
(** Connect to a new client's interface and listen for incoming frames and firewall rule changes. *)
let add_vif get_ts { Dao.ClientVif.domid; device_id } dns_client dns_servers
~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 ->
let client_mac = Netback.frontend_mac backend in
let client_eth = router.clients 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.info (fun m ->
m "Rules did not change for %s"
(Ipaddr.V4.to_string client_ip))
else (
Log.info (fun m ->
m "New firewall rules for %s@.%a"
(Ipaddr.V4.to_string client_ip)
Fmt.(list ~sep:(any "@.") 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.nat client_ip);
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);
add_client router iface >>= fun () ->
Cleanup.on_cleanup cleanup_tasks (fun () -> 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.Packet.sizeof_ethernet
(fun frame ->
match Ethernet.Packet.of_cstruct frame with
| Error err ->
Log.warn (fun f -> f "Invalid Ethernet frame: %s" err);
Lwt.return_unit
| Ok (eth, payload) -> (
match eth.Ethernet.Packet.ethertype with
| `ARP -> client_handle_arp ~fixed_arp ~iface payload
| `IPv4 ->
client_handle_ipv4 get_ts fragment_cache ~iface ~router
dns_client dns_servers payload
| `IPv6 -> Lwt.return_unit (* TODO: oh no! *)))
>|= or_raise "Listen on client interface" Netback.pp_error)
(function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e)
in
Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel listener);
Lwt.pick [ qubesdb_updater; listener ]
(** A new client VM has been found in XenStore. Find its interface and connect to it. *)
let add_client get_ts dns_client dns_servers ~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);
Lwt.async (fun () ->
Lwt.catch
(fun () ->
add_vif get_ts vif dns_client dns_servers ~client_ip ~router
~cleanup_tasks qubesDB)
(fun ex ->
Log.warn (fun f ->
f "Error with client %a: %s" Dao.ClientVif.pp vif
(Printexc.to_string ex));
Lwt.return_unit));
cleanup_tasks
(** Watch XenStore for notifications of new clients. *)
let wait_clients get_ts dns_client dns_servers qubesDB router =
Dao.watch_clients (fun new_set ->
(* Check for removed clients *)
!clients
|> Dao.VifMap.iter (fun key cleanup ->
if not (Dao.VifMap.mem key new_set) then (
clients := !clients |> Dao.VifMap.remove key;
Log.info (fun f -> f "client %a has gone" Dao.ClientVif.pp key);
Cleanup.cleanup cleanup));
(* 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 dns_client dns_servers ~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)))
let send_dns_client_query t ~src_port ~dst ~dst_port buf =
match t with
| None ->
Log.err (fun f -> f "No uplink interface");
Lwt.return (Error (`Msg "failure"))
| Some t -> (
Lwt.catch
(fun () ->
U.write ~src_port ~dst ~dst_port t.udp buf >|= function
| Error s ->
Log.err (fun f -> f "error sending udp packet: %a" U.pp_error s);
Error (`Msg "failure")
| Ok () -> Ok ())
(fun ex ->
Log.err (fun f ->
f "uncaught exception trying to send DNS request to uplink: @[%s@]"
(Printexc.to_string ex));
Lwt.return (Error (`Msg "DNS request not sent"))))
(** Wait for packet from our uplink (we must have an uplink here...). *)
let rec uplink_listen get_ts dns_responses router =
Lwt_condition.wait router.uplink_connected >>= fun () ->
match router.uplink with
| None ->
Log.err (fun f ->
f
"Uplink is connected but not found in the router, retrying...%!");
uplink_listen get_ts dns_responses router
| Some uplink ->
let listen =
Lwt.catch
(fun () ->
Netif.listen uplink.net ~header_size:Ethernet.Packet.sizeof_ethernet
(fun frame ->
(* Handle one Ethernet frame from NetVM *)
UplinkEth.input uplink.eth ~arpv4:(Arp.input uplink.arp)
~ipv4:(fun ip ->
let cache, r =
Nat_packet.of_ipv4_packet uplink.fragments ~now:(get_ts ())
ip
in
uplink.fragments <- cache;
begin match r with
| Error e ->
Log.warn (fun f ->
f "Ignored unknown IPv4 message from uplink: %a"
Nat_packet.pp_error e);
Lwt.return ()
| Ok None -> Lwt.return_unit
| Ok (Some (`IPv4 (header, packet))) ->
let open Udp_packet in
Log.debug (fun f ->
f "received ipv4 packet from %a on uplink" Ipaddr.V4.pp
header.Ipv4_packet.src);
begin match packet with
| `UDP (header, packet) when My_nat.dns_port router.nat header.dst_port ->
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)
| _ -> ipv4_from_netvm router (`IPv4 (header, packet))
end
end)
~ipv6:(fun _ip -> Lwt.return_unit)
frame)
>|= or_raise "Uplink listen loop" Netif.pp_error)
(function Lwt.Canceled ->
(* We can be cancelled if reconnect_uplink is achieved (via the Lwt_condition), so we need to disconnect and broadcast when it's done
currently we delay 1s as Netif.disconnect is non-blocking... (need to fix upstream?) *)
Log.info (fun f ->
f "disconnecting from our uplink");
U.disconnect uplink.udp >>= fun () ->
I.disconnect uplink.ip >>= fun () ->
(* mutable fragments : Fragments.Cache.t; *)
(* interface : interface; *)
Arp.disconnect uplink.arp >>= fun () ->
UplinkEth.disconnect uplink.eth >>= fun () ->
Netif.disconnect uplink.net >>= fun () ->
Lwt_condition.broadcast router.uplink_disconnected ();
Lwt.return_unit
| e -> Lwt.fail e)
in
let reconnect_uplink =
Lwt_condition.wait router.uplink_disconnect >>= fun () ->
Log.info (fun f ->
f "we need to reconnect to the new uplink");
Lwt.return_unit
in
Lwt.pick [ listen ; reconnect_uplink ] >>= fun () ->
uplink_listen get_ts dns_responses router
(** Connect to our uplink backend (we must have an uplink here...). *)
let connect config =
let my_ip = config.Dao.our_ip in
let gateway = config.Dao.netvm_ip in
Netif.connect "0" >>= fun net ->
UplinkEth.connect net >>= fun eth ->
Arp.connect eth >>= fun arp ->
Arp.add_ip arp my_ip >>= fun () ->
let cidr = Ipaddr.V4.Prefix.make 0 my_ip in
I.connect ~cidr ~gateway eth arp >>= fun ip ->
U.connect ip >>= fun udp ->
let netvm_mac =
Arp.query arp gateway >|= or_raise "Getting MAC of our NetVM" Arp.pp_error
in
let interface =
new netvm_iface eth netvm_mac ~my_ip ~other_ip:config.Dao.netvm_ip
in
let fragments = Fragments.Cache.empty (256 * 1024) in
Lwt.return { net; eth; arp; interface; fragments; ip; udp }
(** Wait Xenstore for our uplink changes (we must have an uplink here...). *)
let uplink_wait_update qubesDB router =
let rec aux current_db =
let netvm = "/qubes-gateway" in
Log.info (fun f -> f "Waiting for netvm changes to %S...%!" netvm);
Qubes.DB.after qubesDB current_db >>= fun new_db ->
(match (router.uplink, Qubes.DB.KeyMap.find_opt netvm new_db) with
| Some uplink, Some netvm
when not
(String.equal netvm
(Ipaddr.V4.to_string uplink.interface#other_ip)) ->
Log.info (fun f ->
f "Our netvm IP has changed, before it was %s, now it's: %s%!"
(Ipaddr.V4.to_string uplink.interface#other_ip)
netvm);
Lwt_condition.broadcast router.uplink_disconnect ();
(* wait for uplink disconnexion *)
Lwt_condition.wait router.uplink_disconnected >>= fun () ->
Dao.read_network_config qubesDB >>= fun config ->
Dao.print_network_config config;
connect config >>= fun uplink ->
update router ~config ~uplink:(Some uplink) >>= fun () ->
Lwt_condition.broadcast router.uplink_connected ();
Lwt.return_unit
| None, Some _ ->
(* a new interface is attributed to qubes-mirage-firewall *)
Log.info (fun f -> f "Going from netvm not connected to %s%!" netvm);
Dao.read_network_config qubesDB >>= fun config ->
Dao.print_network_config config;
connect config >>= fun uplink ->
update router ~config ~uplink:(Some uplink) >>= fun () ->
Lwt_condition.broadcast router.uplink_connected ();
Lwt.return_unit
| Some _, None ->
(* This currently is never triggered :( *)
Log.info (fun f ->
f "TODO: Our netvm disapeared, troubles are coming!%!");
Lwt.return_unit
| Some _, Some _ (* The new netvm IP is unchanged (it's our old netvm IP) *)
| None, None ->
Log.info (fun f ->
f "QubesDB has changed but not the situation of our netvm!%!");
Lwt.return_unit)
>>= fun () -> aux new_db
in
aux Qubes.DB.KeyMap.empty
end

121
firewall.ml
View File

@ -1,121 +0,0 @@
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
See the README file for details. *)
open Packet
open Lwt.Infix
let src = Logs.Src.create "firewall" ~doc:"Packet handler"
module Log = (val Logs.src_log src : Logs.LOG)
(* Transmission *)
let transmit_ipv4 packet iface =
Lwt.catch
(fun () ->
let fragments = ref [] in
iface#writev `IPv4 (fun b ->
match Nat_packet.into_cstruct packet b with
| Error e ->
Log.warn (fun f -> f "Failed to write packet to %a: %a"
Ipaddr.V4.pp iface#other_ip
Nat_packet.pp_error e);
0
| Ok (n, frags) -> fragments := frags ; n) >>= fun () ->
Lwt_list.iter_s (fun f ->
let size = Cstruct.length f in
iface#writev `IPv4 (fun b -> Cstruct.blit f 0 b 0 size ; size))
!fragments)
(fun ex ->
Log.warn (fun f -> f "Failed to write packet to %a: %s"
Ipaddr.V4.pp iface#other_ip
(Printexc.to_string ex));
Lwt.return_unit
)
let forward_ipv4 t packet =
let `IPv4 (ip, _) = packet in
match Router.target t ip with
| Some iface -> transmit_ipv4 packet iface
| None -> Lwt.return_unit
(* NAT *)
let translate t packet =
My_nat.translate t.Router.nat packet
(* 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 open Router in
let xl_host = t.uplink#my_ip in
match My_nat.add_nat_rule_and_translate t.nat ~xl_host `NAT packet with
| Ok packet -> forward_ipv4 t packet
| Error e ->
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. *)
let nat_to t ~host ~port packet =
let open Router in
match resolve t host with
| Ipaddr.V6 _ -> Log.warn (fun f -> f "Cannot NAT with IPv6"); Lwt.return_unit
| Ipaddr.V4 target ->
let xl_host = t.uplink#my_ip in
match My_nat.add_nat_rule_and_translate t.nat ~xl_host (`Redirect (target, port)) packet with
| Ok packet -> forward_ipv4 t packet
| Error e ->
Log.warn (fun f -> f "Failed to add NAT redirect rule: %s (%a)" e Nat_packet.pp packet);
Lwt.return_unit
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" Nat_packet.pp packet);
Lwt.return_unit
| `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.debug (fun f -> f "Dropped packet (%s) %a" reason Nat_packet.pp packet);
Lwt.return_unit
let ipv4_from_client resolver dns_servers t ~src packet =
match Memory_pressure.status () with
| `Memory_critical -> Lwt.return_unit
| `Ok ->
(* Check for existing NAT entry for this packet *)
match translate t packet with
| Some frame -> forward_ipv4 t frame (* Some existing connection or redirect *)
| None ->
(* 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 of_mirage_nat_packet ~src:(`Client src) ~dst packet with
| None -> Lwt.return_unit
| Some firewall_packet -> apply_rules t (Rules.from_client resolver dns_servers) ~dst firewall_packet
let ipv4_from_netvm t packet =
match Memory_pressure.status () with
| `Memory_critical -> Lwt.return_unit
| `Ok ->
let `IPv4 (ip, _transport) = packet in
let src = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.src) in
let dst = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in
match Packet.of_mirage_nat_packet ~src ~dst packet with
| None -> Lwt.return_unit
| Some _ ->
match src with
| `Client _ | `Firewall ->
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 ->
match translate t packet with
| Some frame -> forward_ipv4 t frame
| None ->
match Packet.of_mirage_nat_packet ~src ~dst packet with
| None -> Lwt.return_unit
| Some packet -> apply_rules t Rules.from_netvm ~dst packet

13
firewall.mli
View File

@ -1,13 +0,0 @@
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
See the README file for details. *)
(** Classify IP packets, apply rules and send as appropriate. *)
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). *)
(* TODO the function type is a workaround, rework the module dependencies / functors to get rid of it *)
val ipv4_from_client : ([ `host ] Domain_name.t -> (int32 * Ipaddr.V4.Set.t, [> `Msg of string ]) result Lwt.t) ->
Ipaddr.V4.t list -> Router.t -> src:Fw_utils.client_link -> Nat_packet.t -> unit Lwt.t
(** Handle a packet from a client. Caller must check the source IP matches the client's
before calling this. *)

1
fw_utils.ml
View File

@ -8,6 +8,7 @@ module IpMap = struct
let find x map =
try Some (find x map)
with Not_found -> None
| _ -> Logs.err( fun f -> f "uncaught exception in find...%!"); None
end
(** An Ethernet interface. *)

19
memory_pressure.ml
View File

@ -1,32 +1,13 @@
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
See the README file for details. *)
open Lwt
let src = Logs.Src.create "memory_pressure" ~doc:"Memory pressure monitor"
module Log = (val Logs.src_log src : Logs.LOG)
let wordsize_in_bytes = Sys.word_size / 8
let fraction_free stats =
let { Xen_os.Memory.free_words; heap_words; _ } = stats in
float free_words /. float heap_words
let meminfo stats =
let { Xen_os.Memory.free_words; heap_words; _ } = stats in
let mem_total = heap_words * wordsize_in_bytes in
let mem_free = free_words * wordsize_in_bytes in
Log.info (fun f -> f "Writing meminfo: free %a / %a (%.2f %%)"
Fmt.bi_byte_size mem_free
Fmt.bi_byte_size mem_total
(fraction_free stats *. 100.0));
Printf.sprintf "MemTotal: %d kB\n\
MemFree: %d kB\n\
Buffers: 0 kB\n\
Cached: 0 kB\n\
SwapTotal: 0 kB\n\
SwapFree: 0 kB\n" (mem_total / 1024) (mem_free / 1024)
let init () =
Gc.full_major ()

6
my_dns.ml
View File

@ -3,7 +3,8 @@ open Lwt.Infix
module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) (Time : Mirage_time.S) = struct
type +'a io = 'a Lwt.t
type io_addr = Ipaddr.V4.t * int
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
module Dispatcher = Dispatcher.Make(R)(C)(Time)
type stack = Dispatcher.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
module IM = Map.Make(Int)
@ -48,11 +49,10 @@ module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) (Time : Mirage_
let connect (t : t) = Lwt.return (Ok (t.protocol, t))
let send_recv (ctx : context) buf : (Cstruct.t, [> `Msg of string ]) result Lwt.t =
let open Router in
let dst, dst_port = ctx.nameserver in
let router, send_udp, _ = ctx.stack in
let src_port, evict =
My_nat.free_udp_port router.nat ~src:router.uplink#my_ip ~dst ~dst_port:53
My_nat.free_udp_port router.nat ~src:router.config.our_ip ~dst ~dst_port:53
in
let id = Cstruct.BE.get_uint16 buf 0 in
with_timeout ctx.timeout_ns

34
router.ml
View File

@ -1,34 +0,0 @@
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
See the README file for details. *)
open Fw_utils
(* The routing table *)
type t = {
client_eth : Client_eth.t;
nat : My_nat.t;
uplink : interface;
}
let create ~client_eth ~uplink ~nat =
{ client_eth; nat; uplink }
let target t buf =
let dst_ip = buf.Ipv4_packet.dst in
match Client_eth.lookup t.client_eth dst_ip with
| Some client_link -> Some (client_link :> interface)
| None -> Some t.uplink
let add_client t = Client_eth.add_client t.client_eth
let remove_client t = Client_eth.remove_client t.client_eth
let classify t ip =
if ip = Ipaddr.V4 t.uplink#my_ip then `Firewall
else if ip = Ipaddr.V4 t.uplink#other_ip then `NetVM
else (Client_eth.classify t.client_eth ip :> Packet.host)
let resolve t = function
| `Firewall -> Ipaddr.V4 t.uplink#my_ip
| `NetVM -> Ipaddr.V4 t.uplink#other_ip
| #Client_eth.host as host -> Client_eth.resolve t.client_eth host

31
router.mli
View File

@ -1,31 +0,0 @@
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
See the README file for details. *)
(** Routing packets to the right network interface. *)
open Fw_utils
type t = private {
client_eth : Client_eth.t;
nat : My_nat.t;
uplink : interface;
}
val create :
client_eth:Client_eth.t ->
uplink:interface ->
nat:My_nat.t ->
t
(** [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
(** [target t packet] is the interface to which [packet] should be routed. *)
val add_client : t -> client_link -> unit Lwt.t
(** [add_client t iface] adds a rule for routing packets addressed to [iface]. *)
val remove_client : t -> client_link -> unit
val classify : t -> Ipaddr.t -> Packet.host
val resolve : t -> Packet.host -> Ipaddr.t

76
unikernel.ml
View File

@ -3,27 +3,49 @@
open Lwt
open Qubes
open Cmdliner
let src = Logs.Src.create "unikernel" ~doc:"Main unikernel code"
module Log = (val Logs.src_log src : Logs.LOG)
let nat_table_size =
let doc = Arg.info ~doc:"The number of NAT entries to allocate." [ "nat-table-size" ] in
Arg.(value & opt int 5_000 doc)
let ipv4 =
let doc = Arg.info ~doc:"Manual IP setting." [ "ipv4" ] in
Arg.(value & opt string "0.0.0.0" doc)
let ipv4_gw =
let doc = Arg.info ~doc:"Manual Gateway IP setting." [ "ipv4-gw" ] in
Arg.(value & opt string "0.0.0.0" doc)
let ipv4_dns =
let doc = Arg.info ~doc:"Manual DNS IP setting." [ "ipv4-dns" ] in
Arg.(value & opt string "10.139.1.1" doc)
let ipv4_dns2 =
let doc = Arg.info ~doc:"Manual Second DNS IP setting." [ "ipv4-dns2" ] in
Arg.(value & opt string "10.139.1.2" doc)
module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_time.S) = struct
module Uplink = Uplink.Make(R)(Clock)(Time)
module Dispatcher = Dispatcher.Make(R)(Clock)(Time)
module Dns_transport = My_dns.Transport(R)(Clock)(Time)
module Dns_client = Dns_client.Make(Dns_transport)
(* Set up networking and listen for incoming packets. *)
let network dns_client dns_responses dns_servers uplink qubesDB router =
let network dns_client dns_responses dns_servers qubesDB router =
(* Report success *)
Dao.set_iptables_error qubesDB "" >>= fun () ->
(* Handle packets from both networks *)
Lwt.choose [
Client_net.listen Clock.elapsed_ns dns_client dns_servers qubesDB router;
Uplink.listen uplink Clock.elapsed_ns dns_responses router
Dispatcher.wait_clients Clock.elapsed_ns dns_client dns_servers qubesDB router ;
Dispatcher.uplink_wait_update qubesDB router ;
Dispatcher.uplink_listen Clock.elapsed_ns dns_responses router
]
(* Main unikernel entry point (called from auto-generated main.ml). *)
let start _random _clock _time =
let start _random _clock _time nat_table_size ipv4 ipv4_gw ipv4_dns ipv4_dns2 =
let start_time = Clock.elapsed_ns () in
(* Start qrexec agent and QubesDB agent in parallel *)
let qrexec = RExec.connect ~domid:0 () in
@ -44,30 +66,50 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_tim
Xen_os.Lifecycle.await_shutdown_request () >>= fun (`Poweroff | `Reboot) ->
Lwt.return_unit in
(* Set up networking *)
let max_entries = Key_gen.nat_table_size () in
let nat = My_nat.create ~max_entries in
let nat = My_nat.create ~max_entries:nat_table_size in
(* Read network configuration from QubesDB *)
Dao.read_network_config qubesDB >>= fun config ->
let netvm_ip = Ipaddr.V4.of_string_exn ipv4_gw in
let our_ip = Ipaddr.V4.of_string_exn ipv4 in
let dns = Ipaddr.V4.of_string_exn ipv4_dns in
let dns2 = Ipaddr.V4.of_string_exn ipv4_dns2 in
let zero_ip = (Ipaddr.V4.make 0 0 0 0) in
let network_config =
if (netvm_ip = zero_ip && our_ip = zero_ip) then (* Read network configuration from QubesDB *)
Dao.read_network_config qubesDB >>= fun config ->
if config.netvm_ip = zero_ip || config.our_ip = zero_ip then
Log.info (fun f -> f "We currently have no netvm nor command line for setting it up, aborting...");
assert (config.netvm_ip <> zero_ip && config.our_ip <> zero_ip);
Lwt.return config
else begin
let config:Dao.network_config = {from_cmdline=true; netvm_ip; our_ip; dns; dns2} in
Lwt.return config
end
in
network_config >>= fun config ->
(* We now must have a valid netvm IP address and our IP address or crash *)
Dao.print_network_config 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
Client_eth.create config >>= fun clients ->
(* Set up routing between networks and hosts *)
let router = Router.create
~client_eth
~uplink:(Uplink.interface uplink)
let router = Dispatcher.create
~config
~clients
~nat
~uplink:None
in
let send_dns_query = Uplink.send_dns_client_query uplink in
let send_dns_query = Dispatcher.send_dns_client_query None in
let dns_mvar = Lwt_mvar.create_empty () in
let nameservers = `Udp, [ config.Dao.dns, 53 ; config.Dao.dns2, 53 ] in
let dns_client = Dns_client.create ~nameservers (router, send_dns_query, dns_mvar) in
let dns_servers = [ config.Dao.dns ; config.Dao.dns2 ] in
let net_listener = network (Dns_client.getaddrinfo dns_client Dns.Rr_map.A) dns_mvar dns_servers uplink qubesDB router in
let net_listener = network (Dns_client.getaddrinfo dns_client Dns.Rr_map.A) dns_mvar dns_servers qubesDB router in
(* Report memory usage to XenStore *)
Memory_pressure.init ();

94
uplink.ml
View File

@ -1,94 +0,0 @@
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
See the README file for details. *)
open Lwt.Infix
open Fw_utils
module Eth = Ethernet.Make(Netif)
let src = Logs.Src.create "uplink" ~doc:"Network connection to NetVM"
module Log = (val Logs.src_log src : Logs.LOG)
module Make (R:Mirage_random.S) (Clock : Mirage_clock.MCLOCK) (Time : Mirage_time.S) = struct
module Arp = Arp.Make(Eth)(Time)
module I = Static_ipv4.Make(R)(Clock)(Eth)(Arp)
module U = Udp.Make(I)(R)
type t = {
net : Netif.t;
eth : Eth.t;
arp : Arp.t;
interface : interface;
mutable fragments : Fragments.Cache.t;
ip : I.t;
udp: U.t;
}
class netvm_iface eth mac ~my_ip ~other_ip : interface = object
method my_mac = Eth.mac eth
method my_ip = my_ip
method other_ip = other_ip
method writev ethertype fillfn =
mac >>= fun dst ->
Eth.write eth dst ethertype fillfn >|= or_raise "Write to uplink" Eth.pp_error
end
let send_dns_client_query t ~src_port ~dst ~dst_port buf =
U.write ~src_port ~dst ~dst_port t.udp buf >|= function
| Error s -> Log.err (fun f -> f "error sending udp packet: %a" U.pp_error s); Error (`Msg "failure")
| 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 My_nat.dns_port router.Router.nat header.dst_port ->
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.Packet.sizeof_ethernet (fun frame ->
(* Handle one Ethernet frame from NetVM *)
Eth.input t.eth
~arpv4:(Arp.input t.arp)
~ipv4:(fun ip ->
let cache, r =
Nat_packet.of_ipv4_packet t.fragments ~now:(get_ts ()) ip
in
t.fragments <- cache;
match r with
| Error e ->
Log.warn (fun f -> f "Ignored unknown IPv4 message from uplink: %a" Nat_packet.pp_error e);
Lwt.return ()
| Ok None -> Lwt.return_unit
| Ok (Some (`IPv4 (header, packet))) -> handle_packet header packet
)
~ipv6:(fun _ip -> Lwt.return_unit)
frame
) >|= or_raise "Uplink listen loop" Netif.pp_error
let interface t = t.interface
let connect config =
let my_ip = config.Dao.uplink_our_ip in
let gateway = config.Dao.uplink_netvm_ip in
Netif.connect "0" >>= fun net ->
Eth.connect net >>= fun eth ->
Arp.connect eth >>= fun arp ->
Arp.add_ip arp my_ip >>= fun () ->
let cidr = Ipaddr.V4.Prefix.make 0 my_ip in
I.connect ~cidr ~gateway eth arp >>= fun ip ->
U.connect ip >>= fun udp ->
let netvm_mac =
Arp.query arp gateway
>|= or_raise "Getting MAC of our NetVM" Arp.pp_error in
let interface = new netvm_iface eth netvm_mac
~my_ip
~other_ip:config.Dao.uplink_netvm_ip in
let fragments = Fragments.Cache.empty (256 * 1024) in
Lwt.return { net; eth; arp; interface ; fragments ; ip ; udp }
end

21
uplink.mli
View File

@ -1,21 +0,0 @@
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
See the README file for details. *)
(** The link from us to NetVM (and, through that, to the outside world). *)
open Fw_utils
module Make (R: Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_time.S) : sig
type t
val connect : Dao.network_config -> t Lwt.t
(** Connect to our NetVM (gateway). *)
val interface : t -> interface
(** The network interface to NetVM. *)
val listen : t -> (unit -> int64) -> (Udp_packet.t * Cstruct.t) Lwt_mvar.t -> Router.t -> unit Lwt.t
(** 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