From 7e3303a8d61b23696b2601c81238a45478f0357b Mon Sep 17 00:00:00 2001
From: Hannes Mehnert <hannes@mehnert.org>
Date: Fri, 5 Nov 2021 19:53:39 +0100
Subject: [PATCH] read DNS resolver IP addresses from QubesDB as specified in
 https://www.qubes-os.org/doc/vm-interface/

---
 dao.ml       | 14 ++++++++++----
 dao.mli      |  1 +
 my_dns.ml    |  2 +-
 unikernel.ml |  3 ++-
 4 files changed, 14 insertions(+), 6 deletions(-)

diff --git a/dao.ml b/dao.ml
index d1580e1..383b1b6 100644
--- a/dao.ml
+++ b/dao.ml
@@ -125,11 +125,11 @@ type network_config = {
   uplink_our_ip : Ipaddr.V4.t;        (* The IP address of our interface to NetVM *)
 
   clients_our_ip : Ipaddr.V4.t;        (* The IP address of our interface to our client VMs (their gateway) *)
+  dns : Ipaddr.V4.t list;
 }
 
 exception Missing_key of string
 
-(* TODO: /qubes-secondary-dns *)
 let try_read_network_config db =
   let get name =
     match DB.KeyMap.find_opt name db with
@@ -138,14 +138,20 @@ let try_read_network_config db =
   let uplink_our_ip = get "/qubes-ip" |> Ipaddr.V4.of_string_exn in
   let uplink_netvm_ip = get "/qubes-gateway" |> Ipaddr.V4.of_string_exn in
   let clients_our_ip = get "/qubes-netvm-gateway" |> Ipaddr.V4.of_string_exn in
+  let dns =
+    [ get "/qubes-primary-dns" |> Ipaddr.V4.of_string_exn ;
+      get "/qubes-secondary-dns" |> Ipaddr.V4.of_string_exn ]
+  in
   Log.info (fun f -> f "@[<v2>Got network configuration from QubesDB:@,\
                         NetVM IP on uplink network: %a@,\
                         Our IP on uplink network:   %a@,\
-                        Our IP on client networks:  %a@]"
+                        Our IP on client networks:  %a@,\
+                        DNS resolvers:              %a@]"
                Ipaddr.V4.pp uplink_netvm_ip
                Ipaddr.V4.pp uplink_our_ip
-               Ipaddr.V4.pp clients_our_ip);
-  { uplink_netvm_ip; uplink_our_ip; clients_our_ip }
+               Ipaddr.V4.pp clients_our_ip
+               Fmt.(list ~sep:(any ", ") Ipaddr.V4.pp) dns);
+  { uplink_netvm_ip; uplink_our_ip; clients_our_ip ; dns }
 
 let read_network_config qubesDB =
   let rec aux bindings =
diff --git a/dao.mli b/dao.mli
index 811c2e7..94d418e 100644
--- a/dao.mli
+++ b/dao.mli
@@ -24,6 +24,7 @@ type network_config = {
   uplink_our_ip : Ipaddr.V4.t;        (* The IP address of our interface to NetVM *)
 
   clients_our_ip : Ipaddr.V4.t;        (* The IP address of our interface to our client VMs (their gateway) *)
+  dns : Ipaddr.V4.t list;
 }
 
 val read_network_config : Qubes.DB.t -> network_config Lwt.t
diff --git a/my_dns.ml b/my_dns.ml
index bcdfa47..ca2c0f8 100644
--- a/my_dns.ml
+++ b/my_dns.ml
@@ -34,7 +34,7 @@ module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) = struct
     let open Router in
     let open My_nat in
     let nslist = snd ctx.t.nameservers in
-    let dst, dst_port = List.hd(nslist) in
+    let dst, dst_port = List.hd nslist in
     let router, send_udp, _ = ctx.t.stack in
     let src_port = Ports.pick_free_port ~consult:router.ports.nat_udp router.ports.dns_udp in
     ctx.src_port <- src_port;
diff --git a/unikernel.ml b/unikernel.ml
index 72f2c83..0621e42 100644
--- a/unikernel.ml
+++ b/unikernel.ml
@@ -81,7 +81,8 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK) = struct
 
     let send_dns_query = Uplink.send_dns_client_query uplink in
     let dns_mvar = Lwt_mvar.create_empty () in
-    let dns_client = Dns_client.create (router, send_dns_query, dns_mvar) in
+    let nameservers = `Udp, List.map (fun ip -> ip, 53) config.Dao.dns in
+    let dns_client = Dns_client.create ~nameservers (router, send_dns_query, dns_mvar) in
 
     let net_listener = network (Dns_client.getaddrinfo dns_client Dns.Rr_map.A) dns_mvar uplink qubesDB router in