Attempt to update to the new Mirage / DNS APIs

.gitignore

@@ -3,7 +3,13 @@ _build/
 log
 key_gen.ml
 main.ml
-main.native
-mir-qubes-test
-qubes-skeleton.xl.in
-qubes-skeleton_libvirt.xml
+qubes_skeleton.xl.in
+qubes_skeleton_libvirt.xml
+.merlin
+dune
+dune-project
+dune.build
+dune.config
+mirage-unikernel-qubes_skeleton-xen.opam
+.mirage.config
+myocamlbuild.ml

README.md

@@ -10,11 +10,12 @@ done automatically by `mirage configure -t qubes`. This repo remains for educati
 The example code queries QubesDB to get the network configuration, resolves "google.com" using its network VM's DNS service and then fetches "http://google.com".
 It also responds provides a qrexec command, which can be invoked from dom0 (or other domains, if you allow it).
 
-To build (ensure you have mirage 3.0.0 or later):
+To build (ensure you have mirage 3.9.0 or later):
 
     $ opam install mirage
     # NB: We specifically target xen to show explicitly the QubesOS setup independently from the mirage automatic configuration
     $ mirage configure -t xen   
+    $ make depend
     $ make
 
 You can use this with the [test-mirage][] scripts to deploy the unikernel (`qubes_skeleton.xen`) from your development AppVM. e.g.
@@ -96,7 +97,7 @@ You can invoke commands from dom0. e.g.
 
 # LICENSE
 
-Copyright (c) 2016, Thomas Leonard
+Copyright (c) 2020, Thomas Leonard
 All rights reserved.
 
 Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
@@ -109,4 +110,4 @@ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
 gg
 
 [test-mirage]: https://github.com/talex5/qubes-test-mirage
-[mirage-qubes]: https://github.com/talex5/mirage-qubes
+[mirage-qubes]: https://github.com/mirage/mirage-qubes

config.ml

@@ -4,13 +4,15 @@ let main =
   let packages = [
     package "mirage-qubes";
     package "dns";
-    package "mirage-dns";
+    package "dns-client" ~sublibs:["mirage"] ~min:"4.5.0";
   ] in
   foreign
     ~packages
-    "Unikernel.Main" (qubesdb @-> stackv4 @-> time @-> job)
+    "Unikernel.Main" (random @-> qubesdb @-> stackv4 @-> time @-> mclock @-> job)
+
+let stack = qubes_ipv4_stack default_network
 
 let () =
   register "qubes-skeleton" ~argv:no_argv [
-    main $ default_qubesdb $ qubes_ipv4_stack default_network $ default_time
+    main $ default_random $ default_qubesdb $ stack $ default_time $ default_monotonic_clock
   ]

unikernel.ml

@@ -2,7 +2,6 @@
    See the README file for details. *)
 
 open Lwt
-open Qubes
 
 let src = Logs.Src.create "unikernel" ~doc:"Main unikernel code"
 module Log = (val Logs.src_log src : Logs.LOG)
@@ -16,12 +15,14 @@ let rec first_v4 = function
     | Some ipv4 -> Some ipv4
 
 module Main
+    (Random : Mirage_random.S)
     (DB : Qubes.S.DB)
-    (Stack : Mirage_stack_lwt.V4)
-    (Time : Mirage_time_lwt.S) = struct
+    (Stack : Mirage_stack.V4)
+    (Time : Mirage_time.S)
+    (Clock : Mirage_clock.MCLOCK) = struct
 
   (* Initialise DNS resolver *)
-  module Resolver = Dns_resolver_mirage.Make(Time)(Stack)
+  module Resolver = Dns_client_mirage.Make(Random)(Time)(Clock)(Stack)
 
   let get_required qubesDB key =
     match DB.read qubesDB key with
@@ -30,31 +31,29 @@ module Main
       Log.info (fun f -> f "QubesDB %S = %S" key v);
       v
 
-  let start qubesDB stack _time =
+  let start _random qubesDB stack _time _clock =
     Log.info (fun f -> f "Starting");
     (* Start qrexec agent and GUI agent in parallel *)
-    let qrexec = RExec.connect ~domid:0 () in
-    let gui = GUI.connect ~domid:0 () in
+    let qrexec = Qubes.RExec.connect ~domid:0 () in
+    let gui = Qubes.GUI.connect ~domid:0 () in
     (* Wait for clients to connect *)
     qrexec >>= fun qrexec ->
-    let agent_listener = RExec.listen qrexec Command.handler in
+    let agent_listener = Qubes.RExec.listen qrexec Command.handler in
     gui >>= fun gui ->
-    Lwt.async (fun () -> GUI.listen gui);
+    Lwt.async (fun () -> Qubes.GUI.listen gui ());
     Lwt.async (fun () ->
       OS.Lifecycle.await_shutdown_request () >>= fun (`Poweroff | `Reboot) ->
-      RExec.disconnect qrexec
+      Qubes.RExec.disconnect qrexec
     );
-    let resolver = Resolver.create stack in
-    let dns = get_required qubesDB "/qubes-primary-dns" |> Ipaddr.V4.of_string_exn in
-
+    let nameserver_ip = get_required qubesDB "/qubes-primary-dns" |> Ipaddr.V4.of_string_exn in
+    let resolver = Resolver.create stack ~nameserver:(`UDP, (nameserver_ip, 53)) in
     (* Test by downloading http://google.com *)
-    let test_host = "google.com" in
-    Log.info (fun f -> f "Resolving %S" test_host);
-    Resolver.gethostbyname resolver ~server:dns test_host >>= fun addresses ->
-    match first_v4 addresses with
-    | None -> failwith "google.com didn't resolve!"
-    | Some google ->
-    Log.info (fun f -> f "%S has IPv4 address %a" test_host Ipaddr.V4.pp google);
+    let test_host = Domain_name.of_string_exn "google.com" |> Domain_name.host_exn in
+    Log.info (fun f -> f "Resolving %a" Domain_name.pp test_host);
+    Resolver.gethostbyname resolver test_host >>= function
+    | Error (`Msg msg) -> Fmt.failwith "google.com didn't resolve: %s" msg
+    | Ok google ->
+    Log.info (fun f -> f "%a has IPv4 address %a" Domain_name.pp test_host Ipaddr.V4.pp google);
     let tcp = Stack.tcpv4 stack in
     let port = 80 in
     Log.info (fun f -> f "Opening TCP connection to %a:%d" Ipaddr.V4.pp google port);