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

Update to Mirage 3 and latest mirage-nat

Browse Source 
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:
Thomas Leonard 2017-03-18 11:26:59 +00:00
commit 55972cca30
22 changed files with 403 additions and 361 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 - time
- libxen-dev - libxen-dev
env: 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
View File

@ -2,19 +2,19 @@
# It will probably still work on newer images, though, unless Debian 8 # It will probably still work on newer images, though, unless Debian 8
# changes some compiler optimisations (unlikely). # changes some compiler optimisations (unlikely).
#FROM ocaml/opam:debian-8_ocaml-4.03.0 #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. # Pin last known-good version for reproducible builds.
# Remove this line (and the base image pin above) if you want to test with the # Remove this line (and the base image pin above) if you want to test with the
# latest versions. # latest versions.
RUN cd opam-repository && git 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 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 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 RUN mkdir /home/opam/qubes-mirage-firewall
ADD config.ml /home/opam/qubes-mirage-firewall/config.ml ADD config.ml /home/opam/qubes-mirage-firewall/config.ml
WORKDIR /home/opam/qubes-mirage-firewall WORKDIR /home/opam/qubes-mirage-firewall
RUN opam config exec -- mirage configure --xen RUN opam config exec -- mirage configure -t xen && make depend
CMD opam config exec -- mirage configure --xen --no-opam && \ CMD opam config exec -- mirage configure -t xen && \
opam config exec -- make tar opam config exec -- make tar

2
Makefile.user
View File

@ -1,7 +1,7 @@
tar: build tar: build
rm -rf _build/mirage-firewall rm -rf _build/mirage-firewall
mkdir _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 touch _build/mirage-firewall/modules.img
cat /dev/null | gzip > _build/mirage-firewall/initramfs cat /dev/null | gzip > _build/mirage-firewall/initramfs
tar cjf mirage-firewall.tar.bz2 -C _build mirage-firewall tar cjf mirage-firewall.tar.bz2 -C _build mirage-firewall

7
README.md
View File

@ -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) ## Build (without Docker)
To build (tested by creating a fresh Fedora 23 AppVM in Qubes):
1. Install build tools: 1. Install build tools:
sudo yum install git gcc m4 0install patch ncurses-devel tar bzip2 unzip make which findutils xen-devel sudo yum install git gcc m4 0install patch ncurses-devel tar bzip2 unzip make which findutils xen-devel
mkdir ~/bin mkdir ~/bin
0install add opam http://tools.ocaml.org/opam.xml 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` eval `opam config env`
2. Install mirage, pinning a few unreleased features we need: 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 opam install mirage
3. Build mirage-firewall: 3. Build mirage-firewall:

4
build-with-docker.sh
View File

@ -4,5 +4,5 @@ echo Building Docker image with dependencies..
docker build -t qubes-mirage-firewall . docker build -t qubes-mirage-firewall .
echo Building Firewall... echo Building Firewall...
docker run --rm -i -v `pwd`:/home/opam/qubes-mirage-firewall qubes-mirage-firewall docker run --rm -i -v `pwd`:/home/opam/qubes-mirage-firewall qubes-mirage-firewall
echo "SHA2 of build: $(sha256sum mir-qubes-firewall.xen)" echo "SHA2 of build: $(sha256sum qubes_firewall.xen)"
echo "SHA2 last known: f0c1a06fc4b02b494c81972dc89419af6cffa73b75839c0e8ee3798d77bf69b3" echo "SHA2 last known: 4b24bab81f9c1b14bafabd9725428456c4d6eaff0ef5cefd032a59b9f4021693"

74
client_eth.ml
View File

@ -1,7 +1,7 @@
(* Copyright (C) 2016, Thomas Leonard <thomas.leonard@unikernel.com> (* Copyright (C) 2016, Thomas Leonard <thomas.leonard@unikernel.com>
See the README file for details. *) See the README file for details. *)
open Utils open Fw_utils
open Lwt.Infix open Lwt.Infix
let src = Logs.Src.create "client_eth" ~doc:"Ethernet networks for NetVM clients" let src = Logs.Src.create "client_eth" ~doc:"Ethernet networks for NetVM clients"
@ -81,47 +81,8 @@ module ARP = struct
let create ~net client_link = {net; client_link} let create ~net client_link = {net; client_link}
type arp_msg = { let input_query t arp =
op: [ `Request |`Reply |`Unknown of int ]; let req_ipv4 = arp.Arpv4_packet.tpa in
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
Log.info (fun f -> f "who-has %s?" (Ipaddr.V4.to_string req_ipv4)); Log.info (fun f -> f "who-has %s?" (Ipaddr.V4.to_string req_ipv4));
if req_ipv4 = t.client_link#other_ip then ( if req_ipv4 = t.client_link#other_ip then (
Log.info (fun f -> f "ignoring request for client's own IP"); Log.info (fun f -> f "ignoring request for client's own IP");
@ -132,19 +93,20 @@ module ARP = struct
None None
| Some req_mac -> | Some req_mac ->
Log.info (fun f -> f "responding to: who-has %s?" (Ipaddr.V4.to_string req_ipv4)); Log.info (fun f -> f "responding to: who-has %s?" (Ipaddr.V4.to_string req_ipv4));
Some (to_wire { let req_spa = arp.Arpv4_packet.spa in
op = `Reply; 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 *) (* The Target Hardware Address and IP are copied from the request *)
tha = Macaddr.of_bytes_exn (copy_arp_sha frame); tha = req_sha;
tpa = Ipaddr.V4.of_int32 (get_arp_spa frame); tpa = req_spa;
sha = req_mac; sha = req_mac;
spa = req_ipv4; spa = req_ipv4;
}) }
let input_gratuitous t frame = let input_gratuitous t arp =
let open Arpv4_wire in let spa = arp.Arpv4_packet.spa in
let spa = Ipaddr.V4.of_int32 (get_arp_spa frame) in let sha = arp.Arpv4_packet.sha in
let sha = Macaddr.of_bytes_exn (copy_arp_sha frame) in
match lookup t spa with match lookup t spa with
| Some real_mac when Macaddr.compare sha real_mac = 0 -> | Some real_mac when Macaddr.compare sha real_mac = 0 ->
Log.info (fun f -> f "client suggests updating %s -> %s (as expected)" Log.info (fun f -> f "client suggests updating %s -> %s (as expected)"
@ -156,9 +118,9 @@ module ARP = struct
Log.warn (fun f -> f "client suggests incorrect update %s -> %s (unexpected IP)" Log.warn (fun f -> f "client suggests incorrect update %s -> %s (unexpected IP)"
(Ipaddr.V4.to_string spa) (Macaddr.to_string sha)) (Ipaddr.V4.to_string spa) (Macaddr.to_string sha))
let input t frame = let input t arp =
match Arpv4_wire.get_arp_op frame with let op = arp.Arpv4_packet.op in
|1 -> input_query t frame match op with
|2 -> input_gratuitous t frame; None | Arpv4_wire.Request -> input_query t arp
|n -> Log.warn (fun f -> f "unknown message %d - ignored" n); None | Arpv4_wire.Reply -> input_gratuitous t arp; None
end end

4
client_eth.mli
View File

@ -4,7 +4,7 @@
(** The ethernet networks connecting us to our client AppVMs. (** 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. *) 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 type t
(** A collection of clients. *) (** A collection of clients. *)
@ -47,7 +47,7 @@ module ARP : sig
(** [create ~net client_link] is an ARP responder for [client_link]. (** [create ~net client_link] is an ARP responder for [client_link].
It answers only for the client's gateway address. *) 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. (** Process one ethernet frame containing an ARP message.
Returns a response frame, if one is needed. *) Returns a response frame, if one is needed. *)
end end

63
client_net.ml
View File

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

27
config.ml
View File

@ -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. *) See the README file for details. *)
(** Configuration for the "mirage" tool. *) (** Configuration for the "mirage" tool. *)
open Mirage 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 = let main =
foreign foreign
~libraries:["mirage-net-xen"; "tcpip.stack-direct"; "tcpip.xen"; "mirage-qubes"; "mirage-nat"; "mirage-logs"] ~keys:[Functoria_key.abstract table_size]
~packages:["vchan"; "cstruct"; "tcpip"; "mirage-net-xen"; "mirage-qubes"; "mirage-nat"; "mirage-logs"] ~packages:[
"Unikernel.Main" (clock @-> job) 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 () = let () =
register "qubes-firewall" [main $ default_clock] register "qubes-firewall" [main $ default_monotonic_clock]
~argv:no_argv ~argv:no_argv

2
dao.ml
View File

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

173
firewall.ml
View File

@ -1,59 +1,56 @@
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com> (* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
See the README file for details. *) See the README file for details. *)
open Utils open Fw_utils
open Packet open Packet
open Lwt.Infix
let src = Logs.Src.create "firewall" ~doc:"Packet handler" let src = Logs.Src.create "firewall" ~doc:"Packet handler"
module Log = (val Logs.src_log src : Logs.LOG) module Log = (val Logs.src_log src : Logs.LOG)
(* Transmission *) (* Transmission *)
let transmit ~frame iface = let transmit_ipv4 packet 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
Lwt.catch 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 -> (fun ex ->
Log.warn (fun f -> f "Failed to write packet to %a: %s" Log.warn (fun f -> f "Failed to write packet to %a: %s"
Ipaddr.V4.pp_hum iface#other_ip Ipaddr.V4.pp_hum iface#other_ip
(Printexc.to_string ex)); (Printexc.to_string ex));
Lwt.return () Lwt.return ()
) )
)
(fun 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 forward_ipv4 t packet =
let packet = Cstruct.shift frame Wire_structs.sizeof_ethernet in let `IPv4 (ip, _) = packet in
match Router.target t packet with match Router.target t ip with
| Some iface -> transmit ~frame iface | Some iface -> transmit_ipv4 packet iface
| None -> return () | None -> return ()
(* Packet classification *) (* Packet classification *)
let ports transport = let classify t packet =
let sport, dport = Nat_rewrite.ports_of_transport transport in let `IPv4 (ip, transport) = packet 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 proto = let proto =
match Nat_rewrite.proto_of_ip ip with match transport with
| 1 -> `ICMP | `TCP ({Tcp.Tcp_packet.src_port; dst_port; _}, _) -> `TCP {sport = src_port; dport = dst_port}
| 6 -> `TCP (ports transport) | `UDP ({Udp_packet.src_port; dst_port; _}, _) -> `UDP {sport = src_port; dport = dst_port}
| 17 -> `UDP (ports transport) | `ICMP _ -> `ICMP
| _ -> `Unknown in in
Some { Some {
frame; packet;
src = Router.classify t src; src = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.src);
dst = Router.classify t dst; dst = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.dst);
proto; proto;
} }
@ -74,7 +71,7 @@ let pp_proto fmt = function
| `ICMP -> Format.pp_print_string fmt "ICMP" | `ICMP -> Format.pp_print_string fmt "ICMP"
| `Unknown -> Format.pp_print_string fmt "UnknownProtocol" | `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]" Format.fprintf fmt "[src=%a dst=%a proto=%a]"
pp_host src pp_host src
pp_host dst pp_host dst
@ -82,84 +79,42 @@ let pp_packet fmt {src; dst; proto; frame = _} =
(* NAT *) (* NAT *)
let translate t frame = let translate t packet =
Nat_rewrite.translate t.Router.nat frame My_nat.translate t.Router.nat packet
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 ()
(* Add a NAT rule for the endpoints in this frame, via a random port on the firewall. *) (* Add a NAT rule for the endpoints in this frame, via a random port on the firewall. *)
let add_nat_and_forward_ipv4 t ~frame = let add_nat_and_forward_ipv4 t packet =
let xl_host = Ipaddr.V4 t.Router.uplink#my_ip in let xl_host = t.Router.uplink#my_ip in
add_nat_rule_and_transmit t frame My_nat.add_nat_rule_and_translate t.Router.nat ~xl_host `NAT packet >>= function
(* Note: DO NOT partially apply; [t.nat] may change between calls *) | Ok packet -> forward_ipv4 t packet
(fun xl_port -> Nat_rewrite.make_nat_entry t.Router.nat frame xl_host xl_port) | Error e ->
(fun xl_port f -> Log.warn (fun f -> f "Failed to add NAT rewrite rule: %s" e);
match Nat_rewrite.layers frame with Lwt.return ()
| 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)
)
(* Add a NAT rule to redirect this conversation to [host:port] instead of us. *) (* Add a NAT rule to redirect this conversation to [host:port] instead of us. *)
let nat_to t ~frame ~host ~port = let nat_to t ~host ~port packet =
let target = Router.resolve t host in match Router.resolve t host with
let xl_host = Ipaddr.V4 t.Router.uplink#my_ip in | Ipaddr.V6 _ -> Log.warn (fun f -> f "Cannot NAT with IPv6"); Lwt.return ()
add_nat_rule_and_transmit t frame | Ipaddr.V4 target ->
(fun xl_port -> let xl_host = t.Router.uplink#my_ip in
Nat_rewrite.make_redirect_entry t.Router.nat frame (xl_host, xl_port) (target, port) My_nat.add_nat_rule_and_translate t.Router.nat ~xl_host (`Redirect (target, port)) packet >>= function
) | Ok packet -> forward_ipv4 t packet
(fun xl_port f -> | Error e ->
match Nat_rewrite.layers frame with Log.warn (fun f -> f "Failed to add NAT redirect rule: %s" e);
| None -> assert false Lwt.return ()
| 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
)
(* Handle incoming packets *) (* Handle incoming packets *)
let apply_rules t rules info = let apply_rules t rules info =
let frame = info.frame in let packet = info.packet in
match rules info, info.dst with match rules info, info.dst with
| `Accept, `Client client_link -> transmit ~frame client_link | `Accept, `Client client_link -> transmit_ipv4 packet client_link
| `Accept, (`External _ | `NetVM) -> transmit ~frame t.Router.uplink | `Accept, (`External _ | `NetVM) -> transmit_ipv4 packet t.Router.uplink
| `Accept, (`Firewall_uplink | `Client_gateway) -> | `Accept, (`Firewall_uplink | `Client_gateway) ->
Log.warn (fun f -> f "Bad rule: firewall can't accept packets %a" pp_packet info); Log.warn (fun f -> f "Bad rule: firewall can't accept packets %a" pp_packet info);
return () return ()
| `NAT, _ -> add_nat_and_forward_ipv4 t ~frame | `NAT, _ -> add_nat_and_forward_ipv4 t packet
| `NAT_to (host, port), _ -> nat_to t ~frame ~host ~port | `NAT_to (host, port), _ -> nat_to t packet ~host ~port
| `Drop reason, _ -> | `Drop reason, _ ->
Log.info (fun f -> f "Dropped packet (%s) %a" reason pp_packet info); Log.info (fun f -> f "Dropped packet (%s) %a" reason pp_packet info);
return () return ()
@ -168,28 +123,28 @@ let handle_low_memory t =
match Memory_pressure.status () with match Memory_pressure.status () with
| `Memory_critical -> (* TODO: should happen before copying and async *) | `Memory_critical -> (* TODO: should happen before copying and async *)
Log.warn (fun f -> f "Memory low - dropping packet and resetting NAT table"); Log.warn (fun f -> f "Memory low - dropping packet and resetting NAT table");
Router.reset t; My_nat.reset t.Router.nat >|= fun () ->
`Memory_critical `Memory_critical
| `Ok -> `Ok | `Ok -> Lwt.return `Ok
let ipv4_from_client t frame = let ipv4_from_client t packet =
match handle_low_memory t with handle_low_memory t >>= function
| `Memory_critical -> return () | `Memory_critical -> return ()
| `Ok -> | `Ok ->
(* Check for existing NAT entry for this packet *) (* 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 *) | Some frame -> forward_ipv4 t frame (* Some existing connection or redirect *)
| None -> | None ->
(* No existing NAT entry. Check the firewall rules. *) (* No existing NAT entry. Check the firewall rules. *)
match classify t frame with match classify t packet with
| None -> return () | None -> return ()
| Some info -> apply_rules t Rules.from_client info | Some info -> apply_rules t Rules.from_client info
let ipv4_from_netvm t frame = let ipv4_from_netvm t packet =
match handle_low_memory t with handle_low_memory t >>= function
| `Memory_critical -> return () | `Memory_critical -> return ()
| `Ok -> | `Ok ->
match classify t frame with match classify t packet with
| None -> return () | None -> return ()
| Some info -> | Some info ->
match info.src with 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); Log.warn (fun f -> f "Frame from NetVM has internal source IP address! %a" pp_packet info);
return () return ()
| `External _ | `NetVM -> | `External _ | `NetVM ->
match translate t frame with translate t packet >>= function
| Some frame -> forward_ipv4 t frame | Some frame -> forward_ipv4 t frame
| None -> | None ->
apply_rules t Rules.from_netvm info 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. *) (** Classify IP packets, apply rules and send as appropriate. *)
val ipv4_from_netvm : Router.t -> Cstruct.t -> unit Lwt.t val ipv4_from_netvm : Router.t -> Nat_packet.t -> unit Lwt.t
(** Handle a frame from the outside world (this module will validate the source IP). *) (** Handle a packet from the outside world (this module will validate the source IP). *)
val ipv4_from_client : Router.t -> Cstruct.t -> unit Lwt.t val ipv4_from_client : Router.t -> Nat_packet.t -> unit Lwt.t
(** Handle a frame from a client. Caller must check the source IP matches the client's (** Handle a packet from a client. Caller must check the source IP matches the client's
before calling this. *) before calling this. *)

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)

81
my_nat.ml Normal file
View 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
View 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

4
packet.ml
View File

@ -1,7 +1,7 @@
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com> (* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
See the README file for details. *) See the README file for details. *)
open Utils open Fw_utils
type port = int type port = int
@ -14,7 +14,7 @@ type host =
[ `Client of client_link | `Client_gateway | `Firewall_uplink | `NetVM | `External of Ipaddr.t ] [ `Client of client_link | `Client_gateway | `Firewall_uplink | `NetVM | `External of Ipaddr.t ]
type info = { type info = {
frame : Cstruct.t; packet : Nat_packet.t;
src : host; src : host;
dst : host; dst : host;
proto : [ `UDP of ports | `TCP of ports | `ICMP | `Unknown ]; 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> (* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
See the README file for details. *) See the README file for details. *)
open Utils open Fw_utils
let src = Logs.Src.create "router" ~doc:"Router"
module Log = (val Logs.src_log src : Logs.LOG)
(* The routing table *) (* The routing table *)
type t = { type t = {
client_eth : Client_eth.t; client_eth : Client_eth.t;
mutable nat : Nat_lookup.t; nat : My_nat.t;
uplink : interface; uplink : interface;
} }
let create ~client_eth ~uplink = let create ~client_eth ~uplink ~nat =
let nat = Nat_lookup.empty () in
{ client_eth; nat; uplink } { client_eth; nat; uplink }
let target t buf = let target t buf =
let open Wire_structs.Ipv4_wire in let dst_ip = buf.Ipv4_packet.dst in
let dst_ip = get_ipv4_dst buf |> Ipaddr.V4.of_int32 in
match Client_eth.lookup t.client_eth dst_ip with match Client_eth.lookup t.client_eth dst_ip with
| Some client_link -> Some (client_link :> interface) | Some client_link -> Some (client_link :> interface)
| None -> Some t.uplink | None -> Some t.uplink
@ -37,12 +32,3 @@ let resolve t = function
| `Firewall_uplink -> Ipaddr.V4 t.uplink#my_ip | `Firewall_uplink -> Ipaddr.V4 t.uplink#my_ip
| `NetVM -> Ipaddr.V4 t.uplink#other_ip | `NetVM -> Ipaddr.V4 t.uplink#other_ip
| #Client_eth.host as host -> Client_eth.resolve t.client_eth host | #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. *) (** Routing packets to the right network interface. *)
open Utils open Fw_utils
type t = private { type t = private {
client_eth : Client_eth.t; client_eth : Client_eth.t;
mutable nat : Nat_lookup.t; nat : My_nat.t;
uplink : interface; uplink : interface;
} }
(** A routing table. *) (** A routing table. *)
@ -15,12 +15,13 @@ type t = private {
val create : val create :
client_eth:Client_eth.t -> client_eth:Client_eth.t ->
uplink:interface -> uplink:interface ->
nat:My_nat.t ->
t t
(** [create ~client_eth ~uplink] is a new routing table (** [create ~client_eth ~uplink] is a new routing table
that routes packets outside of [client_eth] via [uplink]. *) that routes packets outside of [client_eth] via [uplink]. *)
val target : t -> Cstruct.t -> interface option val target : t -> Ipv4_packet.t -> interface option
(** [target t packet] is the interface to which [packet] (an IP packet) should be routed. *) (** [target t packet] is the interface to which [packet] should be routed. *)
val add_client : t -> client_link -> unit Lwt.t val add_client : t -> client_link -> unit Lwt.t
(** [add_client t iface] adds a rule for routing packets addressed to [iface]. *) (** [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 classify : t -> Ipaddr.t -> Packet.host
val resolve : t -> Packet.host -> Ipaddr.t val resolve : t -> Packet.host -> Ipaddr.t
val reset : t -> unit
(** Clear the NAT table (to free memory). *)

30
unikernel.ml
View File

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

41
uplink.ml
View File

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