Update to new mirage-nat API

.travis.yml

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

Dockerfile

@@ -2,19 +2,20 @@
 # 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:72ebf516fca7a9464db2136f2dcf2a58d09547669b60f3643a8329768febaed6
 
 # 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 8f4d15eae94dfe6f70a66a7572a21a0c60d9f4f4 && 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 tcpip 'https://github.com/talex5/mirage-tcpip.git#fix-length-checks'
+RUN opam pin add -n -y mirage-nat 'https://github.com/talex5/mirage-nat.git#cleanup'
 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

README.md

@@ -31,7 +31,8 @@ This took about 10 minutes on my laptop (it will be much quicker if you run it a
 
 2. Install mirage, pinning a few unreleased features we need:
 
-        opam pin add -y mirage-nat 'https://github.com/talex5/mirage-nat.git#mirage3'
+        opam pin add -n -y tcpip 'https://github.com/talex5/mirage-tcpip.git#fix-length-checks'
+        opam pin add -y mirage-nat 'https://github.com/talex5/mirage-nat.git#cleanup'
         opam install mirage
 
 3. Build mirage-firewall:

build-with-docker.sh

@@ -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: 45b82182341237ca9e754636f771ef3f4c93824212d1a76520a8a79bbee18668"

client_net.ml

@@ -45,7 +45,7 @@ let clients : Cleanup.t Dao.VifMap.t ref = ref Dao.VifMap.empty
 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);
+    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
@@ -55,13 +55,14 @@ let input_arp ~fixed_arp ~iface request =
 
 (** Handle an IPv4 packet from the client. *)
 let input_ipv4 ~client_ip ~router packet =
-  match Ipv4_packet.Unmarshal.of_cstruct packet with
+  match Nat_packet.of_ipv4_packet packet with
   | Error e ->
-    Log.warn (fun f -> f "ignored unknown IPv4 message: %s" e);
+    Log.warn (fun f -> f "Ignored unknown IPv4 message: %a" Nat_packet.pp_error e);
     Lwt.return ()
-  | Ok (ip, payload) ->
+  | Ok packet ->
+    let `IPv4 (ip, _) = packet in
     let src = ip.Ipv4_packet.src in
-    if src = client_ip then Firewall.ipv4_from_client router (ip, payload)
+    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);

firewall.ml

@@ -10,10 +10,10 @@ module Log = (val Logs.src_log src : Logs.LOG)
 
 (* Transmission *)
 
-let transmit (ip, payload) iface =
-  let packet = Ipv4_packet.Marshal.make_cstruct ~payload ip in
+let transmit_ipv4 packet iface =
+  let headers, payload = Nat_packet.make_headers_cstruct packet in
   Lwt.catch
-    (fun () -> iface#writev Ethif_wire.IPv4 [packet; payload])
+    (fun () -> iface#writev Ethif_wire.IPv4 [headers; payload])
     (fun ex ->
        Log.warn (fun f -> f "Failed to write packet to %a: %s"
                     Ipaddr.V4.pp_hum iface#other_ip
@@ -21,42 +21,23 @@ let transmit (ip, payload) iface =
        Lwt.return ()
     )
 
-let forward_ipv4 t (ip, packet) =
+let forward_ipv4 t packet =
+  let `IPv4 (ip, _) = packet in
   match Router.target t ip with
-  | Some iface -> transmit (ip, packet) iface
+  | Some iface -> transmit_ipv4 packet iface
   | None -> return ()
 
 (* Packet classification *)
 
-let classify_tcp trans =
-  match Tcp.Tcp_packet.Unmarshal.of_cstruct trans with
-  | Error e ->
-    Log.info (fun f -> f "Failed to parse TCP packet: %s" e);
-    `Unknown
-  | Ok (tcp, _payload) ->
-    let sport = tcp.Tcp.Tcp_packet.src_port in
-    let dport = tcp.Tcp.Tcp_packet.dst_port in
-    `TCP {sport; dport}
-
-let classify_udp trans =
-  match Udp_packet.Unmarshal.of_cstruct trans with
-  | Error e ->
-    Log.info (fun f -> f "Failed to parse UDP packet: %s" e);
-    `Unknown
-  | Ok (udp, _payload) ->
-    let sport = udp.Udp_packet.src_port in
-    let dport = udp.Udp_packet.dst_port in
-    `UDP {sport; dport}
-
-let classify t (ip, transport) =
+let classify t packet =
+  let `IPv4 (ip, transport) = packet in
   let proto =
-    match ip.Ipv4_packet.proto |> Ipv4_packet.Unmarshal.int_to_protocol with
-    | Some `ICMP -> `ICMP
-    | Some `TCP -> classify_tcp transport
-    | Some `UDP -> classify_udp transport
-    | None -> `Unknown in
+    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}
+  in
   Some {
-    packet = (ip, transport);
+    packet;
     src = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.src);
     dst = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.dst);
     proto;
@@ -114,8 +95,8 @@ let nat_to t ~host ~port packet =
 let apply_rules t rules info =
   let packet = info.packet in
   match rules info, info.dst with
-  | `Accept, `Client client_link -> transmit packet client_link
-  | `Accept, (`External _ | `NetVM) -> transmit packet 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 ()
@@ -133,24 +114,24 @@ let handle_low_memory t =
       `Memory_critical
   | `Ok -> Lwt.return `Ok
 
-let ipv4_from_client t (ip, payload) =
+let ipv4_from_client t packet =
   handle_low_memory t >>= function
   | `Memory_critical -> return ()
   | `Ok ->
   (* Check for existing NAT entry for this packet *)
-  translate t (ip, payload) >>= function
+  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 (ip, payload) with
+  match classify t packet with
   | None -> return ()
   | Some info -> apply_rules t Rules.from_client info
 
-let ipv4_from_netvm t (ip, payload) =
+let ipv4_from_netvm t packet =
   handle_low_memory t >>= function
   | `Memory_critical -> return ()
   | `Ok ->
-  match classify t (ip, payload) with
+  match classify t packet with
   | None -> return ()
   | Some info ->
   match info.src with
@@ -158,7 +139,7 @@ let ipv4_from_netvm t (ip, payload) =
     Log.warn (fun f -> f "Frame from NetVM has internal source IP address! %a" pp_packet info);
     return ()
   | `External _ | `NetVM ->
-  translate t (ip, payload) >>= function
+  translate t packet >>= function
   | Some frame -> forward_ipv4 t frame
   | None ->
   apply_rules t Rules.from_netvm info

firewall.mli

@@ -3,9 +3,9 @@
 
 (** Classify IP packets, apply rules and send as appropriate. *)
 
-val ipv4_from_netvm : Router.t -> Ipv4_packet.t * Cstruct.t -> unit Lwt.t
+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 -> Ipv4_packet.t * Cstruct.t -> unit Lwt.t
+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. *)

my_nat.ml

@@ -11,8 +11,6 @@ type action = [
   | `Redirect of Ipaddr.t * int
 ]
 
-type packet = Ipv4_packet.t * Cstruct.t
-
 (* To avoid needing to allocate a new NAT table when we've run out of
    memory, pre-allocate the new one ahead of time. *)
 type 'a with_standby = {
@@ -35,21 +33,10 @@ let fake_ipv4_eth =
   let dontcare = Macaddr.broadcast in
   Fw_utils.eth_header Ethif_wire.IPv4 ~src:dontcare ~dst:dontcare
 
-let translate (Nat ((module Nat), _, table)) (ip, payload) =
-  (* XXX: change Nat.translate API *)
-  let packet = Ipv4_packet.Marshal.make_cstruct ~payload ip in
-  let frame = Cstruct.concat [
-      fake_ipv4_eth;
-      packet;
-      payload;
-    ] in
-  Nat.translate table.current frame >|= function
+let translate (Nat ((module Nat), _, table)) packet =
+  Nat.translate table.current packet >|= function
   | Mirage_nat.Untranslated -> None
-  | Mirage_nat.Translated _ ->  (* XXX: translate mutates frame *)
-    let packet = Cstruct.shift frame Ethif_wire.sizeof_ethernet in
-    match Ipv4_packet.Unmarshal.of_cstruct packet with
-    | Error e -> Log.err (fun f -> f "Translation failed: %s" e); None
-    | Ok packet -> Some packet
+  | Mirage_nat.Translated packet -> Some packet
 
 let random_user_port () =
   1024 + Random.int (0xffff - 1024)
@@ -62,20 +49,13 @@ let reset (Nat ((module Nat), c, table)) =
   table.next <- next
 
 let add_nat_rule_and_translate ((Nat ((module Nat), c, table)) as t) ~xl_host action packet =
-  let frame =
-    let (ip, payload) = packet in
-    Cstruct.concat [
-      fake_ipv4_eth;
-      Ipv4_packet.Marshal.make_cstruct ~payload ip;
-      payload;
-    ] in
   let apply_action xl_port =
     Lwt.try_bind (fun () ->
       match action with
       | `Rewrite ->
-        Nat.add_nat table.current frame (xl_host, xl_port)
+        Nat.add_nat table.current packet (xl_host, xl_port)
       | `Redirect target ->
-        Nat.add_redirect table.current frame (xl_host, xl_port) target
+        Nat.add_redirect table.current packet (xl_host, xl_port) target
       )
       (function
         | Nat.Ok -> Lwt.return (Ok ())

my_nat.mli

@@ -10,10 +10,8 @@ type action = [
   | `Redirect of Ipaddr.t * int
 ]
 
-type packet = Ipv4_packet.t * Cstruct.t
-
 val create : (module Mirage_nat.S with type t = 'a and type config = 'c) -> 'c -> t Lwt.t
 val reset : t -> unit Lwt.t
-val translate : t -> packet -> packet option Lwt.t
+val translate : t -> Nat_packet.t -> Nat_packet.t option Lwt.t
 val add_nat_rule_and_translate : t -> xl_host:Ipaddr.t ->
-  action -> packet -> (packet, string) result Lwt.t
+  action -> Nat_packet.t -> (Nat_packet.t, string) result Lwt.t

packet.ml

@@ -14,7 +14,7 @@ type host =
   [ `Client of client_link | `Client_gateway | `Firewall_uplink | `NetVM | `External of Ipaddr.t ]
 
 type info = {
-  packet : Ipv4_packet.t * Cstruct.t;
+  packet : Nat_packet.t;
   src : host;
   dst : host;
   proto : [ `UDP of ports | `TCP of ports | `ICMP | `Unknown ];

uplink.ml

@@ -34,17 +34,20 @@ module Make(Clock : Mirage_clock_lwt.MCLOCK) = struct
 
   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 ->
-            match Ipv4_packet.Unmarshal.of_cstruct ip with
-            | Error e -> Log.warn (fun f -> f "Bad IPv4 packet from uplink: %s" e); Lwt.return ()
-            | Ok packet -> Firewall.ipv4_from_netvm router packet
-          )
-        ~ipv6:(fun _ip -> return ())
-        frame
-    ) >|= or_raise "Uplink listen loop" Netif.pp_error
+        (* 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
+              | 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