Merge pull request #90 from talex5/cleanup

Minor cleanups

Dockerfile

@@ -9,7 +9,7 @@ FROM ocurrent/opam@sha256:3f3ce7e577a94942c7f9c63cbdd1ecbfe0ea793f581f69047f3155
 # latest versions.
 RUN cd ~/opam-repository && git fetch origin master && git reset --hard d205c265cee9a86869259180fd2238da98370430 && opam update
 
-RUN opam depext -i -y mirage.3.7.4 lwt
+RUN opam depext -i -y mirage.3.7.4 lwt.4.5.0
 RUN mkdir /home/opam/qubes-mirage-firewall
 ADD config.ml /home/opam/qubes-mirage-firewall/config.ml
 WORKDIR /home/opam/qubes-mirage-firewall

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: 8a337e61e7d093f7c1f0fa5fe277dace4d606bfa06cfde3f2d61d6bdee6eefbc"
+echo "SHA2 last known: 91c5bf44a85339aaf14e4763a29c2b64537f5bc41cd7dc2571af954ec9dd3cad"
 echo "(hashes should match for released versions)"

firewall.ml

@@ -12,33 +12,23 @@ module Log = (val Logs.src_log src : Logs.LOG)
 let transmit_ipv4 packet iface =
   Lwt.catch
     (fun () ->
-       Lwt.catch
+       let fragments = ref [] in
-         (fun () ->
+       iface#writev `IPv4 (fun b ->
-            let fragments = ref [] in
+           match Nat_packet.into_cstruct packet b with
-            iface#writev `IPv4 (fun b ->
+           | Error e ->
-                match Nat_packet.into_cstruct packet b with
+             Log.warn (fun f -> f "Failed to NAT packet to %a: %a"
-                | Error e ->
+                          Ipaddr.V4.pp iface#other_ip
-                  Log.warn (fun f -> f "Failed to write packet to %a: %a"
+                          Nat_packet.pp_error e);
-                               Ipaddr.V4.pp iface#other_ip
+             0
-                               Nat_packet.pp_error e);
+           | Ok (n, frags) -> fragments := frags ; n) >>= fun () ->
-                  0
+       Lwt_list.iter_s (fun f ->
-                | Ok (n, frags) -> fragments := frags ; n) >>= fun () ->
+           let size = Cstruct.len f in
-            Lwt_list.iter_s (fun f ->
+           iface#writev `IPv4 (fun b -> Cstruct.blit f 0 b 0 size ; size))
-                let size = Cstruct.len f in
+         !fragments)
-                iface#writev `IPv4 (fun b -> Cstruct.blit f 0 b 0 size ; size))
-              !fragments)
-         (fun ex ->
-            Log.warn (fun f -> f "Failed to write packet to %a: %s"
-                         Ipaddr.V4.pp iface#other_ip
-                         (Printexc.to_string ex));
-            Lwt.return_unit
-         )
-    )
     (fun ex ->
-       Log.err (fun f -> f "Exception in transmit_ipv4: %s for:@.%a"
+       Log.warn (fun f -> f "Failed to write packet to %a: %s"
-                   (Printexc.to_string ex)
+                    Ipaddr.V4.pp iface#other_ip
-                   Nat_packet.pp packet
+                    (Printexc.to_string ex));
-               );
        Lwt.return_unit
     )
 

unikernel.ml

@@ -8,8 +8,6 @@ let src = Logs.Src.create "unikernel" ~doc:"Main unikernel code"
 module Log = (val Logs.src_log src : Logs.LOG)
 
 module Main (Clock : Mirage_clock.MCLOCK) = struct
-  module Uplink = Uplink.Make(Clock)
-
   (* Set up networking and listen for incoming packets. *)
   let network nat qubesDB =
     (* Read configuration from QubesDB *)

uplink.ml

@@ -9,66 +9,64 @@ 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.MCLOCK) = struct
+module Arp = Arp.Make(Eth)(OS.Time)
-  module Arp = Arp.Make(Eth)(OS.Time)
 
-  type t = {
+type t = {
-    net : Netif.t;
+  net : Netif.t;
-    eth : Eth.t;
+  eth : Eth.t;
-    arp : Arp.t;
+  arp : Arp.t;
-    interface : interface;
+  interface : interface;
-    fragments : Fragments.Cache.t;
+  fragments : Fragments.Cache.t;
-  }
+}
 
-  class netvm_iface eth mac ~my_ip ~other_ip : interface = object
+class netvm_iface eth mac ~my_ip ~other_ip : interface = object
-    val queue = FrameQ.create (Ipaddr.V4.to_string other_ip)
+  val queue = FrameQ.create (Ipaddr.V4.to_string other_ip)
-    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 ethertype fillfn =
+  method writev ethertype fillfn =
-      FrameQ.send queue (fun () ->
+    FrameQ.send queue (fun () ->
-        mac >>= fun dst ->
+      mac >>= fun dst ->
-        Eth.write eth dst ethertype fillfn >|= or_raise "Write to uplink" Eth.pp_error
+      Eth.write eth dst ethertype fillfn >|= or_raise "Write to uplink" Eth.pp_error
-      )
+    )
-  end
-
-  let listen t get_ts router =
-    Netif.listen t.net ~header_size:Ethernet_wire.sizeof_ethernet (fun frame ->
-        (* Handle one Ethernet frame from NetVM *)
-        Eth.input t.eth
-          ~arpv4:(Arp.input t.arp)
-          ~ipv4:(fun ip ->
-              match Nat_packet.of_ipv4_packet t.fragments ~now:(get_ts ()) 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_unit
-              | Ok None -> Lwt.return_unit
-              | Ok (Some packet) ->
-                Firewall.ipv4_from_netvm router packet
-            )
-          ~ipv6:(fun _ip -> Lwt.return_unit)
-          frame
-      ) >|= or_raise "Uplink listen loop" Netif.pp_error
-
-  let interface t = t.interface
-
-  let connect config =
-    let ip = config.Dao.uplink_our_ip in
-    Netif.connect "0" >>= fun net ->
-    Eth.connect net >>= fun eth ->
-    Arp.connect eth >>= fun arp ->
-    Arp.add_ip arp ip >>= fun () ->
-    let netvm_mac =
-      Arp.query arp config.Dao.uplink_netvm_ip
-      >|= or_raise "Getting MAC of our NetVM" Arp.pp_error in
-    let interface = new netvm_iface eth netvm_mac
-      ~my_ip:ip
-      ~other_ip:config.Dao.uplink_netvm_ip in
-    let fragments = Fragments.Cache.create (256 * 1024) in
-    Lwt.return { net; eth; arp; interface ; fragments }
 end
+
+let listen t get_ts router =
+  Netif.listen t.net ~header_size:Ethernet_wire.sizeof_ethernet (fun frame ->
+      (* Handle one Ethernet frame from NetVM *)
+      Eth.input t.eth
+        ~arpv4:(Arp.input t.arp)
+        ~ipv4:(fun ip ->
+            match Nat_packet.of_ipv4_packet t.fragments ~now:(get_ts ()) 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_unit
+            | Ok None -> Lwt.return_unit
+            | Ok (Some packet) ->
+              Firewall.ipv4_from_netvm router packet
+          )
+        ~ipv6:(fun _ip -> Lwt.return_unit)
+        frame
+    ) >|= or_raise "Uplink listen loop" Netif.pp_error
+
+let interface t = t.interface
+
+let connect config =
+  let ip = config.Dao.uplink_our_ip in
+  Netif.connect "0" >>= fun net ->
+  Eth.connect net >>= fun eth ->
+  Arp.connect eth >>= fun arp ->
+  Arp.add_ip arp ip >>= fun () ->
+  let netvm_mac =
+    Arp.query arp config.Dao.uplink_netvm_ip
+    >|= or_raise "Getting MAC of our NetVM" Arp.pp_error in
+  let interface = new netvm_iface eth netvm_mac
+    ~my_ip:ip
+    ~other_ip:config.Dao.uplink_netvm_ip in
+  let fragments = Fragments.Cache.create (256 * 1024) in
+  Lwt.return { net; eth; arp; interface ; fragments }

uplink.mli

@@ -5,15 +5,13 @@
 
 open Fw_utils
 
-module Make(Clock : Mirage_clock.MCLOCK) : sig
+type t
-  type t
 
-  val connect : Dao.network_config -> t Lwt.t
+val connect : Dao.network_config -> t Lwt.t
-  (** Connect to our NetVM (gateway). *)
+(** Connect to our NetVM (gateway). *)
 
-  val interface : t -> interface
+val interface : t -> interface
-  (** The network interface to NetVM. *)
+(** The network interface to NetVM. *)
 
-  val listen : t -> (unit -> int64) -> Router.t -> unit Lwt.t
+val listen : t -> (unit -> int64) -> Router.t -> unit Lwt.t
-  (** Handle incoming frames from NetVM. *)
+(** Handle incoming frames from NetVM. *)
-end