From 748f803ca0ee2135aa70271d9ef3ef56f33baf2b Mon Sep 17 00:00:00 2001
From: Hannes Mehnert <hannes@mehnert.org>
Date: Wed, 10 Nov 2021 18:16:55 +0100
Subject: [PATCH] update to dns 6.1.0

---
 Dockerfile |  2 +-
 config.ml  |  2 +-
 my_dns.ml  | 35 +++++++++++++----------------------
 3 files changed, 15 insertions(+), 24 deletions(-)

diff --git a/Dockerfile b/Dockerfile
index cafdeb1..4c11bc1 100644
--- a/Dockerfile
+++ b/Dockerfile
@@ -7,7 +7,7 @@ FROM ocurrent/opam@sha256:fce44a073ff874166b51c33a4e37782286d48dbba1b5aa43563a0d
 # 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 87ef72b5cd492573258eb1b6f3b30c88af31ae3f && opam update
+RUN cd ~/opam-repository && git fetch origin master && git reset --hard 295910defa4dedc27af45ca64d63e8927f8261ff && opam update
 
 RUN opam depext -i -y mirage
 RUN mkdir /home/opam/qubes-mirage-firewall
diff --git a/config.ml b/config.ml
index 8e2a763..452a165 100644
--- a/config.ml
+++ b/config.ml
@@ -33,7 +33,7 @@ let main =
       package "mirage-nat" ~min:"2.2.1";
       package "mirage-logs";
       package "mirage-xen" ~min:"6.0.0";
-      package ~min:"6.0.0" "dns-client";
+      package ~min:"6.1.0" "dns-client";
       package "pf-qubes";
     ]
     "Unikernel.Main" (random @-> mclock @-> job)
diff --git a/my_dns.ml b/my_dns.ml
index 24aeac3..a0e8b18 100644
--- a/my_dns.ml
+++ b/my_dns.ml
@@ -11,7 +11,7 @@ module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) = struct
     stack : stack ;
     timeout_ns : int64 ;
   }
-  type context = { t : t ; timeout_ns : int64 ref; mutable src_port : int }
+  type context = t
 
   let nameservers { protocol ; nameserver ; _ } = protocol, [ nameserver ]
   let rng = R.generate ?g:None
@@ -24,32 +24,23 @@ module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) = struct
     in
     { protocol ; nameserver ; stack ; timeout_ns = timeout }
 
-  let with_timeout ctx f =
-    let timeout = OS.Time.sleep_ns !(ctx.timeout_ns) >|= fun () -> Error (`Msg "DNS request timeout") in
-    let start = clock () in
-    Lwt.pick [ f ; timeout ] >|= fun result ->
-    let stop = clock () in
-    ctx.timeout_ns := Int64.sub !(ctx.timeout_ns) (Int64.sub stop start);
-    result
+  let with_timeout timeout_ns f =
+    let timeout = OS.Time.sleep_ns timeout_ns >|= fun () -> Error (`Msg "DNS request timeout") in
+    Lwt.pick [ f ; timeout ]
 
-  let connect (t : t) = Lwt.return (Ok { t ; timeout_ns = ref t.timeout_ns ; src_port = 0 })
+  let connect (t : t) = Lwt.return (Ok t)
 
-  let send (ctx : context) buf : (unit, [> `Msg of string ]) result Lwt.t =
+  let send_recv (ctx : context) buf : (Cstruct.t, [> `Msg of string ]) result Lwt.t =
     let open Router in
     let open My_nat in
-    let dst, dst_port = ctx.t.nameserver in
-    let router, send_udp, _ = ctx.t.stack in
+    let dst, dst_port = ctx.nameserver in
+    let router, send_udp, answer = ctx.stack in
     let src_port = Ports.pick_free_port ~consult:router.ports.nat_udp router.ports.dns_udp in
-    ctx.src_port <- src_port;
-    with_timeout ctx (send_udp ~src_port ~dst ~dst_port buf >|= Rresult.R.open_error_msg)
-
-  let recv ctx =
-    let open Router in
-    let open My_nat in
-    let router, _, answers = ctx.t.stack in
-    with_timeout ctx
-      (Lwt_mvar.take answers >|= fun (_, dns_response) -> Ok dns_response) >|= fun result ->
-    router.ports.dns_udp := Ports.remove ctx.src_port !(router.ports.dns_udp);
+    with_timeout ctx.timeout_ns
+      ((send_udp ~src_port ~dst ~dst_port buf >|= Rresult.R.open_error_msg) >>= function
+        | Ok () -> (Lwt_mvar.take answer >|= fun (_, dns_response) -> Ok dns_response)
+        | Error _ as e -> Lwt.return e) >|= fun result ->
+    router.ports.dns_udp := Ports.remove src_port !(router.ports.dns_udp);
     result
 
   let close _ = Lwt.return_unit