Merge pull request #45 from yomimono/just-into-cstruct

use tcpip 3.7, ethernet, arp, mirage-nat 1.1.0

Dockerfile

@@ -2,12 +2,12 @@
 # It will probably still work on newer images, though, unless Debian
 # changes some compiler optimisations (unlikely).
 #FROM ocaml/opam2:debian-9-ocaml-4.07
-FROM ocaml/opam2@sha256:5ff7e5a1d4ab951dcc26cca7834fa57dce8bb08d1d27ba67a0e51071c2197599
+FROM ocaml/opam2@sha256:f7125924dd6632099ff98b2505536fe5f5c36bf0beb24779431bb62be5748562
 
 # 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 git fetch origin && git reset --hard 95448cbb9fad7515e104222f92b3d1e0bee70ede && opam update
+RUN git fetch origin && git reset --hard 55e835f197d5a6961ff9b22eb5bbcb5a17f13e65 && opam update
 
 RUN sudo apt-get install -y m4 libxen-dev pkg-config
 RUN opam install -y vchan xen-gnt mirage-xen-ocaml mirage-xen-minios io-page mirage-xen mirage mirage-nat mirage-qubes

build-with-docker.sh

@@ -5,5 +5,5 @@ 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 qubes_firewall.xen)"
-echo "SHA2 last known: 21bd3e48dbca42ea5327a4fc6e27f9fe1f35f97e65864fff64e7a7675191148c"
+echo "SHA2 last known: addeb78681d73ee44df328ca059f6f15b8b7bbdff38a3de5363229cdf3da2eda"
 echo "(hashes should match for released versions)"

client_eth.ml

@@ -82,7 +82,7 @@ module ARP = struct
   let create ~net client_link = {net; client_link}
 
   let input_query t arp =
-    let req_ipv4 = arp.Arpv4_packet.tpa in
+    let req_ipv4 = arp.Arp_packet.target_ip in
     Log.info (fun f -> f "who-has %s?" (Ipaddr.V4.to_string req_ipv4));
     if req_ipv4 = t.client_link#other_ip then (
       Log.info (fun f -> f "ignoring request for client's own IP");
@@ -93,34 +93,32 @@ module ARP = struct
         None
       | Some req_mac ->
         Log.info (fun f -> f "responding to: who-has %s?" (Ipaddr.V4.to_string req_ipv4));
-        let req_spa = arp.Arpv4_packet.spa in
+        Some { Arp_packet.
-        let req_sha = arp.Arpv4_packet.sha in
+               operation = Arp_packet.Reply;
-        Some { Arpv4_packet.
-               op = Arpv4_wire.Reply;
                (* The Target Hardware Address and IP are copied from the request *)
-               tha = req_sha;
+               target_ip = arp.Arp_packet.source_ip;
-               tpa = req_spa;
+               target_mac = arp.Arp_packet.source_mac;
-               sha = req_mac;
+               source_ip = req_ipv4;
-               spa = req_ipv4;
+               source_mac = req_mac;
              }
 
   let input_gratuitous t arp =
-    let spa = arp.Arpv4_packet.spa in
+    let source_ip = arp.Arp_packet.source_ip in
-    let sha = arp.Arpv4_packet.sha in
+    let source_mac = arp.Arp_packet.source_mac in
-    match lookup t spa with
+    match lookup t source_ip with
-    | Some real_mac when Macaddr.compare sha real_mac = 0 ->
+    | Some real_mac when Macaddr.compare source_mac real_mac = 0 ->
       Log.info (fun f -> f "client suggests updating %s -> %s (as expected)"
-                   (Ipaddr.V4.to_string spa) (Macaddr.to_string sha));
+                   (Ipaddr.V4.to_string source_ip) (Macaddr.to_string source_mac));
     | Some other_mac ->
       Log.warn (fun f -> f "client suggests incorrect update %s -> %s (should be %s)"
-                   (Ipaddr.V4.to_string spa) (Macaddr.to_string sha) (Macaddr.to_string other_mac));
+                   (Ipaddr.V4.to_string source_ip) (Macaddr.to_string source_mac) (Macaddr.to_string other_mac));
     | None ->
       Log.warn (fun f -> f "client suggests incorrect update %s -> %s (unexpected IP)"
-                   (Ipaddr.V4.to_string spa) (Macaddr.to_string sha))
+                   (Ipaddr.V4.to_string source_ip) (Macaddr.to_string source_mac))
 
   let input t arp =
-    let op = arp.Arpv4_packet.op in
+    let op = arp.Arp_packet.operation in
     match op with
-    | Arpv4_wire.Request -> input_query t arp
+    | Arp_packet.Request -> input_query t arp
-    | Arpv4_wire.Reply -> input_gratuitous t arp; None
+    | Arp_packet.Reply -> input_gratuitous t arp; None
 end

client_eth.mli

@@ -47,7 +47,7 @@ module ARP : sig
   (** [create ~net client_link] is an ARP responder for [client_link].
       It answers only for the client's gateway address. *)
 
-  val input : arp -> Arpv4_packet.t -> Arpv4_packet.t option
+  val input : arp -> Arp_packet.t -> Arp_packet.t option
   (** Process one ethernet frame containing an ARP message.
       Returns a response frame, if one is needed. *)
 end

client_net.ml

@@ -5,24 +5,24 @@ open Lwt.Infix
 open Fw_utils
 
 module Netback = Netchannel.Backend.Make(Netchannel.Xenstore.Make(OS.Xs))
-module ClientEth = Ethif.Make(Netback)
+module ClientEth = Ethernet.Make(Netback)
 
 let src = Logs.Src.create "client_net" ~doc:"Client networking"
 module Log = (val Logs.src_log src : Logs.LOG)
 
-let writev eth data =
+let writev eth dst proto fillfn =
   Lwt.catch
     (fun () ->
-       ClientEth.writev eth data >|= function
+       ClientEth.write eth dst proto fillfn >|= function
        | Ok () -> ()
        | Error e ->
-         Log.err (fun f -> f "error trying to send to client:@\n@[<v2>  %a@]@\nError: @[%a@]"
+         Log.err (fun f -> f "error trying to send to client: @[%a@]"
-                     Cstruct.hexdump_pp (Cstruct.concat data) ClientEth.pp_error e);
+                     ClientEth.pp_error e);
     )
     (fun ex ->
        (* Usually Netback_shutdown, because the client disconnected *)
-       Log.err (fun f -> f "uncaught exception trying to send to client:@\n@[<v2>  %a@]@\nException: @[%s@]"
+       Log.err (fun f -> f "uncaught exception trying to send to client: @[%s@]"
-                   Cstruct.hexdump_pp (Cstruct.concat data) (Printexc.to_string ex));
+                   (Printexc.to_string ex));
        Lwt.return ()
     )
 
@@ -32,10 +32,9 @@ class client_iface eth ~gateway_ip ~client_ip client_mac : client_link = object
   method other_mac = client_mac
   method my_ip = gateway_ip
   method other_ip = client_ip
-  method writev proto ip =
+  method writev proto fillfn =
     FrameQ.send queue (fun () ->
-      let eth_hdr = eth_header proto ~src:(ClientEth.mac eth) ~dst:client_mac in
+        writev eth client_mac proto fillfn
-      writev eth (eth_hdr :: ip)
     )
 end
 
@@ -43,15 +42,15 @@ let clients : Cleanup.t Dao.VifMap.t ref = ref Dao.VifMap.empty
 
 (** Handle an ARP message from the client. *)
 let input_arp ~fixed_arp ~iface request =
-  match Arpv4_packet.Unmarshal.of_cstruct request with
+  match Arp_packet.decode 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" Arp_packet.pp_error e);
     Lwt.return ()
   | Ok arp ->
     match Client_eth.ARP.input fixed_arp arp with
     | None -> return ()
     | Some response ->
-      iface#writev Ethif_wire.ARP [Arpv4_packet.Marshal.make_cstruct response]
+      iface#writev `ARP (fun b -> Arp_packet.encode_into response b; Arp_packet.size)
 
 (** Handle an IPv4 packet from the client. *)
 let input_ipv4 ~client_ip ~router packet =
@@ -81,8 +80,8 @@ let add_vif { Dao.ClientVif.domid; device_id } ~client_ip ~router ~cleanup_tasks
   Router.add_client router iface >>= fun () ->
   Cleanup.on_cleanup cleanup_tasks (fun () -> Router.remove_client router iface);
   let fixed_arp = Client_eth.ARP.create ~net:client_eth iface in
-  Netback.listen backend (fun frame ->
+  Netback.listen backend ~header_size:14 (fun frame ->
-    match Ethif_packet.Unmarshal.of_cstruct frame with
+    match Ethernet_packet.Unmarshal.of_cstruct frame with
     | exception ex ->
       Log.err (fun f -> f "Error unmarshalling ethernet frame from client: %s@.%a" (Printexc.to_string ex)
                   Cstruct.hexdump_pp frame
@@ -90,10 +89,10 @@ let add_vif { Dao.ClientVif.domid; device_id } ~client_ip ~router ~cleanup_tasks
       Lwt.return_unit
     | Error err -> Log.warn (fun f -> f "Invalid Ethernet frame: %s" err); return ()
     | Ok (eth, payload) ->
-        match eth.Ethif_packet.ethertype with
+        match eth.Ethernet_packet.ethertype with
-        | Ethif_wire.ARP -> input_arp ~fixed_arp ~iface payload
+        | `ARP -> input_arp ~fixed_arp ~iface payload
-        | Ethif_wire.IPv4 -> input_ipv4 ~client_ip ~router payload
+        | `IPv4 -> input_ipv4 ~client_ip ~router payload
-        | Ethif_wire.IPv6 -> return ()
+        | `IPv6 -> return () (* TODO: oh no! *)
   )
   >|= or_raise "Listen on client interface" Netback.pp_error
 

config.ml

@@ -21,13 +21,17 @@ let main =
       package "vchan";
       package "cstruct";
       package "astring";
-      package "tcpip" ~sublibs:["stack-direct"; "xen"; "arpv4"] ~min:"3.1.0";
+      package "tcpip" ~min:"3.7.0";
+      package "arp";
+      package "arp-mirage";
+      package "ethernet";
+      package "mirage-protocols";
       package "shared-memory-ring" ~min:"3.0.0";
       package "netchannel" ~min:"1.8.0";
       package "mirage-net-xen" ~min:"1.7.1";
       package "ipaddr" ~min:"3.0.0";
       package "mirage-qubes";
-      package "mirage-nat";
+      package "mirage-nat" ~min:"1.1.0";
       package "mirage-logs";
     ]
     "Unikernel.Main" (mclock @-> job)

firewall.ml

@@ -13,9 +13,18 @@ module Log = (val Logs.src_log src : Logs.LOG)
 let transmit_ipv4 packet iface =
   Lwt.catch
     (fun () ->
-       let transport = Nat_packet.to_cstruct packet in
        Lwt.catch
-         (fun () -> iface#writev Ethif_wire.IPv4 transport)
+         (fun () ->
+            iface#writev `IPv4 (fun b ->
+                match Nat_packet.into_cstruct packet b with
+                | Error e ->
+                  Log.warn (fun f -> f "Failed to write packet to %a: %a"
+                               Ipaddr.V4.pp iface#other_ip
+                               Nat_packet.pp_error e);
+                  0
+                | Ok n -> n
+              )
+         )
          (fun ex ->
             Log.warn (fun f -> f "Failed to write packet to %a: %s"
                          Ipaddr.V4.pp iface#other_ip
@@ -35,7 +44,7 @@ let forward_ipv4 t packet =
   let `IPv4 (ip, _) = packet in
   match Router.target t ip with
   | Some iface -> transmit_ipv4 packet iface
-  | None -> return ()
+  | None -> Lwt.return_unit
 
 (* Packet classification *)
 

frameQ.ml

@@ -16,7 +16,7 @@ let max_qlen = 10
 
 let send q fn =
   if q.items = max_qlen then (
-    Log.warn (fun f -> f "Maximim queue length exceeded for %s: dropping frame" q.name);
+    Log.warn (fun f -> f "Maximum queue length exceeded for %s: dropping frame" q.name);
     Lwt.return_unit
   ) else (
     let sent = fn () in

fw_utils.ml

@@ -21,7 +21,7 @@ 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 writev : Mirage_protocols.Ethernet.proto -> (Cstruct.t -> int) -> unit Lwt.t
   method my_ip : Ipaddr.V4.t
   method other_ip : Ipaddr.V4.t
 end
@@ -34,7 +34,7 @@ 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 }
+  Ethernet_packet.Marshal.make_cstruct { Ethernet_packet.source = src; destination = dst; ethertype }
 
 let error fmt =
   let err s = Failure s in

uplink.ml

@@ -4,13 +4,13 @@
 open Lwt.Infix
 open Fw_utils
 
-module Eth = Ethif.Make(Netif)
+module Eth = Ethernet.Make(Netif)
 
 let src = Logs.Src.create "uplink" ~doc:"Network connection to NetVM"
 module Log = (val Logs.src_log src : Logs.LOG)
 
 module Make(Clock : Mirage_clock_lwt.MCLOCK) = struct
-  module Arp = Arpv4.Make(Eth)(Clock)(OS.Time)
+  module Arp = Arp.Make(Eth)(OS.Time)
 
   type t = {
     net : Netif.t;
@@ -24,16 +24,15 @@ module Make(Clock : Mirage_clock_lwt.MCLOCK) = struct
     method my_mac = Eth.mac eth
     method my_ip = my_ip
     method other_ip = other_ip
-    method writev ethertype payload =
+    method writev ethertype fillfn =
       FrameQ.send queue (fun () ->
         mac >>= fun dst ->
-        let eth_hdr = eth_header ethertype ~src:(Eth.mac eth) ~dst in
+        Eth.write eth dst ethertype fillfn >|= or_raise "Write to uplink" Eth.pp_error
-        Eth.writev eth (eth_hdr :: payload) >|= or_raise "Write to uplink" Eth.pp_error
       )
   end
 
   let listen t router =
-    Netif.listen t.net (fun frame ->
+    Netif.listen t.net ~header_size:14 (fun frame ->
         (* Handle one Ethernet frame from NetVM *)
         Eth.input t.eth
           ~arpv4:(Arp.input t.arp)
@@ -56,11 +55,11 @@ module Make(Clock : Mirage_clock_lwt.MCLOCK) = struct
 
   let interface t = t.interface
 
-  let connect ~clock config =
+  let connect ~clock:_ config =
     let ip = config.Dao.uplink_our_ip in
     Netif.connect "0" >>= fun net ->
     Eth.connect net >>= fun eth ->
-    Arp.connect eth clock >>= fun arp ->
+    Arp.connect eth >>= fun arp ->
     Arp.add_ip arp ip >>= fun () ->
     let netvm_mac =
       Arp.query arp config.Dao.uplink_netvm_ip