mirror of
https://github.com/mirage/qubes-mirage-firewall.git
synced 2024-10-01 01:05:39 -04:00
Update to Mirage 3 and latest mirage-nat
In particular, this: - Adds support for ICMP queries and errors. - Uses an LRU cache to avoid running out of memory and needing to reset the table. - Passes around parsed packets rather than raw ethernet frames.
This commit is contained in:
commit
55972cca30
@ -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"
|
||||
- FORK_USER=talex5 FORK_BRANCH=unikernel OCAML_VERSION=4.04 MIRAGE_BACKEND=xen PINS="mirage-nat:https://github.com/talex5/mirage-nat.git#lru"
|
||||
|
10
Dockerfile
10
Dockerfile
@ -2,19 +2,19 @@
|
||||
# It will probably still work on newer images, though, unless Debian 8
|
||||
# changes some compiler optimisations (unlikely).
|
||||
#FROM ocaml/opam:debian-8_ocaml-4.03.0
|
||||
FROM ocaml/opam@sha256:28efab6a5535a517aa719ba5ac6d2e6fddd4831afaeabf5eee6470717eda9cca
|
||||
FROM ocaml/opam@sha256:48c025a4ec2e6ff6dcb4c14f8cae0f332a090fa1ed677170912c4a48627778ab
|
||||
|
||||
# Pin last known-good version for reproducible builds.
|
||||
# Remove this line (and the base image pin above) if you want to test with the
|
||||
# latest versions.
|
||||
RUN cd opam-repository && git reset --hard 0f17b354206c97e729700ce60ddce3789ccb1d52 && opam update
|
||||
RUN cd opam-repository && git reset --hard a51e30ffcec63836014a5bd2408203ec02e4c7af && opam update
|
||||
|
||||
RUN sudo apt-get install -y m4 libxen-dev
|
||||
RUN opam install -y vchan xen-gnt mirage-xen-ocaml mirage-xen-minios io-page mirage-xen mirage
|
||||
RUN opam pin add -n -y mirage-nat 'https://github.com/talex5/mirage-nat.git#simplify-checksum'
|
||||
RUN opam pin add -n -y mirage-nat 'https://github.com/talex5/mirage-nat.git#lru'
|
||||
RUN mkdir /home/opam/qubes-mirage-firewall
|
||||
ADD config.ml /home/opam/qubes-mirage-firewall/config.ml
|
||||
WORKDIR /home/opam/qubes-mirage-firewall
|
||||
RUN opam config exec -- mirage configure --xen
|
||||
CMD opam config exec -- mirage configure --xen --no-opam && \
|
||||
RUN opam config exec -- mirage configure -t xen && make depend
|
||||
CMD opam config exec -- mirage configure -t xen && \
|
||||
opam config exec -- make tar
|
||||
|
@ -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
|
||||
|
@ -21,19 +21,18 @@ 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 -n -y tcpip.3.0.0 'https://github.com/talex5/mirage-tcpip.git#fix-length-checks'
|
||||
opam pin add -y mirage-nat 'https://github.com/talex5/mirage-nat.git#lru'
|
||||
opam install mirage
|
||||
|
||||
3. Build mirage-firewall:
|
||||
|
@ -4,5 +4,5 @@ echo Building Docker image with dependencies..
|
||||
docker build -t qubes-mirage-firewall .
|
||||
echo Building Firewall...
|
||||
docker run --rm -i -v `pwd`:/home/opam/qubes-mirage-firewall qubes-mirage-firewall
|
||||
echo "SHA2 of build: $(sha256sum mir-qubes-firewall.xen)"
|
||||
echo "SHA2 last known: f0c1a06fc4b02b494c81972dc89419af6cffa73b75839c0e8ee3798d77bf69b3"
|
||||
echo "SHA2 of build: $(sha256sum qubes_firewall.xen)"
|
||||
echo "SHA2 last known: 4b24bab81f9c1b14bafabd9725428456c4d6eaff0ef5cefd032a59b9f4021693"
|
||||
|
108
client_eth.ml
108
client_eth.ml
@ -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,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
|
||||
|
@ -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,48 @@ 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 Nat_packet.of_ipv4_packet packet with
|
||||
| Error e ->
|
||||
Log.warn (fun f -> f "Ignored unknown IPv4 message: %a" Nat_packet.pp_error e);
|
||||
Lwt.return ()
|
||||
| Ok packet ->
|
||||
let `IPv4 (ip, _) = packet in
|
||||
let src = ip.Ipv4_packet.src in
|
||||
if src = client_ip then Firewall.ipv4_from_client router packet
|
||||
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 +82,20 @@ 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
|
||||
| exception ex ->
|
||||
Log.err (fun f -> f "Error unmarshalling ethernet frame from client: %s@.%a" (Printexc.to_string ex)
|
||||
Cstruct.hexdump_pp frame
|
||||
);
|
||||
Lwt.return_unit
|
||||
| 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 =
|
||||
|
27
config.ml
27
config.ml
@ -1,16 +1,33 @@
|
||||
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
|
||||
(* Copyright (C) 2017, Thomas Leonard <thomas.leonard@unikernel.com>
|
||||
See the README file for details. *)
|
||||
|
||||
(** Configuration for the "mirage" tool. *)
|
||||
|
||||
open Mirage
|
||||
|
||||
let table_size =
|
||||
let open Functoria_key in
|
||||
let info = Arg.info
|
||||
~doc:"The number of NAT entries to allocate."
|
||||
~docv:"ENTRIES" ["nat-table-size"]
|
||||
in
|
||||
let key = Arg.opt ~stage:`Both Arg.int 5_000 info in
|
||||
create "nat_table_size" key
|
||||
|
||||
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)
|
||||
~keys:[Functoria_key.abstract table_size]
|
||||
~packages:[
|
||||
package "vchan";
|
||||
package "cstruct";
|
||||
package "tcpip" ~sublibs:["stack-direct"; "xen"] ~min:"3.1.0";
|
||||
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
2
dao.ml
@ -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"
|
||||
|
179
firewall.ml
179
firewall.ml
@ -1,59 +1,56 @@
|
||||
(* 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_ipv4 packet iface =
|
||||
Lwt.catch
|
||||
(fun () -> iface#writev [packet])
|
||||
(fun () ->
|
||||
let transport = Nat_packet.to_cstruct packet in
|
||||
Lwt.catch
|
||||
(fun () -> iface#writev Ethif_wire.IPv4 transport)
|
||||
(fun ex ->
|
||||
Log.warn (fun f -> f "Failed to write packet to %a: %s"
|
||||
Ipaddr.V4.pp_hum iface#other_ip
|
||||
(Printexc.to_string ex));
|
||||
Lwt.return ()
|
||||
)
|
||||
)
|
||||
(fun ex ->
|
||||
Log.warn (fun f -> f "Failed to write packet to %a: %s"
|
||||
Ipaddr.V4.pp_hum iface#other_ip
|
||||
(Printexc.to_string ex));
|
||||
Log.err (fun f -> f "Exception in transmit_ipv4: %s for:@.%a"
|
||||
(Printexc.to_string ex)
|
||||
Nat_packet.pp packet
|
||||
);
|
||||
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 packet =
|
||||
let `IPv4 (ip, _) = packet in
|
||||
match Router.target t ip with
|
||||
| Some iface -> transmit_ipv4 packet iface
|
||||
| None -> return ()
|
||||
|
||||
(* Packet classification *)
|
||||
|
||||
let ports transport =
|
||||
let sport, dport = Nat_rewrite.ports_of_transport transport in
|
||||
{ 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 t packet =
|
||||
let `IPv4 (ip, transport) = packet in
|
||||
let proto =
|
||||
match Nat_rewrite.proto_of_ip ip with
|
||||
| 1 -> `ICMP
|
||||
| 6 -> `TCP (ports transport)
|
||||
| 17 -> `UDP (ports transport)
|
||||
| _ -> `Unknown in
|
||||
match transport with
|
||||
| `TCP ({Tcp.Tcp_packet.src_port; dst_port; _}, _) -> `TCP {sport = src_port; dport = dst_port}
|
||||
| `UDP ({Udp_packet.src_port; dst_port; _}, _) -> `UDP {sport = src_port; dport = dst_port}
|
||||
| `ICMP _ -> `ICMP
|
||||
in
|
||||
Some {
|
||||
frame;
|
||||
src = Router.classify t src;
|
||||
dst = Router.classify t dst;
|
||||
packet;
|
||||
src = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.src);
|
||||
dst = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.dst);
|
||||
proto;
|
||||
}
|
||||
|
||||
@ -74,7 +71,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 +79,42 @@ 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 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)
|
||||
)
|
||||
let add_nat_and_forward_ipv4 t packet =
|
||||
let xl_host = t.Router.uplink#my_ip in
|
||||
My_nat.add_nat_rule_and_translate t.Router.nat ~xl_host `NAT packet >>= function
|
||||
| Ok packet -> forward_ipv4 t packet
|
||||
| Error e ->
|
||||
Log.warn (fun f -> f "Failed to add NAT rewrite rule: %s" 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 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
|
||||
)
|
||||
let nat_to t ~host ~port packet =
|
||||
match Router.resolve t host with
|
||||
| Ipaddr.V6 _ -> Log.warn (fun f -> f "Cannot NAT with IPv6"); Lwt.return ()
|
||||
| Ipaddr.V4 target ->
|
||||
let xl_host = t.Router.uplink#my_ip in
|
||||
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_ipv4 packet client_link
|
||||
| `Accept, (`External _ | `NetVM) -> transmit_ipv4 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 +123,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 packet =
|
||||
handle_low_memory t >>= function
|
||||
| `Memory_critical -> return ()
|
||||
| `Ok ->
|
||||
(* Check for existing NAT entry for this packet *)
|
||||
match translate t frame with
|
||||
translate t packet >>= 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 packet 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 packet =
|
||||
handle_low_memory t >>= function
|
||||
| `Memory_critical -> return ()
|
||||
| `Ok ->
|
||||
match classify t frame with
|
||||
match classify t packet with
|
||||
| None -> return ()
|
||||
| Some info ->
|
||||
match info.src with
|
||||
@ -197,7 +152,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 packet >>= function
|
||||
| Some frame -> forward_ipv4 t frame
|
||||
| None ->
|
||||
apply_rules t Rules.from_netvm info
|
||||
|
@ -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 -> Nat_packet.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 -> 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. *)
|
||||
|
48
fw_utils.ml
Normal file
48
fw_utils.ml
Normal 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)
|
81
my_nat.ml
Normal file
81
my_nat.ml
Normal file
@ -0,0 +1,81 @@
|
||||
(* 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 = [
|
||||
| `NAT
|
||||
| `Redirect of Mirage_nat.endpoint
|
||||
]
|
||||
|
||||
module Nat = Mirage_nat_hashtable
|
||||
|
||||
type t = {
|
||||
table : Nat.t;
|
||||
get_time : unit -> Mirage_nat.time;
|
||||
}
|
||||
|
||||
let create ~get_time ~max_entries =
|
||||
let tcp_size = 7 * max_entries / 8 in
|
||||
let udp_size = max_entries - tcp_size in
|
||||
Nat.empty ~tcp_size ~udp_size ~icmp_size:100 >|= fun table ->
|
||||
{ get_time; table }
|
||||
|
||||
let translate t packet =
|
||||
Nat.translate t.table packet >|= function
|
||||
| Error (`Untranslated | `TTL_exceeded as e) ->
|
||||
Log.debug (fun f -> f "Failed to NAT %a: %a"
|
||||
Nat_packet.pp packet
|
||||
Mirage_nat.pp_error e
|
||||
);
|
||||
None
|
||||
| Ok packet -> Some packet
|
||||
|
||||
let random_user_port () =
|
||||
1024 + Random.int (0xffff - 1024)
|
||||
|
||||
let reset t =
|
||||
Nat.reset t.table
|
||||
|
||||
let add_nat_rule_and_translate t ~xl_host action packet =
|
||||
let now = t.get_time () in
|
||||
let apply_action xl_port =
|
||||
Lwt.catch (fun () ->
|
||||
Nat.add t.table ~now packet (xl_host, xl_port) action
|
||||
)
|
||||
(function
|
||||
| Out_of_memory -> Lwt.return (Error `Out_of_memory)
|
||||
| x -> Lwt.fail x
|
||||
)
|
||||
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...");
|
||||
Nat.reset t.table >>= fun () ->
|
||||
aux ~retries:(retries - 1)
|
||||
| Error `Overlap when retries < 0 -> Lwt.return (Error "Too many retries")
|
||||
| Error `Overlap ->
|
||||
if retries = 0 then (
|
||||
Log.warn (fun f -> f "Failed to find a free port; resetting NAT table");
|
||||
Nat.reset t.table >>= fun () ->
|
||||
aux ~retries:(retries - 1)
|
||||
) else (
|
||||
aux ~retries:(retries - 1)
|
||||
)
|
||||
| Error `Cannot_NAT ->
|
||||
Lwt.return (Error "Cannot NAT this packet")
|
||||
| Ok () ->
|
||||
Log.debug (fun f -> f "Updated NAT table: %a" Nat.pp_summary t.table);
|
||||
translate t packet >|= function
|
||||
| None -> Error "No NAT entry, even after adding one!"
|
||||
| Some packet ->
|
||||
Ok packet
|
||||
in
|
||||
aux ~retries:100
|
17
my_nat.mli
Normal file
17
my_nat.mli
Normal file
@ -0,0 +1,17 @@
|
||||
(* 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 = [
|
||||
| `NAT
|
||||
| `Redirect of Mirage_nat.endpoint
|
||||
]
|
||||
|
||||
val create : get_time:(unit -> Mirage_nat.time) -> max_entries:int -> t Lwt.t
|
||||
val reset : t -> unit Lwt.t
|
||||
val translate : t -> Nat_packet.t -> Nat_packet.t option Lwt.t
|
||||
val add_nat_rule_and_translate : t -> xl_host:Ipaddr.V4.t ->
|
||||
action -> Nat_packet.t -> (Nat_packet.t, string) result Lwt.t
|
@ -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 : Nat_packet.t;
|
||||
src : host;
|
||||
dst : host;
|
||||
proto : [ `UDP of ports | `TCP of ports | `ICMP | `Unknown ];
|
||||
|
22
router.ml
22
router.ml
@ -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
12
router.mli
@ -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). *)
|
||||
|
30
unikernel.ml
30
unikernel.ml
@ -7,15 +7,15 @@ open Qubes
|
||||
let src = Logs.Src.create "unikernel" ~doc:"Main unikernel code"
|
||||
module Log = (val Logs.src_log src : Logs.LOG)
|
||||
|
||||
module Main (Clock : V1.CLOCK) = struct
|
||||
module Main (Clock : Mirage_clock_lwt.MCLOCK) = struct
|
||||
module Uplink = Uplink.Make(Clock)
|
||||
|
||||
(* 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 +24,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 +47,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 +59,26 @@ 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
|
||||
let get_time () = Clock.elapsed_ns clock in
|
||||
let max_entries = Key_gen.nat_table_size () in
|
||||
My_nat.create ~get_time ~max_entries >>= 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
|
||||
|
51
uplink.ml
51
uplink.ml
@ -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,35 +24,47 @@ 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
|
||||
|
||||
let listen t router =
|
||||
Netif.listen t.net (fun frame ->
|
||||
(* Handle one Ethernet frame from NetVM *)
|
||||
Eth.input t.eth
|
||||
~arpv4:(Arp.input t.arp)
|
||||
~ipv4:(fun _ip -> Firewall.ipv4_from_netvm router frame)
|
||||
~ipv6:(fun _ip -> return ())
|
||||
frame
|
||||
)
|
||||
(* Handle one Ethernet frame from NetVM *)
|
||||
Eth.input t.eth
|
||||
~arpv4:(Arp.input t.arp)
|
||||
~ipv4:(fun ip ->
|
||||
match Nat_packet.of_ipv4_packet ip with
|
||||
| exception ex ->
|
||||
Log.err (fun f -> f "Error unmarshalling ethernet frame from uplink: %s@.%a" (Printexc.to_string ex)
|
||||
Cstruct.hexdump_pp frame
|
||||
);
|
||||
Lwt.return_unit
|
||||
| Error e ->
|
||||
Log.warn (fun f -> f "Ignored unknown IPv4 message from uplink: %a" Nat_packet.pp_error 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
|
||||
|
@ -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
65
utils.ml
@ -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)
|
Loading…
Reference in New Issue
Block a user