Merge 958b84430a into e36ffdb0a5

Dockerfile

@@ -23,8 +23,8 @@ 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#4399f486aa6edefdc96d5e206a65ce42288ebfdd
+RUN opam init --disable-sandboxing -a --bare https://github.com/ocaml/opam-repository.git#f9f113a6bb242a13702859873fa0fcef9146eb6a
-RUN opam switch create myswitch 4.14.1
+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

Makefile.builder

@@ -1,5 +1,5 @@
 MIRAGE_KERNEL_NAME = dist/qubes-firewall.xen
-OCAML_VERSION ?= 4.14.0
+OCAML_VERSION ?= 4.14.2
 SOURCE_BUILD_DEP := firewall-build-dep
 
 firewall-build-dep:

build-with.sh

@@ -20,5 +20,5 @@ $builder build -t qubes-mirage-firewall .
 echo Building Firewall...
 $builder run --rm -i -v `pwd`:/tmp/orb-build:Z qubes-mirage-firewall
 echo "SHA2 of build:   $(sha256sum ./dist/qubes-firewall.xen)"
-echo "SHA2 last known: 163991ea96842e03d378501a0be99057ad2489440aff8ae81d850624d98fd3f0"
+echo "SHA2 last known: 0cbb202c1b93e10ad115c9e988f9384005656c0855ec9deaf05a5e9ac9972984"
 echo "(hashes should match for released versions)"

config.ml

@@ -18,13 +18,11 @@ let main =
     ~packages:[
       package "vchan" ~min:"4.0.2";
       package "cstruct";
-      package "astring";
       package "tcpip" ~min:"3.7.0";
       package ~min:"2.3.0" ~sublibs:["mirage"] "arp";
       package ~min:"3.0.0" "ethernet";
       package "shared-memory-ring" ~min:"3.0.0";
-      package ~min:"2.1.3" "netchannel";
+      package "mirage-net-xen" ~min:"2.1.4";
-      package "mirage-net-xen" ~min:"2.1.3";
       package "ipaddr" ~min:"5.2.0";
       package "mirage-qubes" ~min:"0.9.1";
       package ~min:"3.0.1" "mirage-nat";

dao.ml

@@ -3,7 +3,6 @@
 
 open Lwt.Infix
 open Qubes
-open Astring
 
 let src = Logs.Src.create "dao" ~doc:"QubesDB data access"
 module Log = (val Logs.src_log src : Logs.LOG)
@@ -66,26 +65,26 @@ let read_rules rules client_ip =
                              number = 0;})]
 
 let vifs client domid =
-  match String.to_int domid with
+  match int_of_string_opt domid with
   | None -> Log.err (fun f -> f "Invalid domid %S" domid); Lwt.return []
   | Some domid ->
     let path = Printf.sprintf "backend/vif/%d" domid in
     Xen_os.Xs.immediate client (fun handle ->
         directory ~handle path >>=
         Lwt_list.filter_map_p (fun device_id ->
-            match String.to_int device_id with
+            match int_of_string_opt device_id with
             | None -> Log.err (fun f -> f "Invalid device ID %S for domid %d" device_id domid); Lwt.return_none
             | Some device_id ->
               let vif = { ClientVif.domid; device_id } in
               Lwt.try_bind
                 (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
+                   let client_ip' = match String.split_on_char ' ' client_ip with
                      | [] -> Log.err (fun m -> m "unexpected empty list"); ""
                      | [ ip ] -> ip
                      | ip::rest ->
                        Log.warn (fun m -> m "ignoring IPs %s from %a, we support one IP per client"
-                                    (String.concat ~sep:" " rest) ClientVif.pp vif);
+                                    (String.concat " " rest) ClientVif.pp vif);
                        ip
                    in
                    match Ipaddr.V4.of_string client_ip' with

dispatcher.ml

@@ -1,6 +1,6 @@
 open Lwt.Infix
 open Fw_utils
-module Netback = Netchannel.Backend.Make (Netchannel.Xenstore.Make (Xen_os.Xs))
+module Netback = Backend.Make (Xenstore.Make (Xen_os.Xs))
 module ClientEth = Ethernet.Make (Netback)
 module UplinkEth = Ethernet.Make (Netif)
 
@@ -446,14 +446,14 @@ struct
                  clients := !clients |> Dao.VifMap.add key cleanup)))
 
   let send_dns_client_query t ~src_port ~dst ~dst_port buf =
-    match t with
+    match t.uplink with
     | None ->
         Log.err (fun f -> f "No uplink interface");
         Lwt.return (Error (`Msg "failure"))
-    | Some t -> (
+    | Some uplink -> (
         Lwt.catch
           (fun () ->
-            U.write ~src_port ~dst ~dst_port t.udp buf >|= function
+            U.write ~src_port ~dst ~dst_port uplink.udp buf >|= function
             | Error s ->
                 Log.err (fun f -> f "error sending udp packet: %a" U.pp_error s);
                 Error (`Msg "failure")

unikernel.ml

@@ -103,7 +103,7 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_tim
       ~uplink:None
     in
 
-    let send_dns_query = Dispatcher.send_dns_client_query None in
+    let send_dns_query = Dispatcher.send_dns_client_query router in
     let dns_mvar = Lwt_mvar.create_empty () in
     let nameservers = `Udp, [ config.Dao.dns, 53 ; config.Dao.dns2, 53 ] in
     let dns_client = Dns_client.create ~nameservers (router, send_dns_query, dns_mvar) in