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

Moved client networking to its own module

Browse Source 
Renamed the old Client_net to Client_eth, as it just handles the
Ethernet layer.
This commit is contained in:
Thomas Leonard 2015-12-30 13:48:13 +00:00
parent f3332ed4da
commit 9dc7d01896
8 changed files with 315 additions and 289 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

128
client_eth.ml Normal file
View File

@ -0,0 +1,128 @@
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
See the README file for details. *)
open Utils
let src = Logs.Src.create "client_eth" ~doc:"Ethernet for NetVM clients"
module Log = (val Logs.src_log src : Logs.LOG)
type t = {
mutable iface_of_ip : client_link IpMap.t;
prefix : Ipaddr.V4.Prefix.t;
client_gw : Ipaddr.V4.t; (* The IP that clients are given as their default gateway. *)
}
let create ~prefix ~client_gw =
{ iface_of_ip = IpMap.empty; client_gw; prefix }
let prefix t = t.prefix
let add_client t iface =
let ip = iface#client_ip in
assert (Ipaddr.V4.Prefix.mem ip t.prefix);
(* TODO: Should probably wait for the previous client to disappear. *)
(* assert (not (IpMap.mem ip t.iface_of_ip)); *)
t.iface_of_ip <- t.iface_of_ip |> IpMap.add ip iface
let remove_client t iface =
let ip = iface#client_ip in
assert (IpMap.mem ip t.iface_of_ip);
t.iface_of_ip <- t.iface_of_ip |> IpMap.remove ip
let lookup t ip = IpMap.find ip t.iface_of_ip
module ARP = struct
type arp = {
net : t;
client_link : client_link;
}
let lookup t ip =
if ip === t.net.client_gw then Some t.client_link#my_mac
else match IpMap.find ip t.net.iface_of_ip with
| Some client_iface -> Some client_iface#client_mac
| None -> None
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
Log.info "who-has %s?" (fun f -> f (Ipaddr.V4.to_string req_ipv4));
if req_ipv4 === t.client_link#client_ip then (
Log.info "ignoring request for client's own IP" Logs.unit;
None
) else match lookup t req_ipv4 with
| None ->
Log.info "unknown address; not responding" Logs.unit;
None
| Some req_mac ->
Log.info "responding to: who-has %s?" (fun f -> f (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 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
match lookup t spa with
| Some real_mac when Macaddr.compare sha real_mac = 0 ->
Log.info "client suggests updating %s -> %s (as expected)"
(fun f -> f (Ipaddr.V4.to_string spa) (Macaddr.to_string sha));
| Some other_mac ->
Log.warn "client suggests incorrect update %s -> %s (should be %s)"
(fun f -> f (Ipaddr.V4.to_string spa) (Macaddr.to_string sha) (Macaddr.to_string other_mac));
| None ->
Log.warn "client suggests incorrect update %s -> %s (unexpected IP)"
(fun f -> f (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 "unknown message %d - ignored" (fun f -> f n); None
end

40
client_eth.mli Normal file
View File

@ -0,0 +1,40 @@
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
See the README file for details. *)
(** The ethernet network our client AppVMs are on. *)
open Utils
type t
(** A network for client AppVMs to join. *)
val create : prefix:Ipaddr.V4.Prefix.t -> client_gw:Ipaddr.V4.t -> t
(** [create ~prefix ~client_gw] is a network of client machines.
Their IP addresses all start with [prefix] and they are configured to
use [client_gw] as their default gateway. *)
val add_client : t -> client_link -> unit
val remove_client : t -> client_link -> unit
val prefix : t -> Ipaddr.V4.Prefix.t
val lookup : t -> Ipaddr.V4.t -> client_link option
module ARP : sig
(** We already know the correct mapping of IP addresses to MAC addresses, so we never
allow clients to update it. We log a warning if a client attempts to set incorrect
information. *)
type arp
(** An ARP-responder for one client. *)
val create : net:t -> client_link -> arp
(** [create ~net client_link] is an ARP responder for [client_link].
It answers on behalf of other clients in [net] (but not for the client
itself, since the client might be trying to check that its own address is
free). It also answers for the client's gateway address. *)
val input : arp -> Cstruct.t -> Cstruct.t option
(** Process one ethernet frame containing an ARP message.
Returns a response frame, if one is needed. *)
end

206
client_net.ml
View File

@ -1,128 +1,94 @@
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
See the README file for details. *)
open Lwt.Infix
open Utils
let src = Logs.Src.create "client_arp" ~doc:"ARP for NetVM clients"
module Netback = Netchannel.Backend.Make(Netchannel.Xenstore.Make(OS.Xs))
module ClientEth = Ethif.Make(Netback)
let src = Logs.Src.create "net" ~doc:"Client networking"
module Log = (val Logs.src_log src : Logs.LOG)
type t = {
mutable iface_of_ip : client_link IpMap.t;
prefix : Ipaddr.V4.Prefix.t;
client_gw : Ipaddr.V4.t; (* The IP that clients are given as their default gateway. *)
}
let create ~prefix ~client_gw =
{ iface_of_ip = IpMap.empty; client_gw; prefix }
let prefix t = t.prefix
let add_client t iface =
let ip = iface#client_ip in
assert (Ipaddr.V4.Prefix.mem ip t.prefix);
(* TODO: Should probably wait for the previous client to disappear. *)
(* assert (not (IpMap.mem ip t.iface_of_ip)); *)
t.iface_of_ip <- t.iface_of_ip |> IpMap.add ip iface
let remove_client t iface =
let ip = iface#client_ip in
assert (IpMap.mem ip t.iface_of_ip);
t.iface_of_ip <- t.iface_of_ip |> IpMap.remove ip
let lookup t ip = IpMap.find ip t.iface_of_ip
module ARP = struct
type arp = {
net : t;
client_link : client_link;
}
let lookup t ip =
if ip === t.net.client_gw then Some t.client_link#my_mac
else match IpMap.find ip t.net.iface_of_ip with
| Some client_iface -> Some client_iface#client_mac
| None -> None
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
Log.info "who-has %s?" (fun f -> f (Ipaddr.V4.to_string req_ipv4));
if req_ipv4 === t.client_link#client_ip then (
Log.info "ignoring request for client's own IP" Logs.unit;
None
) else match lookup t req_ipv4 with
| None ->
Log.info "unknown address; not responding" Logs.unit;
None
| Some req_mac ->
Log.info "responding to: who-has %s?" (fun f -> f (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 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
match lookup t spa with
| Some real_mac when Macaddr.compare sha real_mac = 0 ->
Log.info "client suggests updating %s -> %s (as expected)"
(fun f -> f (Ipaddr.V4.to_string spa) (Macaddr.to_string sha));
| Some other_mac ->
Log.warn "client suggests incorrect update %s -> %s (should be %s)"
(fun f -> f (Ipaddr.V4.to_string spa) (Macaddr.to_string sha) (Macaddr.to_string other_mac));
| None ->
Log.warn "client suggests incorrect update %s -> %s (unexpected IP)"
(fun f -> f (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 "unknown message %d - ignored" (fun f -> f n); None
class client_iface eth client_ip client_mac : client_link = object
method my_mac = ClientEth.mac eth
method client_mac = client_mac
method client_ip = client_ip
method writev ip =
let eth_hdr = eth_header_ipv4 ~src:(ClientEth.mac eth) ~dst:client_mac in
ClientEth.writev eth (fixup_checksums (Cstruct.concat (eth_hdr :: ip)))
end
let clients : Cleanup.t IntMap.t ref = ref IntMap.empty
let start_client ~router domid =
let cleanup_tasks = Cleanup.create () in
Log.info "start_client in domain %d" (fun f -> f domid);
Lwt.async (fun () ->
Lwt.catch (fun () ->
Dao.client_vifs domid >>= (function
| [] -> return None
| vif :: others ->
if others <> [] then Log.warn "Client has multiple interfaces; using first" Logs.unit;
let { Dao.domid; device_id; client_ip } = vif in
Netback.make ~domid ~device_id >|= fun backend ->
Some (backend, client_ip)
) >>= function
| None -> Log.warn "Client has no interfaces" Logs.unit; return ()
| Some (backend, client_ip) ->
Log.info "Client %d (IP: %s) ready" (fun f ->
f domid (Ipaddr.V4.to_string client_ip));
ClientEth.connect backend >>= or_fail "Can't make Ethernet device" >>= fun eth ->
let client_mac = Netback.mac backend in
let iface = new client_iface eth client_ip client_mac in
let fixed_arp = Client_eth.ARP.create ~net:(Router.client_eth router) iface in
Router.add_client router iface;
Cleanup.on_cleanup cleanup_tasks (fun () -> Router.remove_client router iface);
Netback.listen backend (
ClientEth.input
~arpv4:(fun buf ->
match Client_eth.ARP.input fixed_arp buf with
| None -> return ()
| Some frame -> ClientEth.write eth frame
)
~ipv4:(fun packet ->
let src = Wire_structs.Ipv4_wire.get_ipv4_src packet |> Ipaddr.V4.of_int32 in
if src === client_ip then Router.forward_ipv4 router packet
else (
Log.warn "Incorrect source IP %a in IP packet from %a (dropping)"
(fun f -> f Ipaddr.V4.pp_hum src Ipaddr.V4.pp_hum client_ip);
return ()
)
)
~ipv6:(fun _buf -> return ())
eth
)
)
(fun ex ->
Log.warn "Error connecting client domain %d: %s"
(fun f -> f domid (Printexc.to_string ex));
return ()
)
);
cleanup_tasks
let listen router =
let backend_vifs = "backend/vif" in
Log.info "Watching %s" (fun f -> f backend_vifs);
Dao.watch_clients (fun new_set ->
(* Check for removed clients *)
!clients |> IntMap.iter (fun key cleanup ->
if not (IntSet.mem key new_set) then (
clients := !clients |> IntMap.remove key;
Log.info "stop_client %d" (fun f -> f key);
Cleanup.cleanup cleanup
)
);
(* Check for added clients *)
new_set |> IntSet.iter (fun key ->
if not (IntMap.mem key !clients) then (
let cleanup = start_client ~router key in
clients := !clients |> IntMap.add key cleanup
)
)
)

42
client_net.mli
View File

@ -1,40 +1,10 @@
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
See the README file for details. *)
(** The ethernet network our client AppVMs are on. *)
(** Handling client VMs. *)
open Utils
type t
(** A network for client AppVMs to join. *)
val create : prefix:Ipaddr.V4.Prefix.t -> client_gw:Ipaddr.V4.t -> t
(** [create ~prefix ~client_gw] is a network of client machines.
Their IP addresses all start with [prefix] and they are configured to
use [client_gw] as their default gateway. *)
val add_client : t -> client_link -> unit
val remove_client : t -> client_link -> unit
val prefix : t -> Ipaddr.V4.Prefix.t
val lookup : t -> Ipaddr.V4.t -> client_link option
module ARP : sig
(** We already know the correct mapping of IP addresses to MAC addresses, so we never
allow clients to update it. We log a warning if a client attempts to set incorrect
information. *)
type arp
(** An ARP-responder for one client. *)
val create : net:t -> client_link -> arp
(** [create ~net client_link] is an ARP responder for [client_link].
It answers on behalf of other clients in [net] (but not for the client
itself, since the client might be trying to check that its own address is
free). It also answers for the client's gateway address. *)
val input : arp -> Cstruct.t -> Cstruct.t option
(** Process one ethernet frame containing an ARP message.
Returns a response frame, if one is needed. *)
end
val listen : Router.t -> 'a Lwt.t
(** [listen router] is a thread that watches for clients being added to and
removed from XenStore. Clients are connected to the client network and
packets are sent via [router]. We ensure the source IP address is correct
before routing a packet. *)

126
net.ml
View File

@ -14,137 +14,21 @@ module ClientEth = Ethif.Make(Netback)
let src = Logs.Src.create "net" ~doc:"Firewall networking"
module Log = (val Logs.src_log src : Logs.LOG)
(* The checksum logic doesn't depend on ARP or Eth, but we can't access
IPv4.checksum without applying the functor. *)
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]
module Make(Clock : V1.CLOCK) = struct
module Arp = Arpv4.Make(Eth)(Clock)(OS.Time)
module IPv4 = Ipv4.Make(Eth)(Arp)
module Xs = OS.Xs
let eth_header ~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
class netvm_iface eth my_ip mac nat_table : interface = object
method my_mac = Eth.mac eth
method writev ip =
mac >>= fun dst ->
let eth_hdr = eth_header ~src:(Eth.mac eth) ~dst in
let eth_hdr = eth_header_ipv4 ~src:(Eth.mac eth) ~dst in
match Nat_rules.nat my_ip nat_table Nat_rewrite.Source (Cstruct.concat (eth_hdr :: ip)) with
| None -> return ()
| Some frame -> Eth.writev eth (fixup_checksums frame)
end
class client_iface eth client_ip client_mac : client_link = object
method my_mac = ClientEth.mac eth
method client_mac = client_mac
method client_ip = client_ip
method writev ip =
let eth_hdr = eth_header ~src:(ClientEth.mac eth) ~dst:client_mac in
ClientEth.writev eth (fixup_checksums (Cstruct.concat (eth_hdr :: ip)))
end
let or_fail msg = function
| `Ok x -> return x
| `Error _ -> fail (Failure msg)
let clients : Cleanup.t IntMap.t ref = ref IntMap.empty
let forward_ipv4 router buf =
match Memory_pressure.status () with
| `Memory_critical -> (* TODO: should happen before copying and async *)
print_endline "Memory low - dropping packet";
return ()
| `Ok ->
match Router.target router buf with
| Some iface -> iface#writev [buf]
| None -> return ()
let start_client ~router domid =
let cleanup_tasks = Cleanup.create () in
Log.info "start_client in domain %d" (fun f -> f domid);
Lwt.async (fun () ->
Lwt.catch (fun () ->
Dao.client_vifs domid >>= (function
| [] -> return None
| vif :: others ->
if others <> [] then Log.warn "Client has multiple interfaces; using first" Logs.unit;
let { Dao.domid; device_id; client_ip } = vif in
Netback.make ~domid ~device_id >|= fun backend ->
Some (backend, client_ip)
) >>= function
| None -> Log.warn "Client has no interfaces" Logs.unit; return ()
| Some (backend, client_ip) ->
Log.info "Client %d (IP: %s) ready" (fun f ->
f domid (Ipaddr.V4.to_string client_ip));
ClientEth.connect backend >>= or_fail "Can't make Ethernet device" >>= fun eth ->
let client_mac = Netback.mac backend in
let iface = new client_iface eth client_ip client_mac in
let fixed_arp = Client_net.ARP.create ~net:(Router.client_net router) iface in
Router.add_client router iface;
Cleanup.on_cleanup cleanup_tasks (fun () -> Router.remove_client router iface);
Netback.listen backend (
ClientEth.input
~arpv4:(fun buf ->
match Client_net.ARP.input fixed_arp buf with
| None -> return ()
| Some frame -> ClientEth.write eth frame
)
~ipv4:(fun packet ->
let src = Wire_structs.Ipv4_wire.get_ipv4_src packet |> Ipaddr.V4.of_int32 in
if src === client_ip then forward_ipv4 router packet
else (
Log.warn "Incorrect source IP %a in IP packet from %a (dropping)"
(fun f -> f Ipaddr.V4.pp_hum src Ipaddr.V4.pp_hum client_ip);
return ()
)
)
~ipv6:(fun _buf -> return ())
eth
)
)
(fun ex ->
Log.warn "Error connecting client domain %d: %s"
(fun f -> f domid (Printexc.to_string ex));
return ()
)
);
cleanup_tasks
let watch_clients router =
let backend_vifs = "backend/vif" in
Log.info "Watching %s" (fun f -> f backend_vifs);
Dao.watch_clients (fun new_set ->
(* Check for removed clients *)
!clients |> IntMap.iter (fun key cleanup ->
if not (IntSet.mem key new_set) then (
clients := !clients |> IntMap.remove key;
Log.info "stop_client %d" (fun f -> f key);
Cleanup.cleanup cleanup
)
);
(* Check for added clients *)
new_set |> IntSet.iter (fun key ->
if not (IntMap.mem key !clients) then (
let cleanup = start_client ~router key in
clients := !clients |> IntMap.add key cleanup
)
)
)
let connect_uplink config =
let nat_table = Nat_lookup.empty () in
let ip = config.Dao.uplink_our_ip in
@ -169,7 +53,7 @@ module Make(Clock : V1.CLOCK) = struct
return ()
| Some frame ->
let frame = fixup_checksums frame |> Cstruct.concat in
forward_ipv4 router (Cstruct.shift frame Wire_structs.sizeof_ethernet) in
Router.forward_ipv4 router (Cstruct.shift frame Wire_structs.sizeof_ethernet) in
Netif.listen net0 (fun frame ->
Eth.input
~arpv4:(Arp.input arp0)
@ -185,14 +69,14 @@ module Make(Clock : V1.CLOCK) = struct
Dao.set_iptables_error qubesDB "" >>= fun () ->
Logs.info "Client (internal) network is %a"
(fun f -> f Ipaddr.V4.Prefix.pp_hum config.Dao.clients_prefix);
let client_net = Client_net.create
let client_eth = Client_eth.create
~client_gw:config.Dao.clients_our_ip
~prefix:config.Dao.clients_prefix in
let router = Router.create
~default_gateway:netvm_iface
~client_net in
~client_eth in
Lwt.join [
watch_clients router;
Client_net.listen router;
netvm_listen router
]
end

24
router.ml
View File

@ -7,20 +7,20 @@ let src = Logs.Src.create "router" ~doc:"Router"
module Log = (val Logs.src_log src : Logs.LOG)
type t = {
client_net : Client_net.t;
client_eth : Client_eth.t;
default_gateway : interface;
}
let create ~client_net ~default_gateway = { client_net; default_gateway }
let create ~client_eth ~default_gateway = { client_eth; default_gateway }
let client_net t = t.client_net
let client_eth t = t.client_eth
let target t buf =
let open Wire_structs.Ipv4_wire in
let dst_ip = get_ipv4_dst buf |> Ipaddr.V4.of_int32 in
Log.debug "Got IPv4: dst=%s" (fun f -> f (Ipaddr.V4.to_string dst_ip));
if Ipaddr.V4.Prefix.mem dst_ip (Client_net.prefix t.client_net) then (
match Client_net.lookup t.client_net dst_ip with
if Ipaddr.V4.Prefix.mem dst_ip (Client_eth.prefix t.client_eth) then (
match Client_eth.lookup t.client_eth dst_ip with
| Some client_link -> Some (client_link :> interface)
| None ->
Log.warn "Packet to unknown internal client %a - dropping"
@ -28,5 +28,15 @@ let target t buf =
None
) else Some t.default_gateway
let add_client t = Client_net.add_client t.client_net
let remove_client t = Client_net.remove_client t.client_net
let add_client t = Client_eth.add_client t.client_eth
let remove_client t = Client_eth.remove_client t.client_eth
let forward_ipv4 router buf =
match Memory_pressure.status () with
| `Memory_critical -> (* TODO: should happen before copying and async *)
print_endline "Memory low - dropping packet";
return ()
| `Ok ->
match target router buf with
| Some iface -> iface#writev [buf]
| None -> return ()

13
router.mli
View File

@ -9,19 +9,22 @@ type t
(** A routing table. *)
val create :
client_net:Client_net.t ->
client_eth:Client_eth.t ->
default_gateway:interface ->
t
(** [create ~client_net ~default_gateway] is a new routing table that routes packets outside
of [client_net] to [default_gateway]. *)
(** [create ~client_eth ~default_gateway] is a new routing table that routes packets outside
of [client_eth] to [default_gateway]. *)
val client_net : t -> Client_net.t
val client_eth : t -> Client_eth.t
val target : t -> Cstruct.t -> interface option
(** [target t packet] is the interface to which [packet] (an IP packet) should be routed. *)
val add_client : t -> client_link -> unit
(** [add_client t iface] adds a rule for routing packets addressed to [iface].
The client's IP address must be within the [client_net] passed to [create]. *)
The client's IP address must be within the [client_eth] passed to [create]. *)
val remove_client : t -> client_link -> unit
val forward_ipv4 : t -> Cstruct.t -> unit Lwt.t
(** [forward_ipv4 t packet] sends the packet to [target t packet]. *)

25
utils.ml
View File

@ -31,6 +31,27 @@ class type client_link = object
method client_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 (===) a b = (Ipaddr.V4.compare a b = 0)
let error fmt =
@ -45,3 +66,7 @@ let set_fixed_string buffer str =
let len = String.length str in
Cstruct.blit_from_string str 0 buffer 0 len;
Cstruct.memset (Cstruct.shift buffer len) 0
let or_fail msg = function
| `Ok x -> return x
| `Error _ -> fail (Failure msg)