Git-Mirrors/qubes-mirage-firewall
1
0
Fork 0
mirror of https://github.com/mirage/qubes-mirage-firewall.git synced 2024-06-26 14:12:23 +00:00
Code Issues Packages Projects Releases Wiki Activity

Mirage 3 support

Browse Source
This commit is contained in:
Thomas Leonard 2017-03-02 14:52:55 +00:00
parent 150208fc72
commit bb78a726e4
20 changed files with 423 additions and 341 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.travis.yml
View File

@ -20,4 +20,4 @@ addons:
- time
- libxen-dev
env:
- FORK_USER=talex5 FORK_BRANCH=unikernel OCAML_VERSION=4.02 MIRAGE_BACKEND=xen PINS="mirage-nat:https://github.com/talex5/mirage-nat.git#simplify-checksum"
- OCAML_VERSION=4.04 MIRAGE_BACKEND=xen PINS="mirage-nat:https://github.com/talex5/mirage-nat.git#mirage3"

2
Makefile.user
View File

@ -1,7 +1,7 @@
tar: build
rm -rf _build/mirage-firewall
mkdir _build/mirage-firewall
cp mir-qubes-firewall.xen _build/mirage-firewall/vmlinuz
cp qubes_firewall.xen _build/mirage-firewall/vmlinuz
touch _build/mirage-firewall/modules.img
cat /dev/null | gzip > _build/mirage-firewall/initramfs
tar cjf mirage-firewall.tar.bz2 -C _build mirage-firewall

6
README.md
View File

@ -21,19 +21,17 @@ This took about 10 minutes on my laptop (it will be much quicker if you run it a
## Build (without Docker)
To build (tested by creating a fresh Fedora 23 AppVM in Qubes):
1. Install build tools:
sudo yum install git gcc m4 0install patch ncurses-devel tar bzip2 unzip make which findutils xen-devel
mkdir ~/bin
0install add opam http://tools.ocaml.org/opam.xml
opam init --comp=4.02.3
opam init --comp=4.04.0
eval `opam config env`
2. Install mirage, pinning a few unreleased features we need:
opam pin add -y mirage-nat 'https://github.com/talex5/mirage-nat.git#simplify-checksum'
opam pin add -y mirage-nat 'https://github.com/talex5/mirage-nat.git#mirage3'
opam install mirage
3. Build mirage-firewall:

108
client_eth.ml
View File

@ -1,7 +1,7 @@
(* Copyright (C) 2016, Thomas Leonard <thomas.leonard@unikernel.com>
See the README file for details. *)
open Utils
open Fw_utils
open Lwt.Infix
let src = Logs.Src.create "client_eth" ~doc:"Ethernet networks for NetVM clients"
@ -52,10 +52,10 @@ let classify t ip =
match ip with
| Ipaddr.V6 _ -> `External ip
| Ipaddr.V4 ip4 ->
if ip4 = t.client_gw then `Client_gateway
else match lookup t ip4 with
| Some client_link -> `Client client_link
| None -> `External ip
if ip4 = t.client_gw then `Client_gateway
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
@ -71,8 +71,8 @@ module ARP = struct
let lookup t ip =
if ip = t.net.client_gw then Some t.client_link#my_mac
else None
(* We're now treating client networks as point-to-point links,
so we no longer respond on behalf of other clients. *)
(* We're now treating client networks as point-to-point links,
so we no longer respond on behalf of other clients. *)
(*
else match IpMap.find ip t.net.iface_of_ip with
| Some client_iface -> Some client_iface#other_mac
@ -81,84 +81,46 @@ module ARP = struct
let create ~net client_link = {net; client_link}
type arp_msg = {
op: [ `Request |`Reply |`Unknown of int ];
sha: Macaddr.t;
spa: Ipaddr.V4.t;
tha: Macaddr.t;
tpa: Ipaddr.V4.t;
}
let to_wire arp =
let open Arpv4_wire in
(* Obtain a buffer to write into *)
let buf = Cstruct.create (Wire_structs.sizeof_ethernet + sizeof_arp) in
(* Write the ARP packet *)
let dmac = Macaddr.to_bytes arp.tha in
let smac = Macaddr.to_bytes arp.sha in
let spa = Ipaddr.V4.to_int32 arp.spa in
let tpa = Ipaddr.V4.to_int32 arp.tpa in
let op =
match arp.op with
|`Request -> 1
|`Reply -> 2
|`Unknown n -> n
in
Wire_structs.set_ethernet_dst dmac 0 buf;
Wire_structs.set_ethernet_src smac 0 buf;
Wire_structs.set_ethernet_ethertype buf 0x0806; (* ARP *)
let arpbuf = Cstruct.shift buf 14 in
set_arp_htype arpbuf 1;
set_arp_ptype arpbuf 0x0800; (* IPv4 *)
set_arp_hlen arpbuf 6; (* ethernet mac size *)
set_arp_plen arpbuf 4; (* ipv4 size *)
set_arp_op arpbuf op;
set_arp_sha smac 0 arpbuf;
set_arp_spa arpbuf spa;
set_arp_tha dmac 0 arpbuf;
set_arp_tpa arpbuf tpa;
buf
let input_query t frame =
let open Arpv4_wire in
let req_ipv4 = Ipaddr.V4.of_int32 (get_arp_tpa frame) in
let input_query t arp =
let req_ipv4 = arp.Arpv4_packet.tpa in
Log.info (fun f -> f "who-has %s?" (Ipaddr.V4.to_string req_ipv4));
if req_ipv4 = t.client_link#other_ip then (
Log.info (fun f -> f "ignoring request for client's own IP");
None
) else match lookup t req_ipv4 with
| None ->
| None ->
Log.info (fun f -> f "unknown address; not responding");
None
| Some req_mac ->
| Some req_mac ->
Log.info (fun f -> f "responding to: who-has %s?" (Ipaddr.V4.to_string req_ipv4));
Some (to_wire {
op = `Reply;
(* The Target Hardware Address and IP are copied from the request *)
tha = Macaddr.of_bytes_exn (copy_arp_sha frame);
tpa = Ipaddr.V4.of_int32 (get_arp_spa frame);
sha = req_mac;
spa = req_ipv4;
})
let req_spa = arp.Arpv4_packet.spa in
let req_sha = arp.Arpv4_packet.sha in
Some { Arpv4_packet.
op = Arpv4_wire.Reply;
(* The Target Hardware Address and IP are copied from the request *)
tha = req_sha;
tpa = req_spa;
sha = req_mac;
spa = req_ipv4;
}
let input_gratuitous t frame =
let open Arpv4_wire in
let spa = Ipaddr.V4.of_int32 (get_arp_spa frame) in
let sha = Macaddr.of_bytes_exn (copy_arp_sha frame) in
let input_gratuitous t arp =
let spa = arp.Arpv4_packet.spa in
let sha = arp.Arpv4_packet.sha in
match lookup t spa with
| Some real_mac when Macaddr.compare sha real_mac = 0 ->
Log.info (fun f -> f "client suggests updating %s -> %s (as expected)"
(Ipaddr.V4.to_string spa) (Macaddr.to_string sha));
Log.info (fun f -> f "client suggests updating %s -> %s (as expected)"
(Ipaddr.V4.to_string spa) (Macaddr.to_string sha));
| Some other_mac ->
Log.warn (fun f -> f "client suggests incorrect update %s -> %s (should be %s)"
(Ipaddr.V4.to_string spa) (Macaddr.to_string sha) (Macaddr.to_string other_mac));
Log.warn (fun f -> f "client suggests incorrect update %s -> %s (should be %s)"
(Ipaddr.V4.to_string spa) (Macaddr.to_string sha) (Macaddr.to_string other_mac));
| None ->
Log.warn (fun f -> f "client suggests incorrect update %s -> %s (unexpected IP)"
(Ipaddr.V4.to_string spa) (Macaddr.to_string sha))
Log.warn (fun f -> f "client suggests incorrect update %s -> %s (unexpected IP)"
(Ipaddr.V4.to_string spa) (Macaddr.to_string sha))
let input t frame =
match Arpv4_wire.get_arp_op frame with
|1 -> input_query t frame
|2 -> input_gratuitous t frame; None
|n -> Log.warn (fun f -> f "unknown message %d - ignored" n); None
let input t arp =
let op = arp.Arpv4_packet.op in
match op with
| Arpv4_wire.Request -> input_query t arp
| Arpv4_wire.Reply -> input_gratuitous t arp; None
end

4
client_eth.mli
View File

@ -4,7 +4,7 @@
(** The ethernet networks connecting us to our client AppVMs.
Note: each AppVM is on a point-to-point link, each link being considered to be a separate Ethernet network. *)
open Utils
open Fw_utils
type t
(** A collection of clients. *)
@ -47,7 +47,7 @@ module ARP : sig
(** [create ~net client_link] is an ARP responder for [client_link].
It answers only for the client's gateway address. *)
val input : arp -> Cstruct.t -> Cstruct.t option
val input : arp -> Arpv4_packet.t -> Arpv4_packet.t option
(** Process one ethernet frame containing an ARP message.
Returns a response frame, if one is needed. *)
end

69
client_net.ml
View File

@ -2,7 +2,7 @@
See the README file for details. *)
open Lwt.Infix
open Utils
open Fw_utils
module Netback = Netchannel.Backend.Make(Netchannel.Xenstore.Make(OS.Xs))
module ClientEth = Ethif.Make(Netback)
@ -12,7 +12,13 @@ module Log = (val Logs.src_log src : Logs.LOG)
let writev eth data =
Lwt.catch
(fun () -> ClientEth.writev eth data)
(fun () ->
ClientEth.writev eth data >|= function
| Ok () -> ()
| Error e ->
Log.err (fun f -> f "error trying to send to client:@\n@[<v2> %a@]@\nError: @[%a@]"
Cstruct.hexdump_pp (Cstruct.concat data) 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:@\n@[<v2> %a@]@\nException: @[%s@]"
@ -26,36 +32,47 @@ class client_iface eth ~gateway_ip ~client_ip client_mac : client_link = object
method other_mac = client_mac
method my_ip = gateway_ip
method other_ip = client_ip
method writev ip =
method writev proto ip =
FrameQ.send queue (fun () ->
let eth_hdr = eth_header_ipv4 ~src:(ClientEth.mac eth) ~dst:client_mac in
writev eth (fixup_checksums (Cstruct.concat (eth_hdr :: ip)))
let eth_hdr = eth_header proto ~src:(ClientEth.mac eth) ~dst:client_mac in
writev eth (eth_hdr :: ip)
)
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 ~eth request =
match Client_eth.ARP.input fixed_arp request with
| None -> return ()
| Some response -> writev eth [response]
let input_arp ~fixed_arp ~iface request =
match Arpv4_packet.Unmarshal.of_cstruct request with
| Error e ->
Log.warn (fun f -> f "ignored unknown ARP message: %a" Arpv4_packet.Unmarshal.pp_error e);
Lwt.return ()
| Ok arp ->
match Client_eth.ARP.input fixed_arp arp with
| None -> return ()
| Some response ->
iface#writev Ethif_wire.ARP [Arpv4_packet.Marshal.make_cstruct response]
(** Handle an IPv4 packet from the client. *)
let input_ipv4 ~client_ip ~router frame packet =
let src = Wire_structs.Ipv4_wire.get_ipv4_src packet |> Ipaddr.V4.of_int32 in
if src = client_ip then Firewall.ipv4_from_client router frame
else (
Log.warn (fun f -> f "Incorrect source IP %a in IP packet from %a (dropping)"
Ipaddr.V4.pp_hum src Ipaddr.V4.pp_hum client_ip);
return ()
)
let input_ipv4 ~client_ip ~router packet =
match Ipv4_packet.Unmarshal.of_cstruct packet with
| Error e ->
Log.warn (fun f -> f "ignored unknown IPv4 message: %s" e);
Lwt.return ()
| Ok (ip, payload) ->
let src = ip.Ipv4_packet.src in
if src = client_ip then Firewall.ipv4_from_client router (ip, payload)
else (
Log.warn (fun f -> f "Incorrect source IP %a in IP packet from %a (dropping)"
Ipaddr.V4.pp_hum src Ipaddr.V4.pp_hum client_ip);
return ()
)
(** Connect to a new client's interface and listen for incoming frames. *)
let add_vif { Dao.ClientVif.domid; device_id } ~client_ip ~router ~cleanup_tasks =
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 >>= or_fail "Can't make Ethernet device" >>= fun eth ->
ClientEth.connect backend >>= fun eth ->
let client_mac = Netback.mac backend in
let client_eth = router.Router.client_eth in
let gateway_ip = Client_eth.client_gw client_eth in
@ -64,15 +81,15 @@ let add_vif { Dao.ClientVif.domid; device_id } ~client_ip ~router ~cleanup_tasks
Cleanup.on_cleanup cleanup_tasks (fun () -> Router.remove_client router iface);
let fixed_arp = Client_eth.ARP.create ~net:client_eth iface in
Netback.listen backend (fun frame ->
match Wire_structs.parse_ethernet_frame frame with
| None -> Log.warn (fun f -> f "Invalid Ethernet frame"); return ()
| Some (typ, _destination, payload) ->
match typ with
| Some Wire_structs.ARP -> input_arp ~fixed_arp ~eth payload
| Some Wire_structs.IPv4 -> input_ipv4 ~client_ip ~router frame payload
| Some Wire_structs.IPv6 -> return ()
| None -> Logs.warn (fun f -> f "Unknown Ethernet type"); Lwt.return_unit
match Ethif_packet.Unmarshal.of_cstruct frame with
| Error err -> Log.warn (fun f -> f "Invalid Ethernet frame: %s" err); return ()
| Ok (eth, payload) ->
match eth.Ethif_packet.ethertype with
| Ethif_wire.ARP -> input_arp ~fixed_arp ~iface payload
| Ethif_wire.IPv4 -> input_ipv4 ~client_ip ~router payload
| Ethif_wire.IPv6 -> return ()
)
>|= or_raise "Listen on client interface" Netback.pp_error
(** A new client VM has been found in XenStore. Find its interface and connect to it. *)
let add_client ~router vif client_ip =

15
config.ml
View File

@ -7,10 +7,17 @@ open Mirage
let main =
foreign
~libraries:["mirage-net-xen"; "tcpip.stack-direct"; "tcpip.xen"; "mirage-qubes"; "mirage-nat"; "mirage-logs"]
~packages:["vchan"; "cstruct"; "tcpip"; "mirage-net-xen"; "mirage-qubes"; "mirage-nat"; "mirage-logs"]
"Unikernel.Main" (clock @-> job)
~packages:[
package "vchan";
package "cstruct";
package "tcpip" ~sublibs:["stack-direct"; "xen"];
package "mirage-net-xen";
package "mirage-qubes";
package "mirage-nat" ~sublibs:["hashtable"];
package "mirage-logs";
]
"Unikernel.Main" (mclock @-> job)
let () =
register "qubes-firewall" [main $ default_clock]
register "qubes-firewall" [main $ default_monotonic_clock]
~argv:no_argv

2
dao.ml
View File

@ -2,8 +2,8 @@
See the README file for details. *)
open Lwt.Infix
open Utils
open Qubes
open Fw_utils
open Astring
let src = Logs.Src.create "dao" ~doc:"QubesDB data access"

171
firewall.ml
View File

@ -1,23 +1,19 @@
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
See the README file for details. *)
open Utils
open Fw_utils
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 ~frame iface =
(* If packet has been NAT'd then we certainly need to recalculate the checksum,
but even for direct pass-through it might have been received with an invalid
checksum due to checksum offload. For now, recalculate full checksum in all
cases. *)
let frame = fixup_checksums frame |> Cstruct.concat in
let packet = Cstruct.shift frame Wire_structs.sizeof_ethernet in
let transmit (ip, payload) iface =
let packet = Ipv4_packet.Marshal.make_cstruct ~payload ip in
Lwt.catch
(fun () -> iface#writev [packet])
(fun () -> iface#writev Ethif_wire.IPv4 [packet; payload])
(fun ex ->
Log.warn (fun f -> f "Failed to write packet to %a: %s"
Ipaddr.V4.pp_hum iface#other_ip
@ -25,35 +21,44 @@ let transmit ~frame iface =
Lwt.return ()
)
let forward_ipv4 t frame =
let packet = Cstruct.shift frame Wire_structs.sizeof_ethernet in
match Router.target t packet with
| Some iface -> transmit ~frame iface
let forward_ipv4 t (ip, packet) =
match Router.target t ip with
| Some iface -> transmit (ip, packet) iface
| None -> return ()
(* Packet classification *)
let ports transport =
let sport, dport = Nat_rewrite.ports_of_transport transport in
{ sport; dport }
let classify_tcp trans =
match Tcp.Tcp_packet.Unmarshal.of_cstruct trans with
| Error e ->
Log.info (fun f -> f "Failed to parse TCP packet: %s" e);
`Unknown
| Ok (tcp, _payload) ->
let sport = tcp.Tcp.Tcp_packet.src_port in
let dport = tcp.Tcp.Tcp_packet.dst_port in
`TCP {sport; dport}
let classify t frame =
match Nat_rewrite.layers frame with
| None ->
Log.warn (fun f -> f "Failed to parse frame");
None
| Some (_eth, ip, transport) ->
let src, dst = Nat_rewrite.addresses_of_ip ip in
let classify_udp trans =
match Udp_packet.Unmarshal.of_cstruct trans with
| Error e ->
Log.info (fun f -> f "Failed to parse UDP packet: %s" e);
`Unknown
| Ok (udp, _payload) ->
let sport = udp.Udp_packet.src_port in
let dport = udp.Udp_packet.dst_port in
`UDP {sport; dport}
let classify t (ip, transport) =
let proto =
match Nat_rewrite.proto_of_ip ip with
| 1 -> `ICMP
| 6 -> `TCP (ports transport)
| 17 -> `UDP (ports transport)
| _ -> `Unknown in
match ip.Ipv4_packet.proto |> Ipv4_packet.Unmarshal.int_to_protocol with
| Some `ICMP -> `ICMP
| Some `TCP -> classify_tcp transport
| Some `UDP -> classify_udp transport
| None -> `Unknown in
Some {
frame;
src = Router.classify t src;
dst = Router.classify t dst;
packet = (ip, transport);
src = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.src);
dst = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.dst);
proto;
}
@ -74,7 +79,7 @@ let pp_proto fmt = function
| `ICMP -> Format.pp_print_string fmt "ICMP"
| `Unknown -> Format.pp_print_string fmt "UnknownProtocol"
let pp_packet fmt {src; dst; proto; frame = _} =
let pp_packet fmt {src; dst; proto; packet = _} =
Format.fprintf fmt "[src=%a dst=%a proto=%a]"
pp_host src
pp_host dst
@ -82,84 +87,40 @@ let pp_packet fmt {src; dst; proto; frame = _} =
(* NAT *)
let translate t frame =
Nat_rewrite.translate t.Router.nat frame
let random_user_port () =
1024 + Random.int (0xffff - 1024)
let rec add_nat_rule_and_transmit ?(retries=100) t frame fn logf =
let xl_port = random_user_port () in
match fn xl_port with
| exception Out_of_memory ->
(* 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...");
Router.reset t;
add_nat_rule_and_transmit ~retries:(retries - 1) t frame fn logf
| Nat_rewrite.Overlap when retries < 0 -> return ()
| Nat_rewrite.Overlap ->
if retries = 0 then (
Log.warn (fun f -> f "Failed to find a free port; resetting NAT table");
Router.reset t;
);
add_nat_rule_and_transmit ~retries:(retries - 1) t frame fn logf (* Try a different port *)
| Nat_rewrite.Unparseable ->
Log.warn (fun f -> f "Failed to add NAT rule: Unparseable");
return ()
| Nat_rewrite.Ok _ ->
Log.debug (logf xl_port);
match translate t frame with
| Some frame -> forward_ipv4 t frame
| None ->
Log.warn (fun f -> f "No NAT entry, even after adding one!");
return ()
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 ~frame =
let add_nat_and_forward_ipv4 t packet =
let xl_host = Ipaddr.V4 t.Router.uplink#my_ip in
add_nat_rule_and_transmit t frame
(* Note: DO NOT partially apply; [t.nat] may change between calls *)
(fun xl_port -> Nat_rewrite.make_nat_entry t.Router.nat frame xl_host xl_port)
(fun xl_port f ->
match Nat_rewrite.layers frame with
| None -> assert false
| Some (_eth, ip, transport) ->
let src, dst = Nat_rewrite.addresses_of_ip ip in
let sport, dport = Nat_rewrite.ports_of_transport transport in
f "added NAT entry: %s:%d -> firewall:%d -> %d:%s" (Ipaddr.to_string src) sport xl_port dport (Ipaddr.to_string dst)
)
My_nat.add_nat_rule_and_translate t.Router.nat ~xl_host `Rewrite packet >>= function
| Ok packet -> forward_ipv4 t packet
| Error e ->
Log.warn (fun f -> f "Failed to add NAT rewrite rule: %s" e);
Lwt.return ()
(* Add a NAT rule to redirect this conversation to [host:port] instead of us. *)
let nat_to t ~frame ~host ~port =
let nat_to t ~host ~port packet =
let target = Router.resolve t host in
let xl_host = Ipaddr.V4 t.Router.uplink#my_ip in
add_nat_rule_and_transmit t frame
(fun xl_port ->
Nat_rewrite.make_redirect_entry t.Router.nat frame (xl_host, xl_port) (target, port)
)
(fun xl_port f ->
match Nat_rewrite.layers frame with
| None -> assert false
| Some (_eth, ip, transport) ->
let src, _dst = Nat_rewrite.addresses_of_ip ip in
let sport, dport = Nat_rewrite.ports_of_transport transport in
f "added NAT redirect %s:%d -> %d:firewall:%d -> %d:%a"
(Ipaddr.to_string src) sport dport xl_port port pp_host host
)
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" e);
Lwt.return ()
(* Handle incoming packets *)
let apply_rules t rules info =
let frame = info.frame in
let packet = info.packet in
match rules info, info.dst with
| `Accept, `Client client_link -> transmit ~frame client_link
| `Accept, (`External _ | `NetVM) -> transmit ~frame t.Router.uplink
| `Accept, `Client client_link -> transmit packet client_link
| `Accept, (`External _ | `NetVM) -> transmit packet t.Router.uplink
| `Accept, (`Firewall_uplink | `Client_gateway) ->
Log.warn (fun f -> f "Bad rule: firewall can't accept packets %a" pp_packet info);
return ()
| `NAT, _ -> add_nat_and_forward_ipv4 t ~frame
| `NAT_to (host, port), _ -> nat_to t ~frame ~host ~port
| `NAT, _ -> 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 info);
return ()
@ -168,28 +129,28 @@ let handle_low_memory t =
match Memory_pressure.status () with
| `Memory_critical -> (* TODO: should happen before copying and async *)
Log.warn (fun f -> f "Memory low - dropping packet and resetting NAT table");
Router.reset t;
My_nat.reset t.Router.nat >|= fun () ->
`Memory_critical
| `Ok -> `Ok
| `Ok -> Lwt.return `Ok
let ipv4_from_client t frame =
match handle_low_memory t with
let ipv4_from_client t (ip, payload) =
handle_low_memory t >>= function
| `Memory_critical -> return ()
| `Ok ->
(* Check for existing NAT entry for this packet *)
match translate t frame with
translate t (ip, payload) >>= function
| Some frame -> forward_ipv4 t frame (* Some existing connection or redirect *)
| None ->
(* No existing NAT entry. Check the firewall rules. *)
match classify t frame with
match classify t (ip, payload) with
| None -> return ()
| Some info -> apply_rules t Rules.from_client info
let ipv4_from_netvm t frame =
match handle_low_memory t with
let ipv4_from_netvm t (ip, payload) =
handle_low_memory t >>= function
| `Memory_critical -> return ()
| `Ok ->
match classify t frame with
match classify t (ip, payload) with
| None -> return ()
| Some info ->
match info.src with
@ -197,7 +158,7 @@ let ipv4_from_netvm t frame =
Log.warn (fun f -> f "Frame from NetVM has internal source IP address! %a" pp_packet info);
return ()
| `External _ | `NetVM ->
match translate t frame with
translate t (ip, payload) >>= function
| Some frame -> forward_ipv4 t frame
| None ->
apply_rules t Rules.from_netvm info

8
firewall.mli
View File

@ -3,9 +3,9 @@
(** Classify IP packets, apply rules and send as appropriate. *)
val ipv4_from_netvm : Router.t -> Cstruct.t -> unit Lwt.t
(** Handle a frame from the outside world (this module will validate the source IP). *)
val ipv4_from_netvm : Router.t -> Ipv4_packet.t * Cstruct.t -> unit Lwt.t
(** Handle a packet from the outside world (this module will validate the source IP). *)
val ipv4_from_client : Router.t -> Cstruct.t -> unit Lwt.t
(** Handle a frame from a client. Caller must check the source IP matches the client's
val ipv4_from_client : Router.t -> Ipv4_packet.t * Cstruct.t -> unit Lwt.t
(** Handle a packet from a client. Caller must check the source IP matches the client's
before calling this. *)

48
fw_utils.ml Normal file
View File

@ -0,0 +1,48 @@
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
See the README file for details. *)
(** General utility functions. *)
module IpMap = struct
include Map.Make(Ipaddr.V4)
let find x map =
try Some (find x map)
with Not_found -> None
end
module Int = struct
type t = int
let compare (a:t) (b:t) = compare a b
end
module IntSet = Set.Make(Int)
module IntMap = Map.Make(Int)
(** An Ethernet interface. *)
class type interface = object
method my_mac : Macaddr.t
method writev : Ethif_wire.ethertype -> Cstruct.t list -> unit Lwt.t
method my_ip : Ipaddr.V4.t
method other_ip : Ipaddr.V4.t
end
(** An Ethernet interface connected to a clientVM. *)
class type client_link = object
inherit interface
method other_mac : Macaddr.t
end
(** An Ethernet header from [src]'s MAC address to [dst]'s with an IPv4 payload. *)
let eth_header ethertype ~src ~dst =
Ethif_packet.Marshal.make_cstruct { Ethif_packet.source = src; destination = dst; ethertype }
let error fmt =
let err s = Failure s in
Printf.ksprintf err fmt
let return = Lwt.return
let fail = Lwt.fail
let or_raise msg pp = function
| Ok x -> x
| Error e -> failwith (Fmt.strf "%s: %a" msg pp e)

139
my_nat.ml Normal file
View File

@ -0,0 +1,139 @@
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
See the README file for details. *)
open Lwt.Infix
let src = Logs.Src.create "my-nat" ~doc:"NAT shim"
module Log = (val Logs.src_log src : Logs.LOG)
type action = [
| `Rewrite
| `Redirect of Ipaddr.t * int
]
type packet = Ipv4_packet.t * Cstruct.t
(* To avoid needing to allocate a new NAT table when we've run out of
memory, pre-allocate the new one ahead of time. *)
type 'a with_standby = {
mutable current :'a;
mutable next : 'a;
}
type t = Nat : (module Mirage_nat.S with type t = 't and type config = 'c) * 'c * 't with_standby -> t
let create (type c t) (nat:(module Mirage_nat.S with type config = c and type t = t)) (c:c) =
let (module Nat : Mirage_nat.S with type config = c and type t = t) = nat in
Nat.empty c >>= fun current ->
Nat.empty c >>= fun next ->
let table = { current; next } in
Lwt.return (Nat (nat, c, table))
(* Ideally, mirage-nat wouldn't ask us for an ethernet header, since it only
cares about the IP layer anyway. *)
let fake_ipv4_eth =
let dontcare = Macaddr.broadcast in
Fw_utils.eth_header Ethif_wire.IPv4 ~src:dontcare ~dst:dontcare
let translate (Nat ((module Nat), _, table)) (ip, payload) =
(* XXX: change Nat.translate API *)
let packet = Ipv4_packet.Marshal.make_cstruct ~payload ip in
let frame = Cstruct.concat [
fake_ipv4_eth;
packet;
payload;
] in
Nat.translate table.current frame >|= function
| Mirage_nat.Untranslated -> None
| Mirage_nat.Translated _ -> (* XXX: translate mutates frame *)
let packet = Cstruct.shift frame Ethif_wire.sizeof_ethernet in
match Ipv4_packet.Unmarshal.of_cstruct packet with
| Error e -> Log.err (fun f -> f "Translation failed: %s" e); None
| Ok packet -> Some packet
let random_user_port () =
1024 + Random.int (0xffff - 1024)
let reset (Nat ((module Nat), c, table)) =
table.current <- table.next;
(* (at this point, the big old NAT table can be GC'd, so allocating
a new one should be OK) *)
Nat.empty c >|= fun next ->
table.next <- next
let add_nat_rule_and_translate ((Nat ((module Nat), c, table)) as t) ~xl_host action packet =
let frame =
let (ip, payload) = packet in
Cstruct.concat [
fake_ipv4_eth;
Ipv4_packet.Marshal.make_cstruct ~payload ip;
payload;
] in
let apply_action xl_port =
Lwt.try_bind (fun () ->
match action with
| `Rewrite ->
Nat.add_nat table.current frame (xl_host, xl_port)
| `Redirect target ->
Nat.add_redirect table.current frame (xl_host, xl_port) target
)
(function
| Nat.Ok -> Lwt.return (Ok ())
| Nat.Overlap -> Lwt.return (Error `Overlap)
| Nat.Unparseable -> Lwt.return (Error `Unparseable)
)
(function
| Out_of_memory -> Lwt.return (Error `Out_of_memory)
| x -> Lwt.fail x
)
in
let reset () =
table.current <- table.next;
(* (at this point, the big old NAT table can be GC'd, so allocating
a new one should be OK) *)
Nat.empty c >|= fun next ->
table.next <- next
in
let rec aux ~retries =
let xl_port = random_user_port () in
apply_action xl_port >>= function
| Error `Out_of_memory ->
(* 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...");
reset () >>= 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");
reset () >>= fun () ->
aux ~retries:(retries - 1)
) else (
aux ~retries:(retries - 1)
)
| Error `Unparseable ->
Lwt.return (Error "Unparseable by mirage-nat")
| Ok () ->
translate t packet >|= function
| None -> Error "No NAT entry, even after adding one!"
| Some packet ->
(*
Log.debug (fun f ->
match action with
| `Rewrite ->
let (ip, trans) = packet in
let src, dst = Nat_rewrite.addresses_of_ip ip in
let sport, dport = Nat_rewrite.ports_of_transport transport in
f "added NAT entry: %s:%d -> firewall:%d -> %d:%s" (Ipaddr.to_string src) sport xl_port dport (Ipaddr.to_string dst)
| `Redirect ->
let (ip, transport) = packet in
let src, _dst = Nat_rewrite.addresses_of_ip ip in
let sport, dport = Nat_rewrite.ports_of_transport transport in
f "added NAT redirect %s:%d -> %d:firewall:%d -> %d:%a"
(Ipaddr.to_string src) sport dport xl_port port pp_host host
);
*)
Ok packet
in
aux ~retries:100

19
my_nat.mli Normal file
View File

@ -0,0 +1,19 @@
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
See the README file for details. *)
(* Abstract over NAT interface (todo: remove this) *)
type t
type action = [
| `Rewrite
| `Redirect of Ipaddr.t * int
]
type packet = Ipv4_packet.t * Cstruct.t
val create : (module Mirage_nat.S with type t = 'a and type config = 'c) -> 'c -> t Lwt.t
val reset : t -> unit Lwt.t
val translate : t -> packet -> packet option Lwt.t
val add_nat_rule_and_translate : t -> xl_host:Ipaddr.t ->
action -> packet -> (packet, string) result Lwt.t

4
packet.ml
View File

@ -1,7 +1,7 @@
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
See the README file for details. *)
open Utils
open Fw_utils
type port = int
@ -14,7 +14,7 @@ type host =
[ `Client of client_link | `Client_gateway | `Firewall_uplink | `NetVM | `External of Ipaddr.t ]
type info = {
frame : Cstruct.t;
packet : Ipv4_packet.t * Cstruct.t;
src : host;
dst : host;
proto : [ `UDP of ports | `TCP of ports | `ICMP | `Unknown ];

22
router.ml
View File

@ -1,26 +1,21 @@
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
See the README file for details. *)
open Utils
let src = Logs.Src.create "router" ~doc:"Router"
module Log = (val Logs.src_log src : Logs.LOG)
open Fw_utils
(* The routing table *)
type t = {
client_eth : Client_eth.t;
mutable nat : Nat_lookup.t;
nat : My_nat.t;
uplink : interface;
}
let create ~client_eth ~uplink =
let nat = Nat_lookup.empty () in
let create ~client_eth ~uplink ~nat =
{ client_eth; nat; uplink }
let target t buf =
let open Wire_structs.Ipv4_wire in
let dst_ip = get_ipv4_dst buf |> Ipaddr.V4.of_int32 in
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
@ -37,12 +32,3 @@ let resolve t = function
| `Firewall_uplink -> 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
(* To avoid needing to allocate a new NAT table when we've run out of
memory, pre-allocate the new one ahead of time. *)
let next_nat = ref (Nat_lookup.empty ())
let reset t =
t.nat <- !next_nat;
(* (at this point, the big old NAT table can be GC'd, so allocating
a new one should be OK) *)
next_nat := Nat_lookup.empty ()

12
router.mli
View File

@ -3,11 +3,11 @@
(** Routing packets to the right network interface. *)
open Utils
open Fw_utils
type t = private {
client_eth : Client_eth.t;
mutable nat : Nat_lookup.t;
nat : My_nat.t;
uplink : interface;
}
(** A routing table. *)
@ -15,12 +15,13 @@ type t = private {
val create :
client_eth:Client_eth.t ->
uplink:interface ->
nat:My_nat.t ->
t
(** [create ~client_eth ~uplink] is a new routing table
that routes packets outside of [client_eth] via [uplink]. *)
val target : t -> Cstruct.t -> interface option
(** [target t packet] is the interface to which [packet] (an IP packet) should be routed. *)
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]. *)
@ -29,6 +30,3 @@ val remove_client : t -> client_link -> unit
val classify : t -> Ipaddr.t -> Packet.host
val resolve : t -> Packet.host -> Ipaddr.t
val reset : t -> unit
(** Clear the NAT table (to free memory). *)

29
unikernel.ml
View File

@ -7,15 +7,16 @@ open Qubes
let src = Logs.Src.create "unikernel" ~doc:"Main unikernel code"
module Log = (val Logs.src_log src : Logs.LOG)
module Main (Clock : V1.CLOCK) = struct
module Main (Clock : Mirage_clock_lwt.MCLOCK) = struct
module Uplink = Uplink.Make(Clock)
module Nat = Mirage_nat_hashtable.Make(Clock)(OS.Time)
(* Set up networking and listen for incoming packets. *)
let network qubesDB =
let network ~clock nat qubesDB =
(* Read configuration from QubesDB *)
let config = Dao.read_network_config qubesDB in
(* Initialise connection to NetVM *)
Uplink.connect config >>= fun uplink ->
Uplink.connect ~clock config >>= fun uplink ->
(* Report success *)
Dao.set_iptables_error qubesDB "" >>= fun () ->
(* Set up client-side networking *)
@ -24,7 +25,9 @@ module Main (Clock : V1.CLOCK) = struct
(* Set up routing between networks and hosts *)
let router = Router.create
~client_eth
~uplink:(Uplink.interface uplink) in
~uplink:(Uplink.interface uplink)
~nat
in
(* Handle packets from both networks *)
Lwt.choose [
Client_net.listen router;
@ -45,8 +48,8 @@ module Main (Clock : V1.CLOCK) = struct
)
(* Main unikernel entry point (called from auto-generated main.ml). *)
let start () =
let start_time = Clock.time () in
let start clock =
let start_time = Clock.elapsed_ns clock in
(* Start qrexec agent, GUI agent and QubesDB agent in parallel *)
let qrexec = RExec.connect ~domid:0 () in
let gui = GUI.connect ~domid:0 () in
@ -57,18 +60,24 @@ module Main (Clock : V1.CLOCK) = struct
gui >>= fun gui ->
watch_gui gui;
qubesDB >>= fun qubesDB ->
Log.info (fun f -> f "agents connected in %.3f s (CPU time used since boot: %.3f s)"
(Clock.time () -. start_time) (Sys.time ()));
let startup_time =
let (-) = Int64.sub in
let time_in_ns = Clock.elapsed_ns clock - start_time in
Int64.to_float time_in_ns /. 1e9
in
Log.info (fun f -> f "Qubes agents connected in %.3f s (CPU time used since boot: %.3f s)"
startup_time (Sys.time ()));
(* Watch for shutdown requests from Qubes *)
let shutdown_rq =
OS.Lifecycle.await_shutdown_request () >>= fun (`Poweroff | `Reboot) ->
return () in
(* Set up networking *)
let net_listener = network qubesDB in
My_nat.create (module Nat) clock >>= fun nat ->
let net_listener = network ~clock nat qubesDB in
(* Report memory usage to XenStore *)
Memory_pressure.init ();
(* Run until something fails or we get a shutdown request. *)
Lwt.choose [agent_listener; net_listener; shutdown_rq] >>= fun () ->
(* Give the console daemon time to show any final log messages. *)
OS.Time.sleep 1.0
OS.Time.sleep_ns (1.0 *. 1e9 |> Int64.of_float)
end

33
uplink.ml
View File

@ -2,16 +2,15 @@
See the README file for details. *)
open Lwt.Infix
open Utils
open Fw_utils
module Eth = Ethif.Make(Netif)
let src = Logs.Src.create "uplink" ~doc:"Network connection to NetVM"
module Log = (val Logs.src_log src : Logs.LOG)
module Make(Clock : V1.CLOCK) = struct
module Make(Clock : Mirage_clock_lwt.MCLOCK) = struct
module Arp = Arpv4.Make(Eth)(Clock)(OS.Time)
module IPv4 = Ipv4.Make(Eth)(Arp)
type t = {
net : Netif.t;
@ -25,11 +24,11 @@ module Make(Clock : V1.CLOCK) = struct
method my_mac = Eth.mac eth
method my_ip = my_ip
method other_ip = other_ip
method writev ip =
method writev ethertype payload =
FrameQ.send queue (fun () ->
mac >>= fun dst ->
let eth_hdr = eth_header_ipv4 ~src:(Eth.mac eth) ~dst in
Eth.writev eth (eth_hdr :: ip)
let eth_hdr = eth_header ethertype ~src:(Eth.mac eth) ~dst in
Eth.writev eth (eth_hdr :: payload) >|= or_raise "Write to uplink" Eth.pp_error
)
end
@ -38,22 +37,26 @@ module Make(Clock : V1.CLOCK) = struct
(* Handle one Ethernet frame from NetVM *)
Eth.input t.eth
~arpv4:(Arp.input t.arp)
~ipv4:(fun _ip -> Firewall.ipv4_from_netvm router frame)
~ipv4:(fun ip ->
match Ipv4_packet.Unmarshal.of_cstruct ip with
| Error e -> Log.warn (fun f -> f "Bad IPv4 packet from uplink: %s" e); Lwt.return ()
| Ok packet -> Firewall.ipv4_from_netvm router packet
)
~ipv6:(fun _ip -> return ())
frame
)
) >|= or_raise "Uplink listen loop" Netif.pp_error
let interface t = t.interface
let connect config =
let connect ~clock config =
let ip = config.Dao.uplink_our_ip in
Netif.connect "0" >>= or_fail "Can't connect uplink device" >>= fun net ->
Eth.connect net >>= or_fail "Can't make Ethernet device for tap" >>= fun eth ->
Arp.connect eth >>= or_fail "Can't add ARP" >>= fun arp ->
Netif.connect "0" >>= fun net ->
Eth.connect net >>= fun eth ->
Arp.connect eth clock >>= fun arp ->
Arp.add_ip arp ip >>= fun () ->
let netvm_mac = Arp.query arp config.Dao.uplink_netvm_ip >|= function
| `Timeout -> failwith "ARP timeout getting MAC of our NetVM"
| `Ok netvm_mac -> netvm_mac in
let netvm_mac =
Arp.query arp config.Dao.uplink_netvm_ip
>|= or_raise "Getting MAC of our NetVM" Arp.pp_error in
let interface = new netvm_iface eth netvm_mac
~my_ip:ip
~other_ip:config.Dao.uplink_netvm_ip in

6
uplink.mli
View File

@ -3,12 +3,12 @@
(** The link from us to NetVM (and, through that, to the outside world). *)
open Utils
open Fw_utils
module Make(Clock : V1.CLOCK) : sig
module Make(Clock : Mirage_clock_lwt.MCLOCK) : sig
type t
val connect : Dao.network_config -> t Lwt.t
val connect : clock:Clock.t -> Dao.network_config -> t Lwt.t
(** Connect to our NetVM (gateway). *)
val interface : t -> interface

65
utils.ml
View File

@ -1,65 +0,0 @@
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
See the README file for details. *)
(** General utility functions. *)
module IpMap = struct
include Map.Make(Ipaddr.V4)
let find x map =
try Some (find x map)
with Not_found -> None
end
module Int = struct
type t = int
let compare (a:t) (b:t) = compare a b
end
module IntSet = Set.Make(Int)
module IntMap = Map.Make(Int)
(** An Ethernet interface. *)
class type interface = object
method my_mac : Macaddr.t
method writev : Cstruct.t list -> unit Lwt.t
method my_ip : Ipaddr.V4.t
method other_ip : Ipaddr.V4.t
end
(** An Ethernet interface connected to a clientVM. *)
class type client_link = object
inherit interface
method other_mac : Macaddr.t
end
(** An Ethernet header from [src]'s MAC address to [dst]'s with an IPv4 payload. *)
let eth_header_ipv4 ~src ~dst =
let open Wire_structs in
let frame = Cstruct.create sizeof_ethernet in
frame |> set_ethernet_src (Macaddr.to_bytes src) 0;
frame |> set_ethernet_dst (Macaddr.to_bytes dst) 0;
set_ethernet_ethertype frame (ethertype_to_int IPv4);
frame
(** Recalculate checksums after modifying packets.
Note that frames often arrive with invalid checksums due to checksum offload.
For now, we always calculate valid checksums for out-bound frames. *)
let fixup_checksums frame =
match Nat_rewrite.layers frame with
| None -> raise (Invalid_argument "NAT transformation rendered packet unparseable")
| Some (ether, ip, tx) ->
let (just_headers, higherlevel_data) =
Nat_rewrite.recalculate_transport_checksum (ether, ip, tx)
in
[just_headers; higherlevel_data]
let error fmt =
let err s = Failure s in
Printf.ksprintf err fmt
let return = Lwt.return
let fail = Lwt.fail
let or_fail msg = function
| `Ok x -> return x
| `Error _ -> fail (Failure msg)