Merge pull request #215 from hannesm/mirage-49

update to mirage 4.9.0

.github/workflows/format.yml

@@ -0,0 +1,45 @@
+name: ocamlformat
+
+on: [pull_request]
+
+jobs:
+  format:
+    name: ocamlformat
+
+    strategy:
+      fail-fast: false
+      matrix:
+        ocaml-version: ["4.14.2"]
+        operating-system: [ubuntu-latest]
+
+    runs-on: ${{ matrix.operating-system }}
+
+    steps:
+      - name: Checkout code
+        uses: actions/checkout@v2
+        with:
+          ref: ${{ github.event.pull_request.head.ref }}
+
+      - name: Use OCaml ${{ matrix.ocaml-version }}
+        uses: ocaml/setup-ocaml@v3
+        with:
+          ocaml-compiler: ${{ matrix.ocaml-version }}
+
+      - name: Install ocamlformat
+        run: grep ^version .ocamlformat | cut -d '=' -f 2 | xargs -I V opam install ocamlformat=V
+
+      - name: Format code
+        run: git ls-files '*.ml' '*.mli' | xargs opam exec -- ocamlformat --inplace
+
+      - name: Check for modified files
+        id: git-check
+        run: echo "modified=$(if git diff-index --quiet HEAD --; then echo "false"; else echo "true"; fi)" >> $GITHUB_OUTPUT
+
+      - name: Commit and push changes
+        if: steps.git-check.outputs.modified == 'true'
+        run: |
+          git config --global user.name "Automated ocamlformat GitHub action, developed by robur.coop"
+          git config --global user.email "autoformat@robur.coop"
+          git add -A
+          git commit -m "formatted code"
+          git push

.ocamlformat

@@ -0,0 +1,3 @@
+version = 0.27.0
+profile = conventional
+parse-docstrings = true

Dockerfile

@@ -12,10 +12,10 @@ RUN printf "deb [check-valid-until=no] http://snapshot.debian.org/archive/debian
 RUN printf "deb [check-valid-until=no] http://snapshot.debian.org/archive/debian-security/20240419T111010Z bookworm-security main\n" >> /etc/apt/sources.list
 
 RUN apt update && apt install --no-install-recommends --no-install-suggests -y wget ca-certificates git patch unzip bzip2 make gcc g++ libc-dev
-RUN wget -O /usr/bin/opam https://github.com/ocaml/opam/releases/download/2.2.1/opam-2.2.1-i686-linux && chmod 755 /usr/bin/opam
+RUN wget -O /usr/bin/opam https://github.com/ocaml/opam/releases/download/2.3.0/opam-2.3.0-i686-linux && chmod 755 /usr/bin/opam
 # taken from https://raw.githubusercontent.com/ocaml/opam/master/shell/install.sh
 RUN test `sha512sum /usr/bin/opam | cut -d' ' -f1` = \
-"bf16d573137835ce9abbcf6b99cb94a1da69ab58804a4de7c90233f0b354d5e68e9c47ee16670ca9d59866d58c7db345d9723e6eb5fc3a1cb8dca371f0e90225" || exit
+"4c0e8771889a36bad4d5f964e2e662d5b611e6f112777d3d4eea3eea919d109cd17826beba38e6cfa1ad9553a0a989d9268f911ea5485968da04b1e08efc7de2" || exit
 
 ENV OPAMROOT=/tmp
 ENV OPAMCONFIRMLEVEL=unsafe-yes
@@ -23,13 +23,13 @@ ENV OPAMCONFIRMLEVEL=unsafe-yes
 # Remove this line (and the base image pin above) if you want to test with the
 # latest versions.
 # taken from https://github.com/ocaml/opam-repository
-RUN opam init --disable-sandboxing -a --bare https://github.com/ocaml/opam-repository.git#5d3f0d1d655199e596a1e785e69fae8fad78cad3
+RUN opam init --disable-sandboxing -a --bare https://github.com/ocaml/opam-repository.git#8f63148a9025a7b775a069a6c0b0385c22ad51d3
 RUN opam switch create myswitch 4.14.2
 RUN opam exec -- opam install -y mirage opam-monorepo ocaml-solo5
 RUN mkdir /tmp/orb-build
 ADD config.ml /tmp/orb-build/config.ml
 WORKDIR /tmp/orb-build
 CMD opam exec -- sh -exc 'mirage configure -t xen --extra-repos=\
-opam-overlays:https://github.com/dune-universe/opam-overlays.git#4e75ee36715b27550d5bdb87686bb4ae4c9e89c4,\
+opam-overlays:https://github.com/dune-universe/opam-overlays.git#f2bec38beca4aea9e481f2fd3ee319c519124649,\
 mirage-overlays:https://github.com/dune-universe/mirage-opam-overlays.git#797cb363df3ff763c43c8fbec5cd44de2878757e \
 && make depend && make unikernel'

config.ml

@@ -1,4 +1,4 @@
-(* mirage >= 4.8.0 & < 4.9.0 *)
+(* mirage >= 4.9.0 & < 4.10.0 *)
 (* Copyright (C) 2017, Thomas Leonard <thomas.leonard@unikernel.com>
    See the README file for details. *)
 
@@ -24,7 +24,7 @@ let main =
       package ~min:"6.4.0" "dns-client";
       package "pf-qubes";
     ]
-    "Unikernel.Main" (random @-> mclock @-> time @-> job)
+    "Unikernel" job
 
 let () =
-  register "qubes-firewall" [main $ default_random $ default_monotonic_clock $ default_time]
+  register "qubes-firewall" [main]

dispatcher.ml

@@ -8,14 +8,9 @@ let src = Logs.Src.create "dispatcher" ~doc:"Networking dispatch"
 
 module Log = (val Logs.src_log src : Logs.LOG)
 
-module Make
-    (R : Mirage_crypto_rng_mirage.S)
-    (Clock : Mirage_clock.MCLOCK)
-    (Time : Mirage_time.S) =
-struct
-  module Arp = Arp.Make (UplinkEth) (Time)
-  module I = Static_ipv4.Make (R) (Clock) (UplinkEth) (Arp)
-  module U = Udp.Make (I) (R)
+  module Arp = Arp.Make (UplinkEth)
+  module I = Static_ipv4.Make (UplinkEth) (Arp)
+  module U = Udp.Make (I)
 
   class client_iface eth ~domid ~gateway_ip ~client_ip client_mac : client_link
     =
@@ -632,4 +627,3 @@ struct
       >>= fun () -> aux new_db
     in
     aux Qubes.DB.KeyMap.empty
-end

my_dns.ml

@@ -1,9 +1,7 @@
 open Lwt.Infix
 
-module Transport (R : Mirage_crypto_rng_mirage.S) (C : Mirage_clock.MCLOCK) (Time : Mirage_time.S) = struct
   type +'a io = 'a Lwt.t
   type io_addr = Ipaddr.V4.t * int
-  module Dispatcher = Dispatcher.Make(R)(C)(Time)
   type stack = Dispatcher.t *
                (src_port:int -> dst:Ipaddr.V4.t -> dst_port:int -> string -> (unit, [ `Msg of string ]) result Lwt.t) *
                (Udp_packet.t * string) Lwt_mvar.t
@@ -20,8 +18,8 @@ module Transport (R : Mirage_crypto_rng_mirage.S) (C : Mirage_clock.MCLOCK) (Tim
   type context = t
 
   let nameservers { protocol ; nameserver ; _ } = protocol, [ nameserver ]
-  let rng = R.generate ?g:None
-  let clock = C.elapsed_ns
+  let rng = Mirage_crypto_rng.generate ?g:None
+  let clock = Mirage_mtime.elapsed_ns
 
   let rec read t =
     let _, _, answer = t.stack in
@@ -45,7 +43,7 @@ module Transport (R : Mirage_crypto_rng_mirage.S) (C : Mirage_clock.MCLOCK) (Tim
     t
 
   let with_timeout timeout_ns f =
-    let timeout = Time.sleep_ns timeout_ns >|= fun () -> Error (`Msg "DNS request timeout") in
+    let timeout = Mirage_sleep.ns timeout_ns >|= fun () -> Error (`Msg "DNS request timeout") in
     Lwt.pick [ f ; timeout ]
 
   let connect (t : t) = Lwt.return (Ok (t.protocol, t))
@@ -72,5 +70,3 @@ module Transport (R : Mirage_crypto_rng_mirage.S) (C : Mirage_clock.MCLOCK) (Tim
   let bind = Lwt.bind
 
   let lift = Lwt.return
-end
-

qubes-firewall.sha256

@@ -1 +1 @@
-0c3c2c0e62a834112c69d7cddc5dd6f70ecb93afa988768fb860ed26e423b1f8  dist/qubes-firewall.xen
+1cc5664d48a80b96162e14a0d8a17aafa52175cc2043ecf6b834c4bc8fe656f6  dist/qubes-firewall.xen

unikernel.ml

@@ -28,10 +28,7 @@ let ipv4_dns2 =
   let doc = Arg.info ~doc:"Manual Second DNS IP setting." [ "ipv4-dns2" ] in
   Mirage_runtime.register_arg Arg.(value & opt string "10.139.1.2" doc)
 
-module Main (R : Mirage_crypto_rng_mirage.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_time.S) = struct
-  module Dispatcher = Dispatcher.Make(R)(Clock)(Time)
-  module Dns_transport = My_dns.Transport(R)(Clock)(Time)
-  module Dns_client = Dns_client.Make(Dns_transport)
+  module Dns_client = Dns_client.Make(My_dns)
 
   (* Set up networking and listen for incoming packets. *)
   let network dns_client dns_responses dns_servers qubesDB router =
@@ -39,22 +36,22 @@ module Main (R : Mirage_crypto_rng_mirage.S)(Clock : Mirage_clock.MCLOCK)(Time :
     Dao.set_iptables_error qubesDB "" >>= fun () ->
     (* Handle packets from both networks *)
     Lwt.choose [
-      Dispatcher.wait_clients Clock.elapsed_ns dns_client dns_servers qubesDB router ;
+      Dispatcher.wait_clients Mirage_mtime.elapsed_ns dns_client dns_servers qubesDB router ;
       Dispatcher.uplink_wait_update qubesDB router ;
-      Dispatcher.uplink_listen Clock.elapsed_ns dns_responses router
+      Dispatcher.uplink_listen Mirage_mtime.elapsed_ns dns_responses router
     ]
 
   (* Main unikernel entry point (called from auto-generated main.ml). *)
-  let start _random _clock _time =
+  let start () =
     let open Lwt.Syntax in
-    let start_time = Clock.elapsed_ns () in
+    let start_time = Mirage_mtime.elapsed_ns () in
     (* Start qrexec agent and QubesDB agent in parallel *)
     let* qrexec = RExec.connect ~domid:0 () in
     let agent_listener = RExec.listen qrexec Command.handler in
     let* qubesDB = DB.connect ~domid:0 () in
     let startup_time =
       let (-) = Int64.sub in
-      let time_in_ns = Clock.elapsed_ns () - start_time in
+      let time_in_ns = Mirage_mtime.elapsed_ns () - start_time in
       Int64.to_float time_in_ns /. 1e9
     in
     Log.info (fun f -> f "QubesDB and qrexec agents connected in %.3f s" startup_time);
@@ -113,5 +110,4 @@ module Main (R : Mirage_crypto_rng_mirage.S)(Clock : Mirage_clock.MCLOCK)(Time :
     (* 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. *)
-    Time.sleep_ns (1.0 *. 1e9 |> Int64.of_float)
-end
+    Mirage_sleep.ns (1.0 *. 1e9 |> Int64.of_float)