Merge pull request #14 from avsm/mirage-fixes

Mirage fixes

.travis-ci.sh

@@ -1,4 +1,4 @@
-OPAM_DEPENDS="lwt cstruct ipaddr re ounit cmdliner"
+OPAM_DEPENDS="lwt cstruct ipaddr re ounit cmdliner io-page sexplib"
 
 case "$OCAML_VERSION,$OPAM_VERSION" in
 3.12.1,1.0.0) ppa=avsm/ocaml312+opam10 ;;

CHANGES

@@ -1,3 +1,9 @@
+0.9.0 (2014-06-16):
+* Ensure that all `Dns.Buf.t` buffers are page-aligned, via `Io_page`.
+* Remove a Unix dependency that snuck into the `Dns_resolver` portable
+  core, by adding a timeout argument to the `commfn` type.
+* Improve ocamldoc in `Dns_resolver_unix`.
+
 0.8.1 (2014-04-19):
 * Add `process_of_zonebufs` to handle multiple zone files.
 * Adapt `Dns_server_unix` to expose multiple zonebuf functions.

_oasis

@@ -1,7 +1,7 @@
 OASISFormat: 0.3
 OCamlVersion: >= 4.00.0
 Name:        dns
-Version:     0.8.1
+Version:     0.9.0
 Authors:     Anil Madhavapeddy, Tim Deegan, Richard Mortier, Haris Rotsos, David Sheets, Thomas Gazagnaire
 Maintainers: Anil Madhavapeddy <[email protected]>
 License:     ISC
@@ -28,18 +28,20 @@ Library dns
   Modules:
     Base64, Hashcons, Loader, Name, Operators, Packet, Query, RR, Trie,
     Zone, Zone_lexer, Zone_parser, Resolvconf, Buf, Protocol
-  BuildDepends:	cstruct (>= 0.7.1), cstruct.syntax, re, re.str, ipaddr (>= 2.2.0)
+  BuildDepends:	cstruct (>= 0.7.1), cstruct.syntax, re, re.str, ipaddr (>= 2.2.0), io-page
+  XMetaRequires: cstruct, re, re.str, ipaddr, io-page
 
-Library lwt
+Library "dns-lwt"
   Path: lwt
   Build$: flag(lwt)
   Install$: flag(lwt)
   Findlibname: lwt
   Modules: Dns_server_unix, Dns_resolver_unix
-  BuildDepends: lwt.unix (>= 2.4.1), cstruct.lwt, lwt.syntax, dns, dns.lwt-core, ipaddr.unix
+  BuildDepends: lwt.unix (>= 2.4.1), cstruct.lwt, lwt.syntax, dns, dns.lwt-core, ipaddr.unix, io-page.unix
+  XMetaRequires: lwt.unix, cstruct.lwt, dns, dns.lwt-core, ipaddr.unix, io-page.unix
   FindlibParent: dns
 
-Library "lwt-core"
+Library "dns-lwt-core"
   Path: lwt
   Build$: flag(lwt)
   Install$: flag(lwt)

_tags

@@ -1,5 +1,5 @@
 # OASIS_START
-# DO NOT EDIT (digest: b46ef21097bddd75899af6867db104a7)
+# DO NOT EDIT (digest: 78990316922073e9f73a863c21eff3b9)
 # Ignore VCS directories, you can use the same kind of rule outside
 # OASIS_START/STOP if you want to exclude directories that contains
 # useless stuff for the build process
@@ -30,87 +30,98 @@
 "lib/resolvconf.cmx": for-pack(Dns)
 "lib/buf.cmx": for-pack(Dns)
 "lib/protocol.cmx": for-pack(Dns)
-<lib/*.ml{,i}>: package(re)
-<lib/*.ml{,i}>: package(re.str)
-<lib/*.ml{,i}>: package(ipaddr)
 <lib/*.ml{,i}>: package(cstruct)
 <lib/*.ml{,i}>: package(cstruct.syntax)
-# Library lwt-core
-"lwt/lwt-core.cmxs": use_lwt-core
-# Library lwt
-"lwt/lwt.cmxs": use_lwt
+<lib/*.ml{,i}>: package(io-page)
+<lib/*.ml{,i}>: package(ipaddr)
+<lib/*.ml{,i}>: package(re)
+<lib/*.ml{,i}>: package(re.str)
+# Library dns-lwt-core
+"lwt/dns-lwt-core.cmxs": use_dns-lwt-core
+# Library dns-lwt
+"lwt/dns-lwt.cmxs": use_dns-lwt
 # Executable lwt_server
-<lib_test/lwt_server.{native,byte}>: use_lwt
-<lib_test/lwt_server.{native,byte}>: use_lwt-core
-<lib_test/lwt_server.{native,byte}>: use_dns
+<lib_test/lwt_server.{native,byte}>: package(cstruct)
+<lib_test/lwt_server.{native,byte}>: package(cstruct.lwt)
+<lib_test/lwt_server.{native,byte}>: package(cstruct.syntax)
+<lib_test/lwt_server.{native,byte}>: package(io-page)
+<lib_test/lwt_server.{native,byte}>: package(io-page.unix)
+<lib_test/lwt_server.{native,byte}>: package(ipaddr)
+<lib_test/lwt_server.{native,byte}>: package(ipaddr.unix)
 <lib_test/lwt_server.{native,byte}>: package(lwt)
-<lib_test/lwt_server.{native,byte}>: package(lwt.unix)
 <lib_test/lwt_server.{native,byte}>: package(lwt.syntax)
+<lib_test/lwt_server.{native,byte}>: package(lwt.unix)
 <lib_test/lwt_server.{native,byte}>: package(re)
 <lib_test/lwt_server.{native,byte}>: package(re.str)
-<lib_test/lwt_server.{native,byte}>: package(ipaddr)
-<lib_test/lwt_server.{native,byte}>: package(cstruct.lwt)
-<lib_test/lwt_server.{native,byte}>: package(ipaddr.unix)
-<lib_test/lwt_server.{native,byte}>: package(cstruct)
-<lib_test/lwt_server.{native,byte}>: package(cstruct.syntax)
+<lib_test/lwt_server.{native,byte}>: use_dns
+<lib_test/lwt_server.{native,byte}>: use_dns-lwt
+<lib_test/lwt_server.{native,byte}>: use_dns-lwt-core
 <lib_test/lwt_server.{native,byte}>: custom
 # Executable time_server
-<lib_test/time_server.{native,byte}>: use_lwt
-<lib_test/time_server.{native,byte}>: use_lwt-core
-<lib_test/time_server.{native,byte}>: use_dns
+<lib_test/time_server.{native,byte}>: package(cstruct)
+<lib_test/time_server.{native,byte}>: package(cstruct.lwt)
+<lib_test/time_server.{native,byte}>: package(cstruct.syntax)
+<lib_test/time_server.{native,byte}>: package(io-page)
+<lib_test/time_server.{native,byte}>: package(io-page.unix)
+<lib_test/time_server.{native,byte}>: package(ipaddr)
+<lib_test/time_server.{native,byte}>: package(ipaddr.unix)
 <lib_test/time_server.{native,byte}>: package(lwt)
-<lib_test/time_server.{native,byte}>: package(lwt.unix)
 <lib_test/time_server.{native,byte}>: package(lwt.syntax)
+<lib_test/time_server.{native,byte}>: package(lwt.unix)
 <lib_test/time_server.{native,byte}>: package(re)
 <lib_test/time_server.{native,byte}>: package(re.str)
-<lib_test/time_server.{native,byte}>: package(ipaddr)
-<lib_test/time_server.{native,byte}>: package(cstruct.lwt)
-<lib_test/time_server.{native,byte}>: package(ipaddr.unix)
-<lib_test/time_server.{native,byte}>: package(cstruct)
-<lib_test/time_server.{native,byte}>: package(cstruct.syntax)
-<lib_test/*.ml{,i}>: use_lwt
-<lib_test/*.ml{,i}>: use_lwt-core
-<lib_test/*.ml{,i}>: use_dns
+<lib_test/time_server.{native,byte}>: use_dns
+<lib_test/time_server.{native,byte}>: use_dns-lwt
+<lib_test/time_server.{native,byte}>: use_dns-lwt-core
+<lib_test/*.ml{,i}>: package(cstruct)
+<lib_test/*.ml{,i}>: package(cstruct.lwt)
+<lib_test/*.ml{,i}>: package(cstruct.syntax)
+<lib_test/*.ml{,i}>: package(io-page)
+<lib_test/*.ml{,i}>: package(io-page.unix)
+<lib_test/*.ml{,i}>: package(ipaddr)
+<lib_test/*.ml{,i}>: package(ipaddr.unix)
 <lib_test/*.ml{,i}>: package(lwt)
-<lib_test/*.ml{,i}>: package(lwt.unix)
 <lib_test/*.ml{,i}>: package(lwt.syntax)
+<lib_test/*.ml{,i}>: package(lwt.unix)
 <lib_test/*.ml{,i}>: package(re)
 <lib_test/*.ml{,i}>: package(re.str)
-<lib_test/*.ml{,i}>: package(ipaddr)
-<lib_test/*.ml{,i}>: package(cstruct.lwt)
-<lib_test/*.ml{,i}>: package(ipaddr.unix)
-<lib_test/*.ml{,i}>: package(cstruct)
-<lib_test/*.ml{,i}>: package(cstruct.syntax)
+<lib_test/*.ml{,i}>: use_dns
+<lib_test/*.ml{,i}>: use_dns-lwt
+<lib_test/*.ml{,i}>: use_dns-lwt-core
 <lib_test/time_server.{native,byte}>: custom
 # Executable mldig
-<lwt/mldig.{native,byte}>: use_lwt
-<lwt/mldig.{native,byte}>: use_lwt-core
-<lwt/mldig.{native,byte}>: use_dns
+<lwt/mldig.{native,byte}>: package(cmdliner)
+<lwt/mldig.{native,byte}>: package(cstruct)
+<lwt/mldig.{native,byte}>: package(cstruct.lwt)
+<lwt/mldig.{native,byte}>: package(cstruct.syntax)
+<lwt/mldig.{native,byte}>: package(io-page)
+<lwt/mldig.{native,byte}>: package(io-page.unix)
+<lwt/mldig.{native,byte}>: package(ipaddr)
+<lwt/mldig.{native,byte}>: package(ipaddr.unix)
 <lwt/mldig.{native,byte}>: package(lwt)
-<lwt/mldig.{native,byte}>: package(lwt.unix)
 <lwt/mldig.{native,byte}>: package(lwt.syntax)
+<lwt/mldig.{native,byte}>: package(lwt.unix)
 <lwt/mldig.{native,byte}>: package(re)
 <lwt/mldig.{native,byte}>: package(re.str)
-<lwt/mldig.{native,byte}>: package(ipaddr)
-<lwt/mldig.{native,byte}>: package(cmdliner)
-<lwt/mldig.{native,byte}>: package(cstruct.lwt)
-<lwt/mldig.{native,byte}>: package(ipaddr.unix)
-<lwt/mldig.{native,byte}>: package(cstruct)
-<lwt/mldig.{native,byte}>: package(cstruct.syntax)
-<lwt/*.ml{,i}>: use_lwt
-<lwt/*.ml{,i}>: use_lwt-core
-<lwt/*.ml{,i}>: use_dns
+<lwt/mldig.{native,byte}>: use_dns
+<lwt/mldig.{native,byte}>: use_dns-lwt
+<lwt/mldig.{native,byte}>: use_dns-lwt-core
+<lwt/*.ml{,i}>: package(cmdliner)
+<lwt/*.ml{,i}>: package(cstruct)
+<lwt/*.ml{,i}>: package(cstruct.lwt)
+<lwt/*.ml{,i}>: package(cstruct.syntax)
+<lwt/*.ml{,i}>: package(io-page)
+<lwt/*.ml{,i}>: package(io-page.unix)
+<lwt/*.ml{,i}>: package(ipaddr)
+<lwt/*.ml{,i}>: package(ipaddr.unix)
 <lwt/*.ml{,i}>: package(lwt)
-<lwt/*.ml{,i}>: package(lwt.unix)
 <lwt/*.ml{,i}>: package(lwt.syntax)
+<lwt/*.ml{,i}>: package(lwt.unix)
 <lwt/*.ml{,i}>: package(re)
 <lwt/*.ml{,i}>: package(re.str)
-<lwt/*.ml{,i}>: package(ipaddr)
-<lwt/*.ml{,i}>: package(cmdliner)
-<lwt/*.ml{,i}>: package(cstruct.lwt)
-<lwt/*.ml{,i}>: package(ipaddr.unix)
-<lwt/*.ml{,i}>: package(cstruct)
-<lwt/*.ml{,i}>: package(cstruct.syntax)
+<lwt/*.ml{,i}>: use_dns
+<lwt/*.ml{,i}>: use_dns-lwt
+<lwt/*.ml{,i}>: use_dns-lwt-core
 <lwt/mldig.{native,byte}>: custom
 # OASIS_STOP
 true: annot, bin_annot

lib/META

@@ -1,33 +1,33 @@
 # OASIS_START
-# DO NOT EDIT (digest: d3cbf6ebdc6f9751873f39d04006b018)
-version = "0.8.1"
+# DO NOT EDIT (digest: 37fff05d34d3cd5577e9d02d196797be)
+version = "0.9.0"
 description = "DNS client and server implementation"
-requires = "cstruct cstruct.syntax re re.str ipaddr"
+requires = "cstruct re re.str ipaddr io-page"
 archive(byte) = "dns.cma"
 archive(byte, plugin) = "dns.cma"
 archive(native) = "dns.cmxa"
 archive(native, plugin) = "dns.cmxs"
 exists_if = "dns.cma"
 package "lwt-core" (
- version = "0.8.1"
+ version = "0.9.0"
  description = "DNS client and server implementation"
  requires = "lwt cstruct lwt.syntax dns"
- archive(byte) = "lwt-core.cma"
- archive(byte, plugin) = "lwt-core.cma"
- archive(native) = "lwt-core.cmxa"
- archive(native, plugin) = "lwt-core.cmxs"
- exists_if = "lwt-core.cma"
+ archive(byte) = "dns-lwt-core.cma"
+ archive(byte, plugin) = "dns-lwt-core.cma"
+ archive(native) = "dns-lwt-core.cmxa"
+ archive(native, plugin) = "dns-lwt-core.cmxs"
+ exists_if = "dns-lwt-core.cma"
 )
 
 package "lwt" (
- version = "0.8.1"
+ version = "0.9.0"
  description = "DNS client and server implementation"
- requires = "lwt.unix cstruct.lwt lwt.syntax dns dns.lwt-core ipaddr.unix"
- archive(byte) = "lwt.cma"
- archive(byte, plugin) = "lwt.cma"
- archive(native) = "lwt.cmxa"
- archive(native, plugin) = "lwt.cmxs"
- exists_if = "lwt.cma"
+ requires = "lwt.unix cstruct.lwt dns dns.lwt-core ipaddr.unix io-page.unix"
+ archive(byte) = "dns-lwt.cma"
+ archive(byte, plugin) = "dns-lwt.cma"
+ archive(native) = "dns-lwt.cmxa"
+ archive(native, plugin) = "dns-lwt.cmxs"
+ exists_if = "dns-lwt.cma"
 )
 # OASIS_STOP
 

lib/RR.ml

@@ -103,3 +103,4 @@ let rdata_to_string = function
   | X25 _ -> "X25"
   | DNSKEY _ -> "DNSKEY"
   | RRSIG _ -> "RRSIG"
+  | DS _ -> "DS"

lib/buf.ml

@@ -20,7 +20,7 @@ module B1 = B.Array1
 
 type t = (char, B.int8_unsigned_elt, B.c_layout) B1.t
 
-let create = B1.create B.char B.c_layout
+let create len = B1.sub (Io_page.get 1) 0 len
 let length = B1.dim
 let of_cstruct c = Cstruct.(B1.sub c.buffer c.off c.len)
 let shift b k = B1.sub b k (length b - k)

lib/dns.mldylib

@@ -0,0 +1,4 @@
+# OASIS_START
+# DO NOT EDIT (digest: 4d3cc87f77cb704db96a7dc499206433)
+Dns
+# OASIS_STOP

lib/packet.ml

@@ -1226,7 +1226,10 @@ let parse_rr names base buf =
     | None ->
         let ttl = get_rr_ttl buf in
         let rdlen = get_rr_rdlen buf in
-        let Some(cls) = int_to_rr_class (get_rr_cls buf) in
+        let cls =
+          match int_to_rr_class (get_rr_cls buf) with
+          | None -> failwith "invalid RR class"
+          | Some cls -> cls in
         let data = Cstruct.to_string
         (Cstruct.sub buf sizeof_rr rdlen) in
         ({name; cls; ttl; rdata=UNKNOWN(t, data) },

lwt/dns-lwt-core.mldylib

@@ -0,0 +1,5 @@
+# OASIS_START
+# DO NOT EDIT (digest: afa1c4196651341a2e7387809c75f0c6)
+Dns_server
+Dns_resolver
+# OASIS_STOP

lwt/dns-lwt-core.mllib

@@ -0,0 +1,5 @@
+# OASIS_START
+# DO NOT EDIT (digest: afa1c4196651341a2e7387809c75f0c6)
+Dns_server
+Dns_resolver
+# OASIS_STOP

lwt/dns-lwt.mllib

@@ -0,0 +1,5 @@
+# OASIS_START
+# DO NOT EDIT (digest: 09366b2cb909b9a863aa9377be528fb5)
+Dns_server_unix
+Dns_resolver_unix
+# OASIS_STOP

lwt/dns_resolver.ml

@@ -27,29 +27,31 @@ module DP = Dns.Packet
 type result = Answer of DP.t | Error of exn
 
 type commfn =
-  (Dns.Buf.t -> unit Lwt.t) * ((Dns.Buf.t -> Dns.Packet.t option) -> DP.t Lwt.t)
+  (Dns.Buf.t -> unit Lwt.t) *
+  ((Dns.Buf.t -> Dns.Packet.t option) -> DP.t Lwt.t) * 
+  (unit -> unit Lwt.t)
 
 let log_info s = eprintf "INFO: %s\n%!" s
 let log_debug s = eprintf "DEBUG: %s\n%!" s
 let log_warn s = eprintf "WARN: %s\n%!" s
 
-let rec send_req txfn q = function
+let rec send_req txfn timerfn q = function
   | 0 -> return ()
   | count ->
-      lwt _ = txfn q in
-      lwt _ = Lwt_unix.sleep 5.0 in
+      txfn q >>= fun _ ->
+      timerfn () >>= fun () ->
       printf "retrying query for %d times\n%!" (4-count);
-      send_req txfn q (count - 1)
+      send_req txfn timerfn q (count - 1)
 
-let send_pkt client (txfn,rxfn) pkt =
+let send_pkt client (txfn,rxfn,timerfn) pkt =
   let module R = (val client : CLIENT) in
   let cqpl = R.marshal pkt in
   let resl = List.map (fun (ctxt,q) ->
     (* make a new socket for each request flavor *)
     (* start the requests in parallel and run them until success or timeout*)
     let t, w = Lwt.wait () in
     async (fun () -> pick [
-      (send_req txfn q 4
+      (send_req txfn timerfn q 4
        >>= fun () -> return (wakeup w (Error (R.timeout ctxt))));
       (catch
          (fun () ->
@@ -77,7 +79,7 @@ let send_pkt client (txfn,rxfn) pkt =
 
 let resolve client
     ?(dnssec=false)
-    commfn
+    (commfn:commfn)
     (q_class:DP.q_class) (q_type:DP.q_type)
     (q_name:domain_name) =
     try_lwt

lwt/dns_resolver.mli

@@ -17,7 +17,8 @@
 
 type commfn =
   (Dns.Buf.t -> unit Lwt.t) *
-  ((Dns.Buf.t -> Dns.Packet.t option) -> Dns.Packet.t Lwt.t)
+  ((Dns.Buf.t -> Dns.Packet.t option) -> Dns.Packet.t Lwt.t) *
+  (unit -> unit Lwt.t)
 
 val resolve : 
   (module Dns.Protocol.CLIENT) ->

lwt/dns_resolver_unix.ml

@@ -45,6 +45,7 @@ let outfd addr port =
 let connect_to_resolver server port =
   let dst = sockaddr server port in
   let ofd = outfd "0.0.0.0" 0 in
+  let timerfn () = Lwt_unix.sleep 5.0 in
   let txfn buf =
     Lwt_bytes.sendto ofd buf 0 (Dns.Buf.length buf) [] dst 
     >>= fun _ -> return_unit in
@@ -57,7 +58,7 @@ let connect_to_resolver server port =
     | None -> rxfn f
     | Some r -> return r
   in
-  txfn, rxfn
+  txfn, rxfn, timerfn
 
 let resolve client
     ?(dnssec=false)