Merge pull request #140 from palainp/mirage4

update to mirage 4.2.0 & mirage-xen 8.0.0

Dockerfile

@@ -1,18 +1,20 @@
 # Pin the base image to a specific hash for maximum reproducibility.
 # It will probably still work on newer images, though, unless an update
 # changes some compiler optimisations (unlikely).
-#FROM ocurrent/opam:fedora-32-ocaml-4.11
+# fedora-35-ocaml-4.14
-FROM ocurrent/opam@sha256:fce44a073ff874166b51c33a4e37782286d48dbba1b5aa43563a0dd35d15510f
+FROM ocaml/opam@sha256:68b7ce1fd4c992d6f3bfc9b4b0a88ee572ced52427f0547b6e4eb6194415f585
+ENV PATH="${PATH}:/home/opam/.opam/4.14/bin"
+
+# Since mirage 4.2 we must use opam version 2.1 or later
+RUN sudo ln -sf /usr/bin/opam-2.1 /usr/bin/opam
 
 # 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 fetch origin master && git reset --hard 479a47921a489d11833e03cf949bfb612bd65e41 && opam update
+RUN cd /home/opam/opam-repository && git fetch origin master && git reset --hard f904585098b809001380caada4b7426c112d086c && opam update
 
-RUN opam depext -i -y mirage
+RUN opam install -y mirage opam-monorepo
 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 -t xen && make depend
+CMD opam exec -- mirage configure -t xen && make depend && make tar
-CMD opam config exec -- mirage configure -t xen && \
-    opam config exec -- make tar

Makefile.builder

@@ -1,8 +1,7 @@
-MIRAGE_KERNEL_NAME = qubes_firewall.xen
+MIRAGE_KERNEL_NAME = dist/qubes-firewall.xen
-OCAML_VERSION ?= 4.10.0
+OCAML_VERSION ?= 4.14.0
 SOURCE_BUILD_DEP := firewall-build-dep
 
 firewall-build-dep:
-	opam install -y depext
+	opam install -y mirage
-	opam depext -i -y mirage
 

Makefile.user

@@ -1,7 +1,7 @@
 tar: build
 	rm -rf _build/mirage-firewall
 	mkdir _build/mirage-firewall
-	cp qubes_firewall.xen _build/mirage-firewall/vmlinuz
+	cp dist/qubes-firewall.xen _build/mirage-firewall/vmlinuz
 	touch _build/mirage-firewall/modules.img
 	cat /dev/null | gzip -n > _build/mirage-firewall/initramfs
 	tar cjf mirage-firewall.tar.bz2 -C _build --mtime=./build-with-docker.sh mirage-firewall

README.md

@@ -134,7 +134,7 @@ The boot process:
 
 ### Easy deployment for developers
 
-For development, use the [test-mirage][] scripts to deploy the unikernel (`qubes_firewall.xen`) from your development AppVM.
+For development, use the [test-mirage][] scripts to deploy the unikernel (`qubes-firewall.xen`) from your development AppVM.
 This takes a little more setting up the first time, but will be much quicker after that. e.g.
 
     $ test-mirage qubes_firewall.xen mirage-firewall

build-with-docker.sh

@@ -4,6 +4,6 @@ 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 qubes_firewall.xen)"
+echo "SHA2 of build:   $(sha256sum ./dist/qubes-firewall.xen)"
-echo "SHA2 last known: e2af3718b7f40ba533f378d1402a41008c3520fe84d991ab58d3230772cc824c"
+echo "SHA2 last known: 588e921b9d78a99f6f49d468a7b68284c50dabeba95698648ea52e99b381723b"
 echo "(hashes should match for released versions)"

client_net.ml

@@ -4,7 +4,7 @@
 open Lwt.Infix
 open Fw_utils
 
-module Netback = Netchannel.Backend.Make(Netchannel.Xenstore.Make(OS.Xs))
+module Netback = Netchannel.Backend.Make(Netchannel.Xenstore.Make(Xen_os.Xs))
 module ClientEth = Ethernet.Make(Netback)
 
 let src = Logs.Src.create "client_net" ~doc:"Client networking"

config.ml

@@ -6,17 +6,16 @@
 open Mirage
 
 let table_size =
-  let open Functoria_key in
+  let info = Key.Arg.info
-  let info = Arg.info
       ~doc:"The number of NAT entries to allocate."
       ~docv:"ENTRIES" ["nat-table-size"]
   in
-  let key = Arg.opt ~stage:`Both Arg.int 5_000 info in
+  let key = Key.Arg.opt ~stage:`Both Key.Arg.int 5_000 info in
-  create "nat_table_size" key
+  Key.create "nat_table_size" key
 
 let main =
   foreign
-    ~keys:[Functoria_key.abstract table_size]
+    ~keys:[Key.v table_size]
     ~packages:[
       package "vchan" ~min:"4.0.2";
       package "cstruct";
@@ -31,12 +30,11 @@ let main =
       package "mirage-qubes" ~min:"0.9.1";
       package "mirage-nat" ~min:"2.2.1";
       package "mirage-logs";
-      package "mirage-xen" ~min:"6.0.0";
+      package "mirage-xen" ~min:"8.0.0";
       package ~min:"6.1.0" "dns-client";
       package "pf-qubes";
     ]
-    "Unikernel.Main" (random @-> mclock @-> job)
+    "Unikernel.Main" (random @-> mclock @-> time @-> job)
 
 let () =
-  register "qubes-firewall" [main $ default_random $ default_monotonic_clock]
+  register "qubes-firewall" [main $ default_random $ default_monotonic_clock $ default_time]
-    ~argv:no_argv

dao.ml

@@ -29,7 +29,7 @@ module VifMap = struct
 end
 
 let directory ~handle dir =
-  OS.Xs.directory handle dir >|= function
+  Xen_os.Xs.directory handle dir >|= function
   | [""] -> []      (* XenStore client bug *)
   | items -> items
 
@@ -77,7 +77,7 @@ let vifs ~handle domid =
         | Some device_id ->
         let vif = { ClientVif.domid; device_id } in
         Lwt.try_bind
-          (fun () -> OS.Xs.read handle (Printf.sprintf "%s/%d/ip" path device_id))
+          (fun () -> Xen_os.Xs.read handle (Printf.sprintf "%s/%d/ip" path device_id))
           (fun client_ip ->
              let client_ip' = match String.cuts ~sep:" " client_ip with
                | [] -> Log.err (fun m -> m "unexpected empty list"); ""
@@ -104,10 +104,10 @@ let vifs ~handle domid =
       )
 
 let watch_clients fn =
-  OS.Xs.make () >>= fun xs ->
+  Xen_os.Xs.make () >>= fun xs ->
   let backend_vifs = "backend/vif" in
   Log.info (fun f -> f "Watching %s" backend_vifs);
-  OS.Xs.wait xs (fun handle ->
+  Xen_os.Xs.wait xs (fun handle ->
     begin Lwt.catch
       (fun () -> directory ~handle backend_vifs)
       (function

memory_pressure.ml

@@ -9,11 +9,11 @@ module Log = (val Logs.src_log src : Logs.LOG)
 let wordsize_in_bytes = Sys.word_size / 8
 
 let fraction_free stats =
-  let { OS.Memory.free_words; heap_words; _ } = stats in
+  let { Xen_os.Memory.free_words; heap_words; _ } = stats in
   float free_words /. float heap_words
 
 let meminfo stats =
-  let { OS.Memory.free_words; heap_words; _ } = stats in
+  let { Xen_os.Memory.free_words; heap_words; _ } = stats in
   let mem_total = heap_words * wordsize_in_bytes in
   let mem_free = free_words * wordsize_in_bytes in
   Log.info (fun f -> f "Writing meminfo: free %a / %a (%.2f %%)"
@@ -29,7 +29,7 @@ let meminfo stats =
 
 let report_mem_usage stats =
   Lwt.async (fun () ->
-    let open OS in
+    let open Xen_os in
     Xs.make () >>= fun xs ->
     Xs.immediate xs (fun h ->
       Xs.write h "memory/meminfo" (meminfo stats)
@@ -38,16 +38,17 @@ let report_mem_usage stats =
 
 let init () =
   Gc.full_major ();
-  let stats = OS.Memory.quick_stat () in
+  let stats = Xen_os.Memory.quick_stat () in
   report_mem_usage stats
 
 let status () =
-  let stats = OS.Memory.quick_stat () in
+  let stats = Xen_os.Memory.quick_stat () in
-  if fraction_free stats > 0.1 then `Ok
+  if fraction_free stats > 0.4 then `Ok
   else (
     Gc.full_major ();
-    let stats = OS.Memory.quick_stat () in
+    Xen_os.Memory.trim ();
+    let stats = Xen_os.Memory.quick_stat () in
     report_mem_usage stats;
-    if fraction_free stats < 0.1 then `Memory_critical
+    if fraction_free stats < 0.4 then `Memory_critical
     else `Ok
   )

my_dns.ml

@@ -1,6 +1,6 @@
 open Lwt.Infix
 
-module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) = struct
+module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) (Time : Mirage_time.S) = struct
   type +'a io = 'a Lwt.t
   type io_addr = Ipaddr.V4.t * int
   type stack = Router.t * (src_port:int -> dst:Ipaddr.V4.t -> dst_port:int -> Cstruct.t -> (unit, [ `Msg of string ]) result Lwt.t) * (Udp_packet.t * Cstruct.t) Lwt_mvar.t
@@ -25,7 +25,7 @@ module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) = struct
     { protocol ; nameserver ; stack ; timeout_ns = timeout }
 
   let with_timeout timeout_ns f =
-    let timeout = OS.Time.sleep_ns timeout_ns >|= fun () -> Error (`Msg "DNS request timeout") in
+    let timeout = Time.sleep_ns timeout_ns >|= fun () -> Error (`Msg "DNS request timeout") in
     Lwt.pick [ f ; timeout ]
 
   let connect (t : t) = Lwt.return (Ok t)

unikernel.ml

@@ -7,9 +7,9 @@ open Qubes
 let src = Logs.Src.create "unikernel" ~doc:"Main unikernel code"
 module Log = (val Logs.src_log src : Logs.LOG)
 
-module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK) = struct
+module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_time.S) = struct
-  module Uplink = Uplink.Make(R)(Clock)
+  module Uplink = Uplink.Make(R)(Clock)(Time)
-  module Dns_transport = My_dns.Transport(R)(Clock)
+  module Dns_transport = My_dns.Transport(R)(Clock)(Time)
   module Dns_client = Dns_client.Make(Dns_transport)
 
   (* Set up networking and listen for incoming packets. *)
@@ -40,7 +40,7 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK) = struct
     )
 
   (* Main unikernel entry point (called from auto-generated main.ml). *)
-  let start _random _clock =
+  let start _random _clock _time =
     let start_time = Clock.elapsed_ns () in
     (* Start qrexec agent, GUI agent and QubesDB agent in parallel *)
     let qrexec = RExec.connect ~domid:0 () in
@@ -59,7 +59,7 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK) = struct
     Log.info (fun f -> f "QubesDB and qrexec agents connected in %.3f s" startup_time);
     (* Watch for shutdown requests from Qubes *)
     let shutdown_rq =
-      OS.Lifecycle.await_shutdown_request () >>= fun (`Poweroff | `Reboot) ->
+      Xen_os.Lifecycle.await_shutdown_request () >>= fun (`Poweroff | `Reboot) ->
       Lwt.return_unit in
     (* Set up networking *)
     let max_entries = Key_gen.nat_table_size () in
@@ -91,5 +91,5 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK) = struct
     (* Run until something fails or we get a shutdown request. *)
     Lwt.choose [agent_listener; net_listener; shutdown_rq] >>= fun () ->
     (* Give the console daemon time to show any final log messages. *)
-    OS.Time.sleep_ns (1.0 *. 1e9 |> Int64.of_float)
+    Time.sleep_ns (1.0 *. 1e9 |> Int64.of_float)
 end

uplink.ml

@@ -9,8 +9,8 @@ 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 (R:Mirage_random.S) (Clock : Mirage_clock.MCLOCK) = struct
+module Make (R:Mirage_random.S) (Clock : Mirage_clock.MCLOCK) (Time : Mirage_time.S) = struct
-  module Arp = Arp.Make(Eth)(OS.Time)
+  module Arp = Arp.Make(Eth)(Time)
   module I = Static_ipv4.Make(R)(Clock)(Eth)(Arp)
   module U = Udp.Make(I)(R)
 

uplink.mli

@@ -6,7 +6,7 @@
 open Fw_utils
 
 [@@@ocaml.warning "-67"]
-module Make (R: Mirage_random.S)(Clock : Mirage_clock.MCLOCK) : sig
+module Make (R: Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_time.S) : sig
   type t
 
   val connect : Dao.network_config -> t Lwt.t