Merge pull request #136 from hannesm/fixes

update to dns 6.1.0

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

build-with-docker.sh

@@ -5,5 +5,5 @@ docker build -t qubes-mirage-firewall .
 echo Building Firewall...
 docker run --rm -i -v `pwd`:/home/opam/qubes-mirage-firewall qubes-mirage-firewall
 echo "SHA2 of build:   $(sha256sum qubes_firewall.xen)"
-echo "SHA2 last known: 14cc59ec7c3754f83f7422d48176bc0eb8e47d3c3ef116ae09619409b590d3cb"
+echo "SHA2 last known: 4f4b21a8f9d131486700f8be9bd15067878907313b2ebc7a048c27af8a918e1e"
 echo "(hashes should match for released versions)"

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)

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