Rationalised firewall rules syntax

Added explicit NAT target, allowing NAT even within client net and
making it clear that NAT is used externally.

Changed Redirect_to_netvm to NAT_to, and allow specifying any target
host.

client_eth.ml

@@ -12,10 +12,17 @@ type t = {
   client_gw : Ipaddr.V4.t;  (* The IP that clients are given as their default gateway. *)
 }
 
+type host =
+  [ `Client of client_link
+  | `Unknown_client of Ipaddr.t
+  | `Client_gateway
+  | `External of Ipaddr.t ]
+
 let create ~prefix ~client_gw =
   { iface_of_ip = IpMap.empty; client_gw; prefix }
 
 let prefix t = t.prefix
+let client_gw t = t.client_gw
 
 let add_client t iface =
   let ip = iface#other_ip in
@@ -41,6 +48,12 @@ let classify t ip =
   | None when Ipaddr.V4.Prefix.mem ip4 t.prefix -> `Unknown_client ip
   | None -> `External ip
 
+let resolve t : host -> Ipaddr.t = function
+  | `Client client_link -> Ipaddr.V4 client_link#other_ip
+  | `Client_gateway -> Ipaddr.V4 t.client_gw
+  | `Unknown_client addr
+  | `External addr -> addr
+
 module ARP = struct
   type arp = {
     net : t;

client_eth.mli

@@ -8,6 +8,12 @@ open Utils
 type t
 (** A network for client AppVMs to join. *)
 
+type host =
+  [ `Client of client_link
+  | `Unknown_client of Ipaddr.t
+  | `Client_gateway
+  | `External of Ipaddr.t ]
+
 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
@@ -17,9 +23,10 @@ val add_client : t -> client_link -> unit
 val remove_client : t -> client_link -> unit
 
 val prefix : t -> Ipaddr.V4.Prefix.t
+val client_gw : t -> Ipaddr.V4.t
 
-val classify : t -> Ipaddr.t ->
-  [ `Client of client_link | `Unknown_client of Ipaddr.t | `Client_gateway | `External of Ipaddr.t ]
+val classify : t -> Ipaddr.t -> host
+val resolve : t -> host -> Ipaddr.t
 
 val lookup : t -> Ipaddr.V4.t -> client_link option
 

client_net.ml

@@ -10,9 +10,10 @@ module ClientEth = Ethif.Make(Netback)
 let src = Logs.Src.create "net" ~doc:"Client networking"
 module Log = (val Logs.src_log src : Logs.LOG)
 
-class client_iface eth client_ip client_mac : client_link = object
+class client_iface eth ~gateway_ip ~client_ip client_mac : client_link = object
   method my_mac = ClientEth.mac eth
   method other_mac = client_mac
+  method my_ip = gateway_ip
   method other_ip = client_ip
   method writev ip =
     let eth_hdr = eth_header_ipv4 ~src:(ClientEth.mac eth) ~dst:client_mac in
@@ -44,10 +45,12 @@ let add_vif { Dao.domid; device_id; client_ip } ~router ~cleanup_tasks =
     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 client_eth = router.Router.client_eth in
+  let gateway_ip = Client_eth.client_gw client_eth in
+  let iface = new client_iface eth ~gateway_ip ~client_ip client_mac in
   Router.add_client router iface;
   Cleanup.on_cleanup cleanup_tasks (fun () -> Router.remove_client router iface);
-  let fixed_arp = Client_eth.ARP.create ~net:router.Router.client_eth iface in
+  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 "Invalid Ethernet frame" Logs.unit; return ()

firewall.ml

@@ -51,6 +51,7 @@ let pp_ports fmt {sport; dport} =
 let pp_host fmt = function
   | `Client c -> Ipaddr.V4.pp_hum fmt (c#other_ip)
   | `Unknown_client ip -> Format.fprintf fmt "unknown-client(%a)" Ipaddr.pp_hum ip
+  | `NetVM -> Format.pp_print_string fmt "net-vm"
   | `External ip -> Format.fprintf fmt "external(%a)" Ipaddr.pp_hum ip
   | `Firewall_uplink -> Format.pp_print_string fmt "firewall(uplink)"
   | `Client_gateway -> Format.pp_print_string fmt "firewall(client-gw)"
@@ -94,8 +95,9 @@ let rec add_nat_rule_and_transmit t frame fn fmt logf =
 
 (* 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
-    (Nat_rewrite.make_nat_entry t.Router.nat frame t.Router.my_uplink_ip)
+    (Nat_rewrite.make_nat_entry t.Router.nat frame xl_host)
     "added NAT entry: %s:%d -> firewall:%d -> %d:%s"
     (fun xl_port f ->
       match Nat_rewrite.layers frame with
@@ -106,12 +108,13 @@ let add_nat_and_forward_ipv4 t frame =
       f (Ipaddr.to_string src) sport xl_port dport (Ipaddr.to_string dst)
     )
 
-(* Add a NAT rule to redirect this conversation to NetVM instead of us. *)
-let redirect_to_netvm t ~frame ~port =
-  let gw = Ipaddr.V4 t.Router.default_gateway#other_ip in
+(* Add a NAT rule to redirect this conversation to [host:port] instead of us. *)
+let nat_to t ~frame ~host ~port =
+  let gw = 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 (t.Router.my_uplink_ip, xl_port) (gw, port)
+      Nat_rewrite.make_redirect_entry t.Router.nat frame (xl_host, xl_port) (gw, port)
     )
     "added NAT redirect %s:%d -> %d:firewall:%d -> %d:NetVM"
     (fun xl_port f ->
@@ -141,14 +144,15 @@ let ipv4_from_client t frame =
   | Some info ->
   match Rules.from_client info, info.dst with
   | `Accept, `Client client_link -> transmit ~frame client_link
-  | `Accept, `External _ -> add_nat_and_forward_ipv4 t frame
+  | `Accept, (`External _ | `NetVM) -> transmit ~frame t.Router.uplink
   | `Accept, `Unknown_client _ ->
       Log.warn "Dropping packet to unknown client %a" (fun f -> f pp_packet info);
       return ()
   | `Accept, (`Firewall_uplink | `Client_gateway) ->
       Log.warn "Bad rule: firewall can't accept packets %a" (fun f -> f pp_packet info);
       return ()
-  | `Redirect_to_netvm port, _ -> redirect_to_netvm t ~frame ~port
+  | `NAT, _ -> add_nat_and_forward_ipv4 t frame
+  | `NAT_to (host, port), _ -> nat_to t ~frame ~host ~port
   | `Drop reason, _ ->
       Log.info "Dropped packet (%s) %a" (fun f -> f reason pp_packet info);
       return ()
@@ -166,7 +170,7 @@ let ipv4_from_netvm t frame =
   | `Client _ | `Unknown_client _ | `Firewall_uplink | `Client_gateway ->
     Log.warn "Frame from NetVM has internal source IP address! %a" (fun f -> f pp_packet info);
     return ()
-  | `External _ ->
+  | `External _ | `NetVM ->
   match translate t frame with
   | Some frame -> forward_ipv4 t frame
   | None ->

packet.ml

@@ -11,7 +11,7 @@ type ports = {
 }
 
 type host = 
-  [ `Client of client_link | `Unknown_client of Ipaddr.t | `Client_gateway | `Firewall_uplink | `External of Ipaddr.t ]
+  [ `Client of client_link | `Unknown_client of Ipaddr.t | `Client_gateway | `Firewall_uplink | `NetVM | `External of Ipaddr.t ]
 
 type info = {
   frame : Cstruct.t;

router.ml

@@ -11,13 +11,12 @@ module Log = (val Logs.src_log src : Logs.LOG)
 type t = {
   client_eth : Client_eth.t;
   nat : Nat_lookup.t;
-  default_gateway : interface;
-  my_uplink_ip : Ipaddr.t;
+  uplink : interface;
 }
 
-let create ~client_eth ~default_gateway ~my_uplink_ip =
+let create ~client_eth ~uplink =
   let nat = Nat_lookup.empty () in
-  { client_eth; nat; default_gateway; my_uplink_ip }
+  { client_eth; nat; uplink }
 
 let target t buf =
   let open Wire_structs.Ipv4_wire in
@@ -29,12 +28,17 @@ let target t buf =
       Log.warn "Packet to unknown internal client %a - dropping"
         (fun f -> f Ipaddr.V4.pp_hum dst_ip);
       None
-  ) else Some t.default_gateway
+  ) else Some t.uplink
 
 let add_client t = Client_eth.add_client t.client_eth
 let remove_client t = Client_eth.remove_client t.client_eth
 
 let classify t ip =
-  let (===) a b = (Ipaddr.compare a b = 0) in
-  if ip === t.my_uplink_ip then `Firewall_uplink
+  if ip = Ipaddr.V4 t.uplink#my_ip then `Firewall_uplink
+  else if ip = Ipaddr.V4 t.uplink#other_ip then `NetVM
   else (Client_eth.classify t.client_eth ip :> Packet.host)
+
+let resolve t = function
+  | `Firewall_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

router.mli

@@ -8,19 +8,16 @@ open Utils
 type t = private {
   client_eth : Client_eth.t;
   nat : Nat_lookup.t;
-  default_gateway : interface;
-  my_uplink_ip : Ipaddr.t;
+  uplink : interface;
 }
 (** A routing table. *)
 
 val create :
   client_eth:Client_eth.t ->
-  default_gateway:interface ->
-  my_uplink_ip:Ipaddr.t ->
+  uplink:interface ->
   t
-(** [create ~client_eth ~default_gateway ~my_uplink_ip] is a new routing table
-    that routes packets outside of [client_eth] to [default_gateway], changing their
-    source address to [my_uplink_ip] for NAT. *)
+(** [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. *)
@@ -32,3 +29,4 @@ val add_client : t -> client_link -> unit
 val remove_client : t -> client_link -> unit
 
 val classify : t -> Ipaddr.t -> Packet.host
+val resolve : t -> Packet.host -> Ipaddr.t

rules.ml

@@ -8,11 +8,28 @@ open Packet
 (* OCaml normally warns if you don't match all fields, but that's OK here. *)
 [@@@ocaml.warning "-9"]
 
+(** {2 Actions}
+
+  The possible actions are:
+
+    - [`Accept] : Send the packet to its destination.
+
+    - [`NAT] : Rewrite the packet's source field so packet appears to
+      have come from the firewall, via an unused port.
+      Also, add NAT rules so related packets will be translated accordingly.
+
+    - [`NAT_to (host, port)] :
+      As for [`NAT], but also rewrite the packet's destination fields so it
+      will be sent to [host:port].
+
+    - [`Drop reason] drop the packet and log the reason.
+*)
+
 (** Decide what to do with a packet from a client VM.
     Note: If the packet matched an existing NAT rule then this isn't called. *)
 let from_client = function
-  | { dst = `External _ } -> `Accept
-  | { dst = `Client_gateway; proto = `UDP { dport = 53 } } -> `Redirect_to_netvm 53
+  | { dst = (`External _ | `NetVM) } -> `NAT
+  | { dst = `Client_gateway; proto = `UDP { dport = 53 } } -> `NAT_to (`NetVM, 53)
   | { dst = (`Client_gateway | `Firewall_uplink) } -> `Drop "packet addressed to firewall itself"
   | { dst = `Client _ } -> `Drop "prevent communication between client VMs"
   | { dst = `Unknown_client _ } -> `Drop "target client not running"

unikernel.ml

@@ -37,8 +37,7 @@ module Main (Clock : V1.CLOCK) = struct
     (* Set up routing between networks and hosts *)
     let router = Router.create
       ~client_eth
-      ~default_gateway:(Uplink.interface uplink)
-      ~my_uplink_ip:(Ipaddr.V4 config.Dao.uplink_our_ip) in
+      ~uplink:(Uplink.interface uplink) in
     (* Handle packets from both networks *)
     Lwt.join [
       Client_net.listen router;

uplink.ml

@@ -18,12 +18,12 @@ module Make(Clock : V1.CLOCK) = struct
     eth : Eth.t;
     arp : Arp.t;
     interface : interface;
-    my_ip : Ipaddr.t;
   }
 
-  class netvm_iface eth mac netvm_ip : interface = object
+  class netvm_iface eth mac ~my_ip ~other_ip : interface = object
     method my_mac = Eth.mac eth
-    method other_ip = netvm_ip
+    method my_ip = my_ip
+    method other_ip = other_ip
     method writev ip =
       mac >>= fun dst ->
       let eth_hdr = eth_header_ipv4 ~src:(Eth.mac eth) ~dst in
@@ -51,7 +51,8 @@ module Make(Clock : V1.CLOCK) = struct
     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 my_ip = Ipaddr.V4 ip in
-    let interface = new netvm_iface eth netvm_mac config.Dao.uplink_netvm_ip in
-    return { net; eth; arp; interface; my_ip }
+    let interface = new netvm_iface eth netvm_mac
+      ~my_ip:ip
+      ~other_ip:config.Dao.uplink_netvm_ip in
+    return { net; eth; arp; interface }
 end

utils.ml

@@ -22,6 +22,7 @@ module IntMap = Map.Make(Int)
 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