From ca70f2ea609af41985fcb13665772e1e23cdcf16 Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Sat, 5 Oct 2013 21:25:37 +0100 Subject: [PATCH 01/23] bump to 0.7.1 --- CHANGES | 2 ++ _oasis | 7 +++---- _tags | 11 +++++++++-- setup.ml | 10 ++++++---- 4 files changed, 20 insertions(+), 10 deletions(-) diff --git a/CHANGES b/CHANGES index 936dcbfe9..7ae13a9c8 100644 --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,5 @@ +0.7.1 (trunk): + 0.7.0 (2013-08-26): * Add path argument to `Resolv_conf in Dns_resolver.config. * `Dns_resolver.t` is now a record type rather than a first-class module. diff --git a/_oasis b/_oasis index 30410eea5..78a72b582 100644 --- a/_oasis +++ b/_oasis @@ -1,7 +1,7 @@ OASISFormat: 0.3 OCamlVersion: >= 4.00.0 Name: dns -Version: 0.7.0 +Version: 0.7.1 Authors: Anil Madhavapeddy, Tim Deegan, Richard Mortier, Haris Rotsos, David Sheets, Thomas Gazagnaire Maintainers: Anil Madhavapeddy License: LGPL-2.0 with OCaml linking exception @@ -44,8 +44,7 @@ Library lwt Install$: flag(lwt) Findlibname: lwt Modules: Dns_server, Dns_resolver - BuildDepends: - lwt.unix, lwt.syntax, dns + BuildDepends: lwt.unix, cstruct.lwt, lwt.syntax, dns FindlibParent: dns Library mirage @@ -99,7 +98,7 @@ Executable mldig Custom: true CompiledObject: best Install: false - BuildDepends: lwt, lwt.unix, lwt.syntax, dns, re, re.str, ipaddr, cmdliner + BuildDepends: lwt, lwt.unix, lwt.syntax, dns, dns.lwt, re, re.str, ipaddr, cmdliner Test lwt_server Run$: flag(tests) && flag(lwt) diff --git a/_tags b/_tags index 319dc1d76..3f1eaa02a 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: c803411911cbf0397826cf3612ce7c98) +# DO NOT EDIT (digest: 36f399606ab5d914c1dea54bb0950820) # 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 @@ -58,6 +58,7 @@ : pkg_ipaddr : pkg_cstruct : pkg_cstruct.syntax +: pkg_cstruct.lwt : custom # Executable time_server : use_lwt @@ -70,6 +71,7 @@ : pkg_ipaddr : pkg_cstruct : pkg_cstruct.syntax +: pkg_cstruct.lwt : use_lwt : use_dns : pkg_lwt @@ -80,8 +82,10 @@ : pkg_ipaddr : pkg_cstruct : pkg_cstruct.syntax +: pkg_cstruct.lwt : custom # Executable mldig +: use_lwt : use_dns : pkg_lwt : pkg_lwt.unix @@ -92,6 +96,8 @@ : pkg_cmdliner : pkg_cstruct : pkg_cstruct.syntax +: pkg_cstruct.lwt +: use_lwt : use_dns : pkg_lwt : pkg_lwt.unix @@ -102,9 +108,10 @@ : pkg_cmdliner : pkg_cstruct : pkg_cstruct.syntax +: pkg_cstruct.lwt : custom # OASIS_STOP -true: annot +true: annot, bin_annot : syntax_camlp4o, pkg_lwt.syntax : syntax_camlp4o, pkg_lwt.syntax : syntax_camlp4o, pkg_lwt.syntax diff --git a/setup.ml b/setup.ml index 7ac9802dc..499620149 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.3.0 *) (* OASIS_START *) -(* DO NOT EDIT (digest: b6a3a087ca64b47fcf89d7194580b133) *) +(* DO NOT EDIT (digest: 652f19a68d088ada97aa8b023308a6c0) *) (* Regenerated by OASIS v0.3.0 Visit http://oasis.forge.ocamlcore.org for more information and @@ -5752,7 +5752,7 @@ let setup_t = ocaml_version = Some (OASISVersion.VGreaterEqual "4.00.0"); findlib_version = None; name = "dns"; - version = "0.7.0"; + version = "0.7.1"; license = OASISLicense.DEP5License (OASISLicense.DEP5Unit @@ -5933,6 +5933,7 @@ let setup_t = bs_build_depends = [ FindlibPackage ("lwt.unix", None); + FindlibPackage ("cstruct.lwt", None); FindlibPackage ("lwt.syntax", None); InternalLibrary "dns" ]; @@ -6157,6 +6158,7 @@ let setup_t = FindlibPackage ("lwt.unix", None); FindlibPackage ("lwt.syntax", None); InternalLibrary "dns"; + InternalLibrary "lwt"; FindlibPackage ("re", None); FindlibPackage ("re.str", None); FindlibPackage ("ipaddr", None); @@ -6209,7 +6211,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.3.0"; - oasis_digest = Some "¯)5,M\031ÌI»Ák&sw¹\n"; + oasis_digest = Some "¹¡Ëñ\030\159^,ÍJ\142­\140\129]W"; oasis_exec = None; oasis_setup_args = []; setup_update = false; @@ -6217,6 +6219,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 6221 "setup.ml" +# 6223 "setup.ml" (* OASIS_STOP *) let () = setup ();; From c445579beb772478f99320169e04787b81e96432 Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Sat, 5 Oct 2013 21:33:10 +0100 Subject: [PATCH 02/23] Dns.Buf is a cstruct again instead of a bigarray --- lib/buf.ml | 13 +++++++------ lib/buf.mli | 4 +++- 2 files changed, 10 insertions(+), 7 deletions(-) diff --git a/lib/buf.ml b/lib/buf.ml index 9b63f123a..154226af3 100644 --- a/lib/buf.ml +++ b/lib/buf.ml @@ -18,10 +18,11 @@ module B = Bigarray module B1 = B.Array1 -type t = (char, B.int8_unsigned_elt, B.c_layout) B1.t +type t = Cstruct.t -let create = B1.create B.char B.c_layout -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) -let sub = B1.sub +let create len = Cstruct.create len +let length t = t.Cstruct.len +let of_cstruct c = c +let to_cstruct c = c +let shift b k = Cstruct.shift b k +let sub t off len = Cstruct.sub t off len diff --git a/lib/buf.mli b/lib/buf.mli index 56387855a..7970edba6 100644 --- a/lib/buf.mli +++ b/lib/buf.mli @@ -15,10 +15,12 @@ * *) -type t = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t +(* An alias module to make it easier to abstract Cstruct if necessary *) +type t = Cstruct.t val create : int -> t val length : t -> int val of_cstruct : Cstruct.t -> t +val to_cstruct : t -> Cstruct.t val shift : t -> int -> t val sub : t -> int -> int -> t From b05dd6965d143afc760891ab20ac4dd10a9d6573 Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Sat, 5 Oct 2013 21:36:04 +0100 Subject: [PATCH 03/23] Add Travis test scripts --- .travis-ci.sh | 15 +++++++++++++++ .travis.yml | 2 ++ CHANGES | 2 ++ 3 files changed, 19 insertions(+) create mode 100755 .travis-ci.sh create mode 100644 .travis.yml diff --git a/.travis-ci.sh b/.travis-ci.sh new file mode 100755 index 000000000..9e51f260a --- /dev/null +++ b/.travis-ci.sh @@ -0,0 +1,15 @@ +# OPAM packages needed to build tests. +OPAM_PACKAGES="cstruct re lwt mirage mirage-net ipaddr cmdliner ounit" + +# Install OCaml and OPAM PPAs +echo "yes" | sudo add-apt-repository ppa:avsm/ppa-testing +sudo apt-get update -qq +sudo apt-get install -qq ocaml ocaml-native-compilers camlp4-extra opam time +export OPAMYES=1 +export OPAMVERBOSE=1 + +opam init +opam install ${OPAM_PACKAGES} + +eval `opam config env` +make diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 000000000..7072e5ec9 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,2 @@ +language: c +script: bash -ex .travis-ci.sh diff --git a/CHANGES b/CHANGES index 7ae13a9c8..6e3806c83 100644 --- a/CHANGES +++ b/CHANGES @@ -1,4 +1,6 @@ 0.7.1 (trunk): +* `Dns.Buf.t` is now a Cstruct again instead of a direct Bigarray. +* Add Travis scripts. 0.7.0 (2013-08-26): * Add path argument to `Resolv_conf in Dns_resolver.config. From ad82a4f07ce529c5a3905ec049d1d4881a1cffbf Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Sat, 5 Oct 2013 21:36:19 +0100 Subject: [PATCH 04/23] adapt to c445579beb772478f99320169e04787b81e96432 API change --- lib/META | 10 +++++----- lib/packet.ml | 4 +--- 2 files changed, 6 insertions(+), 8 deletions(-) diff --git a/lib/META b/lib/META index 5f0982409..87bb08059 100644 --- a/lib/META +++ b/lib/META @@ -1,6 +1,6 @@ # OASIS_START -# DO NOT EDIT (digest: e91fb139d33350c22d4a6ce9667824b1) -version = "0.7.0" +# DO NOT EDIT (digest: bad5e303291c10b26609d5db1079c690) +version = "0.7.1" description = "DNS client and server implementation" requires = "cstruct cstruct.syntax re re.str ipaddr" archive(byte) = "dns.cma" @@ -9,7 +9,7 @@ archive(native) = "dns.cmxa" archive(native, plugin) = "dns.cmxs" exists_if = "dns.cma" package "mirage" ( - version = "0.7.0" + version = "0.7.1" description = "DNS client and server implementation" requires = "mirage mirage-net cstruct cstruct.syntax dns" archive(byte) = "mirage.cma" @@ -20,9 +20,9 @@ package "mirage" ( ) package "lwt" ( - version = "0.7.0" + version = "0.7.1" description = "DNS client and server implementation" - requires = "lwt.unix lwt.syntax dns" + requires = "lwt.unix cstruct.lwt lwt.syntax dns" archive(byte) = "lwt.cma" archive(byte, plugin) = "lwt.cma" archive(native) = "lwt.cmxa" diff --git a/lib/packet.ml b/lib/packet.ml index 84316f1b9..9d7ceaa85 100644 --- a/lib/packet.ml +++ b/lib/packet.ml @@ -1395,7 +1395,6 @@ let to_string d = (d.additionals ||> rr_to_string |> String.concat ",") let parse buf = - let buf = Cstruct.of_bigarray buf in let names = Hashtbl.create 32 in let parsen f base n buf typ = let rec aux acc n base buf = @@ -1430,7 +1429,6 @@ let marshal txbuf dns = List.fold_left f (names, base, buf) values in - let txbuf = Cstruct.of_bigarray txbuf in set_h_id txbuf dns.id; set_h_detail txbuf (marshal_detail dns.detail); set_h_qdcount txbuf (List.length dns.questions); @@ -1446,7 +1444,7 @@ let marshal txbuf dns = let names,base,buf = marshaln marshal_rr names base buf dns.authorities in let _,_,buf = marshaln marshal_rr names base buf dns.additionals in - let txbuf = Buf.sub txbuf.buffer 0 Cstruct.(len txbuf - len buf) in + let txbuf = Buf.sub txbuf 0 Cstruct.(len txbuf - len buf) in (* Cstruct.hexdump txbuf; *) (* eprintf "TX: %s\n%!" (txbuf |> parse (Hashtbl.create 8) |> to_string); *) txbuf From 26d3bbe0c41564fa3337e68405d7b6b203838615 Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Sat, 5 Oct 2013 21:36:32 +0100 Subject: [PATCH 05/23] Adapt to c445579beb772478f99320169e04787b81e96432 API change --- lwt/dns_resolver.ml | 4 ++-- lwt/dns_server.ml | 5 +++-- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/lwt/dns_resolver.ml b/lwt/dns_resolver.ml index 0bbbbe5f5..d3cfbf0cf 100644 --- a/lwt/dns_resolver.ml +++ b/lwt/dns_resolver.ml @@ -47,11 +47,11 @@ let outfd addr port = fd let txbuf fd dst buf = - Lwt_bytes.sendto fd buf 0 (Dns.Buf.length buf) [] dst + Lwt_cstruct.sendto fd buf [] dst let rxbuf fd len = let buf = Dns.Buf.create len in - lwt (len, sa) = Lwt_bytes.recvfrom fd buf 0 len [] in + lwt (len, sa) = Lwt_cstruct.recvfrom fd buf [] in return (Dns.Buf.sub buf 0 len, sa) let rec send_req ofd dst q = function diff --git a/lwt/dns_server.ml b/lwt/dns_server.ml index 544ac6376..2ed48b86b 100644 --- a/lwt/dns_server.ml +++ b/lwt/dns_server.ml @@ -60,7 +60,7 @@ let process_query fd buf len src dst processor = | None -> return () | Some buf -> (* TODO transmit queue, rather than ignoring result here *) - let _ = Lwt_bytes.(sendto fd buf 0 (Dns.Buf.length buf) [] dst) in + let _ = Lwt_cstruct.sendto fd buf [] dst in return () end @@ -103,7 +103,7 @@ let listen ~fd ~src ~processor = let _ = while_lwt !cont do Lwt_pool.use bufs (fun buf -> - lwt len, dst = Lwt_bytes.(recvfrom fd buf 0 bufsz []) in + lwt len, dst = Lwt_cstruct.recvfrom fd buf [] in return (Lwt.ignore_result (process_query fd buf len src dst processor)) ) @@ -129,3 +129,4 @@ let serve_with_zonefile ~address ~port ~zonefile = >>= fun process -> let processor = (processor_of_process process :> (module PROCESSOR)) in serve_with_processor ~address ~port ~processor + From dc06b4775d468b45e51b443a4e8e4e63607370f2 Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Sat, 5 Oct 2013 21:36:49 +0100 Subject: [PATCH 06/23] Compilation fixes to sync Mirage with Lwt backend (untested) --- mirage/dns_server.ml | 97 +++++++++++++++++++++++++++---------------- mirage/dns_server.mli | 18 +++++++- 2 files changed, 78 insertions(+), 37 deletions(-) diff --git a/mirage/dns_server.ml b/mirage/dns_server.ml index 71392fdd4..84e8abd96 100644 --- a/mirage/dns_server.ml +++ b/mirage/dns_server.ml @@ -17,50 +17,75 @@ open Lwt open Printf -let port = 53 - -let read_file dev filename = - OS.Devices.with_kv_ro dev (fun kv_ro -> - match_lwt kv_ro#read filename with - | None -> fail (Failure "File not found") - | Some s -> Lwt_stream.to_list s >|= Cstruct.copyv - ) - module DQ = Dns.Query module DR = Dns.RR module DP = Dns.Packet -let get_answer dnstrie buf qname qtype id = - let qname = List.map String.lowercase qname in - let ans = DQ.answer_query qname qtype dnstrie in - let detail = - DP.({ qr=Response; opcode=Standard; - aa=ans.DQ.aa; tc=false; rd=false; ra=false; - rcode=ans.DQ.rcode }) - in - let questions = [ DP.({ q_name=qname; q_type=qtype; q_class=Q_IN }) ] in - let dp = DP.({ id; detail; questions; - answers=ans.DQ.answer; - authorities=ans.DQ.authority; - additionals=ans.DQ.additional; - }) - in - DP.marshal buf dp +let port = 53 + +type 'a process = + src:Net.Datagram.UDPv4.src -> dst:Net.Datagram.UDPv4.dst -> 'a + -> Dns.Query.answer option Lwt.t -let no_memo db mgr src dst bits = - let buf = OS.Io_page.(to_cstruct (get ())) in - let names = Hashtbl.create 8 in - DP.( - let d = parse names bits in +module type PROCESSOR = sig + include Dns.Protocol.SERVER + val process : context process +end + +type 'a processor = (module PROCESSOR with type context = 'a) + +let process_query mgr processor src dst buf = + let module Processor = (val processor : PROCESSOR) in + match Processor.parse buf with + |None -> return () + |Some ctxt -> begin + lwt answer = Processor.process ~src ~dst ctxt in + match answer with + |None -> return () + |Some answer -> + let query = Processor.query_of_context ctxt in + let response = Dns.Query.response_of_answer query answer in + match Processor.marshal buf ctxt response with + | None -> return () + | Some buf -> Net.Datagram.UDPv4.send mgr ~src dst buf + end + +let processor_of_process process : Dns.Packet.t processor = + let module P = struct + include Dns.Protocol.Server + + let process = process + end in + (module P) + +let process_of_zonebuf zonebuf = + let db = Dns.Zone.load [] zonebuf in + let dnstrie = db.Dns.Loader.trie in + let get_answer qname qtype id = + let qname = List.map String.lowercase qname in + Dns.Query.answer ~dnssec:true qname qtype dnstrie + in + fun ~src ~dst d -> + let open DP in + (* TODO: FIXME so that 0 question queries don't crash the server *) let q = List.hd d.questions in - let r = get_answer db.Dns.Loader.trie buf q.q_name q.q_type d.id in - Net.Datagram.UDPv4.send mgr ~src dst r - ) + let r = + Dns.Protocol.contain_exc "answer" + (fun () -> get_answer q.q_name q.q_type d.id) + in + return r -let listen ?(mode=`none) ?(origin=[]) ~zb mgr src = - let db = Dns.Zone.load origin zb in +let bufsz = 4096 +let listen ?(mode=`none) ?(origin=[]) ~zb mgr src ~processor = Net.Datagram.UDPv4.(recv mgr src (match mode with - |`none -> no_memo db mgr src + |`none -> process_query mgr processor src ) ) + + (* +let serve_with_zonebuf ~mgr ~address ~port ~zonebuf = + let process = process_of_zonebuf zonebuf in + let processor = (processor_of_process process :> (module PROCESSOR)) in + serve_with_processor ~address ~port ~processor +*) diff --git a/mirage/dns_server.mli b/mirage/dns_server.mli index be29258a6..8e88cd25f 100644 --- a/mirage/dns_server.mli +++ b/mirage/dns_server.mli @@ -1 +1,17 @@ -val listen : ?mode:[ `none ] -> ?origin:string list -> zb:string -> Net.Datagram.UDPv4.mgr -> Net.Datagram.UDPv4.src -> unit Lwt.t +type 'a process = + src:Net.Datagram.UDPv4.src -> dst:Net.Datagram.UDPv4.dst -> 'a + -> Dns.Query.answer option Lwt.t + +module type PROCESSOR = sig + include Dns.Protocol.SERVER + val process : context process +end + + +val listen : + ?mode:[ `none ] -> + ?origin:string list -> + zb:string -> + Net.Datagram.UDPv4.mgr -> + Net.Datagram.UDPv4.src -> + processor:(module PROCESSOR) -> unit Lwt.t From c702d352553f05bf8b4763f321c3dbbcb562350e Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Sat, 5 Oct 2013 21:37:19 +0100 Subject: [PATCH 07/23] bump trunk to 0.8.0 since the Cstruct Dns.Buf.t change will break 0.7.x clients --- CHANGES | 2 +- _oasis | 2 +- lib/META | 8 ++++---- setup.ml | 6 +++--- 4 files changed, 9 insertions(+), 9 deletions(-) diff --git a/CHANGES b/CHANGES index 6e3806c83..76d2e21f3 100644 --- a/CHANGES +++ b/CHANGES @@ -1,4 +1,4 @@ -0.7.1 (trunk): +0.8.0 (trunk): * `Dns.Buf.t` is now a Cstruct again instead of a direct Bigarray. * Add Travis scripts. diff --git a/_oasis b/_oasis index 78a72b582..86340ae97 100644 --- a/_oasis +++ b/_oasis @@ -1,7 +1,7 @@ OASISFormat: 0.3 OCamlVersion: >= 4.00.0 Name: dns -Version: 0.7.1 +Version: 0.8.0 Authors: Anil Madhavapeddy, Tim Deegan, Richard Mortier, Haris Rotsos, David Sheets, Thomas Gazagnaire Maintainers: Anil Madhavapeddy License: LGPL-2.0 with OCaml linking exception diff --git a/lib/META b/lib/META index 87bb08059..7f79dfb96 100644 --- a/lib/META +++ b/lib/META @@ -1,6 +1,6 @@ # OASIS_START -# DO NOT EDIT (digest: bad5e303291c10b26609d5db1079c690) -version = "0.7.1" +# DO NOT EDIT (digest: 932e1d4c71869f94ad5f042dc4a8df6b) +version = "0.8.0" description = "DNS client and server implementation" requires = "cstruct cstruct.syntax re re.str ipaddr" archive(byte) = "dns.cma" @@ -9,7 +9,7 @@ archive(native) = "dns.cmxa" archive(native, plugin) = "dns.cmxs" exists_if = "dns.cma" package "mirage" ( - version = "0.7.1" + version = "0.8.0" description = "DNS client and server implementation" requires = "mirage mirage-net cstruct cstruct.syntax dns" archive(byte) = "mirage.cma" @@ -20,7 +20,7 @@ package "mirage" ( ) package "lwt" ( - version = "0.7.1" + version = "0.8.0" description = "DNS client and server implementation" requires = "lwt.unix cstruct.lwt lwt.syntax dns" archive(byte) = "lwt.cma" diff --git a/setup.ml b/setup.ml index 499620149..f310a5db6 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.3.0 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 652f19a68d088ada97aa8b023308a6c0) *) +(* DO NOT EDIT (digest: a221854c2d22c71882fa07f1ff6c4ceb) *) (* Regenerated by OASIS v0.3.0 Visit http://oasis.forge.ocamlcore.org for more information and @@ -5752,7 +5752,7 @@ let setup_t = ocaml_version = Some (OASISVersion.VGreaterEqual "4.00.0"); findlib_version = None; name = "dns"; - version = "0.7.1"; + version = "0.8.0"; license = OASISLicense.DEP5License (OASISLicense.DEP5Unit @@ -6211,7 +6211,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.3.0"; - oasis_digest = Some "¹¡Ëñ\030\159^,ÍJ\142­\140\129]W"; + oasis_digest = Some "%Ã\149CÇÝN®\153wgóc¸\158Ò"; oasis_exec = None; oasis_setup_args = []; setup_update = false; From d96a9abb818c0f650c59449a1682b6f1eae8ab2f Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Sat, 5 Oct 2013 21:37:48 +0100 Subject: [PATCH 08/23] Add a Merlin editor file --- .merlin | 7 +++++++ 1 file changed, 7 insertions(+) create mode 100644 .merlin diff --git a/.merlin b/.merlin new file mode 100644 index 000000000..a15784787 --- /dev/null +++ b/.merlin @@ -0,0 +1,7 @@ +PKG lwt cstruct mirage-net mirage +S lib +S lib_test +S lwt +B _build/lib +B _build/lib_test +B _build/lwt From 9d77e2bcd4196e1f0e949c2c8424dab3ed6e06d3 Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Fri, 20 Dec 2013 14:22:57 +0000 Subject: [PATCH 09/23] Incorporate ipv6 parsing into `Packet` since cstruct has removed it Closes #10 --- lib/packet.ml | 29 +++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) diff --git a/lib/packet.ml b/lib/packet.ml index 84316f1b9..bdd2db147 100644 --- a/lib/packet.ml +++ b/lib/packet.ml @@ -21,6 +21,35 @@ open Operators open Name open Cstruct +let bytes_to_ipv4 bs = + let (|||) x y = Int32.logor x y in + let (<<<) x y = Int32.shift_left x y in + let a = Int32.of_int (byte_to_int bs.[0]) in + let b = Int32.of_int (byte_to_int bs.[1]) in + let c = Int32.of_int (byte_to_int bs.[2]) in + let d = Int32.of_int (byte_to_int bs.[3]) in + (a <<< 24) ||| (b <<< 16) ||| (c <<< 8) ||| d + +type ipv6 = int64 * int64 +let ipv6_to_string (hi, lo) = + let (&&&&) x y = Int64.logand x y in + let (>>>>) x y = Int64.shift_right_logical x y in + sprintf "%Lx:%Lx:%Lx:%Lx:%Lx:%Lx:%Lx:%Lx" + ((hi >>>> 48) &&&& 0xffff_L) ((hi >>>> 32) &&&& 0xffff_L) + ((hi >>>> 16) &&&& 0xffff_L) ( hi &&&& 0xffff_L) + ((lo >>>> 48) &&&& 0xffff_L) ((lo >>>> 32) &&&& 0xffff_L) + ((lo >>>> 16) &&&& 0xffff_L) ( lo &&&& 0xffff_L) + +let bytes_to_ipv6 bs = + let (++++) x y = Int64.add x y in + let (<<<<) x y = Int64.shift_left x y in + let hihi = bytes_to_ipv4 (String.sub bs 0 4) in + let hilo = bytes_to_ipv4 (String.sub bs 4 4) in + let lohi = bytes_to_ipv4 (String.sub bs 8 4) in + let lolo = bytes_to_ipv4 (String.sub bs 12 4) in + ((Int64.of_int32 hihi) <<<< 48) ++++ (Int64.of_int32 hilo), + ((Int64.of_int32 lohi) <<<< 48) ++++ (Int64.of_int32 lolo) + cenum digest_alg { SHA1 = 1; SHA256 = 2 From c9e6b72f6b42f6aa2c5ecabfb3d1dcd036f03d33 Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Tue, 18 Feb 2014 15:03:55 +0000 Subject: [PATCH 10/23] Split the `dns.lwt` into a portable `dns.lwt-core` that doesn't require Unix (from which a Mirage version can be built). The only change to existing applications is that `module type PROCESSOR` now comes from `Dns_server_core` rather than `Dns_server`. --- CHANGES | 5 ++ README.md | 2 +- _oasis | 11 +++- _tags | 14 ++++- lib/META | 15 ++++- lib/dns.mllib | 4 ++ lib/zone_parser.mly | 8 +-- lib_test/time_server.ml | 1 + lwt/dns_server.ml | 127 ++++++++++++---------------------------- lwt/dns_server.mli | 27 ++------- lwt/dns_server_core.ml | 72 +++++++++++++++++++++++ lwt/dns_server_core.mli | 43 ++++++++++++++ lwt/lwt-core.mllib | 4 ++ myocamlbuild.ml | 8 ++- setup.ml | 54 +++++++++++++++-- 15 files changed, 265 insertions(+), 130 deletions(-) create mode 100644 lib/dns.mllib create mode 100644 lwt/dns_server_core.ml create mode 100644 lwt/dns_server_core.mli create mode 100644 lwt/lwt-core.mllib diff --git a/CHANGES b/CHANGES index 37c86f705..cd3567dde 100644 --- a/CHANGES +++ b/CHANGES @@ -1,6 +1,11 @@ 0.8.0 (trunk): * `Dns.Buf.t` is now a Cstruct again instead of a direct Bigarray. * Add Travis continuous integration scripts. +* Regenerate with OASIS 0.4.1 +* Split the `dns.lwt` into a portable `dns.lwt-core` that doesn't + require Unix (from which a Mirage version can be built). The only + change to existing applications is that `module type PROCESSOR` now + comes from `Dns_server_core` rather than `Dns_server`. 0.7.0 (2013-08-26): * Add path argument to `Resolv_conf in Dns_resolver.config. diff --git a/README.md b/README.md index 8f2daba0b..4b921c3cc 100644 --- a/README.md +++ b/README.md @@ -4,7 +4,7 @@ than low-level performance hacks. To build it, the following packages are required: -* OCaml 3.12.0 or higher. +* OCaml 4.00.1 or higher. * Lwt 2.3.2 or higher: http://ocsigen.org/lwt/ * Cstruct: http://github.com/mirage/ocaml-cstruct * Re: http://github.com/mirage/ocaml-re diff --git a/_oasis b/_oasis index e3f1f0046..ef17b589a 100644 --- a/_oasis +++ b/_oasis @@ -41,7 +41,16 @@ Library lwt Install$: flag(lwt) Findlibname: lwt Modules: Dns_server, Dns_resolver - BuildDepends: lwt.unix (>= 2.4.1), cstruct.lwt, lwt.syntax, dns + BuildDepends: lwt.unix (>= 2.4.1), cstruct.lwt, lwt.syntax, dns, dns.lwt-core, ipaddr.unix + FindlibParent: dns + +Library "lwt-core" + Path: lwt + Build$: flag(lwt) + Install$: flag(lwt) + Findlibname: lwt-core + Modules: Dns_server_core + BuildDepends: lwt, cstruct, lwt.syntax, dns FindlibParent: dns Document dns diff --git a/_tags b/_tags index 1e83a5af0..4e0a7922d 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: df2d157e716ec6142b46cd19e57366e6) +# DO NOT EDIT (digest: b46ef21097bddd75899af6867db104a7) # 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 @@ -35,10 +35,13 @@ : package(ipaddr) : package(cstruct) : package(cstruct.syntax) +# Library lwt-core +"lwt/lwt-core.cmxs": use_lwt-core # Library lwt "lwt/lwt.cmxs": use_lwt # Executable lwt_server : use_lwt +: use_lwt-core : use_dns : package(lwt) : package(lwt.unix) @@ -47,11 +50,13 @@ : package(re.str) : package(ipaddr) : package(cstruct.lwt) +: package(ipaddr.unix) : package(cstruct) : package(cstruct.syntax) : custom # Executable time_server : use_lwt +: use_lwt-core : use_dns : package(lwt) : package(lwt.unix) @@ -60,9 +65,11 @@ : package(re.str) : package(ipaddr) : package(cstruct.lwt) +: package(ipaddr.unix) : package(cstruct) : package(cstruct.syntax) : use_lwt +: use_lwt-core : use_dns : package(lwt) : package(lwt.unix) @@ -71,11 +78,13 @@ : package(re.str) : package(ipaddr) : package(cstruct.lwt) +: package(ipaddr.unix) : package(cstruct) : package(cstruct.syntax) : custom # Executable mldig : use_lwt +: use_lwt-core : use_dns : package(lwt) : package(lwt.unix) @@ -85,9 +94,11 @@ : package(ipaddr) : package(cmdliner) : package(cstruct.lwt) +: package(ipaddr.unix) : package(cstruct) : package(cstruct.syntax) : use_lwt +: use_lwt-core : use_dns : package(lwt) : package(lwt.unix) @@ -97,6 +108,7 @@ : package(ipaddr) : package(cmdliner) : package(cstruct.lwt) +: package(ipaddr.unix) : package(cstruct) : package(cstruct.syntax) : custom diff --git a/lib/META b/lib/META index 63022203b..77f1b3a97 100644 --- a/lib/META +++ b/lib/META @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: bba98f391c6c996e9cdd26500ceecc0f) +# DO NOT EDIT (digest: 85565c0ecd22b743afa123d3a0ed14d4) version = "0.8.0" description = "DNS client and server implementation" requires = "cstruct cstruct.syntax re re.str ipaddr" @@ -8,10 +8,21 @@ archive(byte, plugin) = "dns.cma" archive(native) = "dns.cmxa" archive(native, plugin) = "dns.cmxs" exists_if = "dns.cma" +package "lwt-core" ( + version = "0.8.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" +) + package "lwt" ( version = "0.8.0" description = "DNS client and server implementation" - requires = "lwt.unix cstruct.lwt lwt.syntax dns" + 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" diff --git a/lib/dns.mllib b/lib/dns.mllib new file mode 100644 index 000000000..0ad6b9288 --- /dev/null +++ b/lib/dns.mllib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: 4d3cc87f77cb704db96a7dc499206433) +Dns +# OASIS_STOP diff --git a/lib/zone_parser.mly b/lib/zone_parser.mly index dba3341f9..9075af8bb 100644 --- a/lib/zone_parser.mly +++ b/lib/zone_parser.mly @@ -314,10 +314,10 @@ rr: ipv4: NUMBER DOT NUMBER DOT NUMBER DOT NUMBER { try - let a = Int32.of_int (parse_uint8 $1) in - let b = Int32.of_int (parse_uint8 $3) in - let c = Int32.of_int (parse_uint8 $5) in - let d = Int32.of_int (parse_uint8 $7) in + let a = parse_uint8 $1 in + let b = parse_uint8 $3 in + let c = parse_uint8 $5 in + let d = parse_uint8 $7 in Ipaddr.V4.make a b c d with Failure _ | Parsing.Parse_error -> parse_error ("invalid IPv4 address " ^ diff --git a/lib_test/time_server.ml b/lib_test/time_server.ml index 363008882..68c0dadc1 100644 --- a/lib_test/time_server.ml +++ b/lib_test/time_server.ml @@ -42,6 +42,7 @@ let dnsfn ~src ~dst query = let _ = let address = "0.0.0.0" in let port = 5354 in + let open Dns_server_core in let open Dns_server in let processor = (processor_of_process dnsfn :> (module PROCESSOR)) in Lwt_main.run (serve_with_processor ~address ~port ~processor) diff --git a/lwt/dns_server.ml b/lwt/dns_server.ml index 2ed48b86b..2995de8c4 100644 --- a/lwt/dns_server.ml +++ b/lwt/dns_server.ml @@ -1,112 +1,57 @@ -(* - * Copyright (c) 2005-2012 Anil Madhavapeddy - * Copyright (c) 2013 David Sheets - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - *) - open Lwt -open Printf - -module DR = Dns.RR -module DP = Dns.Packet - -type 'a process = - src:Lwt_unix.sockaddr -> dst:Lwt_unix.sockaddr -> 'a - -> Dns.Query.answer option Lwt.t - -module type PROCESSOR = sig - include Dns.Protocol.SERVER - val process : context process -end - -type 'a processor = (module PROCESSOR with type context = 'a) +open Dns_server_core let bind_fd ~address ~port = - lwt src = try_lwt - (* should this be lwt hent = Lwt_lib.gethostbyname addr ? *) - let hent = Unix.gethostbyname address in - return (Unix.ADDR_INET (hent.Unix.h_addr_list.(0), port)) - with _ -> - raise_lwt (Failure ("cannot resolve " ^ address)) + lwt src = + try_lwt + (* should this be lwt hent = Lwt_lib.gethostbyname addr ? *) + let hent = Unix.gethostbyname address in + return (Unix.ADDR_INET (hent.Unix.h_addr_list.(0), port)) + with _ -> + raise_lwt (Failure ("cannot resolve " ^ address)) in let fd = Lwt_unix.(socket PF_INET SOCK_DGRAM 0) in let () = Lwt_unix.bind fd src in return (fd,src) -let process_query fd buf len src dst processor = - let module Processor = (val processor : PROCESSOR) in - match Processor.parse (Dns.Buf.sub buf 0 len) with - |None -> return () - |Some ctxt -> begin - lwt answer = Processor.process ~src ~dst ctxt in - match answer with - |None -> return () - |Some answer -> - let query = Processor.query_of_context ctxt in - let response = Dns.Query.response_of_answer query answer in - (* Lwt_bytes.unsafe_fill buf 0 (Lwt_bytes.length buf) '\x00'; *) - match Processor.marshal buf ctxt response with - | None -> return () - | Some buf -> - (* TODO transmit queue, rather than ignoring result here *) - let _ = Lwt_cstruct.sendto fd buf [] dst in - return () - end - -let processor_of_process process : Dns.Packet.t processor = - let module P = struct - include Dns.Protocol.Server - - let process = process - end in - (module P) - -let process_of_zonebuf zonebuf = - let db = Dns.Zone.load [] zonebuf in - let dnstrie = db.Dns.Loader.trie in - let get_answer qname qtype id = - let qname = List.map String.lowercase qname in - Dns.Query.answer ~dnssec:true qname qtype dnstrie - in - fun ~src ~dst d -> - let open DP in - (* TODO: FIXME so that 0 question queries don't crash the server *) - let q = List.hd d.questions in - let r = - Dns.Protocol.contain_exc "answer" - (fun () -> get_answer q.q_name q.q_type d.id) - in - return r - let eventual_process_of_zonefile zonefile = let lines = Lwt_io.lines_of_file zonefile in let buf = Buffer.create 1024 in Lwt_stream.iter (fun l -> - Buffer.add_string buf l; Buffer.add_char buf '\n') lines - >>= fun () -> return (process_of_zonebuf (Buffer.contents buf)) + Buffer.add_string buf l; + Buffer.add_char buf '\n') lines + >>= fun () -> + return (process_of_zonebuf (Buffer.contents buf)) let bufsz = 4096 + +let ipaddr_of_sockaddr = + function + | Unix.ADDR_UNIX _ -> fail (Failure "Unix domain sockets not supported") + | Unix.ADDR_INET (ip,port) -> return (Ipaddr_unix.of_inet_addr ip, port) + let listen ~fd ~src ~processor = let cont = ref true in - let bufs = Lwt_pool.create 64 (fun () -> return (Dns.Buf.create bufsz)) in + let bufs = Lwt_pool.create 64 + (fun () -> return (Dns.Buf.create bufsz)) in + lwt src = ipaddr_of_sockaddr src in let _ = while_lwt !cont do - Lwt_pool.use bufs (fun buf -> - lwt len, dst = Lwt_cstruct.recvfrom fd buf [] in - return (Lwt.ignore_result - (process_query fd buf len src dst processor)) - ) + Lwt_pool.use bufs + (fun buf -> + lwt len, dst = Lwt_cstruct.recvfrom fd buf [] in + (* TODO Process in a background thread; should be a bounded queue *) + let _ = ignore_result ( + lwt dst' = ipaddr_of_sockaddr dst in + process_query buf len src dst' processor + >>= function + | None -> return () + | Some buf -> + Lwt_cstruct.sendto fd buf [] dst + >>= fun _ -> return () + ) in + return () + ) done in let t,u = Lwt.task () in diff --git a/lwt/dns_server.mli b/lwt/dns_server.mli index 7d636539f..12ce93703 100644 --- a/lwt/dns_server.mli +++ b/lwt/dns_server.mli @@ -1,5 +1,5 @@ (* - * Copyright (c) 2011 Anil Madhavapeddy + * Copyright (c) 2011-2014 Anil Madhavapeddy * Copyright (c) 2013 David Sheets * * Permission to use, copy, modify, and distribute this software for any @@ -15,33 +15,13 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) +open Dns_server_core + (** Given a source address and a port, return a bound file descriptor and source sockaddr suitable for passing to the [listen] functions *) val bind_fd : address:string -> port:int -> (Lwt_unix.file_descr * Lwt_unix.sockaddr) Lwt.t -type 'a process = - src:Lwt_unix.sockaddr -> dst:Lwt_unix.sockaddr -> 'a -> - Dns.Query.answer option Lwt.t - -module type PROCESSOR = sig - include Dns.Protocol.SERVER - - (** DNS responder function. - @param src Server sockaddr - @param dst Client sockaddr - @param Query packet - @return Answer packet - *) - val process : context process -end - -type 'a processor = (module PROCESSOR with type context = 'a) - -val processor_of_process : Dns.Packet.t process -> Dns.Packet.t processor - -val process_of_zonebuf : string -> Dns.Packet.t process - val eventual_process_of_zonefile : string -> Dns.Packet.t process Lwt.t (** General listening function for DNS servers. Pass in the [fd] and @@ -61,3 +41,4 @@ val serve_with_zonebuf : val serve_with_zonefile : address:string -> port:int -> zonefile:string -> unit Lwt.t + diff --git a/lwt/dns_server_core.ml b/lwt/dns_server_core.ml new file mode 100644 index 000000000..6c3ea61b0 --- /dev/null +++ b/lwt/dns_server_core.ml @@ -0,0 +1,72 @@ +(* + * Copyright (c) 2005-2012 Anil Madhavapeddy + * Copyright (c) 2013 David Sheets + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Lwt +open Printf + +module DR = Dns.RR +module DP = Dns.Packet + +type addr = Ipaddr.t * int + +type 'a process = src:addr -> dst:addr -> 'a -> Dns.Query.answer option Lwt.t + +module type PROCESSOR = sig + include Dns.Protocol.SERVER + val process : context process +end + +type 'a processor = (module PROCESSOR with type context = 'a) + +let process_query buf len src dst processor = + let module Processor = (val processor : PROCESSOR) in + match Processor.parse (Dns.Buf.sub buf 0 len) with + |None -> return None + |Some ctxt -> begin + lwt answer = Processor.process ~src ~dst ctxt in + match answer with + |None -> return None + |Some answer -> + let query = Processor.query_of_context ctxt in + let response = Dns.Query.response_of_answer query answer in + return (Processor.marshal buf ctxt response) + end + +let processor_of_process process : Dns.Packet.t processor = + let module P = struct + include Dns.Protocol.Server + + let process = process + end in + (module P) + +let process_of_zonebuf zonebuf = + let db = Dns.Zone.load [] zonebuf in + let dnstrie = db.Dns.Loader.trie in + let get_answer qname qtype id = + let qname = List.map String.lowercase qname in + Dns.Query.answer ~dnssec:true qname qtype dnstrie + in + fun ~src ~dst d -> + let open DP in + (* TODO: FIXME so that 0 question queries don't crash the server *) + let q = List.hd d.questions in + let r = + Dns.Protocol.contain_exc "answer" + (fun () -> get_answer q.q_name q.q_type d.id) + in + return r diff --git a/lwt/dns_server_core.mli b/lwt/dns_server_core.mli new file mode 100644 index 000000000..9c0a8eae4 --- /dev/null +++ b/lwt/dns_server_core.mli @@ -0,0 +1,43 @@ +(* + * Copyright (c) 2011 Anil Madhavapeddy + * Copyright (c) 2013 David Sheets + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +type addr = Ipaddr.t * int + +type 'a process = src:addr -> dst:addr -> 'a -> Dns.Query.answer option Lwt.t + +module type PROCESSOR = sig + include Dns.Protocol.SERVER + + (** DNS responder function. + @param src Server sockaddr + @param dst Client sockaddr + @param Query packet + @return Answer packet + *) + val process : context process +end + +type 'a processor = (module PROCESSOR with type context = 'a) + +val process_query: Dns.Buf.t -> int -> addr -> addr -> + (module PROCESSOR) -> Dns.Buf.t option Lwt.t + +val processor_of_process : Dns.Packet.t process -> Dns.Packet.t processor + +val process_of_zonebuf : string -> Dns.Packet.t process + + diff --git a/lwt/lwt-core.mllib b/lwt/lwt-core.mllib new file mode 100644 index 000000000..c6a6327e2 --- /dev/null +++ b/lwt/lwt-core.mllib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: f6b30e96c45cd4d4d8560e058b109c5a) +Dns_server_core +# OASIS_STOP diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 0fa244d21..87a015396 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,5 +1,5 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: f0ee8d2bb5920ec4e695d53982d7d1a6) *) +(* DO NOT EDIT (digest: e7435ee7ed69997095d4e8e5d5a41bb6) *) module OASISGettext = struct (* # 22 "src/oasis/OASISGettext.ml" *) @@ -555,7 +555,9 @@ end open Ocamlbuild_plugin;; let package_default = { - MyOCamlbuildBase.lib_ocaml = [("dns", ["lib"], []); ("lwt", ["lwt"], [])]; + MyOCamlbuildBase.lib_ocaml = + [("dns", ["lib"], []); ("lwt-core", ["lwt"], []); ("lwt", ["lwt"], []) + ]; lib_c = []; flags = []; includes = [("lwt", ["lib"]); ("lib_test", ["lib"; "lwt"])] @@ -564,6 +566,6 @@ let package_default = let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;; -# 568 "myocamlbuild.ml" +# 570 "myocamlbuild.ml" (* OASIS_STOP *) Ocamlbuild_plugin.dispatch dispatch_default;; diff --git a/setup.ml b/setup.ml index 4810c9480..dc3a1884b 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.4.1 *) (* OASIS_START *) -(* DO NOT EDIT (digest: a943239e0071c8f1a1d2bd4aa9ed9558) *) +(* DO NOT EDIT (digest: 7c09a62b3e48b962c11c220e9be58d59) *) (* Regenerated by OASIS v0.4.1 Visit http://oasis.forge.ocamlcore.org for more information and @@ -6889,6 +6889,50 @@ let setup_t = lib_findlib_name = Some "dns"; lib_findlib_containers = [] }); + Library + ({ + cs_name = "lwt-core"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EFlag "lwt", true) + ]; + bs_install = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EFlag "lwt", true) + ]; + bs_path = "lwt"; + bs_compiled_object = Best; + bs_build_depends = + [ + FindlibPackage ("lwt", None); + FindlibPackage ("cstruct", None); + FindlibPackage ("lwt.syntax", None); + InternalLibrary "dns" + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, + { + lib_modules = ["Dns_server_core"]; + lib_pack = false; + lib_internal_modules = []; + lib_findlib_parent = Some "dns"; + lib_findlib_name = Some "lwt-core"; + lib_findlib_containers = [] + }); Library ({ cs_name = "lwt"; @@ -6915,7 +6959,9 @@ let setup_t = Some (OASISVersion.VGreaterEqual "2.4.1")); FindlibPackage ("cstruct.lwt", None); FindlibPackage ("lwt.syntax", None); - InternalLibrary "dns" + InternalLibrary "dns"; + InternalLibrary "lwt-core"; + FindlibPackage ("ipaddr.unix", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; @@ -7146,7 +7192,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.4.1"; - oasis_digest = Some "ö,ö \\ø\150þqJ\152\136³H\143Û"; + oasis_digest = Some "_É\147&G\152\"`¸úq±3Ü^¾"; oasis_exec = None; oasis_setup_args = []; setup_update = false @@ -7154,6 +7200,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 7158 "setup.ml" +# 7204 "setup.ml" (* OASIS_STOP *) let () = setup ();; From a8d8a40274f5ef0de61a023250a28cd146191c26 Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Thu, 20 Feb 2014 15:43:24 +0000 Subject: [PATCH 11/23] Revert "Dns.Buf is a cstruct again instead of a bigarray" This reverts commit c445579beb772478f99320169e04787b81e96432. --- lib/buf.ml | 13 ++++++------- lib/buf.mli | 4 +--- 2 files changed, 7 insertions(+), 10 deletions(-) diff --git a/lib/buf.ml b/lib/buf.ml index 154226af3..9b63f123a 100644 --- a/lib/buf.ml +++ b/lib/buf.ml @@ -18,11 +18,10 @@ module B = Bigarray module B1 = B.Array1 -type t = Cstruct.t +type t = (char, B.int8_unsigned_elt, B.c_layout) B1.t -let create len = Cstruct.create len -let length t = t.Cstruct.len -let of_cstruct c = c -let to_cstruct c = c -let shift b k = Cstruct.shift b k -let sub t off len = Cstruct.sub t off len +let create = B1.create B.char B.c_layout +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) +let sub = B1.sub diff --git a/lib/buf.mli b/lib/buf.mli index 7970edba6..56387855a 100644 --- a/lib/buf.mli +++ b/lib/buf.mli @@ -15,12 +15,10 @@ * *) -(* An alias module to make it easier to abstract Cstruct if necessary *) -type t = Cstruct.t +type t = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t val create : int -> t val length : t -> int val of_cstruct : Cstruct.t -> t -val to_cstruct : t -> Cstruct.t val shift : t -> int -> t val sub : t -> int -> int -> t From f0c2cb3f0346d1ed0315ef93c9e661eca0b78498 Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Thu, 20 Feb 2014 16:13:58 +0000 Subject: [PATCH 12/23] finish the revert of c445579beb772478f99320169e04787b81e96432 --- CHANGES | 1 - lib/packet.ml | 4 +++- lwt/dns_resolver.ml | 4 ++-- lwt/dns_server.ml | 4 ++-- 4 files changed, 7 insertions(+), 6 deletions(-) diff --git a/CHANGES b/CHANGES index cd3567dde..53a390cdc 100644 --- a/CHANGES +++ b/CHANGES @@ -1,5 +1,4 @@ 0.8.0 (trunk): -* `Dns.Buf.t` is now a Cstruct again instead of a direct Bigarray. * Add Travis continuous integration scripts. * Regenerate with OASIS 0.4.1 * Split the `dns.lwt` into a portable `dns.lwt-core` that doesn't diff --git a/lib/packet.ml b/lib/packet.ml index b939c5463..bdd2db147 100644 --- a/lib/packet.ml +++ b/lib/packet.ml @@ -1424,6 +1424,7 @@ let to_string d = (d.additionals ||> rr_to_string |> String.concat ",") let parse buf = + let buf = Cstruct.of_bigarray buf in let names = Hashtbl.create 32 in let parsen f base n buf typ = let rec aux acc n base buf = @@ -1458,6 +1459,7 @@ let marshal txbuf dns = List.fold_left f (names, base, buf) values in + let txbuf = Cstruct.of_bigarray txbuf in set_h_id txbuf dns.id; set_h_detail txbuf (marshal_detail dns.detail); set_h_qdcount txbuf (List.length dns.questions); @@ -1473,7 +1475,7 @@ let marshal txbuf dns = let names,base,buf = marshaln marshal_rr names base buf dns.authorities in let _,_,buf = marshaln marshal_rr names base buf dns.additionals in - let txbuf = Buf.sub txbuf 0 Cstruct.(len txbuf - len buf) in + let txbuf = Buf.sub txbuf.buffer 0 Cstruct.(len txbuf - len buf) in (* Cstruct.hexdump txbuf; *) (* eprintf "TX: %s\n%!" (txbuf |> parse (Hashtbl.create 8) |> to_string); *) txbuf diff --git a/lwt/dns_resolver.ml b/lwt/dns_resolver.ml index d3cfbf0cf..0bbbbe5f5 100644 --- a/lwt/dns_resolver.ml +++ b/lwt/dns_resolver.ml @@ -47,11 +47,11 @@ let outfd addr port = fd let txbuf fd dst buf = - Lwt_cstruct.sendto fd buf [] dst + Lwt_bytes.sendto fd buf 0 (Dns.Buf.length buf) [] dst let rxbuf fd len = let buf = Dns.Buf.create len in - lwt (len, sa) = Lwt_cstruct.recvfrom fd buf [] in + lwt (len, sa) = Lwt_bytes.recvfrom fd buf 0 len [] in return (Dns.Buf.sub buf 0 len, sa) let rec send_req ofd dst q = function diff --git a/lwt/dns_server.ml b/lwt/dns_server.ml index 2995de8c4..3d37b7947 100644 --- a/lwt/dns_server.ml +++ b/lwt/dns_server.ml @@ -39,7 +39,7 @@ let listen ~fd ~src ~processor = while_lwt !cont do Lwt_pool.use bufs (fun buf -> - lwt len, dst = Lwt_cstruct.recvfrom fd buf [] in + lwt len, dst = Lwt_bytes.recvfrom fd buf 0 bufsz [] in (* TODO Process in a background thread; should be a bounded queue *) let _ = ignore_result ( lwt dst' = ipaddr_of_sockaddr dst in @@ -47,7 +47,7 @@ let listen ~fd ~src ~processor = >>= function | None -> return () | Some buf -> - Lwt_cstruct.sendto fd buf [] dst + Lwt_bytes.sendto fd buf 0 (Dns.Buf.length buf) [] dst >>= fun _ -> return () ) in return () From 121725400449110fab970d0c9a86c5bb37f187d6 Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Thu, 20 Feb 2014 16:16:06 +0000 Subject: [PATCH 13/23] Remove unused Async flag --- _oasis | 4 ---- setup.ml | 16 +++------------- 2 files changed, 3 insertions(+), 17 deletions(-) diff --git a/_oasis b/_oasis index ef17b589a..5c1318729 100644 --- a/_oasis +++ b/_oasis @@ -17,10 +17,6 @@ Flag lwt Description: build the Lwt library Default: false -Flag async - Description: build the Core/Async library - Default: false - Flag nettests Description: run the internet-using tests Default: false diff --git a/setup.ml b/setup.ml index dc3a1884b..8654cae91 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.4.1 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 7c09a62b3e48b962c11c220e9be58d59) *) +(* DO NOT EDIT (digest: 5148afb182b943a598a996f6acae0cbd) *) (* Regenerated by OASIS v0.4.1 Visit http://oasis.forge.ocamlcore.org for more information and @@ -6811,16 +6811,6 @@ let setup_t = flag_description = Some "build the Lwt library"; flag_default = [(OASISExpr.EBool true, false)] }); - Flag - ({ - cs_name = "async"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - flag_description = Some "build the Core/Async library"; - flag_default = [(OASISExpr.EBool true, false)] - }); Flag ({ cs_name = "nettests"; @@ -7192,7 +7182,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.4.1"; - oasis_digest = Some "_É\147&G\152\"`¸úq±3Ü^¾"; + oasis_digest = Some "\132+·EWùíÄù½ÄYͬ\014´"; oasis_exec = None; oasis_setup_args = []; setup_update = false @@ -7200,6 +7190,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 7204 "setup.ml" +# 7194 "setup.ml" (* OASIS_STOP *) let () = setup ();; From 240d791fc537820266a69ec8671bf15bdbc07eda Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Thu, 20 Feb 2014 23:30:46 +0000 Subject: [PATCH 14/23] `process_query` now takes an output buffer so it doesn't have to overwrite the input buffer it just parsed. --- CHANGES | 2 ++ lwt/dns_server.ml | 3 ++- lwt/dns_server_core.ml | 4 ++-- lwt/dns_server_core.mli | 4 +++- 4 files changed, 9 insertions(+), 4 deletions(-) diff --git a/CHANGES b/CHANGES index 53a390cdc..d50feea9f 100644 --- a/CHANGES +++ b/CHANGES @@ -1,4 +1,6 @@ 0.8.0 (trunk): +* `process_query` now takes an output buffer so it doesn't have to + overwrite the input buffer it just parsed. * Add Travis continuous integration scripts. * Regenerate with OASIS 0.4.1 * Split the `dns.lwt` into a portable `dns.lwt-core` that doesn't diff --git a/lwt/dns_server.ml b/lwt/dns_server.ml index 3d37b7947..961e9541a 100644 --- a/lwt/dns_server.ml +++ b/lwt/dns_server.ml @@ -1,4 +1,5 @@ open Lwt + open Dns_server_core let bind_fd ~address ~port = @@ -43,7 +44,7 @@ let listen ~fd ~src ~processor = (* TODO Process in a background thread; should be a bounded queue *) let _ = ignore_result ( lwt dst' = ipaddr_of_sockaddr dst in - process_query buf len src dst' processor + process_query buf len buf src dst' processor >>= function | None -> return () | Some buf -> diff --git a/lwt/dns_server_core.ml b/lwt/dns_server_core.ml index 6c3ea61b0..1b547e274 100644 --- a/lwt/dns_server_core.ml +++ b/lwt/dns_server_core.ml @@ -32,7 +32,7 @@ end type 'a processor = (module PROCESSOR with type context = 'a) -let process_query buf len src dst processor = +let process_query buf len obuf src dst processor = let module Processor = (val processor : PROCESSOR) in match Processor.parse (Dns.Buf.sub buf 0 len) with |None -> return None @@ -43,7 +43,7 @@ let process_query buf len src dst processor = |Some answer -> let query = Processor.query_of_context ctxt in let response = Dns.Query.response_of_answer query answer in - return (Processor.marshal buf ctxt response) + return (Processor.marshal obuf ctxt response) end let processor_of_process process : Dns.Packet.t processor = diff --git a/lwt/dns_server_core.mli b/lwt/dns_server_core.mli index 9c0a8eae4..a0e13ac01 100644 --- a/lwt/dns_server_core.mli +++ b/lwt/dns_server_core.mli @@ -33,7 +33,9 @@ end type 'a processor = (module PROCESSOR with type context = 'a) -val process_query: Dns.Buf.t -> int -> addr -> addr -> + +(** [process_query ibuf ibuflen obuf src dst processor] *) +val process_query: Dns.Buf.t -> int -> Dns.Buf.t -> addr -> addr -> (module PROCESSOR) -> Dns.Buf.t option Lwt.t val processor_of_process : Dns.Packet.t process -> Dns.Packet.t processor From 2d141ae79b1aa13e90355bdc1b0b036460e357bc Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Fri, 21 Feb 2014 00:14:48 +0000 Subject: [PATCH 15/23] Remove the mirage libs, as they are no longer used in this repository --- mirage/dns_server.ml | 91 ------------------------------------------- mirage/dns_server.mli | 17 -------- mirage/mirage.mllib | 4 -- 3 files changed, 112 deletions(-) delete mode 100644 mirage/dns_server.ml delete mode 100644 mirage/dns_server.mli delete mode 100644 mirage/mirage.mllib diff --git a/mirage/dns_server.ml b/mirage/dns_server.ml deleted file mode 100644 index 84e8abd96..000000000 --- a/mirage/dns_server.ml +++ /dev/null @@ -1,91 +0,0 @@ -(* - * Copyright (c) 2005-2013 Anil Madhavapeddy - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - *) - -open Lwt -open Printf - -module DQ = Dns.Query -module DR = Dns.RR -module DP = Dns.Packet - -let port = 53 - -type 'a process = - src:Net.Datagram.UDPv4.src -> dst:Net.Datagram.UDPv4.dst -> 'a - -> Dns.Query.answer option Lwt.t - -module type PROCESSOR = sig - include Dns.Protocol.SERVER - val process : context process -end - -type 'a processor = (module PROCESSOR with type context = 'a) - -let process_query mgr processor src dst buf = - let module Processor = (val processor : PROCESSOR) in - match Processor.parse buf with - |None -> return () - |Some ctxt -> begin - lwt answer = Processor.process ~src ~dst ctxt in - match answer with - |None -> return () - |Some answer -> - let query = Processor.query_of_context ctxt in - let response = Dns.Query.response_of_answer query answer in - match Processor.marshal buf ctxt response with - | None -> return () - | Some buf -> Net.Datagram.UDPv4.send mgr ~src dst buf - end - -let processor_of_process process : Dns.Packet.t processor = - let module P = struct - include Dns.Protocol.Server - - let process = process - end in - (module P) - -let process_of_zonebuf zonebuf = - let db = Dns.Zone.load [] zonebuf in - let dnstrie = db.Dns.Loader.trie in - let get_answer qname qtype id = - let qname = List.map String.lowercase qname in - Dns.Query.answer ~dnssec:true qname qtype dnstrie - in - fun ~src ~dst d -> - let open DP in - (* TODO: FIXME so that 0 question queries don't crash the server *) - let q = List.hd d.questions in - let r = - Dns.Protocol.contain_exc "answer" - (fun () -> get_answer q.q_name q.q_type d.id) - in - return r - -let bufsz = 4096 -let listen ?(mode=`none) ?(origin=[]) ~zb mgr src ~processor = - Net.Datagram.UDPv4.(recv mgr src - (match mode with - |`none -> process_query mgr processor src - ) - ) - - (* -let serve_with_zonebuf ~mgr ~address ~port ~zonebuf = - let process = process_of_zonebuf zonebuf in - let processor = (processor_of_process process :> (module PROCESSOR)) in - serve_with_processor ~address ~port ~processor -*) diff --git a/mirage/dns_server.mli b/mirage/dns_server.mli deleted file mode 100644 index 8e88cd25f..000000000 --- a/mirage/dns_server.mli +++ /dev/null @@ -1,17 +0,0 @@ -type 'a process = - src:Net.Datagram.UDPv4.src -> dst:Net.Datagram.UDPv4.dst -> 'a - -> Dns.Query.answer option Lwt.t - -module type PROCESSOR = sig - include Dns.Protocol.SERVER - val process : context process -end - - -val listen : - ?mode:[ `none ] -> - ?origin:string list -> - zb:string -> - Net.Datagram.UDPv4.mgr -> - Net.Datagram.UDPv4.src -> - processor:(module PROCESSOR) -> unit Lwt.t diff --git a/mirage/mirage.mllib b/mirage/mirage.mllib deleted file mode 100644 index a1f82ca46..000000000 --- a/mirage/mirage.mllib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: de2400dccdf0a27b549427f12eaf3c77) -Dns_server -# OASIS_STOP From 76ccfb64844d6b7b6eb3e571283cabd2f2f8c192 Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Fri, 21 Feb 2014 00:19:02 +0000 Subject: [PATCH 16/23] fix conflicts --- .travis.yml | 5 ----- 1 file changed, 5 deletions(-) diff --git a/.travis.yml b/.travis.yml index 0a8afa9fb..9a057c8c5 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,10 +1,5 @@ language: c script: bash -ex .travis-ci.sh -<<<<<<< HEAD -======= env: - - OCAML_VERSION=4.01.0 OPAM_VERSION=1.0.0 - OCAML_VERSION=4.01.0 OPAM_VERSION=1.1.0 - - OCAML_VERSION=4.00.1 OPAM_VERSION=1.0.0 - OCAML_VERSION=4.00.1 OPAM_VERSION=1.1.0 ->>>>>>> 9d77e2bcd4196e1f0e949c2c8424dab3ed6e06d3 From 7990abe61a32afffac210127f45deb2082508889 Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Fri, 21 Feb 2014 12:57:44 +0000 Subject: [PATCH 17/23] Add a `Dns_resolver_core` that is a portable Lwt resolver --- CHANGES | 1 + _oasis | 5 +- lwt/dns_resolver.ml | 116 ++++++++----------------------------- lwt/dns_resolver.mli | 2 - lwt/dns_resolver_core.ml | 118 ++++++++++++++++++++++++++++++++++++++ lwt/dns_resolver_core.mli | 38 ++++++++++++ lwt/lwt-core.mllib | 3 +- setup.ml | 6 +- 8 files changed, 188 insertions(+), 101 deletions(-) create mode 100644 lwt/dns_resolver_core.ml create mode 100644 lwt/dns_resolver_core.mli diff --git a/CHANGES b/CHANGES index d50feea9f..0a0e5b558 100644 --- a/CHANGES +++ b/CHANGES @@ -1,4 +1,5 @@ 0.8.0 (trunk): +* Add a `Dns_resolver_core` that is a portable Lwt resolver. * `process_query` now takes an output buffer so it doesn't have to overwrite the input buffer it just parsed. * Add Travis continuous integration scripts. diff --git a/_oasis b/_oasis index 5c1318729..443f6184e 100644 --- a/_oasis +++ b/_oasis @@ -28,8 +28,7 @@ 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 (>= 0.2.2) + BuildDepends: cstruct (>= 0.7.1), cstruct.syntax, re, re.str, ipaddr (>= 0.2.2) Library lwt Path: lwt @@ -45,7 +44,7 @@ Library "lwt-core" Build$: flag(lwt) Install$: flag(lwt) Findlibname: lwt-core - Modules: Dns_server_core + Modules: Dns_server_core, Dns_resolver_core BuildDepends: lwt, cstruct, lwt.syntax, dns FindlibParent: dns diff --git a/lwt/dns_resolver.ml b/lwt/dns_resolver.ml index 0bbbbe5f5..3809c0bf9 100644 --- a/lwt/dns_resolver.ml +++ b/lwt/dns_resolver.ml @@ -1,4 +1,5 @@ (* + * Copyright (c) 2014 Anil Madhavapeddy * Copyright (c) 2012 Richard Mortier * Copyright (c) 2013 David Sheets * @@ -20,19 +21,14 @@ open Printf open Dns.Name open Dns.Operators open Dns.Protocol +open Dns_resolver_core module DP = Dns.Packet -type result = Answer of DP.t | Error of exn - let buflen = 4096 let ns = "8.8.8.8" let port = 53 -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 sockaddr addr port = Lwt_unix.(ADDR_INET (Unix.inet_addr_of_string addr, port)) @@ -46,103 +42,45 @@ let outfd addr port = Lwt_unix.(bind fd (sockaddr addr port)); fd -let txbuf fd dst buf = - Lwt_bytes.sendto fd buf 0 (Dns.Buf.length buf) [] dst - -let rxbuf fd len = - let buf = Dns.Buf.create len in - lwt (len, sa) = Lwt_bytes.recvfrom fd buf 0 len [] in - return (Dns.Buf.sub buf 0 len, sa) - -let rec send_req ofd dst q = function - | 0 -> return () - | count -> - lwt _ = txbuf ofd dst q in - lwt _ = Lwt_unix.sleep 5.0 in - printf "retrying query for %d times\n%!" (4-count); - send_req ofd dst q (count - 1) - -let rec rcv_query ofd f = - lwt (buf,sa) = rxbuf ofd buflen in - match f buf with Some r -> return r | None -> rcv_query ofd f - -let send_pkt client server dns_port pkt = - let module R = (val client : CLIENT) in - let dst = sockaddr server dns_port in - let cqpl = R.marshal pkt in - let resl = List.map (fun (ctxt,q) -> - (* make a new socket for each request flavor *) - let ofd = outfd "0.0.0.0" 0 in - (* start the requests in parallel and run them until success or timeout*) - let t, w = Lwt.wait () in - async (fun () -> pick [ - (send_req ofd dst q 4 - >>= fun () -> return (wakeup w (Error (R.timeout ctxt)))); - (catch - (fun () -> - rcv_query ofd (R.parse ctxt) - >>= fun r -> return (wakeup w (Answer r)) - ) - (fun exn -> return (wakeup w (Error exn))) - ) - ]); - t - ) cqpl in - (* return an answer or all the errors if no request succeeded *) - let rec select errors = function - | [] -> fail (Dns_resolve_error errors) - | ts -> - nchoose_split ts - >>= fun (rs, ts) -> - let rec find_answer errors = function - | [] -> select errors ts - | (Answer a)::_ -> return a - | (Error e)::r -> find_answer (e::errors) r - in - find_answer errors rs - in select [] resl +let connect_to_resolver server port = + let dst = sockaddr server port in + let ofd = outfd "0.0.0.0" 0 in + let txfn buf = + Lwt_bytes.sendto ofd buf 0 (Dns.Buf.length buf) [] dst + >>= fun _ -> return_unit in + let rec rxfn f = + let buf = Dns.Buf.create buflen in + Lwt_bytes.recvfrom ofd buf 0 buflen [] + >>= fun (len, sa) -> + let buf = Dns.Buf.sub buf 0 len in + match f buf with + | None -> rxfn f + | Some r -> return r + in + txfn, rxfn let resolve client ?(dnssec=false) (server:string) (dns_port:int) (q_class:DP.q_class) (q_type:DP.q_type) (q_name:domain_name) = - try_lwt - let id = (let module R = (val client : CLIENT) in R.get_id ()) in - let q = Dns.Query.create ~id ~dnssec q_class q_type q_name in - log_info (sprintf "query: %s\n%!" (DP.to_string q)); - send_pkt client server dns_port q - with exn -> - log_warn (sprintf "%s\n%!" (Printexc.to_string exn)); - fail exn + let commfn = connect_to_resolver server dns_port in + Dns_resolver_core.resolve client ~dnssec commfn q_class q_type q_name let gethostbyname ?(server:string = ns) ?(dns_port:int = port) ?(q_class:DP.q_class = DP.Q_IN) ?(q_type:DP.q_type = DP.Q_A) name = - let open DP in - let domain = string_to_domain_name name in - resolve (module Dns.Protocol.Client) server dns_port q_class q_type domain - >|= fun r -> - List.fold_left (fun a x -> - match x.rdata with |A ip -> ip::a |_ -> a - ) [] r.answers - |> List.rev + let commfn = connect_to_resolver server dns_port in + Dns_resolver_core.gethostbyname ~q_class ~q_type commfn name let gethostbyaddr ?(server:string = ns) ?(dns_port:int = port) ?(q_class:DP.q_class = DP.Q_IN) ?(q_type:DP.q_type = DP.Q_PTR) addr = - let addr = for_reverse addr in - log_info (sprintf "gethostbyaddr: %s" (domain_name_to_string addr)); - let open DP in - resolve (module Dns.Protocol.Client) server dns_port q_class q_type addr - >|= fun r -> - List.fold_left (fun a x -> - match x.rdata with |PTR n -> (domain_name_to_string n)::a |_->a - ) [] r.answers - |> List.rev + let commfn = connect_to_resolver server dns_port in + Dns_resolver_core.gethostbyaddr ~q_class ~q_type commfn addr open Dns.Resolvconf @@ -209,12 +147,6 @@ let gethostbyaddr t ?q_class ?q_type q_name = |(server,dns_port)::_ -> gethostbyaddr ~server ~dns_port ?q_class ?q_type q_name -let send_pkt t pkt = - match t.servers with - |[] -> fail (Failure "No resolvers available") - |(server,dns_port)::_ -> - send_pkt t.client server dns_port pkt - let resolve t ?(dnssec=false) q_class q_type q_name = match t.servers with |[] -> fail (Failure "No resolvers available") diff --git a/lwt/dns_resolver.mli b/lwt/dns_resolver.mli index c80ed9ea3..03c844fdb 100644 --- a/lwt/dns_resolver.mli +++ b/lwt/dns_resolver.mli @@ -56,5 +56,3 @@ val gethostbyaddr : t -> ?q_class:q_class -> ?q_type:q_type *) val resolve : t -> ?dnssec:bool -> q_class -> q_type -> domain_name -> Dns.Packet.t Lwt.t - -val send_pkt : t -> Dns.Packet.t -> Dns.Packet.t Lwt.t diff --git a/lwt/dns_resolver_core.ml b/lwt/dns_resolver_core.ml new file mode 100644 index 000000000..da4dcfb6a --- /dev/null +++ b/lwt/dns_resolver_core.ml @@ -0,0 +1,118 @@ +(* + * Copyright (c) 2014 Anil Madhavapeddy + * Copyright (c) 2012 Richard Mortier + * Copyright (c) 2013 David Sheets + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Lwt +open Printf +open Dns.Name +open Dns.Operators +open Dns.Protocol + +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) + +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 + | 0 -> return () + | count -> + lwt _ = txfn q in + lwt _ = Lwt_unix.sleep 5.0 in + printf "retrying query for %d times\n%!" (4-count); + send_req txfn q (count - 1) + +let send_pkt client (txfn,rxfn) 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 + >>= fun () -> return (wakeup w (Error (R.timeout ctxt)))); + (catch + (fun () -> + rxfn (R.parse ctxt) + >>= fun r -> return (wakeup w (Answer r)) + ) + (fun exn -> return (wakeup w (Error exn))) + ) + ]); + t + ) cqpl in + (* return an answer or all the errors if no request succeeded *) + let rec select errors = function + | [] -> fail (Dns_resolve_error errors) + | ts -> + nchoose_split ts + >>= fun (rs, ts) -> + let rec find_answer errors = function + | [] -> select errors ts + | (Answer a)::_ -> return a + | (Error e)::r -> find_answer (e::errors) r + in + find_answer errors rs + in select [] resl + +let resolve client + ?(dnssec=false) + commfn + (q_class:DP.q_class) (q_type:DP.q_type) + (q_name:domain_name) = + try_lwt + let id = (let module R = (val client : CLIENT) in R.get_id ()) in + let q = Dns.Query.create ~id ~dnssec q_class q_type q_name in + log_info (sprintf "query: %s\n%!" (DP.to_string q)); + send_pkt client commfn q + with exn -> + log_warn (sprintf "%s\n%!" (Printexc.to_string exn)); + fail exn + +let gethostbyname + ?(q_class:DP.q_class = DP.Q_IN) ?(q_type:DP.q_type = DP.Q_A) + commfn + name = + let open DP in + let domain = string_to_domain_name name in + resolve (module Dns.Protocol.Client) commfn q_class q_type domain + >|= fun r -> + List.fold_left (fun a x -> + match x.rdata with |A ip -> ip::a |_ -> a + ) [] r.answers + |> List.rev + +let gethostbyaddr + ?(q_class:DP.q_class = DP.Q_IN) ?(q_type:DP.q_type = DP.Q_PTR) + commfn + addr + = + let addr = for_reverse addr in + log_info (sprintf "gethostbyaddr: %s" (domain_name_to_string addr)); + let open DP in + resolve (module Dns.Protocol.Client) commfn q_class q_type addr + >|= fun r -> + List.fold_left (fun a x -> + match x.rdata with |PTR n -> (domain_name_to_string n)::a |_->a + ) [] r.answers + |> List.rev diff --git a/lwt/dns_resolver_core.mli b/lwt/dns_resolver_core.mli new file mode 100644 index 000000000..0c9bbcbbb --- /dev/null +++ b/lwt/dns_resolver_core.mli @@ -0,0 +1,38 @@ +(* + * Copyright (c) 2014 Anil Madhavapeddy + * Copyright (c) 2012 Richard Mortier + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +type commfn = + (Dns.Buf.t -> unit Lwt.t) * + ((Dns.Buf.t -> Dns.Packet.t option) -> Dns.Packet.t Lwt.t) + +val resolve : + (module Dns.Protocol.CLIENT) -> + ?dnssec:bool -> + commfn -> Dns.Packet.q_class -> + Dns.Packet.q_type -> + Dns.Name.domain_name -> + Dns.Packet.t Lwt.t + +val gethostbyname : + ?q_class:Dns.Packet.q_class -> + ?q_type:Dns.Packet.q_type -> commfn -> + string -> Ipaddr.V4.t list Lwt.t + +val gethostbyaddr : + ?q_class:Dns.Packet.q_class -> + ?q_type:Dns.Packet.q_type -> commfn -> + Ipaddr.V4.t -> string list Lwt.t diff --git a/lwt/lwt-core.mllib b/lwt/lwt-core.mllib index c6a6327e2..50917b144 100644 --- a/lwt/lwt-core.mllib +++ b/lwt/lwt-core.mllib @@ -1,4 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: f6b30e96c45cd4d4d8560e058b109c5a) +# DO NOT EDIT (digest: b730eadd41f16ee61fea07bc004a3ae0) Dns_server_core +Dns_resolver_core # OASIS_STOP diff --git a/setup.ml b/setup.ml index 8654cae91..4d3786a33 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.4.1 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 5148afb182b943a598a996f6acae0cbd) *) +(* DO NOT EDIT (digest: 5b25aec74303e6e96d0ce04f2f928acb) *) (* Regenerated by OASIS v0.4.1 Visit http://oasis.forge.ocamlcore.org for more information and @@ -6916,7 +6916,7 @@ let setup_t = bs_nativeopt = [(OASISExpr.EBool true, [])] }, { - lib_modules = ["Dns_server_core"]; + lib_modules = ["Dns_server_core"; "Dns_resolver_core"]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = Some "dns"; @@ -7182,7 +7182,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.4.1"; - oasis_digest = Some "\132+·EWùíÄù½ÄYͬ\014´"; + oasis_digest = Some "\007+^b\159G@õB\132zMéé°¸"; oasis_exec = None; oasis_setup_args = []; setup_update = false From 19b37d1fc6e077cd6ed69ef2c302c5f21a95a96f Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Fri, 21 Feb 2014 14:26:10 +0000 Subject: [PATCH 18/23] Use `Ipaddr.V6` to restore IPv6/AAAA RR support --- CHANGES | 1 + lib/RR.ml | 2 +- lib/RR.mli | 2 +- lib/loader.ml | 7 +++--- lib/loader.mli | 2 +- lib/packet.ml | 53 +++++++++++------------------------------- lib/packet.mli | 2 +- lib/query.ml | 8 +++---- lib/zone_parser.mly | 56 +-------------------------------------------- 9 files changed, 26 insertions(+), 107 deletions(-) diff --git a/CHANGES b/CHANGES index 0a0e5b558..3590f7784 100644 --- a/CHANGES +++ b/CHANGES @@ -1,4 +1,5 @@ 0.8.0 (trunk): +* Use `Ipaddr.V6` to restore IPv6/AAAA RR support. * Add a `Dns_resolver_core` that is a portable Lwt resolver. * `process_query` now takes an output buffer so it doesn't have to overwrite the input buffer it just parsed. diff --git a/lib/RR.ml b/lib/RR.ml index 0f829a08b..b3a23d3af 100644 --- a/lib/RR.ml +++ b/lib/RR.ml @@ -50,7 +50,7 @@ and rrsig = { and rdata = | A of Ipaddr.V4.t list (* always length = 1 *) - | AAAA of cstr list + | AAAA of Ipaddr.V6.t list (* always length = 1 *) | AFSDB of (Cstruct.uint16 * dnsnode) list | CNAME of dnsnode list | HINFO of (cstr * cstr) list diff --git a/lib/RR.mli b/lib/RR.mli index 071abb8bd..347fb8366 100644 --- a/lib/RR.mli +++ b/lib/RR.mli @@ -64,7 +64,7 @@ and rrsig = { *) and rdata = | A of Ipaddr.V4.t list - | AAAA of cstr list + | AAAA of Ipaddr.V6.t list | AFSDB of (uint16 * dnsnode) list | CNAME of dnsnode list | HINFO of (cstr * cstr) list diff --git a/lib/loader.ml b/lib/loader.ml index 45cac1ab5..c93053872 100644 --- a/lib/loader.ml +++ b/lib/loader.ml @@ -171,6 +171,9 @@ let add_generic_rr tcode str ttl owner db = let add_a_rr ip ttl owner db = add_rrset { ttl; rdata = A [ ip ] } owner db +let add_aaaa_rr ip ttl owner db = + add_rrset { ttl; rdata = AAAA [ ip ] } owner db + let add_ns_rr target ttl owner db = try let targetnode = get_target_dnsnode target db in @@ -258,10 +261,6 @@ let add_rt_rr pref target ttl owner db = let targetnode = get_target_dnsnode target db in add_rrset { ttl; rdata = RT [ (pref, targetnode) ] } owner db -let add_aaaa_rr str ttl owner db = - let s = hashcons_charstring str in - add_rrset { ttl; rdata = AAAA [ s ] } owner db - let add_srv_rr pri weight port target ttl owner db = let pri = pri in let weight = weight in diff --git a/lib/loader.mli b/lib/loader.mli index b3892647d..1e1b616d4 100644 --- a/lib/loader.mli +++ b/lib/loader.mli @@ -39,6 +39,7 @@ val no_more_updates : db -> unit val add_generic_rr : int -> string -> int32 -> domain_name -> db -> unit val add_a_rr : Ipaddr.V4.t -> int32 -> domain_name -> db -> unit +val add_aaaa_rr : Ipaddr.V6.t -> int32 -> domain_name -> db -> unit val add_ns_rr : domain_name -> int32 -> domain_name -> db -> unit val add_cname_rr : domain_name -> int32 -> domain_name -> db -> unit val add_soa_rr : @@ -62,7 +63,6 @@ val add_x25_rr : string -> int32 -> domain_name -> db -> unit val add_isdn_rr : string -> string option -> int32 -> domain_name -> db -> unit val add_rt_rr : int -> domain_name -> int32 -> domain_name -> db -> unit -val add_aaaa_rr : string -> int32 -> domain_name -> db -> unit val add_srv_rr : int -> int -> int -> domain_name -> int32 -> domain_name -> db -> unit (* val add_unspec_rr : string -> int32 -> domain_name -> db -> unit *) diff --git a/lib/packet.ml b/lib/packet.ml index bdd2db147..06ba88c78 100644 --- a/lib/packet.ml +++ b/lib/packet.ml @@ -21,35 +21,6 @@ open Operators open Name open Cstruct -let bytes_to_ipv4 bs = - let (|||) x y = Int32.logor x y in - let (<<<) x y = Int32.shift_left x y in - let a = Int32.of_int (byte_to_int bs.[0]) in - let b = Int32.of_int (byte_to_int bs.[1]) in - let c = Int32.of_int (byte_to_int bs.[2]) in - let d = Int32.of_int (byte_to_int bs.[3]) in - (a <<< 24) ||| (b <<< 16) ||| (c <<< 8) ||| d - -type ipv6 = int64 * int64 -let ipv6_to_string (hi, lo) = - let (&&&&) x y = Int64.logand x y in - let (>>>>) x y = Int64.shift_right_logical x y in - sprintf "%Lx:%Lx:%Lx:%Lx:%Lx:%Lx:%Lx:%Lx" - ((hi >>>> 48) &&&& 0xffff_L) ((hi >>>> 32) &&&& 0xffff_L) - ((hi >>>> 16) &&&& 0xffff_L) ( hi &&&& 0xffff_L) - ((lo >>>> 48) &&&& 0xffff_L) ((lo >>>> 32) &&&& 0xffff_L) - ((lo >>>> 16) &&&& 0xffff_L) ( lo &&&& 0xffff_L) - -let bytes_to_ipv6 bs = - let (++++) x y = Int64.add x y in - let (<<<<) x y = Int64.shift_left x y in - let hihi = bytes_to_ipv4 (String.sub bs 0 4) in - let hilo = bytes_to_ipv4 (String.sub bs 4 4) in - let lohi = bytes_to_ipv4 (String.sub bs 8 4) in - let lolo = bytes_to_ipv4 (String.sub bs 12 4) in - ((Int64.of_int32 hihi) <<<< 48) ++++ (Int64.of_int32 hilo), - ((Int64.of_int32 lohi) <<<< 48) ++++ (Int64.of_int32 lolo) - cenum digest_alg { SHA1 = 1; SHA256 = 2 @@ -64,11 +35,11 @@ cenum gateway_tc { type gateway = | IPv4 of Ipaddr.V4.t - | IPv6 of ipv6 + | IPv6 of Ipaddr.V6.t | NAME of domain_name let gateway_to_string = function | IPv4 i -> Ipaddr.V4.to_string i - | IPv6 i -> ipv6_to_string i + | IPv6 i -> Ipaddr.V6.to_string i | NAME n -> domain_name_to_string n cenum pubkey_alg { @@ -219,7 +190,7 @@ let type_bit_maps_to_string (tbms:type_bit_maps) : string = type rdata = | A of Ipaddr.V4.t - | AAAA of string + | AAAA of Ipaddr.V6.t | AFSDB of uint16 * domain_name | CNAME of domain_name | DNSKEY of uint16 * dnssec_alg * string @@ -265,7 +236,7 @@ let hex_of_string in_str = let rdata_to_string = function | A ip -> sprintf "A (%s)" (Ipaddr.V4.to_string ip) - | AAAA bs -> sprintf "AAAA (%s)" bs + | AAAA ip -> sprintf "AAAA (%s)" (Ipaddr.V6.to_string ip) | AFSDB (x, n) -> sprintf "AFSDB (%d, %s)" x (domain_name_to_string n) | CNAME n -> sprintf "CNAME (%s)" (domain_name_to_string n) @@ -947,7 +918,8 @@ let parse_rdata names base t cls ttl buf = | RR_A -> A (Ipaddr.V4.of_int32 (BE.get_uint32 buf 0)) - | RR_AAAA -> AAAA (Cstruct.to_string buf) + | RR_AAAA -> AAAA (Ipaddr.V6.of_int64 ((BE.get_uint64 buf 0),(BE.get_uint64 buf 8))) + | RR_AFSDB -> AFSDB (BE.get_uint16 buf 0, buf |> parse_name names (base+2) |> stop) @@ -1064,10 +1036,11 @@ let parse_rdata names base t cls ttl buf = | A ip -> BE.set_uint32 rdbuf 0 (Ipaddr.V4.to_int32 ip); RR_A, names, 4 - | AAAA s -> - let s, slen = charstr s in - Cstruct.blit_from_string s 0 rdbuf 0 slen; - RR_AAAA, names, slen + | AAAA ip -> + let s1,s2 = Ipaddr.V6.to_int64 ip in + BE.set_uint64 rdbuf 0 s1; + BE.set_uint64 rdbuf 8 s2; + RR_AAAA, names, 16 | AFSDB (x,name) -> BE.set_uint16 rdbuf 0 x; let names, offset, _ = @@ -1213,8 +1186,8 @@ let parse_rdata names base t cls ttl buf = let compare_rdata a_rdata b_rdata = match (a_rdata, b_rdata) with | A a_ip, A b_ip -> Ipaddr.V4.compare a_ip b_ip - | X25 a, X25 b - | AAAA a, AAAA b -> String.compare a b + | AAAA a_ip, AAAA b_ip -> Ipaddr.V6.compare a_ip b_ip + | X25 a, X25 b -> String.compare a b | AFSDB (a_x,a_name), AFSDB (b_x, b_name) -> if (a_x = b_x) then Name.dnssec_compare a_name b_name diff --git a/lib/packet.mli b/lib/packet.mli index 182c06566..837d8a707 100644 --- a/lib/packet.mli +++ b/lib/packet.mli @@ -198,7 +198,7 @@ type type_bit_maps type rdata = | A of Ipaddr.V4.t -| AAAA of string +| AAAA of Ipaddr.V6.t | AFSDB of uint16 * domain_name | CNAME of domain_name | DNSKEY of uint16 * dnssec_alg * string diff --git a/lib/query.ml b/lib/query.ml index 6afa4bd15..4070279c0 100644 --- a/lib/query.ml +++ b/lib/query.ml @@ -142,6 +142,10 @@ let answer ?(dnssec=false) qname qtype trie = log_rrset owner Packet.RR_A; List.iter (fun ip -> addrr (Packet.A ip)) l + | RR.AAAA l -> + log_rrset owner Packet.RR_AAAA; + List.iter (fun ip -> addrr (Packet.AAAA ip)) l + | RR.NS l -> log_rrset owner Packet.RR_NS; List.iter (fun d -> @@ -233,10 +237,6 @@ let answer ?(dnssec=false) qname qtype trie = enqueue_additional d Packet.RR_ISDN; addrr (Packet.RT (preference, d.owner.H.node))) l - | RR.AAAA l -> - log_rrset owner Packet.RR_AAAA; - List.iter (fun i -> addrr (Packet.AAAA i.H.node)) l - | RR.SRV l -> List.iter (fun (priority, weight, port, d) -> enqueue_additional d Packet.RR_A; diff --git a/lib/zone_parser.mly b/lib/zone_parser.mly index 9075af8bb..3105ec463 100644 --- a/lib/zone_parser.mly +++ b/lib/zone_parser.mly @@ -103,61 +103,7 @@ let parse_wks proto services = (* Parse an IPv6 address. (RFC 3513 section 2.2) *) let parse_ipv6 s = - failwith "notyet" - (* XXX TODO use the parsing regexps from ocaml-uri here? - let singledot = Regexp.Re.from_string "\\." in - let singlecolon = Regexp.Re.from_string ":" in - let doublecolon = Regexp.Re.from_string "::" in - (* Parse an IPv4 dotted-quad into big-endian bytes *) - let ipv4_chunk s = - match (Regexp.Re.split_delim singledot s) with - a :: b :: c :: d :: [] -> - let abyte = String.make 1 (char_of_int (parse_uint8 a)) in - let bbyte = String.make 1 (char_of_int (parse_uint8 b)) in - let cbyte = String.make 1 (char_of_int (parse_uint8 c)) in - let dbyte = String.make 1 (char_of_int (parse_uint8 d)) in - abyte ^ bbyte ^ cbyte ^ dbyte - | _ -> raise Parsing.Parse_error - in - (* Parse a 16-bit hex number into big-endian bytes *) - let ipv6_chunk s = - let n = int_of_string ("0x" ^ s) in - if n > 0xffff then raise Parsing.Parse_error; - let nl = char_of_int (n land 0xff) in - let nh = char_of_int ((n lsr 8) land 0xff) in - String.make 1 nh ^ (String.make 1 nl) - in - (* Before the "::" -- 16bit hex chunks *) - let rec ipv6_lhs = function - [] -> "" - | chunk :: rest -> ipv6_chunk chunk ^ (ipv6_lhs rest) - in - (* After the "::" -- 16bit hex chunks, but might end with ipv4 *) - let rec ipv6_rhs = function - [] -> "" - | chunk :: [] -> - begin - try ipv6_chunk chunk - with Failure _ | Parsing.Parse_error -> ipv4_chunk chunk - end - | chunk :: rest -> ipv6_chunk chunk ^ (ipv6_rhs rest) - in - let halves = Regexp.Re.split_delim doublecolon s in - match halves with - [] -> String.make 16 '\000' - | [ a ] -> - let r = ipv6_rhs (Regexp.Re.split_delim singlecolon a) in - let len = String.length r in - if not (len = 16) then raise Parsing.Parse_error; - r - | [ a ; b ] -> - let l = ipv6_lhs (Regexp.Re.split_delim singlecolon a) in - let r = ipv6_rhs (Regexp.Re.split_delim singlecolon b) in - let len = String.length r + (String.length l) in - if len > 16 then raise Parsing.Parse_error; - l ^ (String.make (16 - len) '\000') ^ r - | _ -> raise Parsing.Parse_error - *) + Ipaddr.V6.of_string_exn s %} From 03b532b4a6229f5651bac1c6130d4c7f1a31b405 Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Fri, 21 Feb 2014 14:26:27 +0000 Subject: [PATCH 19/23] bump minimum required ipaddr version for v6 support --- _oasis | 2 +- setup.ml | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/_oasis b/_oasis index 443f6184e..c799e0368 100644 --- a/_oasis +++ b/_oasis @@ -28,7 +28,7 @@ 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 (>= 0.2.2) + BuildDepends: cstruct (>= 0.7.1), cstruct.syntax, re, re.str, ipaddr (>= 2.2.0) Library lwt Path: lwt diff --git a/setup.ml b/setup.ml index 4d3786a33..4a9cd3ad3 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.4.1 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 5b25aec74303e6e96d0ce04f2f928acb) *) +(* DO NOT EDIT (digest: 5214479cc9ab67bc4b2e3f60caa35d9c) *) (* Regenerated by OASIS v0.4.1 Visit http://oasis.forge.ocamlcore.org for more information and @@ -6842,7 +6842,7 @@ let setup_t = FindlibPackage ("re.str", None); FindlibPackage ("ipaddr", - Some (OASISVersion.VGreaterEqual "0.2.2")) + Some (OASISVersion.VGreaterEqual "2.2.0")) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; @@ -7182,7 +7182,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.4.1"; - oasis_digest = Some "\007+^b\159G@õB\132zMéé°¸"; + oasis_digest = Some "dØL,²|Úmð\012½þ\000PÍ\154"; oasis_exec = None; oasis_setup_args = []; setup_update = false From 867b7ade47f481b8e7a21336613d1dc420fc9cfa Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Fri, 21 Feb 2014 14:30:31 +0000 Subject: [PATCH 20/23] Remove mirage-net from the required deps list --- .travis-ci.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis-ci.sh b/.travis-ci.sh index b30657af8..4e46bd933 100755 --- a/.travis-ci.sh +++ b/.travis-ci.sh @@ -1,4 +1,4 @@ -OPAM_DEPENDS="lwt cstruct ipaddr re ounit mirage-net cmdliner" +OPAM_DEPENDS="lwt cstruct ipaddr re ounit cmdliner" case "$OCAML_VERSION,$OPAM_VERSION" in 3.12.1,1.0.0) ppa=avsm/ocaml312+opam10 ;; From 7e507c796ad7823dda58371cbdd81f0262d4ea06 Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Fri, 21 Feb 2014 14:39:49 +0000 Subject: [PATCH 21/23] Keep the module types in `Dns_server` and `Dns_resolver` and instead move the Unix-specific functionality into `Dns_server_unix` and `Dns_resolver_unix`. This preserves backwards compatibility with dnscurve and is consistent with our style in other libraries. --- CHANGES | 6 +- _oasis | 4 +- lib_test/lwt_server.ml | 2 +- lib_test/time_server.ml | 2 +- lwt/dns_resolver.ml | 192 ++++++++++++++++---------------------- lwt/dns_resolver.mli | 64 +++++-------- lwt/dns_resolver_core.ml | 118 ----------------------- lwt/dns_resolver_core.mli | 38 -------- lwt/dns_resolver_unix.ml | 154 ++++++++++++++++++++++++++++++ lwt/dns_resolver_unix.mli | 58 ++++++++++++ lwt/dns_server.ml | 130 ++++++++++++-------------- lwt/dns_server.mli | 43 ++++----- lwt/dns_server_core.ml | 72 -------------- lwt/dns_server_core.mli | 45 --------- lwt/dns_server_unix.ml | 78 ++++++++++++++++ lwt/dns_server_unix.mli | 44 +++++++++ lwt/lwt-core.mllib | 6 +- lwt/lwt.mllib | 6 +- lwt/mldig.ml | 8 +- setup.ml | 8 +- 20 files changed, 539 insertions(+), 539 deletions(-) delete mode 100644 lwt/dns_resolver_core.ml delete mode 100644 lwt/dns_resolver_core.mli create mode 100644 lwt/dns_resolver_unix.ml create mode 100644 lwt/dns_resolver_unix.mli delete mode 100644 lwt/dns_server_core.ml delete mode 100644 lwt/dns_server_core.mli create mode 100644 lwt/dns_server_unix.ml create mode 100644 lwt/dns_server_unix.mli diff --git a/CHANGES b/CHANGES index 3590f7784..05695bcf1 100644 --- a/CHANGES +++ b/CHANGES @@ -1,14 +1,14 @@ 0.8.0 (trunk): * Use `Ipaddr.V6` to restore IPv6/AAAA RR support. -* Add a `Dns_resolver_core` that is a portable Lwt resolver. * `process_query` now takes an output buffer so it doesn't have to overwrite the input buffer it just parsed. * Add Travis continuous integration scripts. * Regenerate with OASIS 0.4.1 * Split the `dns.lwt` into a portable `dns.lwt-core` that doesn't require Unix (from which a Mirage version can be built). The only - change to existing applications is that `module type PROCESSOR` now - comes from `Dns_server_core` rather than `Dns_server`. + change to existing applications is that Unix-specific functions + have shifted into `Dns_resolver_unix` or `Dns_server_unix`, with + the module types for `PROCESSOR` and `CLIENT` unchanged. 0.7.0 (2013-08-26): * Add path argument to `Resolv_conf in Dns_resolver.config. diff --git a/_oasis b/_oasis index c799e0368..af8c0c87b 100644 --- a/_oasis +++ b/_oasis @@ -35,7 +35,7 @@ Library lwt Build$: flag(lwt) Install$: flag(lwt) Findlibname: lwt - Modules: Dns_server, Dns_resolver + Modules: Dns_server_unix, Dns_resolver_unix BuildDepends: lwt.unix (>= 2.4.1), cstruct.lwt, lwt.syntax, dns, dns.lwt-core, ipaddr.unix FindlibParent: dns @@ -44,7 +44,7 @@ Library "lwt-core" Build$: flag(lwt) Install$: flag(lwt) Findlibname: lwt-core - Modules: Dns_server_core, Dns_resolver_core + Modules: Dns_server, Dns_resolver BuildDepends: lwt, cstruct, lwt.syntax, dns FindlibParent: dns diff --git a/lib_test/lwt_server.ml b/lib_test/lwt_server.ml index af278edce..4ee92497a 100644 --- a/lib_test/lwt_server.ml +++ b/lib_test/lwt_server.ml @@ -16,7 +16,7 @@ open Lwt -let t = Dns_server.serve_with_zonefile +let t = Dns_server_unix.serve_with_zonefile ~address:"0.0.0.0" ~port:5354 ~zonefile:"lib_test/test.zone" let _ = Lwt_main.run t diff --git a/lib_test/time_server.ml b/lib_test/time_server.ml index 68c0dadc1..7f4040c46 100644 --- a/lib_test/time_server.ml +++ b/lib_test/time_server.ml @@ -42,7 +42,7 @@ let dnsfn ~src ~dst query = let _ = let address = "0.0.0.0" in let port = 5354 in - let open Dns_server_core in let open Dns_server in + let open Dns_server_unix in let processor = (processor_of_process dnsfn :> (module PROCESSOR)) in Lwt_main.run (serve_with_processor ~address ~port ~processor) diff --git a/lwt/dns_resolver.ml b/lwt/dns_resolver.ml index 3809c0bf9..da4dcfb6a 100644 --- a/lwt/dns_resolver.ml +++ b/lwt/dns_resolver.ml @@ -21,134 +21,98 @@ open Printf open Dns.Name open Dns.Operators open Dns.Protocol -open Dns_resolver_core module DP = Dns.Packet -let buflen = 4096 -let ns = "8.8.8.8" -let port = 53 - -let sockaddr addr port = - Lwt_unix.(ADDR_INET (Unix.inet_addr_of_string addr, port)) - -let sockaddr_to_string = Lwt_unix.(function - | ADDR_INET (a,p) -> sprintf "%s/%d" (Unix.string_of_inet_addr a) p - | ADDR_UNIX s -> s ^ "/UNIX" - ) - -let outfd addr port = - let fd = Lwt_unix.(socket PF_INET SOCK_DGRAM 17) in - Lwt_unix.(bind fd (sockaddr addr port)); - fd - -let connect_to_resolver server port = - let dst = sockaddr server port in - let ofd = outfd "0.0.0.0" 0 in - let txfn buf = - Lwt_bytes.sendto ofd buf 0 (Dns.Buf.length buf) [] dst - >>= fun _ -> return_unit in - let rec rxfn f = - let buf = Dns.Buf.create buflen in - Lwt_bytes.recvfrom ofd buf 0 buflen [] - >>= fun (len, sa) -> - let buf = Dns.Buf.sub buf 0 len in - match f buf with - | None -> rxfn f - | Some r -> return r - in - txfn, rxfn +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) + +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 + | 0 -> return () + | count -> + lwt _ = txfn q in + lwt _ = Lwt_unix.sleep 5.0 in + printf "retrying query for %d times\n%!" (4-count); + send_req txfn q (count - 1) + +let send_pkt client (txfn,rxfn) 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 + >>= fun () -> return (wakeup w (Error (R.timeout ctxt)))); + (catch + (fun () -> + rxfn (R.parse ctxt) + >>= fun r -> return (wakeup w (Answer r)) + ) + (fun exn -> return (wakeup w (Error exn))) + ) + ]); + t + ) cqpl in + (* return an answer or all the errors if no request succeeded *) + let rec select errors = function + | [] -> fail (Dns_resolve_error errors) + | ts -> + nchoose_split ts + >>= fun (rs, ts) -> + let rec find_answer errors = function + | [] -> select errors ts + | (Answer a)::_ -> return a + | (Error e)::r -> find_answer (e::errors) r + in + find_answer errors rs + in select [] resl let resolve client ?(dnssec=false) - (server:string) (dns_port:int) + commfn (q_class:DP.q_class) (q_type:DP.q_type) (q_name:domain_name) = - let commfn = connect_to_resolver server dns_port in - Dns_resolver_core.resolve client ~dnssec commfn q_class q_type q_name + try_lwt + let id = (let module R = (val client : CLIENT) in R.get_id ()) in + let q = Dns.Query.create ~id ~dnssec q_class q_type q_name in + log_info (sprintf "query: %s\n%!" (DP.to_string q)); + send_pkt client commfn q + with exn -> + log_warn (sprintf "%s\n%!" (Printexc.to_string exn)); + fail exn let gethostbyname - ?(server:string = ns) ?(dns_port:int = port) ?(q_class:DP.q_class = DP.Q_IN) ?(q_type:DP.q_type = DP.Q_A) + commfn name = - let commfn = connect_to_resolver server dns_port in - Dns_resolver_core.gethostbyname ~q_class ~q_type commfn name + let open DP in + let domain = string_to_domain_name name in + resolve (module Dns.Protocol.Client) commfn q_class q_type domain + >|= fun r -> + List.fold_left (fun a x -> + match x.rdata with |A ip -> ip::a |_ -> a + ) [] r.answers + |> List.rev let gethostbyaddr - ?(server:string = ns) ?(dns_port:int = port) ?(q_class:DP.q_class = DP.Q_IN) ?(q_type:DP.q_type = DP.Q_PTR) + commfn addr = - let commfn = connect_to_resolver server dns_port in - Dns_resolver_core.gethostbyaddr ~q_class ~q_type commfn addr - -open Dns.Resolvconf - -type t = { - client : (module CLIENT); - servers : (string * int) list; - search_domains : string list; -} - -type config = [ - | `Resolv_conf of string - | `Static of (string * int) list * string list -] - -module Resolv_conf = struct - let default_file = "/etc/resolv.conf" - - let get_resolvers ?(file=default_file) () = - Lwt_io.with_file ~mode:Lwt_io.input file (fun ic -> - (* Read lines and filter out whitespace/blanks *) - let lines = Lwt_stream.filter_map map_line (Lwt_io.read_lines ic) in - let warn x = prerr_endline (Printf.sprintf "resolvconf in file %s: %s" file x) in - (* Parse remaining lines *) - Lwt_stream.(to_list (filter_map (fun line -> - try Some (KeywordValue.of_string line) - with - | KeywordValue.Unknown x -> warn ("unknown keyword: " ^ x); None - | OptionsValue.Unknown x -> warn ("unknown option: " ^ x); None - | LookupValue.Unknown x -> warn ("unknown lookup option: " ^ x); None - ) lines)) - ) - - let create client ?(file=default_file) () = - lwt t = get_resolvers ~file () in - return { - client; - servers = all_servers t; - search_domains = search_domains t; - } -end - -module Static = struct - let create client ?(servers=["8.8.8.8",53]) ?(search_domains=[]) () = - { client; servers; search_domains } -end - -let create - ?(client=(module Dns.Protocol.Client : CLIENT)) - ?(config=`Resolv_conf Resolv_conf.default_file) () = - match config with - |`Static (servers, search_domains) -> - return (Static.create client ~servers ~search_domains ()) - |`Resolv_conf file -> Resolv_conf.create client ~file () - -let gethostbyname t ?q_class ?q_type q_name = - match t.servers with - |[] -> fail (Failure "No resolvers available") - |(server,dns_port)::_ -> - gethostbyname ~server ~dns_port ?q_class ?q_type q_name - -let gethostbyaddr t ?q_class ?q_type q_name = - match t.servers with - |[] -> fail (Failure "No resolvers available") - |(server,dns_port)::_ -> - gethostbyaddr ~server ~dns_port ?q_class ?q_type q_name - -let resolve t ?(dnssec=false) q_class q_type q_name = - match t.servers with - |[] -> fail (Failure "No resolvers available") - |(server,dns_port)::_ -> - resolve t.client ~dnssec server dns_port q_class q_type q_name + let addr = for_reverse addr in + log_info (sprintf "gethostbyaddr: %s" (domain_name_to_string addr)); + let open DP in + resolve (module Dns.Protocol.Client) commfn q_class q_type addr + >|= fun r -> + List.fold_left (fun a x -> + match x.rdata with |PTR n -> (domain_name_to_string n)::a |_->a + ) [] r.answers + |> List.rev diff --git a/lwt/dns_resolver.mli b/lwt/dns_resolver.mli index 03c844fdb..0c9bbcbbb 100644 --- a/lwt/dns_resolver.mli +++ b/lwt/dns_resolver.mli @@ -1,4 +1,5 @@ (* + * Copyright (c) 2014 Anil Madhavapeddy * Copyright (c) 2012 Richard Mortier * * Permission to use, copy, modify, and distribute this software for any @@ -14,45 +15,24 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Dns.Name -open Dns.Packet -open Dns.Protocol -open Cstruct - -type t = { - client : (module CLIENT); - servers : (string * int) list; - search_domains : string list; -} - -type config = [ - | `Resolv_conf of string - | `Static of (string * int) list * string list -] - -(** Create a resolver instance that either uses the system - /etc/resolv.conf, or a statically specified preference - *) -val create : ?client:(module CLIENT) -> ?config:config -> unit -> t Lwt.t - -(** Lookup a {! domain_name }. - - @return the corresponding IPv4 addresses. -*) -val gethostbyname : t -> ?q_class:q_class -> ?q_type:q_type - -> string -> Ipaddr.V4.t list Lwt.t - -(** Reverse lookup an IPv4 address. - - @return the corresponding {! domain_name }s. -*) -val gethostbyaddr : t -> ?q_class:q_class -> ?q_type:q_type - -> Ipaddr.V4.t -> string list Lwt.t - -(** Resolve a fully specified query, {! q_class }, {! q_type } and {! - domain_name }. - - @return the full a {! dns } structure. -*) -val resolve : t -> ?dnssec:bool -> q_class -> q_type -> - domain_name -> Dns.Packet.t Lwt.t +type commfn = + (Dns.Buf.t -> unit Lwt.t) * + ((Dns.Buf.t -> Dns.Packet.t option) -> Dns.Packet.t Lwt.t) + +val resolve : + (module Dns.Protocol.CLIENT) -> + ?dnssec:bool -> + commfn -> Dns.Packet.q_class -> + Dns.Packet.q_type -> + Dns.Name.domain_name -> + Dns.Packet.t Lwt.t + +val gethostbyname : + ?q_class:Dns.Packet.q_class -> + ?q_type:Dns.Packet.q_type -> commfn -> + string -> Ipaddr.V4.t list Lwt.t + +val gethostbyaddr : + ?q_class:Dns.Packet.q_class -> + ?q_type:Dns.Packet.q_type -> commfn -> + Ipaddr.V4.t -> string list Lwt.t diff --git a/lwt/dns_resolver_core.ml b/lwt/dns_resolver_core.ml deleted file mode 100644 index da4dcfb6a..000000000 --- a/lwt/dns_resolver_core.ml +++ /dev/null @@ -1,118 +0,0 @@ -(* - * Copyright (c) 2014 Anil Madhavapeddy - * Copyright (c) 2012 Richard Mortier - * Copyright (c) 2013 David Sheets - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - *) - -open Lwt -open Printf -open Dns.Name -open Dns.Operators -open Dns.Protocol - -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) - -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 - | 0 -> return () - | count -> - lwt _ = txfn q in - lwt _ = Lwt_unix.sleep 5.0 in - printf "retrying query for %d times\n%!" (4-count); - send_req txfn q (count - 1) - -let send_pkt client (txfn,rxfn) 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 - >>= fun () -> return (wakeup w (Error (R.timeout ctxt)))); - (catch - (fun () -> - rxfn (R.parse ctxt) - >>= fun r -> return (wakeup w (Answer r)) - ) - (fun exn -> return (wakeup w (Error exn))) - ) - ]); - t - ) cqpl in - (* return an answer or all the errors if no request succeeded *) - let rec select errors = function - | [] -> fail (Dns_resolve_error errors) - | ts -> - nchoose_split ts - >>= fun (rs, ts) -> - let rec find_answer errors = function - | [] -> select errors ts - | (Answer a)::_ -> return a - | (Error e)::r -> find_answer (e::errors) r - in - find_answer errors rs - in select [] resl - -let resolve client - ?(dnssec=false) - commfn - (q_class:DP.q_class) (q_type:DP.q_type) - (q_name:domain_name) = - try_lwt - let id = (let module R = (val client : CLIENT) in R.get_id ()) in - let q = Dns.Query.create ~id ~dnssec q_class q_type q_name in - log_info (sprintf "query: %s\n%!" (DP.to_string q)); - send_pkt client commfn q - with exn -> - log_warn (sprintf "%s\n%!" (Printexc.to_string exn)); - fail exn - -let gethostbyname - ?(q_class:DP.q_class = DP.Q_IN) ?(q_type:DP.q_type = DP.Q_A) - commfn - name = - let open DP in - let domain = string_to_domain_name name in - resolve (module Dns.Protocol.Client) commfn q_class q_type domain - >|= fun r -> - List.fold_left (fun a x -> - match x.rdata with |A ip -> ip::a |_ -> a - ) [] r.answers - |> List.rev - -let gethostbyaddr - ?(q_class:DP.q_class = DP.Q_IN) ?(q_type:DP.q_type = DP.Q_PTR) - commfn - addr - = - let addr = for_reverse addr in - log_info (sprintf "gethostbyaddr: %s" (domain_name_to_string addr)); - let open DP in - resolve (module Dns.Protocol.Client) commfn q_class q_type addr - >|= fun r -> - List.fold_left (fun a x -> - match x.rdata with |PTR n -> (domain_name_to_string n)::a |_->a - ) [] r.answers - |> List.rev diff --git a/lwt/dns_resolver_core.mli b/lwt/dns_resolver_core.mli deleted file mode 100644 index 0c9bbcbbb..000000000 --- a/lwt/dns_resolver_core.mli +++ /dev/null @@ -1,38 +0,0 @@ -(* - * Copyright (c) 2014 Anil Madhavapeddy - * Copyright (c) 2012 Richard Mortier - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - *) - -type commfn = - (Dns.Buf.t -> unit Lwt.t) * - ((Dns.Buf.t -> Dns.Packet.t option) -> Dns.Packet.t Lwt.t) - -val resolve : - (module Dns.Protocol.CLIENT) -> - ?dnssec:bool -> - commfn -> Dns.Packet.q_class -> - Dns.Packet.q_type -> - Dns.Name.domain_name -> - Dns.Packet.t Lwt.t - -val gethostbyname : - ?q_class:Dns.Packet.q_class -> - ?q_type:Dns.Packet.q_type -> commfn -> - string -> Ipaddr.V4.t list Lwt.t - -val gethostbyaddr : - ?q_class:Dns.Packet.q_class -> - ?q_type:Dns.Packet.q_type -> commfn -> - Ipaddr.V4.t -> string list Lwt.t diff --git a/lwt/dns_resolver_unix.ml b/lwt/dns_resolver_unix.ml new file mode 100644 index 000000000..708fa128d --- /dev/null +++ b/lwt/dns_resolver_unix.ml @@ -0,0 +1,154 @@ +(* + * Copyright (c) 2014 Anil Madhavapeddy + * Copyright (c) 2012 Richard Mortier + * Copyright (c) 2013 David Sheets + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Lwt +open Printf +open Dns.Name +open Dns.Operators +open Dns.Protocol +open Dns_resolver + +module DP = Dns.Packet + +let buflen = 4096 +let ns = "8.8.8.8" +let port = 53 + +let sockaddr addr port = + Lwt_unix.(ADDR_INET (Unix.inet_addr_of_string addr, port)) + +let sockaddr_to_string = Lwt_unix.(function + | ADDR_INET (a,p) -> sprintf "%s/%d" (Unix.string_of_inet_addr a) p + | ADDR_UNIX s -> s ^ "/UNIX" + ) + +let outfd addr port = + let fd = Lwt_unix.(socket PF_INET SOCK_DGRAM 17) in + Lwt_unix.(bind fd (sockaddr addr port)); + fd + +let connect_to_resolver server port = + let dst = sockaddr server port in + let ofd = outfd "0.0.0.0" 0 in + let txfn buf = + Lwt_bytes.sendto ofd buf 0 (Dns.Buf.length buf) [] dst + >>= fun _ -> return_unit in + let rec rxfn f = + let buf = Dns.Buf.create buflen in + Lwt_bytes.recvfrom ofd buf 0 buflen [] + >>= fun (len, sa) -> + let buf = Dns.Buf.sub buf 0 len in + match f buf with + | None -> rxfn f + | Some r -> return r + in + txfn, rxfn + +let resolve client + ?(dnssec=false) + (server:string) (dns_port:int) + (q_class:DP.q_class) (q_type:DP.q_type) + (q_name:domain_name) = + let commfn = connect_to_resolver server dns_port in + resolve client ~dnssec commfn q_class q_type q_name + +let gethostbyname + ?(server:string = ns) ?(dns_port:int = port) + ?(q_class:DP.q_class = DP.Q_IN) ?(q_type:DP.q_type = DP.Q_A) + name = + let commfn = connect_to_resolver server dns_port in + gethostbyname ~q_class ~q_type commfn name + +let gethostbyaddr + ?(server:string = ns) ?(dns_port:int = port) + ?(q_class:DP.q_class = DP.Q_IN) ?(q_type:DP.q_type = DP.Q_PTR) + addr + = + let commfn = connect_to_resolver server dns_port in + gethostbyaddr ~q_class ~q_type commfn addr + +open Dns.Resolvconf + +type t = { + client : (module CLIENT); + servers : (string * int) list; + search_domains : string list; +} + +type config = [ + | `Resolv_conf of string + | `Static of (string * int) list * string list +] + +module Resolv_conf = struct + let default_file = "/etc/resolv.conf" + + let get_resolvers ?(file=default_file) () = + Lwt_io.with_file ~mode:Lwt_io.input file (fun ic -> + (* Read lines and filter out whitespace/blanks *) + let lines = Lwt_stream.filter_map map_line (Lwt_io.read_lines ic) in + let warn x = prerr_endline (Printf.sprintf "resolvconf in file %s: %s" file x) in + (* Parse remaining lines *) + Lwt_stream.(to_list (filter_map (fun line -> + try Some (KeywordValue.of_string line) + with + | KeywordValue.Unknown x -> warn ("unknown keyword: " ^ x); None + | OptionsValue.Unknown x -> warn ("unknown option: " ^ x); None + | LookupValue.Unknown x -> warn ("unknown lookup option: " ^ x); None + ) lines)) + ) + + let create client ?(file=default_file) () = + lwt t = get_resolvers ~file () in + return { + client; + servers = all_servers t; + search_domains = search_domains t; + } +end + +module Static = struct + let create client ?(servers=["8.8.8.8",53]) ?(search_domains=[]) () = + { client; servers; search_domains } +end + +let create + ?(client=(module Dns.Protocol.Client : CLIENT)) + ?(config=`Resolv_conf Resolv_conf.default_file) () = + match config with + |`Static (servers, search_domains) -> + return (Static.create client ~servers ~search_domains ()) + |`Resolv_conf file -> Resolv_conf.create client ~file () + +let gethostbyname t ?q_class ?q_type q_name = + match t.servers with + |[] -> fail (Failure "No resolvers available") + |(server,dns_port)::_ -> + gethostbyname ~server ~dns_port ?q_class ?q_type q_name + +let gethostbyaddr t ?q_class ?q_type q_name = + match t.servers with + |[] -> fail (Failure "No resolvers available") + |(server,dns_port)::_ -> + gethostbyaddr ~server ~dns_port ?q_class ?q_type q_name + +let resolve t ?(dnssec=false) q_class q_type q_name = + match t.servers with + |[] -> fail (Failure "No resolvers available") + |(server,dns_port)::_ -> + resolve t.client ~dnssec server dns_port q_class q_type q_name diff --git a/lwt/dns_resolver_unix.mli b/lwt/dns_resolver_unix.mli new file mode 100644 index 000000000..03c844fdb --- /dev/null +++ b/lwt/dns_resolver_unix.mli @@ -0,0 +1,58 @@ +(* + * Copyright (c) 2012 Richard Mortier + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Dns.Name +open Dns.Packet +open Dns.Protocol +open Cstruct + +type t = { + client : (module CLIENT); + servers : (string * int) list; + search_domains : string list; +} + +type config = [ + | `Resolv_conf of string + | `Static of (string * int) list * string list +] + +(** Create a resolver instance that either uses the system + /etc/resolv.conf, or a statically specified preference + *) +val create : ?client:(module CLIENT) -> ?config:config -> unit -> t Lwt.t + +(** Lookup a {! domain_name }. + + @return the corresponding IPv4 addresses. +*) +val gethostbyname : t -> ?q_class:q_class -> ?q_type:q_type + -> string -> Ipaddr.V4.t list Lwt.t + +(** Reverse lookup an IPv4 address. + + @return the corresponding {! domain_name }s. +*) +val gethostbyaddr : t -> ?q_class:q_class -> ?q_type:q_type + -> Ipaddr.V4.t -> string list Lwt.t + +(** Resolve a fully specified query, {! q_class }, {! q_type } and {! + domain_name }. + + @return the full a {! dns } structure. +*) +val resolve : t -> ?dnssec:bool -> q_class -> q_type -> + domain_name -> Dns.Packet.t Lwt.t diff --git a/lwt/dns_server.ml b/lwt/dns_server.ml index 961e9541a..1b547e274 100644 --- a/lwt/dns_server.ml +++ b/lwt/dns_server.ml @@ -1,78 +1,72 @@ +(* + * Copyright (c) 2005-2012 Anil Madhavapeddy + * Copyright (c) 2013 David Sheets + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + open Lwt +open Printf -open Dns_server_core +module DR = Dns.RR +module DP = Dns.Packet -let bind_fd ~address ~port = - lwt src = - try_lwt - (* should this be lwt hent = Lwt_lib.gethostbyname addr ? *) - let hent = Unix.gethostbyname address in - return (Unix.ADDR_INET (hent.Unix.h_addr_list.(0), port)) - with _ -> - raise_lwt (Failure ("cannot resolve " ^ address)) - in - let fd = Lwt_unix.(socket PF_INET SOCK_DGRAM 0) in - let () = Lwt_unix.bind fd src in - return (fd,src) +type addr = Ipaddr.t * int -let eventual_process_of_zonefile zonefile = - let lines = Lwt_io.lines_of_file zonefile in - let buf = Buffer.create 1024 in - Lwt_stream.iter (fun l -> - Buffer.add_string buf l; - Buffer.add_char buf '\n') lines - >>= fun () -> - return (process_of_zonebuf (Buffer.contents buf)) +type 'a process = src:addr -> dst:addr -> 'a -> Dns.Query.answer option Lwt.t -let bufsz = 4096 +module type PROCESSOR = sig + include Dns.Protocol.SERVER + val process : context process +end -let ipaddr_of_sockaddr = - function - | Unix.ADDR_UNIX _ -> fail (Failure "Unix domain sockets not supported") - | Unix.ADDR_INET (ip,port) -> return (Ipaddr_unix.of_inet_addr ip, port) +type 'a processor = (module PROCESSOR with type context = 'a) -let listen ~fd ~src ~processor = - let cont = ref true in - let bufs = Lwt_pool.create 64 - (fun () -> return (Dns.Buf.create bufsz)) in - lwt src = ipaddr_of_sockaddr src in - let _ = - while_lwt !cont do - Lwt_pool.use bufs - (fun buf -> - lwt len, dst = Lwt_bytes.recvfrom fd buf 0 bufsz [] in - (* TODO Process in a background thread; should be a bounded queue *) - let _ = ignore_result ( - lwt dst' = ipaddr_of_sockaddr dst in - process_query buf len buf src dst' processor - >>= function - | None -> return () - | Some buf -> - Lwt_bytes.sendto fd buf 0 (Dns.Buf.length buf) [] dst - >>= fun _ -> return () - ) in - return () - ) - done - in - let t,u = Lwt.task () in - Lwt.on_cancel t - (fun () -> Printf.eprintf "listen: cancelled\n%!"; cont := false); - Printf.eprintf "listen: done\n%!"; - t +let process_query buf len obuf src dst processor = + let module Processor = (val processor : PROCESSOR) in + match Processor.parse (Dns.Buf.sub buf 0 len) with + |None -> return None + |Some ctxt -> begin + lwt answer = Processor.process ~src ~dst ctxt in + match answer with + |None -> return None + |Some answer -> + let query = Processor.query_of_context ctxt in + let response = Dns.Query.response_of_answer query answer in + return (Processor.marshal obuf ctxt response) + end -let serve_with_processor ~address ~port ~processor = - bind_fd ~address ~port - >>= fun (fd, src) -> listen ~fd ~src ~processor +let processor_of_process process : Dns.Packet.t processor = + let module P = struct + include Dns.Protocol.Server -let serve_with_zonebuf ~address ~port ~zonebuf = - let process = process_of_zonebuf zonebuf in - let processor = (processor_of_process process :> (module PROCESSOR)) in - serve_with_processor ~address ~port ~processor - -let serve_with_zonefile ~address ~port ~zonefile = - eventual_process_of_zonefile zonefile - >>= fun process -> - let processor = (processor_of_process process :> (module PROCESSOR)) in - serve_with_processor ~address ~port ~processor + let process = process + end in + (module P) +let process_of_zonebuf zonebuf = + let db = Dns.Zone.load [] zonebuf in + let dnstrie = db.Dns.Loader.trie in + let get_answer qname qtype id = + let qname = List.map String.lowercase qname in + Dns.Query.answer ~dnssec:true qname qtype dnstrie + in + fun ~src ~dst d -> + let open DP in + (* TODO: FIXME so that 0 question queries don't crash the server *) + let q = List.hd d.questions in + let r = + Dns.Protocol.contain_exc "answer" + (fun () -> get_answer q.q_name q.q_type d.id) + in + return r diff --git a/lwt/dns_server.mli b/lwt/dns_server.mli index 12ce93703..a0e13ac01 100644 --- a/lwt/dns_server.mli +++ b/lwt/dns_server.mli @@ -1,5 +1,5 @@ (* - * Copyright (c) 2011-2014 Anil Madhavapeddy + * Copyright (c) 2011 Anil Madhavapeddy * Copyright (c) 2013 David Sheets * * Permission to use, copy, modify, and distribute this software for any @@ -15,30 +15,31 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Dns_server_core +type addr = Ipaddr.t * int -(** Given a source address and a port, return a bound file descriptor and - source sockaddr suitable for passing to the [listen] functions *) -val bind_fd : - address:string -> port:int -> (Lwt_unix.file_descr * Lwt_unix.sockaddr) Lwt.t +type 'a process = src:addr -> dst:addr -> 'a -> Dns.Query.answer option Lwt.t -val eventual_process_of_zonefile : string -> Dns.Packet.t process Lwt.t +module type PROCESSOR = sig + include Dns.Protocol.SERVER -(** General listening function for DNS servers. Pass in the [fd] and - [src] from calling [bind_fd] and supply a [processor] which - deserializes the wire format, generates a DNS response packet, - and serializes it into the wire format -*) -val listen : - fd:Lwt_unix.file_descr -> src:Lwt_unix.sockaddr - -> processor:(module PROCESSOR) -> unit Lwt.t + (** DNS responder function. + @param src Server sockaddr + @param dst Client sockaddr + @param Query packet + @return Answer packet + *) + val process : context process +end -val serve_with_processor : - address:string -> port:int -> processor:(module PROCESSOR) -> unit Lwt.t +type 'a processor = (module PROCESSOR with type context = 'a) -val serve_with_zonebuf : - address:string -> port:int -> zonebuf:string -> unit Lwt.t -val serve_with_zonefile : - address:string -> port:int -> zonefile:string -> unit Lwt.t +(** [process_query ibuf ibuflen obuf src dst processor] *) +val process_query: Dns.Buf.t -> int -> Dns.Buf.t -> addr -> addr -> + (module PROCESSOR) -> Dns.Buf.t option Lwt.t + +val processor_of_process : Dns.Packet.t process -> Dns.Packet.t processor + +val process_of_zonebuf : string -> Dns.Packet.t process + diff --git a/lwt/dns_server_core.ml b/lwt/dns_server_core.ml deleted file mode 100644 index 1b547e274..000000000 --- a/lwt/dns_server_core.ml +++ /dev/null @@ -1,72 +0,0 @@ -(* - * Copyright (c) 2005-2012 Anil Madhavapeddy - * Copyright (c) 2013 David Sheets - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - *) - -open Lwt -open Printf - -module DR = Dns.RR -module DP = Dns.Packet - -type addr = Ipaddr.t * int - -type 'a process = src:addr -> dst:addr -> 'a -> Dns.Query.answer option Lwt.t - -module type PROCESSOR = sig - include Dns.Protocol.SERVER - val process : context process -end - -type 'a processor = (module PROCESSOR with type context = 'a) - -let process_query buf len obuf src dst processor = - let module Processor = (val processor : PROCESSOR) in - match Processor.parse (Dns.Buf.sub buf 0 len) with - |None -> return None - |Some ctxt -> begin - lwt answer = Processor.process ~src ~dst ctxt in - match answer with - |None -> return None - |Some answer -> - let query = Processor.query_of_context ctxt in - let response = Dns.Query.response_of_answer query answer in - return (Processor.marshal obuf ctxt response) - end - -let processor_of_process process : Dns.Packet.t processor = - let module P = struct - include Dns.Protocol.Server - - let process = process - end in - (module P) - -let process_of_zonebuf zonebuf = - let db = Dns.Zone.load [] zonebuf in - let dnstrie = db.Dns.Loader.trie in - let get_answer qname qtype id = - let qname = List.map String.lowercase qname in - Dns.Query.answer ~dnssec:true qname qtype dnstrie - in - fun ~src ~dst d -> - let open DP in - (* TODO: FIXME so that 0 question queries don't crash the server *) - let q = List.hd d.questions in - let r = - Dns.Protocol.contain_exc "answer" - (fun () -> get_answer q.q_name q.q_type d.id) - in - return r diff --git a/lwt/dns_server_core.mli b/lwt/dns_server_core.mli deleted file mode 100644 index a0e13ac01..000000000 --- a/lwt/dns_server_core.mli +++ /dev/null @@ -1,45 +0,0 @@ -(* - * Copyright (c) 2011 Anil Madhavapeddy - * Copyright (c) 2013 David Sheets - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - *) - -type addr = Ipaddr.t * int - -type 'a process = src:addr -> dst:addr -> 'a -> Dns.Query.answer option Lwt.t - -module type PROCESSOR = sig - include Dns.Protocol.SERVER - - (** DNS responder function. - @param src Server sockaddr - @param dst Client sockaddr - @param Query packet - @return Answer packet - *) - val process : context process -end - -type 'a processor = (module PROCESSOR with type context = 'a) - - -(** [process_query ibuf ibuflen obuf src dst processor] *) -val process_query: Dns.Buf.t -> int -> Dns.Buf.t -> addr -> addr -> - (module PROCESSOR) -> Dns.Buf.t option Lwt.t - -val processor_of_process : Dns.Packet.t process -> Dns.Packet.t processor - -val process_of_zonebuf : string -> Dns.Packet.t process - - diff --git a/lwt/dns_server_unix.ml b/lwt/dns_server_unix.ml new file mode 100644 index 000000000..e7b6f3cdc --- /dev/null +++ b/lwt/dns_server_unix.ml @@ -0,0 +1,78 @@ +open Lwt + +open Dns_server + +let bind_fd ~address ~port = + lwt src = + try_lwt + (* should this be lwt hent = Lwt_lib.gethostbyname addr ? *) + let hent = Unix.gethostbyname address in + return (Unix.ADDR_INET (hent.Unix.h_addr_list.(0), port)) + with _ -> + raise_lwt (Failure ("cannot resolve " ^ address)) + in + let fd = Lwt_unix.(socket PF_INET SOCK_DGRAM 0) in + let () = Lwt_unix.bind fd src in + return (fd,src) + +let eventual_process_of_zonefile zonefile = + let lines = Lwt_io.lines_of_file zonefile in + let buf = Buffer.create 1024 in + Lwt_stream.iter (fun l -> + Buffer.add_string buf l; + Buffer.add_char buf '\n') lines + >>= fun () -> + return (process_of_zonebuf (Buffer.contents buf)) + +let bufsz = 4096 + +let ipaddr_of_sockaddr = + function + | Unix.ADDR_UNIX _ -> fail (Failure "Unix domain sockets not supported") + | Unix.ADDR_INET (ip,port) -> return (Ipaddr_unix.of_inet_addr ip, port) + +let listen ~fd ~src ~processor = + let cont = ref true in + let bufs = Lwt_pool.create 64 + (fun () -> return (Dns.Buf.create bufsz)) in + lwt src = ipaddr_of_sockaddr src in + let _ = + while_lwt !cont do + Lwt_pool.use bufs + (fun buf -> + lwt len, dst = Lwt_bytes.recvfrom fd buf 0 bufsz [] in + (* TODO Process in a background thread; should be a bounded queue *) + let _ = ignore_result ( + lwt dst' = ipaddr_of_sockaddr dst in + process_query buf len buf src dst' processor + >>= function + | None -> return () + | Some buf -> + Lwt_bytes.sendto fd buf 0 (Dns.Buf.length buf) [] dst + >>= fun _ -> return () + ) in + return () + ) + done + in + let t,u = Lwt.task () in + Lwt.on_cancel t + (fun () -> Printf.eprintf "listen: cancelled\n%!"; cont := false); + Printf.eprintf "listen: done\n%!"; + t + +let serve_with_processor ~address ~port ~processor = + bind_fd ~address ~port + >>= fun (fd, src) -> listen ~fd ~src ~processor + +let serve_with_zonebuf ~address ~port ~zonebuf = + let process = process_of_zonebuf zonebuf in + let processor = (processor_of_process process :> (module PROCESSOR)) in + serve_with_processor ~address ~port ~processor + +let serve_with_zonefile ~address ~port ~zonefile = + eventual_process_of_zonefile zonefile + >>= fun process -> + let processor = (processor_of_process process :> (module PROCESSOR)) in + serve_with_processor ~address ~port ~processor + diff --git a/lwt/dns_server_unix.mli b/lwt/dns_server_unix.mli new file mode 100644 index 000000000..c3f7f36f1 --- /dev/null +++ b/lwt/dns_server_unix.mli @@ -0,0 +1,44 @@ +(* + * Copyright (c) 2011-2014 Anil Madhavapeddy + * Copyright (c) 2013 David Sheets + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Dns_server + +(** Given a source address and a port, return a bound file descriptor and + source sockaddr suitable for passing to the [listen] functions *) +val bind_fd : + address:string -> port:int -> (Lwt_unix.file_descr * Lwt_unix.sockaddr) Lwt.t + +val eventual_process_of_zonefile : string -> Dns.Packet.t process Lwt.t + +(** General listening function for DNS servers. Pass in the [fd] and + [src] from calling [bind_fd] and supply a [processor] which + deserializes the wire format, generates a DNS response packet, + and serializes it into the wire format +*) +val listen : + fd:Lwt_unix.file_descr -> src:Lwt_unix.sockaddr + -> processor:(module PROCESSOR) -> unit Lwt.t + +val serve_with_processor : + address:string -> port:int -> processor:(module PROCESSOR) -> unit Lwt.t + +val serve_with_zonebuf : + address:string -> port:int -> zonebuf:string -> unit Lwt.t + +val serve_with_zonefile : + address:string -> port:int -> zonefile:string -> unit Lwt.t + diff --git a/lwt/lwt-core.mllib b/lwt/lwt-core.mllib index 50917b144..3a880b53e 100644 --- a/lwt/lwt-core.mllib +++ b/lwt/lwt-core.mllib @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: b730eadd41f16ee61fea07bc004a3ae0) -Dns_server_core -Dns_resolver_core +# DO NOT EDIT (digest: afa1c4196651341a2e7387809c75f0c6) +Dns_server +Dns_resolver # OASIS_STOP diff --git a/lwt/lwt.mllib b/lwt/lwt.mllib index 3a880b53e..b0a184f80 100644 --- a/lwt/lwt.mllib +++ b/lwt/lwt.mllib @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: afa1c4196651341a2e7387809c75f0c6) -Dns_server -Dns_resolver +# DO NOT EDIT (digest: 09366b2cb909b9a863aa9377be528fb5) +Dns_server_unix +Dns_resolver_unix # OASIS_STOP diff --git a/lwt/mldig.ml b/lwt/mldig.ml index feff4489b..74022f930 100644 --- a/lwt/mldig.ml +++ b/lwt/mldig.ml @@ -88,7 +88,7 @@ open Cmdliner let dns_port = 53 let dig source_ip opt_dest_port q_class q_type args = - lwt res = Dns_resolver.create () in + lwt res = Dns_resolver_unix.create () in let timeout = 5 (* matches dig *) in (* Fold over args to determine overrides for q_class/type *) let (server, q_class, q_type, domains) = List.fold_left ( @@ -109,7 +109,7 @@ let dig source_ip opt_dest_port q_class q_type args = |None, Some q_class -> (server, q_class, q_type, domains) |Some q_type, Some q_class -> (server, q_class, q_type, domains) end - ) (begin match res.Dns_resolver.servers with + ) (begin match res.Dns_resolver_unix.servers with [] -> None | (s,p)::_ -> Some (s,Some p) end, q_class, q_type, []) args in let domains = match domains with |[] -> ["."] |_ -> domains in @@ -122,13 +122,13 @@ let dig source_ip opt_dest_port q_class q_type args = let _ = Lwt_unix.sleep (float_of_int timeout) >|= print_timeout in lwt addr = try return Ipaddr.V4.(to_string (of_string_exn x)) with Ipaddr.Parse_error _ -> - lwt addrs = Dns_resolver.gethostbyname res x in + lwt addrs = Dns_resolver_unix.gethostbyname res x in match addrs with | [] -> error "dig" ("Could not resolve nameserver '"^x^"'") | addr::_ -> return (Ipaddr.V4.to_string addr) in let port = match opt_port with None -> dns_port | Some p -> p in - Dns_resolver.(resolve + Dns_resolver_unix.(resolve {res with servers = [addr,port]} q_class q_type domain >|= print_answers) diff --git a/setup.ml b/setup.ml index 4a9cd3ad3..14297a988 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.4.1 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 5214479cc9ab67bc4b2e3f60caa35d9c) *) +(* DO NOT EDIT (digest: 37d273b260e01f93d97c2c0763ca6625) *) (* Regenerated by OASIS v0.4.1 Visit http://oasis.forge.ocamlcore.org for more information and @@ -6916,7 +6916,7 @@ let setup_t = bs_nativeopt = [(OASISExpr.EBool true, [])] }, { - lib_modules = ["Dns_server_core"; "Dns_resolver_core"]; + lib_modules = ["Dns_server"; "Dns_resolver"]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = Some "dns"; @@ -6964,7 +6964,7 @@ let setup_t = bs_nativeopt = [(OASISExpr.EBool true, [])] }, { - lib_modules = ["Dns_server"; "Dns_resolver"]; + lib_modules = ["Dns_server_unix"; "Dns_resolver_unix"]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = Some "dns"; @@ -7182,7 +7182,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.4.1"; - oasis_digest = Some "dØL,²|Úmð\012½þ\000PÍ\154"; + oasis_digest = Some "\139Ë$íI\131l{\003¶\007gyñm¾"; oasis_exec = None; oasis_setup_args = []; setup_update = false From 3c1e5a0af11915fb7d28b70689a796d2518712bc Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Fri, 21 Feb 2014 15:36:46 +0000 Subject: [PATCH 22/23] remove duplicate `8.8.8.8` ref; via @dsheets --- lwt/dns_resolver_unix.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lwt/dns_resolver_unix.ml b/lwt/dns_resolver_unix.ml index 708fa128d..89a7c950a 100644 --- a/lwt/dns_resolver_unix.ml +++ b/lwt/dns_resolver_unix.ml @@ -123,7 +123,7 @@ module Resolv_conf = struct end module Static = struct - let create client ?(servers=["8.8.8.8",53]) ?(search_domains=[]) () = + let create client ?(servers=[ns,port]) ?(search_domains=[]) () = { client; servers; search_domains } end From a16923b6244ebe6d9237450b721343597cf0274f Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Fri, 21 Feb 2014 15:38:30 +0000 Subject: [PATCH 23/23] Dns_server.addr -> ip_endpoint to be more explicit inconsistency pointed out by @dsheets --- lwt/dns_server.ml | 4 ++-- lwt/dns_server.mli | 6 +++--- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/lwt/dns_server.ml b/lwt/dns_server.ml index 1b547e274..0d1b2f8af 100644 --- a/lwt/dns_server.ml +++ b/lwt/dns_server.ml @@ -21,9 +21,9 @@ open Printf module DR = Dns.RR module DP = Dns.Packet -type addr = Ipaddr.t * int +type ip_endpoint = Ipaddr.t * int -type 'a process = src:addr -> dst:addr -> 'a -> Dns.Query.answer option Lwt.t +type 'a process = src:ip_endpoint -> dst:ip_endpoint -> 'a -> Dns.Query.answer option Lwt.t module type PROCESSOR = sig include Dns.Protocol.SERVER diff --git a/lwt/dns_server.mli b/lwt/dns_server.mli index a0e13ac01..dc1993388 100644 --- a/lwt/dns_server.mli +++ b/lwt/dns_server.mli @@ -15,9 +15,9 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -type addr = Ipaddr.t * int +type ip_endpoint = Ipaddr.t * int -type 'a process = src:addr -> dst:addr -> 'a -> Dns.Query.answer option Lwt.t +type 'a process = src:ip_endpoint -> dst:ip_endpoint -> 'a -> Dns.Query.answer option Lwt.t module type PROCESSOR = sig include Dns.Protocol.SERVER @@ -35,7 +35,7 @@ type 'a processor = (module PROCESSOR with type context = 'a) (** [process_query ibuf ibuflen obuf src dst processor] *) -val process_query: Dns.Buf.t -> int -> Dns.Buf.t -> addr -> addr -> +val process_query: Dns.Buf.t -> int -> Dns.Buf.t -> ip_endpoint -> ip_endpoint -> (module PROCESSOR) -> Dns.Buf.t option Lwt.t val processor_of_process : Dns.Packet.t process -> Dns.Packet.t processor