packages feed

dns 0.3.8 → 4.2.0

raw patch · 33 files changed

Files

+ Changelog.md view
@@ -0,0 +1,279 @@+# ChangeLog++## 4.2.0++- Switching cryptonite to crypton.++## 4.1.1++- Adding encoder/decoder for CAA RR.++## 4.1.0++- Breaking change: GHC 7.x and earlier no longer supported.+  We now require support for PatternSynonyms, available since+  GHC 8.0.+- Feature: relaxed lookup-raw interface+  [#167](https://github.com/kazu-yamamoto/dns/pull/167)+- Using "53" instead of "domain".+  [#166](ttps://github.com/kazu-yamamoto/dns/pull/166)+- UDP ReceiveFrom, sendTo with SockAddr+  [#165](https://github.com/kazu-yamamoto/dns/pull/165)+- Feature: Support for RP resource record type+  [#161](https://github.com/kazu-yamamoto/dns/pull/161)+- Feature: New `splitDomain` function splits a domain name+  at the first label break, unescaping the first label to+  a raw ByteString.+- Feature: New `splitMailbox` function splits a domain name+  at the first label break, unescaping the first label to+  a raw ByteString.+  [#155](https://github.com/kazu-yamamoto/dns/pull/155)+- Bugfix: Encoding of large packets could produce invalid+  compression pointers.+  [#156](https://github.com/kazu-yamamoto/dns/pull/156)+- Bugfix: SRV record presentation form (RD_SRV show instance)+  was missing a space between the port and the target.++## 4.0.1++- Bugfix: Retry without EDNS on empty FormatErr responses. Non-EDNS resolvers+  may return a FormErr response with an empty question section. Such a response+  must be accepted as a valid signal to switch to non-EDNS queries, even though+  the response does not contain a matching question.+- Feature: New RData constructors RD_CDS and RD_CDNSKEY+- Usability: More friendly network errors, instead of reporting the error+  location as an overly verbose "addrinfo" it is now just the essential+  "tcp@address" or "udp@address".+- BCP: The EDNS UDP buffer size has been changed to the RIPE recommended+  default of 1232 bytes.  Note that this recomendation is for a default value,+  to be used when better information is not available.  Users can still+  configure larger values if their networks support larger data frames and they+  are certain there is no risk of IP fragmentation.+- CI: Linux tests now pass with GHC 8.0.2, 8.2.2, 8.4.4, 8.6.5 and 8.8.1.+  Windows tests now build and run, but pass only intermittently.  The Windows+  doctests hang most of the time, perhaps a bug or portability issue in the+  doctest code, rather than the DNS library?+- Build: Internal modules are no longer exposed outside the build, this uses+  Cabal 2.0 or later features to expose internal modules only to the test+  executables.++## 4.0.0++- Breaking change: when `Domain` name ByteStrings are+  parsed as a sequence of DNS labels, backslashed escapes+  (single-character and 3-digit decimal) are decoded to+  the corresponding character or byte. Therefore, `encode`+  is not a total function, it may raise a `DecodeError`+  when a `ResourceRecord` contains a malformed `Domain`.+- Breaking change: when wire-form DNS names are converted+  to `Domain` ByteStrings, special characters in DNS labels+  are now encoded as `\c` (single-character backslash escapes)+  and non-printing characters as `\DDD` (3-digit decimal escapes).+- Output format change: `show` for TXT RDATA now includes+  enclosing double quotes, and escapes special characters.+  This is consistent with the format of TXT records in zone+  files and, e.g., dig(1) output. The DNS string quoting+  syntax is similar to a proper subset of the Haskell string+  quoting syntax, but its decimal escapes require exactly+  three digits, while Haskell accepts 1 or more, and uses+  `'\&'` as a null. Therefore, `read @String` does not+  reliably decode the DNS text string presentation form.+- Breaking change: the DNSMessage __component__ encoding+  functions are now internal.  They're still exported from+  the new 'Nework.DNS.Encode.Internal' module, but this+  is only to make them available for the test-suite.+- Added the TYPE definition, but not yet RData, for CAA.+- Added decode, encode and show for NSEC3 RRs.+- Added base16-bytestring as a new dependency.+- Added decode, encode and show for NSEC RRs.+- New RData constructor RD\_NSEC.+- Correct presentation form of unknown RR types.+- Corrected encoding of long TXT records+- RD\_NULL now has an opaque data payload.+- Safety: Both 'decode' and 'decodeAt' must now consume exactly+  the complete input buffer or a DecodeError is returned.+  * The same applies to each complete message with 'decodeMany'+    and 'decodeManyAt'.  Any final encoded message segment at the+    end of the input buffer is still returned as the second+    element of the result pair.+- Bugfix: fixed incorrect decoding of TXT records, and corrected+  the associated test.+- Cleanup: More precise control over decoder error messages via+  'failSGet', which avoids the unhelpful Attoparsec "Failure+  reading: " error prefix.+- Cleanup: Simplified loop detection in name decompression, making+  use of a monotone strictly decreasing limit on valid "pointer"+  targets.+- Breaking change: In the "Decode" module, expose only the+  decode{,Many}{,At} functions.  The rest of the "Decode" module's+  functions are now internal, exposed only for testing.  These+  include:+  * decodeDNSHeader+  * decodeDNSFlags+  * decodeResourceRecord+  * decodeDomain+  * decodeMailbox+- Cleanup: Reworked Decode module structure:+    * Moved Decode.Internal to Decode.Parsers+    * Created a new Decode.Internal which is now exposed, and+      moved some functions there from Decode which are only+      exposed for testing, since they could not reliably be used+      except as part of decoding a full message.+- Feature: RRSIG support, we can now encode, decode and show RRSIG+  records.  This uses the new 'decodeAt' and 'decodeManyAt' API.+- New API: 'decodeAt' and 'decodeManyAt' make it possible for+  the decoder to get the current time, in order to decode some+  RR types (like RRSIG) whose full meaning is time-dependent.+- Re-export 'sendAll' and export 'encodeVC' for use with TCP.+- No longer using sendAll with UDP, UDP datagrams must not be sent+  piece-by-piece+- Removed socket I/O work-around for no longer supported GHC versions+  on Windows.+- TCP queries now also use EDNS, since the DO bit and other options+  may be relevant, even when the UDP buffer size is not.  Therefore,+  TCP now also does a non-EDNS fallback.+- The resolvEDNS field is subsumed in resolvQueryControls and+  removed.  The encodeQuestion function changes to no longer take+  an explicit "EDNSheader" argument, instead the EDNS record is+  built based on the supplied options.  Also the encodeQuestions+  function has been removed, since we're deprecating it, but the+  legacy interface can no longer be maintained.+- New API: lookupRawCtl+- New API: ODataOp, doFlag, ednsEnable, ednsSetVersion, ednsSetSize+  and ednsSetOptions make it possible for 'QueryControls' to adjust+  EDNS settings.+- New API: FlagOp, rdFlag, adFlag and cdFlag make it possible to+  override the default settings of the query-related DNS header+  flags.+- Breaking change: the decoded EDNS record no longer contains+  an error field.  Instead the header of decoded messages is+  updated hold the extended error code when valid EDNS OPT records+  (EDNS pseudo-headers) are found.  The remaining EDNS record+  fields have been renamed:+      * udpSize  -> ednsBufferSize+      * dnssecOk -> ednsDnssecOk+      * options  -> ednsOptions+  The reverse process happens on output with the 12-bit header+  RCODE split across the wire-form DNS header and the OPT record.+  When EDNS is not enabled, and the RCODE > 15, it is mapped to+  FormatErr instead.+- Breaking change: The fromRCODEforHeader and toRCODEforHeader+  functions have been removed.+- Breaking change: DNSFormat and fromDNSFormat+  have been removed.+- The fromDNSMessage function now distinguishes between FormatErr+  responses without an OPT record (which signal no EDNS support),+  and FormatErr with an OPT record, which signal problems+  (malformed or unsupported version) with the OPT record received+  in the request.  For the latter the 'BadOptRecord' error is+  returned.+- Added more RCODEs, including a BadRCODE that is generated+  locally, rather than parsed from the message.  The value+  lies just above the EDNS 12-bit range, with the bottom+  12-bits matching FormatErr.+- Breaking change: The DNSMessage structure now has an+  "ednsHeader" field, initialized to "EDNSheader defaultEDNS"+  in "defaultQuery" and to "NoEDNS" in "defaultResponse".+  The former enables EDNS(0) with default options, the latter+  leaves EDNS unconfigured.+- The BadOpt RCODE is renamed to BadVers to better resemble+  the term used in RFCs.+- Added EDNS OPTIONS: NSID, DAU, DHU, N3U+- Decoding of the ClientSubnet option is now a total function,+  provided the RDATA is structurally sound.  Unexpected values+  just yield OD\_ECSgeneric results.+- Breaking change: New OD\_ECSgeneric EDNS constructor, represents+  ClientSubnet values whose address family is not IP or that violate+  the specification.  The "family" field distinguishes the two cases.+- The ClientSubnet EDNS option is now encoded correctly even when the+  source bits match some trailing all-zero bytes.+- Breaking change: EDNS0 is renamed to EDNS.+- Breaking change: lookupRawAD, composeQuery, composeQueryAD are removed.+- New OP codes: OP\_NOTIFY and OP\_UPDATE.+  [#113](https://github.com/kazu-yamamoto/dns/pull/113)++## 3.0.4++- Drop unexpected UDP answers [#112](https://github.com/kazu-yamamoto/dns/pull/112)++## 3.0.3++- Implementing NSEC3PARAM [#109](https://github.com/kazu-yamamoto/dns/pull/109)+- Fixing an example of DNS server.+- Improving DNS decoder [#111](https://github.com/kazu-yamamoto/dns/pull/111)++## 3.0.2++- Supporting conduit 1.3 [#105](https://github.com/kazu-yamamoto/dns/pull/105)+- Supporting GHC 8.4 with semigroup hack.++## 3.0.1++- Supporting GHC 7.8 again.++## 3.0.0++- The version introduces some breaking changes internally. But upper layer APIs in the `Lookup` module remain the same.+- Breaking change: `Network.DNS.Types` is redesigned. `ResourceRecord` is not a sum type anymore. It holds only normal RRs. For EDNS0, a new scheme is implemented. [#63](https://github.com/kazu-yamamoto/dns/issues/63)+- Breaking change: the `Encode` and `Decode` modules use strict ByteString instead of lazy one. [#59](https://github.com/kazu-yamamoto/dns/issues/59)+- Default DNS servers are detected automatically on Windows if `RCFilePath` is used. Use vanilla `defaultResolvConf` on Windows! [#83](https://github.com/kazu-yamamoto/dns/pull/83)+- Multiple DNS servers can be used. You can choose either sequential lookup or concurrent lookup. See `resolvConcurrent`. [#81](https://github.com/kazu-yamamoto/dns/pull/81)+- EDNS0 queries are used by default. [#95](https://github.com/kazu-yamamoto/dns/pull/95)+- `lookupSOA` is defined. [#93](https://github.com/kazu-yamamoto/dns/pull/93)+- Cache mechanism is provided. See `resolvCache`.+- Some constructors such as ANY are added in the `Types` module.+- Some bug fixes and code clean-up.++## 2.0.13+- Testing with AppVeyor.+- Detecting a default DNS server on Windows.+- Fixing sendAll on Windows [#72](https://github.com/kazu-yamamoto/dns/pull/72)++## 2.0.12+- Fixing Windows build again++## 2.0.11+- Fixing the StateBinary.get32 parser [#57](https://github.com/kazu-yamamoto/dns/pull/57)+- Removing bytestring-builder dependency [#61](https://github.com/kazu-yamamoto/dns/pull/61)+- Fixing Windows build [#62](https://github.com/kazu-yamamoto/dns/pull/62)++## 2.0.10+- Cleaning up the code. [#47](https://github.com/kazu-yamamoto/dns/pull/47)++## 2.0.9+- Implemented TCP fallback after a truncated UDP response. [#46](https://github.com/kazu-yamamoto/dns/pull/46)++## 2.0.8+- Better handling of encoding and decoding the "root" domain ".". [#45](https://github.com/kazu-yamamoto/dns/pull/45)++## 2.0.7+- Add length checks for A and AAAA records. [#43](https://github.com/kazu-yamamoto/dns/pull/43)++## 2.0.6+- Adding Ord instance. [#41](https://github.com/kazu-yamamoto/dns/pull/41)+- Adding DNSSEC-related RRTYPEs [#40](https://github.com/kazu-yamamoto/dns/pull/40)++## 2.0.5+- Supporting DNS-SEC AD (authenticated data). [#38](https://github.com/kazu-yamamoto/dns/pull/38)+- Removing the dependency to blaze-builder.++## 2.0.4+- Renaming a variable to fix preprocessor conflicts [#37](https://github.com/kazu-yamamoto/dns/pull/37)++## 2.0.3+- Handle invalid opcodes gracefully. [#36](https://github.com/kazu-yamamoto/dns/pull/36)++## 2.0.2+- Providing a new API: decodeMany.++## 2.0.1+- Updating document.++## 2.0.0+- DNSMessage is now monomorphic+- RDATA is now monomorphic+- Removed traversal instance for DNSMessage+- EDNS0 encoding/decoding is now supported+- Removed dnsMapWithType and dnsTraverseWithType functions+- responseA and responseAAAA now take lists of IP addresses as their arguments+- DNSHeader type no longer has qdCount, anCount, nsCount, and arCount fields
Network/DNS.hs view
@@ -1,35 +1,56 @@-{-|-  Thread-safe DNS library written in Haskell.--  This code is written in Haskell, not using FFI.--  Sample code for DNS lookup:--@-    import qualified Network.DNS as DNS (lookup)-    import Network.DNS hiding (lookup)-    main :: IO ()-    main = do-        rs <- makeResolvSeed defaultResolvConf-        withResolver rs $ \\resolver -> do-            DNS.lookup resolver \"www.example.com\" A >>= print-@--}-+-- | A thread-safe DNS library for both clients and servers written+--   in pure Haskell.+--   The Network.DNS module re-exports all other exposed modules for+--   convenience.+--   Applications will most likely use the high-level interface, while+--   library/daemon authors may need to use the lower-level one.+--   EDNS and TCP fallback are supported.+--+--   Examples:+--+--   >>> :set -XOverloadedStrings+--   >>> rs <- makeResolvSeed defaultResolvConf+--   >>> withResolver rs $ \resolver -> lookupA resolver "192.0.2.1.nip.io"+--   Right [192.0.2.1] module Network.DNS (   -- * High level     module Network.DNS.Lookup+  -- | This module contains simple functions to+  --   perform various DNS lookups. If you simply want to resolve a+  --   hostname ('lookupA'), or find a domain's MX record+  --   ('lookupMX'), this is the easiest way to do it.+   , module Network.DNS.Resolver+  -- | Resolver related data types.+   , module Network.DNS.Types+  -- | All of the types that the other modules use.++  , module Network.DNS.Utils+  -- | This module contains utility functions used+  --   for processing DNS data.++  -- * Middle level+  , module Network.DNS.LookupRaw+  -- | This provides the 'lookup', 'lookupAuth', 'lookupRaw' and+  --   'lookupRawCtl' functions for any resource records.+   -- * Low level-  , module Network.DNS.Decode   , module Network.DNS.Encode-  ) where+  -- | Encoding a query or response. +  , module Network.DNS.Decode+  -- | Decoding a qurey or response.++  , module Network.DNS.IO+  -- | Sending and receiving.+) where++import Network.DNS.Decode+import Network.DNS.Encode+import Network.DNS.IO import Network.DNS.Lookup+import Network.DNS.LookupRaw import Network.DNS.Resolver import Network.DNS.Types-import Network.DNS.Decode-import Network.DNS.Encode--+import Network.DNS.Utils
Network/DNS/Decode.hs view
@@ -1,185 +1,103 @@-{-# LANGUAGE OverloadedStrings #-}-+-- | DNS message decoders.+--+-- When in doubt, use the 'decodeAt' or 'decodeManyAt' functions, which+-- correctly handle /circle-arithmetic/ DNS timestamps, e.g., in @RRSIG@+-- resource records.  The 'decode', and 'decodeMany' functions are only+-- appropriate in pure contexts when the current time is not available, and+-- @RRSIG@ records are not expected or desired.+--+-- The 'decodeMany' and 'decodeManyAt' functions decode a buffer holding one or+-- more messages, each preceded by 16-bit length in network byte order.  This+-- encoding is generally only appropriate for DNS TCP, and because TCP does not+-- preserve message boundaries, the decode is prepared to return a trailing+-- message fragment to be completed and retried when more input arrives from+-- network.+-- module Network.DNS.Decode (-    decode-  , receive+    -- * Decoding a single DNS message+    decodeAt+  , decode+    -- * Decoding multple length-encoded DNS messages,+    -- e.g., from TCP traffic.+  , decodeManyAt+  , decodeMany   ) where -import Control.Applicative-import Control.Monad-import Data.Bits-import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as BS-import qualified Data.ByteString.Lazy as BL-import Data.Conduit-import Data.Conduit.Network-import Data.IP-import Data.Maybe-import Network-import Network.DNS.Internal+import qualified Data.ByteString as B++import Network.DNS.Decode.Parsers+import Network.DNS.Imports import Network.DNS.StateBinary+import Network.DNS.Types.Internal  ---------------------------------------------------------------- -{-| Receiving DNS data from 'Socket' and parse it.-    The second argument is a buffer size for the socket.--}-receive :: Socket -> IO DNSFormat-receive sock = receiveDNSFormat $ sourceSocket sock+-- | Decode an input buffer containing a single encoded DNS message.  If the+-- input buffer has excess content beyond the end of the message an error is+-- returned.  DNS /circle-arithmetic/ timestamps (e.g. in RRSIG records) are+-- interpreted at the supplied epoch time.+--+decodeAt :: Int64                      -- ^ current epoch time+         -> ByteString                 -- ^ encoded input buffer+         -> Either DNSError DNSMessage -- ^ decoded message or error+decodeAt t bs = fst <$> runSGetAt t (fitSGet (B.length bs) getResponse) bs -----------------------------------------------------------------+-- | Decode an input buffer containing a single encoded DNS message.  If the+-- input buffer has excess content beyond the end of the message an error is+-- returned.  DNS /circle-arithmetic/ timestamps (e.g. in RRSIG records) are+-- interpreted based on a nominal time in the year 2073 chosen to maximize+-- the time range for which this gives correct translations of 32-bit epoch+-- times to absolute 64-bit epoch times.  This will yield incorrect results+-- starting circa 2141.+--+decode :: ByteString                 -- ^ encoded input buffer+       -> Either DNSError DNSMessage -- ^ decoded message or error+decode bs = fst <$> runSGet (fitSGet (B.length bs) getResponse) bs -{-| Parsing DNS data.--}-decode :: BL.ByteString -> Either String DNSFormat-decode bs = fst <$> runSGet decodeResponse bs+-- | Decode a buffer containing multiple encoded DNS messages each preceded by+-- a 16-bit length in network byte order.  Any left-over bytes of a partial+-- message after the last complete message are returned as the second element+-- of the result tuple.  DNS /circle-arithmetic/ timestamps (e.g. in RRSIG+-- records) are interpreted at the supplied epoch time.+--+decodeManyAt :: Int64      -- ^ current epoch time+             -> ByteString -- ^ encoded input buffer+             -> Either DNSError ([DNSMessage], ByteString)+                           -- ^ decoded messages and left-over partial message+                           -- or error if any complete message fails to parse.+decodeManyAt t bs = decodeMParse (decodeAt t) bs ------------------------------------------------------------------receiveDNSFormat :: Source (ResourceT IO) ByteString -> IO DNSFormat-receiveDNSFormat src = fst <$> runResourceT (src $$ sink)-  where-    sink = sinkSGet decodeResponse+-- | Decode a buffer containing multiple encoded DNS messages each preceded by+-- a 16-bit length in network byte order.  Any left-over bytes of a partial+-- message after the last complete message are returned as the second element+-- of the result tuple.  DNS /circle-arithmetic/ timestamps (e.g. in RRSIG+-- records) are interpreted based on a nominal time in the year 2078 chosen to+-- give correct dates for DNS timestamps over a 136 year time range from the+-- date the root zone was signed on the 15th of July 2010 until the 21st of+-- August in 2146.  Outside this date range the output is off by some non-zero+-- multiple 2\^32 seconds.+--+decodeMany :: ByteString -- ^ encoded input buffer+           -> Either DNSError ([DNSMessage], ByteString)+                         -- ^ decoded messages and left-over partial message+                         -- or error if any complete message fails to parse.+decodeMany bs = decodeMParse decode bs ----------------------------------------------------------------- -decodeResponse :: SGet DNSFormat-decodeResponse = do-    hd <- decodeHeader-    DNSFormat hd <$> decodeQueries (qdCount hd)-                 <*> decodeRRs (anCount hd)-                 <*> decodeRRs (nsCount hd)-                 <*> decodeRRs (arCount hd)--------------------------------------------------------------------decodeFlags :: SGet DNSFlags-decodeFlags = toFlags <$> get16-  where-    toFlags flgs = DNSFlags (getQorR flgs)-                            (getOpcode flgs)-                            (getAuthAnswer flgs)-                            (getTrunCation flgs)-                            (getRecDesired flgs)-                            (getRecAvailable flgs)-                            (getRcode flgs)-    getQorR w = if testBit w 15 then QR_Response else QR_Query-    getOpcode w = toEnum $ fromIntegral $ shiftR w 11 .&. 0x0f-    getAuthAnswer w = testBit w 10-    getTrunCation w = testBit w 9-    getRecDesired w = testBit w 8-    getRecAvailable w = testBit w 7-    getRcode w = toEnum $ fromIntegral $ w .&. 0x0f--------------------------------------------------------------------decodeHeader :: SGet DNSHeader-decodeHeader = DNSHeader <$> decodeIdentifier-                         <*> decodeFlags-                         <*> decodeQdCount-                         <*> decodeAnCount-                         <*> decodeNsCount-                         <*> decodeArCount-  where-    decodeIdentifier = getInt16-    decodeQdCount = getInt16-    decodeAnCount = getInt16-    decodeNsCount = getInt16-    decodeArCount = getInt16--------------------------------------------------------------------decodeQueries :: Int -> SGet [Question]-decodeQueries n = replicateM n decodeQuery--decodeType :: SGet TYPE-decodeType = intToType <$> getInt16--decodeQuery :: SGet Question-decodeQuery = Question <$> decodeDomain-                       <*> (decodeType <* ignoreClass)--decodeRRs :: Int -> SGet [ResourceRecord]-decodeRRs n = replicateM n decodeRR--decodeRR :: SGet ResourceRecord-decodeRR = do-    Question dom typ <- decodeQuery-    ttl <- decodeTTL-    len <- decodeRLen-    dat <- decodeRData typ len-    return ResourceRecord { rrname = dom-                          , rrtype = typ-                          , rrttl  = ttl-                          , rdlen  = len-                          , rdata  = dat-                          }-  where-    decodeTTL = fromIntegral <$> get32-    decodeRLen = getInt16--decodeRData :: TYPE -> Int -> SGet RDATA-decodeRData NS _ = RD_NS <$> decodeDomain-decodeRData MX _ = RD_MX <$> decodePreference <*> decodeDomain-  where-    decodePreference = getInt16-decodeRData CNAME _ = RD_CNAME <$> decodeDomain-decodeRData TXT len = (RD_TXT . ignoreLength) <$> getNByteString len-  where-    ignoreLength = BS.tail-decodeRData A len  = (RD_A . toIPv4) <$> getNBytes len-decodeRData AAAA len  = (RD_AAAA . toIPv6 . combine) <$> getNBytes len-  where-    combine [] = []-    combine [_] = error "combine"-    combine (a:b:cs) =  a * 256 + b : combine cs-decodeRData SOA _ = RD_SOA <$> decodeDomain-                           <*> decodeDomain-                           <*> decodeSerial-                           <*> decodeRefesh-                           <*> decodeRetry-                           <*> decodeExpire-                           <*> decodeMinumun-  where-    decodeSerial  = getInt32-    decodeRefesh  = getInt32-    decodeRetry   = getInt32-    decodeExpire  = getInt32-    decodeMinumun = getInt32-decodeRData PTR _ = RD_PTR <$> decodeDomain-decodeRData SRV _ = RD_SRV <$> decodePriority-                           <*> decodeWeight-                           <*> decodePort-                           <*> decodeDomain-  where-    decodePriority = getInt16-    decodeWeight   = getInt16-    decodePort     = getInt16--decodeRData _  len = RD_OTH <$> getNBytes len--------------------------------------------------------------------decodeDomain :: SGet Domain-decodeDomain = do-    pos <- getPosition-    c <- getInt8-    if c == 0 then-        return ""-      else do-        let n = getValue c-        if isPointer c then do-            d <- getInt8-            let offset = n * 256 + d-            fromMaybe (error $ "decodeDomain: " ++ show offset) <$> pop offset-          else do-            hs <- getNByteString n-            ds <- decodeDomain-            let dom = hs `BS.append` "." `BS.append` ds-            push pos dom-            return dom+-- | Decode multiple messages using the given parser.+--+decodeMParse :: (ByteString -> Either DNSError DNSMessage)+                -- ^ message decoder+             -> ByteString+                -- ^ enoded input buffer+             -> Either DNSError ([DNSMessage], ByteString)+                -- ^ decoded messages and left-over partial message+                -- or error if any complete message fails to parse.+decodeMParse decoder bs = do+    ((bss, _), leftovers) <- runSGetWithLeftovers lengthEncoded bs+    msgs <- mapM decoder bss+    return (msgs, leftovers)   where-    getValue c = c .&. 0x3f-    isPointer c = testBit c 7 && testBit c 6--ignoreClass :: SGet ()-ignoreClass = () <$ get16+    -- Read a list of length-encoded bytestrings+    lengthEncoded :: SGet [ByteString]+    lengthEncoded = many $ getInt16 >>= getNByteString
Network/DNS/Encode.hs view
@@ -1,167 +1,34 @@-{-# LANGUAGE RecordWildCards #-}+-- | DNS message encoder.+--+-- Note: 'Nework.DNS' is a client library, and its focus is on /sending/+-- /queries/, and /receiving/ /replies/.  Thefore, while this module is+-- reasonably adept at query generation, building a DNS server with this+-- module requires additional work to handle message size limits, correct UDP+-- truncation, proper EDNS negotiation, and so on.  Support for server-side DNS+-- is at best rudimentary.+--+-- For sending queries, in most cases you should be using one of the functions+-- from 'Network.DNS.Lookup' and 'Network.DNS.LookupRaw', or lastly, if you+-- want to handle the network reads and writes for yourself (with your own code+-- for UDP retries, TCP fallback, EDNS fallback, ...), then perhaps+-- 'Network.DNS.IO.encodeQuestion' (letting 'Network.DNS' do the lookups for+-- you in an @async@ thread is likely much simpler).+-- module Network.DNS.Encode (+    -- * Encode a DNS query (or response).     encode-  , composeQuery   ) where -import qualified Blaze.ByteString.Builder as BB (toByteString, fromWrite, writeInt16be)-import qualified Data.ByteString.Lazy.Char8 as BL (ByteString)-import qualified Data.ByteString.Char8 as BS (length, null, break, drop)+import Network.DNS.Imports import Network.DNS.StateBinary-import Network.DNS.Internal-import Data.Monoid-import Control.Monad.State-import Data.Bits-import Data.Word-import Data.IP--(+++) :: Monoid a => a -> a -> a-(+++) = mappend--------------------------------------------------------------------{-| Composing query. First argument is a number to identify response.--}-composeQuery :: Int -> [Question] -> BL.ByteString-composeQuery idt qs = encode qry-  where-    hdr = header defaultQuery-    qry = defaultQuery {-        header = hdr {-           identifier = idt-         , qdCount = length qs-         }-      , question = qs-      }--------------------------------------------------------------------{-| Composing DNS data.--}-encode :: DNSFormat -> BL.ByteString-encode fmt = runSPut (encodeDNSFormat fmt)--------------------------------------------------------------------encodeDNSFormat :: DNSFormat -> SPut-encodeDNSFormat fmt = encodeHeader hdr-                  +++ mconcat (map encodeQuestion qs)-                  +++ mconcat (map encodeRR an)-                  +++ mconcat (map encodeRR au)-                  +++ mconcat (map encodeRR ad)-  where-    hdr = header fmt-    qs = question fmt-    an = answer fmt-    au = authority fmt-    ad = additional fmt--encodeHeader :: DNSHeader -> SPut-encodeHeader hdr = encodeIdentifier (identifier hdr)-               +++ encodeFlags (flags hdr)-               +++ decodeQdCount (qdCount hdr)-               +++ decodeAnCount (anCount hdr)-               +++ decodeNsCount (nsCount hdr)-               +++ decodeArCount (arCount hdr)-  where-    encodeIdentifier = putInt16-    decodeQdCount = putInt16-    decodeAnCount = putInt16-    decodeNsCount = putInt16-    decodeArCount = putInt16--encodeFlags :: DNSFlags -> SPut-encodeFlags DNSFlags{..} = put16 word-  where-    word16 :: Enum a => a -> Word16-    word16 = toEnum . fromEnum--    set :: Word16 -> State Word16 ()-    set byte = modify (.|. byte)--    st :: State Word16 ()-    st = sequence_-              [ set (word16 rcode)-              , when recAvailable        $ set (bit 7)-              , when recDesired          $ set (bit 8)-              , when trunCation          $ set (bit 9)-              , when authAnswer          $ set (bit 10)-              , set (word16 opcode `shiftL` 11)-              , when (qOrR==QR_Response) $ set (bit 15)-              ]--    word = execState st 0--encodeQuestion :: Question -> SPut-encodeQuestion Question{..} =-        encodeDomain qname-    +++ putInt16 (typeToInt qtype)-    +++ put16 1--encodeRR :: ResourceRecord -> SPut-encodeRR ResourceRecord{..} =-    mconcat-      [ encodeDomain rrname-      , putInt16 (typeToInt rrtype)-      , put16 1-      , putInt32 rrttl-      , rlenRDATA-      ]-  where-    -- Encoding rdata without using rdlen-    rlenRDATA = do-        addPositionW 2 -- "simulate" putInt16-        rDataWrite <- encodeRDATA rdata-        let rdataLength = fromIntegral . BS.length . BB.toByteString . BB.fromWrite $ rDataWrite-        let rlenWrite = BB.writeInt16be rdataLength-        return rlenWrite +++ return rDataWrite--encodeRDATA :: RDATA -> SPut-encodeRDATA rd = case rd of-    (RD_A ip)          -> mconcat $ map putInt8 (fromIPv4 ip)-    (RD_AAAA ip)       -> mconcat $ map putInt16 (fromIPv6 ip)-    (RD_NS dom)        -> encodeDomain dom-    (RD_CNAME dom)     -> encodeDomain dom-    (RD_PTR dom)       -> encodeDomain dom-    (RD_MX prf dom)    -> mconcat [putInt16 prf, encodeDomain dom]-    (RD_TXT txt)       -> putByteString txt-    (RD_OTH bytes)     -> mconcat $ map putInt8 bytes-    (RD_SOA d1 d2 serial refresh retry expire min') -> mconcat-        [ encodeDomain d1-        , encodeDomain d2-        , putInt32 serial-        , putInt32 refresh-        , putInt32 retry-        , putInt32 expire-        , putInt32 min'-        ]-    (RD_SRV prio weight port dom) -> mconcat-        [ putInt16 prio-        , putInt16 weight-        , putInt16 port-        , encodeDomain dom-        ]--------------------------------------------------------------------encodeDomain :: Domain -> SPut-encodeDomain dom | BS.null dom = put8 0-encodeDomain dom = do-    mpos <- wsPop dom-    cur <- gets wsPosition-    case mpos of-        Just pos -> encodePointer pos-        Nothing  -> wsPush dom cur >>-                    mconcat [ encodePartialDomain hd-                            , encodeDomain tl-                            ]-  where-    (hd, tl') = BS.break (=='.') dom-    tl = if BS.null tl' then tl' else BS.drop 1 tl'--encodePointer :: Int -> SPut-encodePointer pos = let w = (pos .|. 0xc000) in putInt16 w+import Network.DNS.Types.Internal+import Network.DNS.Encode.Builders -encodePartialDomain :: Domain -> SPut-encodePartialDomain sub = putInt8 (BS.length sub)-                      +++ putByteString sub+-- | Encode a 'DNSMessage' for transmission over UDP.  For transmission over+-- TCP encapsulate the result via 'Network.DNS.IO.encodeVC', or use+-- 'Network.DNS.IO.sendVC', which handles this internally.  If any+-- 'ResourceRecord' in the message contains incorrectly encoded 'Domain' name+-- ByteStrings, this function may raise a 'DecodeError'.+--+encode :: DNSMessage -> ByteString+encode = runSPut . putDNSMessage
+ Network/DNS/IO.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.DNS.IO (+    -- * Receiving DNS messages+    receive+  , receiveFrom+  , receiveVC+    -- * Sending pre-encoded messages+  , send+  , sendTo+  , sendVC+  , sendAll+    -- ** Encoding queries for transmission+  , encodeQuestion+  , encodeVC+    -- ** Creating query response messages+  , responseA+  , responseAAAA+  ) where++import qualified Control.Exception as E+import qualified Data.ByteString as B+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy.Char8 as LBS+import Data.IP (IPv4, IPv6)+import Time.System (timeCurrent)+import Time.Types (Elapsed(..), Seconds(..))+import Network.Socket (Socket, SockAddr)+import Network.Socket.ByteString (recv, recvFrom)+import qualified Network.Socket.ByteString as Socket+import System.IO.Error++import Network.DNS.Decode (decodeAt)+import Network.DNS.Encode (encode)+import Network.DNS.Imports+import Network.DNS.Types.Internal++----------------------------------------------------------------++-- | Receive and decode a single 'DNSMessage' from a UDP 'Socket', throwing away+-- the client address.  Messages longer than 'maxUdpSize' are silently+-- truncated, but this should not occur in practice, since we cap the advertised+-- EDNS UDP buffer size limit at the same value.  A 'DNSError' is raised if I/O+-- or message decoding fails.+--+receive :: Socket -> IO DNSMessage+receive sock = do+    let bufsiz = fromIntegral maxUdpSize+    bs <- recv sock bufsiz `E.catch` \e -> E.throwIO $ NetworkFailure e+    Elapsed (Seconds now) <- timeCurrent+    case decodeAt now bs of+        Left  e   -> E.throwIO e+        Right msg -> return msg++-- | Receive and decode a single 'DNSMessage' from a UDP 'Socket'.  Messages+-- longer than 'maxUdpSize' are silently truncated, but this should not occur+-- in practice, since we cap the advertised EDNS UDP buffer size limit at the+-- same value.  A 'DNSError' is raised if I/O or message decoding fails.+--+receiveFrom :: Socket -> IO (DNSMessage, SockAddr)+receiveFrom sock = do+    let bufsiz = fromIntegral maxUdpSize+    (bs, client) <- recvFrom sock bufsiz `E.catch` \e -> E.throwIO $ NetworkFailure e+    Elapsed (Seconds now) <- timeCurrent+    case decodeAt now bs of+        Left  e   -> E.throwIO e+        Right msg -> return (msg, client)++-- | Receive and decode a single 'DNSMesage' from a virtual-circuit (TCP).  It+-- is up to the caller to implement any desired timeout. An 'DNSError' is+-- raised if I/O or message decoding fails.+--+receiveVC :: Socket -> IO DNSMessage+receiveVC sock = do+    len <- toLen <$> recvDNS sock 2+    bs <- recvDNS sock len+    Elapsed (Seconds now) <- timeCurrent+    case decodeAt now bs of+        Left e    -> E.throwIO e+        Right msg -> return msg+  where+    toLen bs = case B.unpack bs of+        [hi, lo] -> 256 * (fromIntegral hi) + (fromIntegral lo)+        _        -> 0              -- never reached++recvDNS :: Socket -> Int -> IO ByteString+recvDNS sock len = recv1 `E.catch` \e -> E.throwIO $ NetworkFailure e+  where+    recv1 = do+        bs1 <- recvCore len+        if BS.length bs1 == len then+            return bs1+          else do+            loop bs1+    loop bs0 = do+        let left = len - BS.length bs0+        bs1 <- recvCore left+        let bs = bs0 `BS.append` bs1+        if BS.length bs == len then+            return bs+          else+            loop bs+    eofE = mkIOError eofErrorType "connection terminated" Nothing Nothing+    recvCore len0 = do+        bs <- recv sock len0+        if bs == "" then+            E.throwIO eofE+          else+            return bs++----------------------------------------------------------------++-- | Send an encoded 'DNSMessage' datagram over UDP.  The message length is+-- implicit in the size of the UDP datagram.  With TCP you must use 'sendVC',+-- because TCP does not have message boundaries, and each message needs to be+-- prepended with an explicit length.  The socket must be explicitly connected+-- to the destination nameserver.+--+send :: Socket -> ByteString -> IO ()+send = (void .). Socket.send+{-# INLINE send #-}++-- | Send an encoded 'DNSMessage' datagram over UDP to a given address.  The+-- message length is implicit in the size of the UDP datagram.  With TCP you+-- must use 'sendVC', because TCP does not have message boundaries, and each+-- message needs to be prepended with an explicit length.+--+sendTo :: Socket -> ByteString -> SockAddr -> IO ()+sendTo sock str addr = Socket.sendTo sock str addr >> return ()+{-# INLINE sendTo #-}++-- | Send a single encoded 'DNSMessage' over TCP.  An explicit length is+-- prepended to the encoded buffer before transmission.  If you want to+-- send a batch of multiple encoded messages back-to-back over a single+-- TCP connection, and then loop to collect the results, use 'encodeVC'+-- to prefix each message with a length, and then use 'sendAll' to send+-- a concatenated batch of the resulting encapsulated messages.+--+sendVC :: Socket -> ByteString -> IO ()+sendVC = (. encodeVC). sendAll+{-# INLINE sendVC #-}++-- | Send one or more encoded 'DNSMessage' buffers over TCP, each allready+-- encapsulated with an explicit length prefix (perhaps via 'encodeVC') and+-- then concatenated into a single buffer.  DO NOT use 'sendAll' with UDP.+--+sendAll :: Socket -> BS.ByteString -> IO ()+sendAll = Socket.sendAll+{-# INLINE sendAll #-}++-- | The encoded 'DNSMessage' has the specified request ID.  The default values+-- of the RD, AD, CD and DO flag bits, as well as various EDNS features, can be+-- adjusted via the 'QueryControls' parameter.+--+-- The caller is responsible for generating the ID via a securely seeded+-- CSPRNG.+--+encodeQuestion :: Identifier     -- ^ Crypto random request id+                -> Question      -- ^ Query name and type+                -> QueryControls -- ^ Query flag and EDNS overrides+                -> ByteString+encodeQuestion idt q ctls = encode $ makeQuery idt q ctls++-- | Encapsulate an encoded 'DNSMessage' buffer for transmission over a TCP+-- virtual circuit.  With TCP the buffer needs to start with an explicit+-- length (the length is implicit with UDP).+--+encodeVC :: ByteString -> ByteString+encodeVC legacyQuery =+    let len = LBS.toStrict . BB.toLazyByteString $ BB.int16BE $ fromIntegral $ BS.length legacyQuery+    in len <> legacyQuery+{-# INLINE encodeVC #-}++----------------------------------------------------------------++-- | Compose a response with a single IPv4 RRset.  If the query+-- had an EDNS pseudo-header, a suitable EDNS pseudo-header must+-- be added to the response message, or else a 'FormatErr' response+-- must be sent.  The response TTL defaults to 300 seconds, and+-- should be updated (to the same value across all the RRs) if some+-- other TTL value is more appropriate.+--+responseA :: Identifier -> Question -> [IPv4] -> DNSMessage+responseA idt q ips = makeResponse idt q as+  where+    dom = qname q+    as  = ResourceRecord dom A classIN 300 . RD_A <$> ips++-- | Compose a response with a single IPv6 RRset.  If the query+-- had an EDNS pseudo-header, a suitable EDNS pseudo-header must+-- be added to the response message, or else a 'FormatErr' response+-- must be sent.  The response TTL defaults to 300 seconds, and+-- should be updated (to the same value across all the RRs) if some+-- other TTL value is more appropriate.+--+responseAAAA :: Identifier -> Question -> [IPv6] -> DNSMessage+responseAAAA idt q ips = makeResponse idt q as+  where+    dom = qname q+    as  = ResourceRecord dom AAAA classIN 300 . RD_AAAA <$> ips
− Network/DNS/Internal.hs 
@@ -1,208 +0,0 @@-module Network.DNS.Internal where--import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as BS-import Data.Char-import Data.IP-import Data.Maybe--------------------------------------------------------------------{-|-  Type for domain.--}-type Domain = ByteString--------------------------------------------------------------------{-|-  Types for resource records.--}-data TYPE = A | AAAA | NS | TXT | MX | CNAME | SOA | PTR | SRV-          | UNKNOWN Int deriving (Eq, Show, Read)--rrDB :: [(TYPE, Int)]-rrDB = [-    (A,      1)-  , (NS,     2)-  , (CNAME,  5)-  , (SOA,    6)-  , (PTR,   12)-  , (MX,    15)-  , (TXT,   16)-  , (AAAA,  28)-  , (SRV,   33)-  ]--rookup                  :: (Eq b) => b -> [(a,b)] -> Maybe a-rookup _    []          =  Nothing-rookup  key ((x,y):xys)-  | key == y          =  Just x-  | otherwise         =  rookup key xys--intToType :: Int -> TYPE-intToType n = fromMaybe (UNKNOWN n) $ rookup n rrDB-typeToInt :: TYPE -> Int-typeToInt (UNKNOWN x)  = x-typeToInt t = fromMaybe 0 $ lookup t rrDB--toType :: String -> TYPE-toType = read . map toUpper--------------------------------------------------------------------{-|-  Raw data format for DNS Query and Response.--}-data DNSFormat = DNSFormat {-    header     :: DNSHeader-  , question   :: [Question]-  , answer     :: [ResourceRecord]-  , authority  :: [ResourceRecord]-  , additional :: [ResourceRecord]-  } deriving (Eq, Show)--{-|-  Raw data format for the header of DNS Query and Response.--}-data DNSHeader = DNSHeader {-    identifier :: Int-  , flags      :: DNSFlags-  , qdCount    :: Int-  , anCount    :: Int-  , nsCount    :: Int-  , arCount    :: Int-  } deriving (Eq, Show)--{-|-  Raw data format for the flags of DNS Query and Response.--}-data DNSFlags = DNSFlags {-    qOrR         :: QorR-  , opcode       :: OPCODE-  , authAnswer   :: Bool-  , trunCation   :: Bool-  , recDesired   :: Bool-  , recAvailable :: Bool-  , rcode        :: RCODE-  } deriving (Eq, Show)--------------------------------------------------------------------data QorR = QR_Query | QR_Response deriving (Eq, Show)--data OPCODE = OP_STD | OP_INV | OP_SSR deriving (Eq, Show, Enum)--data RCODE = NoErr | FormatErr | ServFail | NameErr | NotImpl | Refused deriving (Eq, Show, Enum)--------------------------------------------------------------------{-|-  Raw data format for DNS questions.--}-data Question = Question {-    qname  :: Domain-  , qtype  :: TYPE-  } deriving (Eq, Show)--{-|-  Making "Question".--}-makeQuestion :: Domain -> TYPE -> Question-makeQuestion = Question--------------------------------------------------------------------{-|-  Raw data format for resource records.--}-data ResourceRecord = ResourceRecord {-    rrname :: Domain-  , rrtype :: TYPE-  , rrttl  :: Int-  , rdlen  :: Int-  , rdata  :: RDATA-  } deriving (Eq, Show)--{-|-  Raw data format for each type.--}-data RDATA = RD_NS Domain | RD_CNAME Domain | RD_MX Int Domain | RD_PTR Domain-           | RD_SOA Domain Domain Int Int Int Int Int-           | RD_A IPv4 | RD_AAAA IPv6 | RD_TXT ByteString-           | RD_SRV Int Int Int Domain-           | RD_OTH [Int] deriving (Eq)--instance Show RDATA where-  show (RD_NS dom) = BS.unpack dom-  show (RD_MX prf dom) = BS.unpack dom ++ " " ++ show prf-  show (RD_CNAME dom) = BS.unpack dom-  show (RD_A a) = show a-  show (RD_AAAA aaaa) = show aaaa-  show (RD_TXT txt) = BS.unpack txt-  show (RD_SOA mn _ _ _ _ _ mi) = BS.unpack mn ++ " " ++ show mi-  show (RD_PTR dom) = BS.unpack dom-  show (RD_SRV pri wei prt dom) = show pri ++ " " ++ show wei ++ " " ++ show prt ++ BS.unpack dom-  show (RD_OTH is) = show is--------------------------------------------------------------------defaultQuery :: DNSFormat-defaultQuery = DNSFormat {-    header = DNSHeader {-       identifier = 0-     , flags = DNSFlags {-           qOrR         = QR_Query-         , opcode       = OP_STD-         , authAnswer   = False-         , trunCation   = False-         , recDesired   = True-         , recAvailable = False-         , rcode        = NoErr-         }-     , qdCount = 0-     , anCount = 0-     , nsCount = 0-     , arCount = 0-     }-  , question   = []-  , answer     = []-  , authority  = []-  , additional = []-  }--defaultResponse :: DNSFormat-defaultResponse =-  let hd = header defaultQuery-      flg = flags hd-  in  defaultQuery {-        header = hd {-          flags = flg {-              qOrR = QR_Response-            , authAnswer = True-            , recAvailable = True-            }-        }-      }--responseA :: Int -> Question -> IPv4 -> DNSFormat-responseA ident q ip =-  let hd = header defaultResponse-      dom = qname q-      an = ResourceRecord dom A 300 4 (RD_A ip)-  in  defaultResponse {-          header = hd { identifier=ident, qdCount = 1, anCount = 1 }-        , question = [q]-        , answer = [an]-      }--responseAAAA :: Int -> Question -> IPv6 -> DNSFormat-responseAAAA ident q ip =-  let hd = header defaultResponse-      dom = qname q-      an = ResourceRecord dom AAAA 300 16 (RD_AAAA ip)-  in  defaultResponse {-          header = hd { identifier=ident, qdCount = 1, anCount = 1 }-        , question = [q]-        , answer = [an]-      }
Network/DNS/Lookup.hs view
@@ -1,123 +1,439 @@-{-|-  Upper level DNS lookup functions.--}-+-- | Simple, high-level DNS lookup functions for clients.+--+--   All of the lookup functions necessary run in IO since they+--   interact with the network. The return types are similar, but+--   differ in what can be returned from a successful lookup.+--+--   We can think of the return type as either \"what I asked for\" or+--   \"an error\". For example, the 'lookupA' function, if successful,+--   will return a list of 'IPv4'. The 'lookupMX' function will+--   instead return a list of @('Domain','Int')@ pairs, where each pair+--   represents a hostname and its associated priority.+--+--   The order of multiple results may not be consistent between+--   lookups. If you require consistent results, apply+--   'Data.List.sort' to the returned list.+--+--   The errors that can occur are the same for all lookups. Namely:+--+--     * Timeout+--+--     * Wrong sequence number (foul play?)+--+--     * Unexpected data in the response+--+--   If an error occurs, you should be able to pattern match on the+--   'DNSError' constructor to determine which of these is the case.+--+--   /Note/: A result of \"no records\" is not considered an+--   error. If you perform, say, an \'AAAA\' lookup for a domain with+--   no such records, the \"success\" result would be @Right []@.+--+--   We perform a successful lookup of \"www.example.com\":+--+--   >>> let hostname = Data.ByteString.Char8.pack "www.example.com"+--   >>>+--   >>> rs <- makeResolvSeed defaultResolvConf+--   >>> withResolver rs $ \resolver -> lookupA resolver hostname+--   Right [93.184.216.34]+--+--   The only error that we can easily cause is a timeout. We do this+--   by creating and utilizing a 'ResolvConf' which has a timeout of+--   one millisecond and a very limited number of retries:+--+--   >>> let hostname2 = Data.ByteString.Char8.pack "www.example.com"+--   >>> let badrc = defaultResolvConf { resolvTimeout = 0, resolvRetry = 1 }+--   >>>+--   >>> rs2 <- makeResolvSeed badrc+--   >>> withResolver rs2 $ \resolver -> lookupA resolver hostname2+--   Left RetryLimitExceeded+--+--   As is the convention, successful results will always be wrapped+--   in a 'Right' while errors will be wrapped in a 'Left'.+--+--   For convenience, you may wish to enable GHC\'s OverloadedStrings+--   extension. This will allow you to avoid calling+--   'Data.ByteString.Char8.pack' on each domain name. See+--   <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#overloaded-string-literals>+--   for more information. In the following examples,+--   we assuem this extension is enabled.+--+--   All lookup functions eventually call 'lookupRaw'. See its documentation+--   to understand the concrete lookup behavior. module Network.DNS.Lookup (     lookupA, lookupAAAA   , lookupMX, lookupAviaMX, lookupAAAAviaMX   , lookupNS+  , lookupNSAuth   , lookupTXT+  , lookupSOA   , lookupPTR+  , lookupRDNS   , lookupSRV   ) where -import Control.Applicative-import Data.ByteString (ByteString)-import Data.IP-import Data.Maybe+import qualified Data.ByteString.Char8 as BS+import Data.IP (IPv4, IPv6)++import Network.DNS.Imports+import Network.DNS.LookupRaw as DNS import Network.DNS.Resolver as DNS-import Network.DNS.Types+import Network.DNS.Types.Internal +-- $setup+-- >>> :set -XOverloadedStrings+ ---------------------------------------------------------------- -{-|-  Resolving 'IPv4' by 'A'.--}-lookupA :: Resolver -> Domain -> IO (Maybe [IPv4])-lookupA rlv dom = toV4 <$> DNS.lookup rlv dom A+-- | Look up all \'A\' records for the given hostname.+--+--   A straightforward example:+--+--   >>> rs <- makeResolvSeed defaultResolvConf+--   >>> withResolver rs $ \resolver -> lookupA resolver "192.0.2.1.nip.io"+--   Right [192.0.2.1]+--+--   This function will also follow a CNAME and resolve its target if+--   one exists for the queried hostname:+--+--   >>> rs2 <- makeResolvSeed defaultResolvConf+--   >>> withResolver rs2 $ \resolver -> lookupA resolver "www.kame.net"+--   Right [210.155.141.200]+--+lookupA :: Resolver -> Domain -> IO (Either DNSError [IPv4])+lookupA rlv dom = do+  erds <- DNS.lookup rlv dom A+  case erds of+    -- See lookupXviaMX for an explanation of this construct.+    Left err  -> return (Left err)+    Right rds -> return $ mapM unTag rds   where-    toV4 = fmap (map unTag)-    unTag (RD_A x) = x-    unTag _ = error "lookupA"+    unTag :: RData -> Either DNSError IPv4+    unTag (RD_A x) = Right x+    unTag _ = Left UnexpectedRDATA -{-|-  Resolving 'IPv6' by 'AAAA'.--}-lookupAAAA :: Resolver -> Domain -> IO (Maybe [IPv6])-lookupAAAA rlv dom = toV6 <$> DNS.lookup rlv dom AAAA++-- | Look up all (IPv6) \'AAAA\' records for the given hostname.+--+--   Examples:+--+--   >>> rs <- makeResolvSeed defaultResolvConf+--   >>> withResolver rs $ \resolver -> lookupAAAA resolver "www.wide.ad.jp"+--   Right [2001:200:0:180c:20c:29ff:fec9:9d61]+--+lookupAAAA :: Resolver -> Domain -> IO (Either DNSError [IPv6])+lookupAAAA rlv dom = do+  erds <- DNS.lookup rlv dom AAAA+  case erds of+    -- See lookupXviaMX for an explanation of this construct.+    Left err  -> return (Left err)+    Right rds -> return $ mapM unTag rds   where-    toV6 = fmap (map unTag)-    unTag (RD_AAAA x) = x-    unTag _ = error "lookupAAAA"+    unTag :: RData -> Either DNSError IPv6+    unTag (RD_AAAA x) = Right x+    unTag _ = Left UnexpectedRDATA  ---------------------------------------------------------------- -{-|-  Resolving 'Domain' and its preference by 'MX'.--}-lookupMX :: Resolver -> Domain -> IO (Maybe [(Domain,Int)])-lookupMX rlv dom = toMX <$> DNS.lookup rlv dom MX+-- | Look up all \'MX\' records for the given hostname. Two parts+--   constitute an MX record: a hostname , and an integer priority. We+--   therefore return each record as a @('Domain', Int)@.+--+--   In this first example, we look up the MX for the domain \"example.com\".+--   It has an RFC7505 NULL MX (to prevent a deluge of spam from examples+--   posted on the internet).+--+--   >>> rs <- makeResolvSeed defaultResolvConf+--   >>> withResolver rs $ \resolver -> lookupMX resolver "example.com"+--   Right [(".",0)]+--+--+--   The domain \"mew.org\" does however have a single MX:+--+--   >>> rs2 <- makeResolvSeed defaultResolvConf+--   >>> withResolver rs2 $ \resolver -> lookupMX resolver "mew.org"+--   Right [("mail.mew.org.",10)]+--+--   Also note that all hostnames are returned with a trailing dot to+--   indicate the DNS root.+--+--   However the MX host itself has no need for an MX record, so its MX RRset+--   is empty.  But, \"no results\" is still a successful result.+--+--   >>> rs3 <- makeResolvSeed defaultResolvConf+--   >>> withResolver rs3 $ \resolver -> lookupMX resolver "mail.mew.org"+--   Right []+--+lookupMX :: Resolver -> Domain -> IO (Either DNSError [(Domain,Int)])+lookupMX rlv dom = do+  erds <- DNS.lookup rlv dom MX+  case erds of+    -- See lookupXviaMX for an explanation of this construct.+    Left err  -> return (Left err)+    Right rds -> return $ mapM unTag rds   where-    toMX = fmap (map unTag)-    unTag (RD_MX pr dm) = (dm,pr)-    unTag _ = error "lookupMX"+    unTag :: RData -> Either DNSError (Domain,Int)+    unTag (RD_MX pr dm) = Right (dm, fromIntegral pr)+    unTag _ = Left UnexpectedRDATA -{-|-  Resolving 'IPv4' by 'A' via 'MX'.--}-lookupAviaMX :: Resolver -> Domain -> IO (Maybe [IPv4])+-- | Look up all \'MX\' records for the given hostname, and then+--   resolve their hostnames to IPv4 addresses by calling+--   'lookupA'. The priorities are not retained.+--+--   Examples:+--+--   >>> import Data.List (sort)+--   >>> rs <- makeResolvSeed defaultResolvConf+--   >>> ips <- withResolver rs $ \resolver -> lookupAviaMX resolver "wide.ad.jp"+--   >>> fmap sort ips+--   Right [203.178.136.30]+--+--   Since there is more than one result, it is necessary to sort the+--   list in order to check for equality.+--+lookupAviaMX :: Resolver -> Domain -> IO (Either DNSError [IPv4]) lookupAviaMX rlv dom = lookupXviaMX rlv dom (lookupA rlv) -{-|-  Resolving 'IPv6' by 'AAAA' via 'MX'.--}-lookupAAAAviaMX :: Resolver -> Domain -> IO (Maybe [IPv6])+-- | Look up all \'MX\' records for the given hostname, and then+--   resolve their hostnames to IPv6 addresses by calling+--   'lookupAAAA'. The priorities are not retained.+--+lookupAAAAviaMX :: Resolver -> Domain -> IO (Either DNSError [IPv6]) lookupAAAAviaMX rlv dom = lookupXviaMX rlv dom (lookupAAAA rlv) -lookupXviaMX :: Show a => Resolver -> Domain -> (Domain -> IO (Maybe [a])) -> IO (Maybe [a])+lookupXviaMX :: Resolver+             -> Domain+             -> (Domain -> IO (Either DNSError [a]))+             -> IO (Either DNSError [a]) lookupXviaMX rlv dom func = do-    mdps <- lookupMX rlv dom-    maybe (return Nothing) lookup' mdps+    edps <- lookupMX rlv dom+    case edps of+      -- We have to deconstruct and reconstruct the error so that the+      -- typechecker does not conclude that a ~ (Domain, Int).+      Left err -> return (Left err)+      Right dps -> do+        -- We'll get back a [Either DNSError a] here.+        responses <- mapM (func . fst) dps+        -- We can use 'sequence' to join all of the Eithers+        -- together. If any of them are (Left _), we'll get a Left+        -- overall. Otherwise, we'll get Right [a].+        let overall = sequence responses+        -- Finally, we use (fmap concat) to concatenate the responses+        -- if there were no errors.+        return $ fmap concat overall++++----------------------------------------------------------------++-- | This function performs the real work for both 'lookupNS' and+--   'lookupNSAuth'. The only difference between those two is which+--   function, 'lookup' or 'lookupAuth', is used to perform the+--   lookup. We take either of those as our first parameter.+lookupNSImpl :: (Resolver -> Domain -> TYPE -> IO (Either DNSError [RData]))+             -> Resolver+             -> Domain+             -> IO (Either DNSError [Domain])+lookupNSImpl lookup_function rlv dom = do+  erds <- lookup_function rlv dom NS+  case erds of+    -- See lookupXviaMX for an explanation of this construct.+    Left err  -> return (Left err)+    Right rds -> return $ mapM unTag rds   where-    lookup' dps = check . catMaybes <$> mapM (func . fst) dps-    check as = case as of-        []  -> Nothing-        ass -> Just (concat ass)+    unTag :: RData -> Either DNSError Domain+    unTag (RD_NS dm) = Right dm+    unTag _ = Left UnexpectedRDATA +-- | Look up all \'NS\' records for the given hostname. The results+--   are taken from the ANSWER section of the response (as opposed to+--   AUTHORITY). For details, see e.g.+--   <http://www.zytrax.com/books/dns/ch15/>.+--+--   There will typically be more than one name server for a+--   domain. It is therefore extra important to sort the results if+--   you prefer them to be at all deterministic.+--+--   Examples:+--+--   >>> import Data.List (sort)+--   >>> rs <- makeResolvSeed defaultResolvConf+--   >>> ns <- withResolver rs $ \resolver -> lookupNS resolver "mew.org"+--   >>> fmap sort ns+--   Right ["ns1.mew.org.","ns2.mew.org."]+--+lookupNS :: Resolver -> Domain -> IO (Either DNSError [Domain])+lookupNS = lookupNSImpl DNS.lookup++-- | Look up all \'NS\' records for the given hostname. The results+--   are taken from the AUTHORITY section of the response and not the+--   usual ANSWER (use 'lookupNS' for that). For details, see e.g.+--   <http://www.zytrax.com/books/dns/ch15/>.+--+--   There will typically be more than one name server for a+--   domain. It is therefore extra important to sort the results if+--   you prefer them to be at all deterministic.+--+--   For an example, we can look up the nameservers for+--   \"example.com\" from one of the root servers, a.gtld-servers.net,+--   the IP address of which was found beforehand:+--+--   >>> import Data.List (sort)+--   >>> let ri = RCHostName "192.5.6.30" -- a.gtld-servers.net+--   >>> let rc = defaultResolvConf { resolvInfo = ri }+--   >>> rs <- makeResolvSeed rc+--   >>> ns <- withResolver rs $ \resolver -> lookupNSAuth resolver "example.com"+--   >>> fmap sort ns+--   Right ["a.iana-servers.net.","b.iana-servers.net."]+--+lookupNSAuth :: Resolver -> Domain -> IO (Either DNSError [Domain])+lookupNSAuth = lookupNSImpl DNS.lookupAuth++ ---------------------------------------------------------------- -{-|-  Resolving 'Domain' by 'NS'.--}-lookupNS :: Resolver -> Domain -> IO (Maybe [Domain])-lookupNS rlv dom = toNS <$> DNS.lookup rlv dom NS+-- | Look up all \'TXT\' records for the given hostname. The results+--   are free-form 'ByteString's.+--+--   Two common uses for \'TXT\' records are+--   <http://en.wikipedia.org/wiki/Sender_Policy_Framework> and+--   <http://en.wikipedia.org/wiki/DomainKeys_Identified_Mail>. As an+--   example, we find the SPF record for \"mew.org\":+--+--   >>> rs <- makeResolvSeed defaultResolvConf+--   >>> withResolver rs $ \resolver -> lookupTXT resolver "mew.org"+--   Right ["v=spf1 +mx -all"]+--+lookupTXT :: Resolver -> Domain -> IO (Either DNSError [ByteString])+lookupTXT rlv dom = do+  erds <- DNS.lookup rlv dom TXT+  case erds of+    -- See lookupXviaMX for an explanation of this construct.+    Left err  -> return (Left err)+    Right rds -> return $ mapM unTag rds   where-    toNS = fmap (map unTag)-    unTag (RD_NS dm) = dm-    unTag _ = error "lookupNS"+    unTag :: RData -> Either DNSError ByteString+    unTag (RD_TXT x) = Right x+    unTag _ = Left UnexpectedRDATA  ---------------------------------------------------------------- -{-|-  Resolving 'String' by 'TXT'.--}-lookupTXT :: Resolver -> Domain -> IO (Maybe [ByteString])-lookupTXT rlv dom = toTXT <$> DNS.lookup rlv dom TXT+-- | Look up the \'SOA\' record for the given domain. The result 7-tuple+--   consists of the \'mname\', \'rname\', \'serial\', \'refresh\', \'retry\',+--   \'expire\' and \'minimum\' fields of the SOA record.+--+--   An \@ separator is used between the first and second labels of the+--   \'rname\' field.  Since \'rname\' is an email address, it often contains+--   periods within its first label.  Presently, the trailing period is not+--   removed from the domain part of the \'rname\', but this may change in the+--   future.  Users should be prepared to remove any trailing period before+--   using the \'rname\` as a contact email address.+--+--   >>> rs <- makeResolvSeed defaultResolvConf+--   >>> soa <- withResolver rs $ \resolver -> lookupSOA resolver "mew.org"+--   >>> map (\ (mn, rn, _, _, _, _, _) -> (mn, rn)) <$> soa+--   Right [("ns1.mew.org.","kazu@mew.org.")]+--+lookupSOA :: Resolver -> Domain -> IO (Either DNSError [(Domain,Mailbox,Word32,Word32,Word32,Word32,Word32)])+lookupSOA rlv dom = do+  erds <- DNS.lookup rlv dom SOA+  case erds of+    -- See lookupXviaMX for an explanation of this construct.+    Left err  -> return (Left err)+    Right rds -> return $ mapM unTag rds   where-    toTXT = fmap (map unTag)-    unTag (RD_TXT x) = x-    unTag _ = error "lookupTXT"+    unTag :: RData -> Either DNSError (Domain,Mailbox,Word32,Word32,Word32,Word32,Word32)+    unTag (RD_SOA mn mr serial refresh retry expire mini) = Right (mn, mr, serial, refresh, retry, expire, mini)+    unTag _ = Left UnexpectedRDATA  ---------------------------------------------------------------- -{-|-  Resolving 'Domain' and its preference by 'PTR'.--}-lookupPTR :: Resolver -> Domain -> IO (Maybe [Domain])-lookupPTR rlv dom = toPTR <$> DNS.lookup rlv dom PTR+-- | Look up all \'PTR\' records for the given hostname. To perform a+--   reverse lookup on an IP address, you must first reverse its+--   octets and then append the suffix \".in-addr.arpa.\"+--+--   We look up the PTR associated with the IP address+--   210.130.137.80, i.e., 80.137.130.210.in-addr.arpa:+--+--   >>> rs <- makeResolvSeed defaultResolvConf+--   >>> withResolver rs $ \resolver -> lookupPTR resolver "180.2.232.202.in-addr.arpa"+--   Right ["www.iij.ad.jp."]+--+--   The 'lookupRDNS' function is more suited to this particular task.+--+lookupPTR :: Resolver -> Domain -> IO (Either DNSError [Domain])+lookupPTR rlv dom = do+  erds <- DNS.lookup rlv dom PTR+  case erds of+    -- See lookupXviaMX for an explanation of this construct.+    Left err  -> return (Left err)+    Right rds -> return $ mapM unTag rds   where-    toPTR = fmap (map unTag)-    unTag (RD_PTR dm) = dm-    unTag _ = error "lookupPTR"+    unTag :: RData -> Either DNSError Domain+    unTag (RD_PTR dm) = Right dm+    unTag _ = Left UnexpectedRDATA ++-- | Convenient wrapper around 'lookupPTR' to perform a reverse lookup+--   on a single IP address.+--+--   We repeat the example from 'lookupPTR', except now we pass the IP+--   address directly:+--+--   >>> rs <- makeResolvSeed defaultResolvConf+--   >>> withResolver rs $ \resolver -> lookupRDNS resolver "202.232.2.180"+--   Right ["www.iij.ad.jp."]+--+lookupRDNS :: Resolver -> Domain -> IO (Either DNSError [Domain])+lookupRDNS rlv ip = lookupPTR rlv dom+  where+    -- ByteString constants.+    dot = BS.pack "."+    suffix = BS.pack ".in-addr.arpa"++    octets = BS.split '.' ip+    reverse_ip = BS.intercalate dot (reverse octets)+    dom = reverse_ip `BS.append` suffix+ ---------------------------------------------------------------- -{-|-  Resolving 'Domain' and its preference by 'SRV'.--}-lookupSRV :: Resolver -> Domain -> IO (Maybe [(Int,Int,Int,Domain)])-lookupSRV rlv dom = toSRV <$> DNS.lookup rlv dom SRV+-- | Look up all \'SRV\' records for the given hostname. SRV records+--   consist (see <https://tools.ietf.org/html/rfc2782>) of the+--   following four fields:+--+--     * Priority (lower is more-preferred)+--+--     * Weight (relative frequency with which to use this record+--       amongst all results with the same priority)+--+--     * Port (the port on which the service is offered)+--+--     * Target (the hostname on which the service is offered)+--+--   The first three are integral, and the target is another DNS+--   hostname. We therefore return a four-tuple+--   @(Int,Int,Int,'Domain')@.+--+--   Examples:+--+--   >>> rs <- makeResolvSeed defaultResolvConf+--   >>> withResolver rs $ \resolver -> lookupSRV resolver "_xmpp-server._tcp.jabber.ietf.org"+--   Right [(5,0,5269,"_dc-srv.6661af51975d._xmpp-server._tcp.jabber.ietf.org.")]++-- Though the "jabber.ietf.orgs" SRV record may prove reasonably stable, as+-- with anything else published in DNS it is subject to change.  Also, this+-- example only works when connected to the Internet.  Perhaps the above+-- example should be displayed in a format that is not recognized as a test+-- by "doctest".++lookupSRV :: Resolver -> Domain -> IO (Either DNSError [(Word16, Word16, Word16, Domain)])+lookupSRV rlv dom = do+  erds <- DNS.lookup rlv dom SRV+  case erds of+    -- See lookupXviaMX for an explanation of this construct.+    Left err  -> return (Left err)+    Right rds -> return $ mapM unTag rds   where-    toSRV = fmap (map unTag)-    unTag (RD_SRV pri wei prt dm) = (pri,wei,prt,dm)-    unTag _ = error "lookupSRV"+    unTag :: RData -> Either DNSError (Word16, Word16, Word16, Domain)+    unTag (RD_SRV pri wei prt dm) = Right (pri,wei,prt,dm)+    unTag _ = Left UnexpectedRDATA
+ Network/DNS/LookupRaw.hs view
@@ -0,0 +1,298 @@+{-# LANGUAGE RecordWildCards #-}++module Network.DNS.LookupRaw (+  -- * Lookups returning requested RData+    lookup+  , lookupAuth+  -- * Lookups returning DNS Messages+  , lookupRaw+  , lookupRawCtl+  , lookupRawCtlRecv+  -- * DNS Message procesing+  , fromDNSMessage+  ) where++import Data.Hourglass (timeAdd, Seconds)+import Prelude hiding (lookup)+import Time.System (timeCurrent)+import Network.Socket (Socket)++import Network.DNS.IO+import Network.DNS.Imports hiding (lookup)+import Network.DNS.Memo+import Network.DNS.Transport+import Network.DNS.Types.Internal+import Network.DNS.Types.Resolver++-- $setup+-- >>> import Network.DNS.Resolver++----------------------------------------------------------------++-- | Look up resource records of a specified type for a domain,+--   collecting the results+--   from the ANSWER section of the response.+--   See the documentation of 'lookupRaw'+--   to understand the concrete behavior.+--   Cache is used if 'resolvCache' is 'Just'.+--+--   Example:+--+--   >>> rs <- makeResolvSeed defaultResolvConf+--   >>> withResolver rs $ \resolver -> lookup resolver "www.example.com" A+--   Right [93.184.216.34]+--+lookup :: Resolver -> Domain -> TYPE -> IO (Either DNSError [RData])+lookup = lookupSection Answer++-- | Look up resource records of a specified type for a domain,+--   collecting the results+--   from the AUTHORITY section of the response.+--   See the documentation of 'lookupRaw'+--   to understand the concrete behavior.+--   Cache is used even if 'resolvCache' is 'Just'.+lookupAuth :: Resolver -> Domain -> TYPE -> IO (Either DNSError [RData])+lookupAuth = lookupSection Authority++----------------------------------------------------------------++-- | Looking up resource records of a domain. The first parameter is one of+--   the field accessors of the 'DNSMessage' type -- this allows you to+--   choose which section (answer, authority, or additional) you would like+--   to inspect for the result.++lookupSection :: Section+              -> Resolver+              -> Domain+              -> TYPE+              -> IO (Either DNSError [RData])+lookupSection section rlv dom typ+  | section == Authority = lookupFreshSection rlv dom typ section+  | otherwise = case mcacheConf of+      Nothing           -> lookupFreshSection rlv dom typ section+      Just cacheconf    -> lookupCacheSection rlv dom typ cacheconf+  where+    mcacheConf = resolvCache $ resolvconf $ resolvseed rlv++lookupFreshSection :: Resolver+                   -> Domain+                   -> TYPE+                   -> Section+                   -> IO (Either DNSError [RData])+lookupFreshSection rlv dom typ section = do+    eans <- lookupRaw rlv dom typ+    case eans of+      Left err  -> return $ Left err+      Right ans -> return $ fromDNSMessage ans toRData+  where+    correct ResourceRecord{..} = rrtype == typ+    toRData = map rdata . filter correct . sectionF+    sectionF = case section of+      Answer    -> answer+      Authority -> authority++lookupCacheSection :: Resolver+                   -> Domain+                   -> TYPE+                   -> CacheConf+                   -> IO (Either DNSError [RData])+lookupCacheSection rlv dom typ cconf = do+    mx <- lookupCache (dom,typ) c+    case mx of+      Nothing -> do+          eans <- lookupRaw rlv dom typ+          case eans of+            Left  err ->+                -- Probably a network error happens.+                -- We do not cache anything.+                return $ Left err+            Right ans -> do+                let ex = fromDNSMessage ans toRR+                case ex of+                  Left NameError -> do+                      let v = Left NameError+                      cacheNegative cconf c key v ans+                      return v+                  Left e -> return $ Left e+                  Right [] -> do+                      let v = Right []+                      cacheNegative cconf c key v ans+                      return v+                  Right rss -> do+                      cachePositive cconf c key rss+                      return $ Right $ map rdata rss+      Just (_,x) -> return x+  where+    toRR = filter (typ `isTypeOf`) . answer+    Just c = cache rlv+    key = (dom,typ)++cachePositive :: CacheConf -> Cache -> Key -> [ResourceRecord] -> IO ()+cachePositive cconf c key rss+  | ttl == 0  = return () -- does not cache anything+  | otherwise = insertPositive cconf c key (Right rds) ttl+  where+    rds = map rdata rss+    ttl = minimum $ map rrttl rss -- rss is non-empty++insertPositive :: CacheConf -> Cache -> Key -> Entry -> TTL -> IO ()+insertPositive CacheConf{..} c k v ttl = when (ttl /= 0) $ do+    ctime <- timeCurrent+    let tim = ctime `timeAdd` life+    insertCache k tim v c+  where+    life :: Seconds+    life = fromIntegral (maximumTTL `min` ttl)++cacheNegative :: CacheConf -> Cache -> Key -> Entry -> DNSMessage -> IO ()+cacheNegative cconf c key v ans = case soas of+  []    -> return () -- does not cache anything+  soa:_ -> insertNegative cconf c key v $ rrttl soa+  where+    soas = filter (SOA `isTypeOf`) $ authority ans++insertNegative :: CacheConf -> Cache -> Key -> Entry -> TTL -> IO ()+insertNegative _ c k v ttl = when (ttl /= 0) $ do+    ctime <- timeCurrent+    let tim = ctime `timeAdd` life+    insertCache k tim v c+  where+    life :: Seconds+    life = fromIntegral ttl++isTypeOf :: TYPE -> ResourceRecord -> Bool+isTypeOf t ResourceRecord{..} = rrtype == t++----------------------------------------------------------------++-- | Look up a name and return the entire DNS Response.+--+-- For a given DNS server, the queries are done:+--+--  * A new UDP socket bound to a new local port is created and+--    a new identifier is created atomically from the cryptographically+--    secure pseudo random number generator for the target DNS server.+--    Then UDP queries are tried with the limitation of 'resolvRetry'+--    (use EDNS if specifiecd).+--    If it appears that the target DNS server does not support EDNS,+--    it falls back to traditional queries.+--+--  * If the response is truncated, a new TCP socket bound to a new+--    local port is created. Then exactly one TCP query is retried.+--+--+-- If multiple DNS servers are specified 'ResolvConf' ('RCHostNames ')+-- or found ('RCFilePath'), either sequential lookup or+-- concurrent lookup is carried out:+--+--  * In sequential lookup ('resolvConcurrent' is False),+--    the query procedure above is processed+--    in the order of the DNS servers sequentially until a successful+--    response is received.+--+--  * In concurrent lookup ('resolvConcurrent' is True),+--    the query procedure above is processed+--    for each DNS server concurrently.+--    The first received response is accepted even if+--    it is an error.+--+--  Cache is not used even if 'resolvCache' is 'Just'.+--+--+--   The example code:+--+--   @+--   rs <- makeResolvSeed defaultResolvConf+--   withResolver rs $ \\resolver -> lookupRaw resolver \"www.example.com\" A+--   @+--+--   And the (formatted) expected output:+--+--   @+--   Right (DNSMessage+--           { header = DNSHeader+--                        { identifier = 1,+--                          flags = DNSFlags+--                                    { qOrR = QR_Response,+--                                      opcode = OP_STD,+--                                      authAnswer = False,+--                                      trunCation = False,+--                                      recDesired = True,+--                                      recAvailable = True,+--                                      rcode = NoErr,+--                                      authenData = False+--                                    },+--                        },+--             question = [Question { qname = \"www.example.com.\",+--                                    qtype = A}],+--             answer = [ResourceRecord {rrname = \"www.example.com.\",+--                                       rrtype = A,+--                                       rrttl = 800,+--                                       rdlen = 4,+--                                       rdata = 93.184.216.119}],+--             authority = [],+--             additional = []})+--  @+--+--  AXFR requests cannot be performed with this interface.+--+--   >>> rs <- makeResolvSeed defaultResolvConf+--   >>> withResolver rs $ \resolver -> lookupRaw resolver "mew.org" AXFR+--   Left InvalidAXFRLookup+--+lookupRaw :: Resolver   -- ^ Resolver obtained via 'withResolver'+          -> Domain     -- ^ Query domain+          -> TYPE       -- ^ Query RRtype+          -> IO (Either DNSError DNSMessage)+lookupRaw rslv dom typ = lookupRawCtl rslv dom typ mempty++-- | Similar to 'lookupRaw', but the default values of the RD, AD, CD and DO+-- flag bits, as well as various EDNS features, can be adjusted via the+-- 'QueryControls' parameter.+--+lookupRawCtl :: Resolver      -- ^ Resolver obtained via 'withResolver'+             -> Domain        -- ^ Query domain+             -> TYPE          -- ^ Query RRtype+             -> QueryControls -- ^ Query flag and EDNS overrides+             -> IO (Either DNSError DNSMessage)+lookupRawCtl rslv dom typ ctls = resolve rslv dom typ ctls receive++-- | Similar to 'lookupRawCtl', but the recv action can be replaced with+-- something other than `Network.DNS.IO.receive`.+-- For example, in an environment where frequent retrieval of the current time+-- is a performance issue, you can pass the time from outside instead of+-- having `Network.DNS.IO.receive` retrieve the current time.+lookupRawCtlRecv :: Resolver                  -- ^ Resolver obtained via 'withResolver'+                 -> Domain                    -- ^ Query domain+                 -> TYPE                      -- ^ Query RRtype+                 -> QueryControls             -- ^ Query flag and EDNS overrides+                 -> (Socket -> IO DNSMessage) -- ^ Action to receive message from socket+                 -> IO (Either DNSError DNSMessage)+lookupRawCtlRecv = resolve++----------------------------------------------------------------++-- | Messages with a non-error RCODE are passed to the supplied function+-- for processing.  Other messages are translated to 'DNSError' instances.+--+-- Note that 'NameError' is not a lookup error.  The lookup is successful,+-- bearing the sad news that the requested domain does not exist.  'NameError'+-- responses may return a meaningful AD bit, may contain useful data in the+-- authority section, and even initial CNAME records that lead to the+-- ultimately non-existent domain.  Applications that wish to process the+-- content of 'NameError' (NXDomain) messages will need to implement their+-- own RCODE handling.+--+fromDNSMessage :: DNSMessage -> (DNSMessage -> a) -> Either DNSError a+fromDNSMessage ans conv = case errcode ans of+    NoErr     -> Right $ conv ans+    FormatErr -> Left FormatError+    ServFail  -> Left ServerFailure+    NameErr   -> Left NameError+    NotImpl   -> Left NotImplemented+    Refused   -> Left OperationRefused+    BadVers   -> Left BadOptRecord+    BadRCODE  -> Left $ DecodeError "Malformed EDNS message"+    _         -> Left UnknownDNSError+  where+    errcode = rcode . flags . header
Network/DNS/Resolver.hs view
@@ -1,195 +1,108 @@-{-# LANGUAGE CPP #-}-{-|-  DNS Resolver and lookup functions.--  Sample code:--@-    import qualified Network.DNS as DNS (lookup)-    import Network.DNS hiding (lookup)-    main :: IO ()-    main = do-        rs <- makeResolvSeed defaultResolvConf-        withResolver rs $ \\resolver -> do-            DNS.lookup resolver \"www.example.com\" A >>= print-@--}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-} +-- | Resolver related data types. module Network.DNS.Resolver (-  -- * Documentation-  -- ** Configuration for resolver-    FileOrNumericHost(..), ResolvConf(..), defaultResolvConf-  -- ** Intermediate data type for resolver-  , ResolvSeed, makeResolvSeed-  -- ** Type and function for resolver-  , Resolver(..), withResolver-  -- ** Looking up functions-  , lookup, lookupRaw+  -- * Configuration for resolver+    ResolvConf+  , defaultResolvConf+  -- ** Accessors+  , resolvInfo+  , resolvTimeout+  , resolvRetry+  , resolvConcurrent+  , resolvCache+  , resolvQueryControls+  -- ** Specifying DNS servers+  , FileOrNumericHost(..)+  -- ** Configuring cache+  , CacheConf+  , defaultCacheConf+  , maximumTTL+  , pruningDelay+  -- * Intermediate data type for resolver+  , ResolvSeed+  , makeResolvSeed+  -- * Type and function for resolver+  , Resolver+  , withResolver+  , withResolvers   ) where -import Control.Applicative-import Control.Exception-import Data.Char-import Data.Int-import Data.List hiding (find, lookup)-import Network.BSD-import Network.DNS.Decode-import Network.DNS.Encode-import Network.DNS.Internal-import Network.Socket hiding (send, sendTo, recv, recvFrom)-import Network.Socket.ByteString.Lazy-import Prelude hiding (lookup)-import System.Random-import System.Timeout--#if mingw32_HOST_OS == 1-import Network.Socket (send)-import qualified Data.ByteString.Lazy.Char8 as LB-import Control.Monad (when)-#endif-------------------------------------------------------------------{-|-  Union type for 'FilePath' and 'HostName'. Specify 'FilePath' to-  \"resolv.conf\" or numeric IP address in 'String' form.--}-data FileOrNumericHost = RCFilePath FilePath | RCHostName HostName--{-|-  Type for resolver configuration--}-data ResolvConf = ResolvConf {-    resolvInfo :: FileOrNumericHost-  , resolvTimeout :: Int-  -- | This field was obsoleted.-  , resolvBufsize :: Integer-}--{-|-  Default 'ResolvConf'.-  'resolvInfo' is 'RCFilePath' \"\/etc\/resolv.conf\".-  'resolvTimeout' is 3,000,000 micro seconds.-  'resolvBufsize' is 512. (obsoleted)--}-defaultResolvConf :: ResolvConf-defaultResolvConf = ResolvConf {-    resolvInfo = RCFilePath "/etc/resolv.conf"-  , resolvTimeout = 3 * 1000 * 1000-  , resolvBufsize = 512-}--------------------------------------------------------------------{-|-  Abstract data type of DNS Resolver seed--}-data ResolvSeed = ResolvSeed {-    addrInfo :: AddrInfo-  , rsTimeout :: Int-  , rsBufsize :: Integer-}+import Control.Exception as E+import qualified Crypto.Random as C+import qualified Data.ByteString as BS+import Data.IORef (IORef)+import qualified Data.IORef as I+import qualified Data.List.NonEmpty as NE+import Network.Socket (AddrInfoFlag(..), AddrInfo(..), PortNumber, HostName, SocketType(Datagram), getAddrInfo, defaultHints)+import Prelude -{-|-  Abstract data type of DNS Resolver--}-data Resolver = Resolver {-    genId   :: IO Int-  , dnsSock :: Socket-  , dnsTimeout :: Int-  , dnsBufsize :: Integer-}+import Network.DNS.Imports+import Network.DNS.Memo+import Network.DNS.Resolver.Internal+import Network.DNS.Transport+import Network.DNS.Types.Internal+import Network.DNS.Types.Resolver  ---------------------------------------------------------------- -{-|-  Making 'ResolvSeed' from an IP address of a DNS cache server.--}+-- |  Make a 'ResolvSeed' from a 'ResolvConf'.+--+--    Examples:+--+--    >>> rs <- makeResolvSeed defaultResolvConf+-- makeResolvSeed :: ResolvConf -> IO ResolvSeed-makeResolvSeed conf = ResolvSeed <$> addr-                                 <*> pure (resolvTimeout conf)-                                 <*> pure (resolvBufsize conf)+makeResolvSeed conf = ResolvSeed conf <$> findAddresses   where-    addr = case resolvInfo conf of-        RCHostName numhost -> makeAddrInfo numhost-        RCFilePath file -> toAddr <$> readFile file >>= makeAddrInfo-    toAddr cs = let l:_ = filter ("nameserver" `isPrefixOf`) $ lines cs-                in extract l-    extract = reverse . dropWhile isSpace . reverse . dropWhile isSpace . drop 11+    findAddresses :: IO (NonEmpty AddrInfo)+    findAddresses = case resolvInfo conf of+        RCHostName numhost       -> (:| []) <$> makeAddrInfo numhost Nothing+        RCHostPort numhost mport -> (:| []) <$> makeAddrInfo numhost (Just mport)+        RCHostNames nss          -> mkAddrs nss+        RCFilePath file          -> getDefaultDnsServers file >>= mkAddrs+    mkAddrs []     = E.throwIO BadConfiguration+    mkAddrs (l:ls) = (:|) <$> makeAddrInfo l Nothing <*> forM ls (`makeAddrInfo` Nothing) -makeAddrInfo :: HostName -> IO AddrInfo-makeAddrInfo addr = do-    proto <- getProtocolNumber "udp"+makeAddrInfo :: HostName -> Maybe PortNumber -> IO AddrInfo+makeAddrInfo addr mport = do     let hints = defaultHints {-            addrFlags = [AI_ADDRCONFIG, AI_NUMERICHOST, AI_PASSIVE]+            addrFlags = [AI_ADDRCONFIG, AI_NUMERICHOST, AI_NUMERICSERV, AI_PASSIVE]           , addrSocketType = Datagram-          , addrProtocol = proto           }-    a:_ <- getAddrInfo (Just hints) (Just addr) (Just "domain")-    return a+        -- 53 is the standard port number for domain name servers as assigned by IANA+        serv = maybe "53" show mport+    head <$> getAddrInfo (Just hints) (Just addr) (Just serv)  ---------------------------------------------------------------- -{-|-  Giving a thread-safe 'Resolver' to the function of the second-  argument. 'withResolver' should be passed to 'forkIO'.--}-+-- | Giving a thread-safe 'Resolver' to the function of the second+--   argument. withResolver :: ResolvSeed -> (Resolver -> IO a) -> IO a-withResolver seed func = do-  let ai = addrInfo seed-  sock <- socket (addrFamily ai) (addrSocketType ai) (addrProtocol ai)-  connect sock (addrAddress ai)-  let resolv = Resolver {-          genId = getRandom-        , dnsSock = sock-        , dnsTimeout = rsTimeout seed-        , dnsBufsize = rsBufsize seed-        }-  func resolv `finally` sClose sock--getRandom :: IO Int-getRandom = getStdRandom (randomR (0,65535))------------------------------------------------------------------+withResolver seed f = makeResolver seed >>= f -{-|-  Looking up resource records of a domain.--}-lookup :: Resolver -> Domain -> TYPE -> IO (Maybe [RDATA])-lookup rlv dom typ = (>>= toRDATA) <$> lookupRaw rlv dom typ-  where-    {- CNAME hack-    dom' = if "." `isSuffixOf` dom then dom else dom ++ "."-    correct r = rrname r == dom' && rrtype r == typ-    -}-    correct r = rrtype r == typ-    listToMaybe [] = Nothing-    listToMaybe xs = Just xs-    toRDATA = listToMaybe . map rdata . filter correct . answer+{-# DEPRECATED withResolvers "Use withResolver with resolvConcurrent set to True" #-}+-- | Giving thread-safe 'Resolver's to the function of the second+--   argument.  For each 'Resolver', multiple lookups must be done+--   sequentially.  'Resolver's can be used concurrently.+withResolvers :: [ResolvSeed] -> ([Resolver] -> IO a) -> IO a+withResolvers seeds f = mapM makeResolver seeds >>= f -{-|-  Looking up a domain and returning an entire DNS Response.--}-lookupRaw :: Resolver -> Domain -> TYPE -> IO (Maybe DNSFormat)-lookupRaw rlv dom typ = do-    seqno <- genId rlv-    sendAll sock (composeQuery seqno [q])-    (>>= check seqno) <$> timeout tm (receive sock)-  where-    sock = dnsSock rlv-    tm = dnsTimeout rlv-    q = makeQuestion dom typ-    check seqno res = do-        let hdr = header res-        if identifier hdr == seqno then-            Just res-          else-            Nothing+makeResolver :: ResolvSeed -> IO Resolver+makeResolver seed = do+  let n = NE.length $ nameservers seed+  refs <- replicateM n (C.drgNew >>= I.newIORef)+  let gens = NE.fromList $ map getRandom refs+  case resolvCache $ resolvconf seed of+    Just cacheconf -> do+        c <- newCache $ pruningDelay cacheconf+        return $ Resolver seed gens $ Just c+    Nothing -> return $ Resolver seed gens Nothing -#if mingw32_HOST_OS == 1-    -- Windows does not support sendAll in Network.ByteString.Lazy.-    -- This implements sendAll with Haskell Strings.-    sendAll sock bs = do-	sent <- send sock (LB.unpack bs)-	when (sent < fromIntegral (LB.length bs)) $ sendAll sock (LB.drop (fromIntegral sent) bs)-#endif+getRandom :: IORef C.ChaChaDRG -> IO Word16+getRandom ref = I.atomicModifyIORef' ref $ \gen ->+  let (bs, gen') = C.randomBytesGenerate 2 gen+      [u,l] = map fromIntegral $ BS.unpack bs+      !seqno = u * 256 + l+  in (gen', seqno)
− Network/DNS/StateBinary.hs 
@@ -1,169 +0,0 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}-module Network.DNS.StateBinary where--import Blaze.ByteString.Builder-import Control.Applicative-import Control.Monad.State-import Data.Attoparsec.ByteString-import qualified Data.Attoparsec.ByteString.Lazy as AL-import Data.ByteString (ByteString)-import qualified Data.ByteString as BS (unpack, length)-import qualified Data.ByteString.Lazy as BL (ByteString)-import Data.Conduit-import Data.Conduit.Attoparsec-import Data.Int-import Data.IntMap (IntMap)-import qualified Data.IntMap as IM (insert, lookup, empty)-import Data.Map (Map)-import qualified Data.Map as M (insert, lookup, empty)-import Data.Monoid-import Data.Word-import Network.DNS.Types-import Prelude hiding (lookup, take)--import qualified Data.Attoparsec.Types as T (Parser)--------------------------------------------------------------------type SPut = State WState Write--data WState = WState {-    wsDomain :: Map Domain Int-  , wsPosition :: Int-}--initialWState :: WState-initialWState = WState M.empty 0--instance Monoid SPut where-    mempty = return mempty-    mappend a b = mconcat <$> sequence [a, b]--put8 :: Word8 -> SPut-put8 = fixedSized 1 writeWord8--put16 :: Word16 -> SPut-put16 = fixedSized 2 writeWord16be--put32 :: Word32 -> SPut-put32 = fixedSized 4 writeWord32be--putInt8 :: Int -> SPut-putInt8 = fixedSized 1 (writeInt8 . fromIntegral)--putInt16 :: Int -> SPut-putInt16 = fixedSized 2 (writeInt16be . fromIntegral)--putInt32 :: Int -> SPut-putInt32 = fixedSized 4 (writeInt32be . fromIntegral)--putByteString :: ByteString -> SPut-putByteString = writeSized BS.length writeByteString--addPositionW :: Int -> State WState ()-addPositionW n = do-    (WState m cur) <- get-    put $ WState m (cur+n)--fixedSized :: Int -> (a -> Write) -> a -> SPut-fixedSized n f a = do addPositionW n-                      return (f a)--writeSized :: Show a => (a -> Int) -> (a -> Write) -> a -> SPut-writeSized n f a = do addPositionW (n a)-                      return (f a)--wsPop :: Domain -> State WState (Maybe Int)-wsPop dom = do-    doms <- gets wsDomain-    return $ M.lookup dom doms--wsPush :: Domain -> Int -> State WState ()-wsPush dom pos = do-    (WState m cur) <- get-    put $ WState (M.insert dom pos m) cur--------------------------------------------------------------------type SGet = StateT PState (T.Parser ByteString)--data PState = PState {-    psDomain :: IntMap Domain-  , psPosition :: Int-  }--------------------------------------------------------------------getPosition :: SGet Int-getPosition = psPosition <$> get--addPosition :: Int -> SGet ()-addPosition n = do-    PState dom pos <- get-    put $ PState dom (pos + n)--push :: Int -> Domain -> SGet ()-push n d = do-    PState dom pos <- get-    put $ PState (IM.insert n d dom) pos--pop :: Int -> SGet (Maybe Domain)-pop n = IM.lookup n . psDomain <$> get--------------------------------------------------------------------get8 :: SGet Word8-get8  = lift anyWord8 <* addPosition 1--get16 :: SGet Word16-get16 = lift getWord16be <* addPosition 2-  where-    word8' = fromIntegral <$> anyWord8-    getWord16be = do-        a <- word8'-        b <- word8'-        return $ a * 256 + b--get32 :: SGet Word32-get32 = lift getWord32be <* addPosition 4-  where-    word8' = fromIntegral <$> anyWord8-    getWord32be = do-        a <- word8'-        b <- word8'-        c <- word8'-        d <- word8'-        return $ a * 1677721 + b * 65536 + c * 256 + d--getInt8 :: SGet Int-getInt8 = fromIntegral <$> get8--getInt16 :: SGet Int-getInt16 = fromIntegral <$> get16--getInt32 :: SGet Int-getInt32 = fromIntegral <$> get32--------------------------------------------------------------------getNBytes :: Int -> SGet [Int]-getNBytes len = toInts <$> getNByteString len-  where-    toInts = map fromIntegral . BS.unpack--getNByteString :: Int -> SGet ByteString-getNByteString n = lift (take n) <* addPosition n--------------------------------------------------------------------initialState :: PState-initialState = PState IM.empty 0--sinkSGet :: SGet a -> Sink ByteString (ResourceT IO) (a, PState)-sinkSGet parser = sinkParser (runStateT parser initialState)--runSGet :: SGet a -> BL.ByteString -> Either String (a, PState)-runSGet parser bs = AL.eitherResult $ AL.parse (runStateT parser initialState) bs--runSPut :: SPut -> BL.ByteString-runSPut = toLazyByteString . fromWrite . flip evalState initialWState
+ Network/DNS/Transport.hs view
@@ -0,0 +1,245 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}++module Network.DNS.Transport (+    Resolver(..)+  , resolve+  ) where++import Control.Concurrent.Async (async, waitAnyCancel)+import Control.Exception as E+import qualified Data.ByteString.Char8 as BS+import qualified Data.List.NonEmpty as NE+import Network.Socket (AddrInfo(..), SockAddr(..), Family(AF_INET, AF_INET6), Socket, SocketType(Stream), close, socket, connect, defaultProtocol)+import System.IO.Error (annotateIOError)+import System.Timeout (timeout)++import Network.DNS.IO+import Network.DNS.Imports+import Network.DNS.Types.Internal+import Network.DNS.Types.Resolver++-- | Check response for a matching identifier and question.  If we ever do+-- pipelined TCP, we'll need to handle out of order responses.  See:+-- https://tools.ietf.org/html/rfc7766#section-7+--+checkResp :: Question -> Identifier -> DNSMessage -> Bool+checkResp q seqno = isNothing . checkRespM q seqno++-- When the response 'RCODE' is 'FormatErr', the server did not understand our+-- query packet, and so is not expected to return a matching question.+--+checkRespM :: Question -> Identifier -> DNSMessage -> Maybe DNSError+checkRespM q seqno resp+  | identifier (header resp) /= seqno = Just SequenceNumberMismatch+  | FormatErr <- rcode $ flags $ header resp+  , []        <- question resp        = Nothing+  | [q] /= question resp              = Just QuestionMismatch+  | otherwise                         = Nothing++----------------------------------------------------------------++data TCPFallback = TCPFallback deriving (Show, Typeable)+instance Exception TCPFallback++type Rslv0 = QueryControls -> (Socket -> IO DNSMessage)+           -> IO (Either DNSError DNSMessage)++type Rslv1 = Question+          -> Int -- Timeout+          -> Int -- Retry+          -> Rslv0++type TcpRslv = AddrInfo+            -> Question+            -> Int -- Timeout+            -> QueryControls+            -> IO DNSMessage++type UdpRslv = Int -- Retry+            -> (Socket -> IO DNSMessage)+            -> TcpRslv++-- In lookup loop, we try UDP until we get a response.  If the response+-- is truncated, we try TCP once, with no further UDP retries.+--+-- For now, we optimize for low latency high-availability caches+-- (e.g.  running on a loopback interface), where TCP is cheap+-- enough.  We could attempt to complete the TCP lookup within the+-- original time budget of the truncated UDP query, by wrapping both+-- within a a single 'timeout' thereby staying within the original+-- time budget, but it seems saner to give TCP a full opportunity to+-- return results.  TCP latency after a truncated UDP reply will be+-- atypical.+--+-- Future improvements might also include support for TCP on the+-- initial query.+--+-- This function merges the query flag overrides from the resolver+-- configuration with any additional overrides from the caller.+--+resolve :: Resolver -> Domain -> TYPE -> Rslv0+resolve rlv dom typ qctls rcv+  | isIllegal dom = return $ Left IllegalDomain+  | typ == AXFR   = return $ Left InvalidAXFRLookup+  | onlyOne       = resolveOne        (head nss) (head gens) q tm retry ctls rcv+  | concurrent    = resolveConcurrent nss        gens        q tm retry ctls rcv+  | otherwise     = resolveSequential nss        gens        q tm retry ctls rcv+  where+    q = case BS.last dom of+          '.' -> Question dom typ+          _   -> Question (dom <> ".") typ++    gens = NE.toList $ genIds rlv++    seed    = resolvseed rlv+    nss     = NE.toList $ nameservers seed+    onlyOne = length nss == 1+    ctls    = qctls <> resolvQueryControls (resolvconf $ resolvseed rlv)++    conf       = resolvconf seed+    concurrent = resolvConcurrent conf+    tm         = resolvTimeout conf+    retry      = resolvRetry conf+++resolveSequential :: [AddrInfo] -> [IO Identifier] -> Rslv1+resolveSequential nss gs q tm retry ctls rcv = loop nss gs+  where+    loop [ai]     [gen] = resolveOne ai gen q tm retry ctls rcv+    loop (ai:ais) (gen:gens) = do+        eres <- resolveOne ai gen q tm retry ctls rcv+        case eres of+          Left  _ -> loop ais gens+          res     -> return res+    loop _  _     = error "resolveSequential:loop"++resolveConcurrent :: [AddrInfo] -> [IO Identifier] -> Rslv1+resolveConcurrent nss gens q tm retry ctls rcv = do+    asyncs <- mapM mkAsync $ zip nss gens+    snd <$> waitAnyCancel asyncs+  where+    mkAsync (ai,gen) = async $ resolveOne ai gen q tm retry ctls rcv++resolveOne :: AddrInfo -> IO Identifier -> Rslv1+resolveOne ai gen q tm retry ctls rcv =+    E.try $ udpTcpLookup gen retry rcv ai q tm ctls++----------------------------------------------------------------++-- UDP attempts must use the same ID and accept delayed answers+-- but we use a fresh ID for each TCP lookup.+--+udpTcpLookup :: IO Identifier -> UdpRslv+udpTcpLookup gen retry rcv ai q tm ctls = do+    ident <- gen+    udpLookup ident retry rcv ai q tm ctls `E.catch`+            \TCPFallback -> tcpLookup gen ai q tm ctls++----------------------------------------------------------------++ioErrorToDNSError :: AddrInfo -> String -> IOError -> IO DNSMessage+ioErrorToDNSError ai protoName ioe = throwIO $ NetworkFailure aioe+  where+    loc = protoName ++ "@" ++ show (addrAddress ai)+    aioe = annotateIOError ioe loc Nothing Nothing++----------------------------------------------------------------++udpOpen :: AddrInfo -> IO Socket+udpOpen ai = do+    sock <- socket (addrFamily ai) (addrSocketType ai) (addrProtocol ai)+    connect sock (addrAddress ai)+    return sock++-- This throws DNSError or TCPFallback.+udpLookup :: Identifier -> UdpRslv+udpLookup ident retry rcv ai q tm ctls = do+    let qry = encodeQuestion ident q ctls+    E.handle (ioErrorToDNSError ai "udp") $+      bracket (udpOpen ai) close (loop qry ctls 0 RetryLimitExceeded)+  where+    loop qry lctls cnt err sock+      | cnt == retry = E.throwIO err+      | otherwise    = do+          mres <- timeout tm (send sock qry >> getAns sock)+          case mres of+              Nothing  -> loop qry lctls (cnt + 1) RetryLimitExceeded sock+              Just res -> do+                      let fl = flags $ header res+                          tc = trunCation fl+                          rc = rcode fl+                          eh = ednsHeader res+                          cs = ednsEnabled FlagClear <> lctls+                      if tc then E.throwIO TCPFallback+                      else if rc == FormatErr && eh == NoEDNS && cs /= lctls+                      then let qry' = encodeQuestion ident q cs+                            in loop qry' cs cnt RetryLimitExceeded sock+                      else return res++    -- | Closed UDP ports are occasionally re-used for a new query, with+    -- the nameserver returning an unexpected answer to the wrong socket.+    -- Such answers should be simply dropped, with the client continuing+    -- to wait for the right answer, without resending the question.+    -- Note, this eliminates sequence mismatch as a UDP error condition,+    -- instead we'll time out if no matching answer arrives.+    --+    getAns sock = do+        resp <- rcv sock+        if checkResp q ident resp+        then return resp+        else getAns sock++----------------------------------------------------------------++-- Create a TCP socket with the given socket address.+tcpOpen :: SockAddr -> IO Socket+tcpOpen peer = case peer of+    SockAddrInet{}  -> socket AF_INET  Stream defaultProtocol+    SockAddrInet6{} -> socket AF_INET6 Stream defaultProtocol+    _               -> E.throwIO ServerFailure++-- Perform a DNS query over TCP, if we were successful in creating+-- the TCP socket.+-- This throws DNSError only.+tcpLookup :: IO Identifier -> TcpRslv+tcpLookup gen ai q tm ctls =+    E.handle (ioErrorToDNSError ai "tcp") $ do+        res <- bracket (tcpOpen addr) close (perform ctls)+        let rc = rcode $ flags $ header res+            eh = ednsHeader res+            cs = ednsEnabled FlagClear <> ctls+        -- If we first tried with EDNS, retry without on FormatErr.+        if rc == FormatErr && eh == NoEDNS && cs /= ctls+        then bracket (tcpOpen addr) close (perform cs)+        else return res+  where+    addr = addrAddress ai+    perform cs vc = do+        ident <- gen+        let qry = encodeQuestion ident q cs+        mres <- timeout tm $ do+            connect vc addr+            sendVC vc qry+            receiveVC vc+        case mres of+            Nothing  -> E.throwIO TimeoutExpired+            Just res -> maybe (return res) E.throwIO (checkRespM q ident res)++----------------------------------------------------------------++badLength :: Domain -> Bool+badLength dom+    | BS.null dom        = True+    | BS.last dom == '.' = BS.length dom > 254+    | otherwise          = BS.length dom > 253++isIllegal :: Domain -> Bool+isIllegal dom+  | badLength dom               = True+  | '.' `BS.notElem` dom        = True+  | ':' `BS.elem` dom           = True+  | '/' `BS.elem` dom           = True+  | any (\x -> BS.length x > 63)+        (BS.split '.' dom)      = True+  | otherwise                   = False
Network/DNS/Types.hs view
@@ -1,26 +1,134 @@-{-|-  Data types for DNS Query and Response. For more information, see <http://www.ietf.org/rfc/rfc1035>.--}+-- | Data types for DNS Query and Response.+--   For more information, see <http://www.ietf.org/rfc/rfc1035>.  module Network.DNS.Types (-  -- * Domain-    Domain-  -- * TYPE-  , TYPE (..), intToType, typeToInt, toType-  -- * DNS Format-  , DNSFormat (..)-  -- * DNS Header+  -- * Resource Records+    ResourceRecord (..)+  , Answers+  , AuthorityRecords+  , AdditionalRecords+  -- ** Types+  , Domain+  , CLASS+  , classIN+  , TTL+  -- ** Resource Record Types+  , TYPE (+    A+  , NS+  , CNAME+  , SOA+  , NULL+  , PTR+  , MX+  , TXT+  , AAAA+  , SRV+  , DNAME+  , OPT+  , DS+  , RRSIG+  , NSEC+  , DNSKEY+  , NSEC3+  , NSEC3PARAM+  , TLSA+  , CDS+  , CDNSKEY+  , CSYNC+  , AXFR+  , ANY+  , CAA+  )+  , fromTYPE+  , toTYPE+  -- ** Resource Data+  , RData (..)+  , RD_RRSIG(..)+  , dnsTime+  -- * DNS Message+  , DNSMessage (..)+  -- ** Query+  , makeQuery+  , makeEmptyQuery+  , defaultQuery+  -- ** Query Controls+  , QueryControls+  , rdFlag+  , adFlag+  , cdFlag+  , doFlag+  , ednsEnabled+  , ednsSetVersion+  , ednsSetUdpSize+  , ednsSetOptions+  -- *** Flag and OData control operations+  , FlagOp(..)+  , ODataOp(..)+  -- ** Response+  , defaultResponse+  , makeResponse+  -- ** DNS Header   , DNSHeader (..)-  -- * DNS Flags+  , Identifier+  -- *** DNS flags   , DNSFlags (..)-  -- * DNS Body   , QorR (..)+  , defaultDNSFlags+  -- *** OPCODE and RCODE   , OPCODE (..)-  , RCODE (..)-  , ResourceRecord (..)+  , fromOPCODE+  , toOPCODE+  , RCODE (+    NoErr+  , FormatErr+  , ServFail+  , NameErr+  , NotImpl+  , Refused+  , YXDomain+  , YXRRSet+  , NXRRSet+  , NotAuth+  , NotZone+  , BadVers+  , BadKey+  , BadTime+  , BadMode+  , BadName+  , BadAlg+  , BadTrunc+  , BadCookie+  , BadRCODE+  )+  , fromRCODE+  , toRCODE+  -- ** EDNS Pseudo-Header+  , EDNSheader(..)+  , ifEDNS+  , mapEDNS+  -- *** EDNS record+  , EDNS(..)+  , defaultEDNS+  , maxUdpSize+  , minUdpSize+  -- *** EDNS options+  , OData (..)+  , OptCode (+    ClientSubnet+  , DAU+  , DHU+  , N3U+  , NSID+  )+  , fromOptCode+  , toOptCode+  -- ** DNS Body   , Question (..)-  , RDATA (..)-  , responseA, responseAAAA-  ) where+  -- * DNS Error+  , DNSError (..)+  -- * Other types+  , Mailbox+    ) where -import Network.DNS.Internal+import Network.DNS.Types.Internal
+ Network/DNS/Utils.hs view
@@ -0,0 +1,177 @@+-- | Miscellaneous utility functions for processing DNS data.+--+module Network.DNS.Utils (+    normalize+  , normalizeCase+  , normalizeRoot+  , splitDomain+  , splitMailbox+  ) where++import qualified Data.ByteString.Char8 as BS+import Data.Char (toLower)++import Network.DNS.Types.Internal (DNSError, Domain, Mailbox)+import Network.DNS.StateBinary (parseLabel)+++-- | Perform both 'normalizeCase' and 'normalizeRoot' on the given+--   'Domain'. When comparing DNS names taken from user input, this is+--   often necessary to avoid unexpected results.+--+--   /Examples/:+--+--   >>> let domain1 = BS.pack "ExAmPlE.COM"+--   >>> let domain2 = BS.pack "example.com."+--   >>> domain1 == domain2+--   False+--   >>> normalize domain1 == normalize domain2+--   True+--+--   The 'normalize' function should be idempotent:+--+--   >>> normalize (normalize domain1) == normalize domain1+--   True+--+--   Ensure that we don't crash on the empty 'Domain':+--+--   >>> import qualified Data.ByteString.Char8 as BS+--   >>> normalize BS.empty+--   "."+--+normalize :: Domain -> Domain+normalize = normalizeCase . normalizeRoot+++-- | Normalize the case of the given DNS name for comparisons.+--+--   According to RFC #1035, \"For all parts of the DNS that are part+--   of the official protocol, all comparisons between character+--   strings (e.g., labels, domain names, etc.) are done in a+--   case-insensitive manner.\" This function chooses to lowercase+--   its argument, but that should be treated as an implementation+--   detail if at all possible.+--+--   /Examples/:+--+--   >>> let domain1 = BS.pack "ExAmPlE.COM"+--   >>> let domain2 = BS.pack "exAMPle.com"+--   >>> domain1 == domain2+--   False+--   >>> normalizeCase domain1 == normalizeCase domain2+--   True+--+--   The 'normalizeCase' function should be idempotent:+--+--   >>> normalizeCase (normalizeCase domain2) == normalizeCase domain2+--   True+--+--   Ensure that we don't crash on the empty 'Domain':+--+--   >>> import qualified Data.ByteString.Char8 as BS+--   >>> normalizeCase BS.empty+--   ""+--+normalizeCase :: Domain -> Domain+normalizeCase = BS.map toLower+++-- | Normalize the given name by appending a trailing dot (the DNS+--   root) if one does not already exist.+--+--   Warning: this does not produce an equivalent DNS name! However,+--   users are often unaware of the effect that the absence of the+--   root will have. In user interface design, it may therefore be+--   wise to act as if the user supplied the trailing dot during+--   comparisons.+--+--   Per RFC #1034,+--+--   \"Since a complete domain name ends with the root label, this leads+--   to a printed form which ends in a dot. We use this property to+--   distinguish between:+--+--   * a character string which represents a complete domain name+--     (often called \'absolute\'). For example, \'poneria.ISI.EDU.\'+--+--   * a character string that represents the starting labels of a+--     domain name which is incomplete, and should be completed by+--     local software using knowledge of the local domain (often+--     called \'relative\'). For example, \'poneria\' used in the+--     ISI.EDU domain.+--+--   Relative names are either taken relative to a well known origin,+--   or to a list of domains used as a search list. Relative names+--   appear mostly at the user interface, where their interpretation+--   varies from implementation to implementation, and in master+--   files, where they are relative to a single origin domain name.\"+--+--   /Examples/:+--+--   >>> let domain1 = BS.pack "example.com"+--   >>> let domain2 = BS.pack "example.com."+--   >>> domain1 == domain2+--   False+--   >>> normalizeRoot domain1 == normalizeRoot domain2+--   True+--+--   The 'normalizeRoot' function should be idempotent:+--+--   >>> normalizeRoot (normalizeRoot domain1) == normalizeRoot domain1+--   True+--+--   Ensure that we don't crash on the empty 'Domain':+--+--   >>> import qualified Data.ByteString.Char8 as BS+--   >>> normalizeRoot BS.empty+--   "."+--+normalizeRoot :: Domain -> Domain+normalizeRoot d+  | BS.null d = trailing_dot+  | BS.last d == '.' = d+  | otherwise = d `BS.append` trailing_dot+    where+      trailing_dot = BS.pack "."++-- | Split a domain name in A-label form into its initial label and the rest of+-- the domain.  Returns an error if the initial label is malformed.  When no+-- more labels remain, the initial label will satisfy 'BS.null'.+--+-- This also decodes any escaped characters in the initial label, which may+-- therefore contain whitespace, binary data, or unescaped internal dots.  To+-- reconstruct the original domain, the initial label may sometimes require+-- correct escaping of special characters.+--+-- ==== __Examples__+--+-- >>> import Data.ByteString.Char8 as BS+-- >>> splitDomain $ BS.pack "abc\\.def.xyz"+-- Right ("abc.def","xyz")+--+-- >>> splitDomain $ BS.pack ".abc.def.xyz"+-- Left (DecodeError "invalid domain: .abc.def.xyz")+--+splitDomain :: Domain -> Either DNSError (BS.ByteString, Domain)+splitDomain = parseLabel 0x2e++-- | Split a 'Mailbox' in A-label form into its initial label 'BS.ByteString'+-- (the /localpart/ of the email address) and the remaining 'Domain' (the+-- /domainpart/ of the email address, with a possible trailing @'.'@).  Returns+-- an error if the initial label is malformed.  When no more labels remain, the+-- initial label will satisfy 'BS.null'.  The remaining labels can be obtained+-- by applying 'splitDomain' the returned domain part.+--+-- This also decodes any escaped characters in the initial label, which may+-- therefore contain whitespace, binary data, or unescaped internal dots.  To+-- reconstruct the original mailbox, the initial label may sometimes require+-- correct escaping of special characters.+--+-- ==== __Example__+--+-- >>> import Data.ByteString.Char8 as BS+-- >>> splitMailbox $ BS.pack "Joe.Admin@example.com."+-- Right ("Joe.Admin","example.com.")+--+splitMailbox :: Mailbox -> Either DNSError (BS.ByteString, Domain)+splitMailbox = parseLabel 0x40
Setup.hs view
@@ -1,2 +1,4 @@ import Distribution.Simple++main :: IO () main = defaultMain
+ cabal.project view
@@ -0,0 +1,3 @@+packages: .+optimization: True+write-ghc-environment-files: always
+ cbits/dns.c view
@@ -0,0 +1,77 @@+#include <winsock2.h>+#include <iphlpapi.h>+#include <string.h>+#include <windows.h>+#include <string.h>++#define MALLOC(x) HeapAlloc(GetProcessHeap(), 0, (x))+#define FREE(x) HeapFree(GetProcessHeap(), 0, (x))++// Fills `dnsAddresses` with the DNS addresses found, up to `bufferLen`.+// Returns NO_ERROR (0x0) in case the operation succeeds, otherwise a non-zero+// error code. See: https://msdn.microsoft.com/en-us/library/windows/desktop/ms681382(v=vs.85).aspx+DWORD getWindowsDefDnsServers(char* dnsAddresses, size_t bufferLen) {+    FIXED_INFO *pFixedInfo;+    ULONG ulOutBufLen;+    DWORD dwRetVal;++    if (bufferLen <= 0) return ERROR_NOT_ENOUGH_MEMORY;++    pFixedInfo = (FIXED_INFO *) MALLOC(sizeof (FIXED_INFO));+    if (pFixedInfo == NULL)+      return ERROR_NOT_ENOUGH_MEMORY;+    ulOutBufLen = sizeof (FIXED_INFO);++    // Make an initial call to GetAdaptersInfo to get the necessary size into the+    // ulOutBufLen variable+    if (GetNetworkParams(pFixedInfo, &ulOutBufLen) == ERROR_BUFFER_OVERFLOW) {+        FREE(pFixedInfo);+        pFixedInfo = (FIXED_INFO *) MALLOC(ulOutBufLen);+        if (pFixedInfo == NULL)+            return ERROR_NOT_ENOUGH_MEMORY;+    }++    dwRetVal = GetNetworkParams(pFixedInfo, &ulOutBufLen);++    if (dwRetVal == NO_ERROR) {+      int offset = 0;+      int spaceAvailable = bufferLen;+      IP_ADDR_STRING* head = &pFixedInfo->DnsServerList;+      int count = 0;++      while (head != NULL) {+        int ipLen = strlen(head->IpAddress.String);+        int copySize = ipLen + 1;++        spaceAvailable -= copySize;+	if (spaceAvailable >= 0) {+	  // Write the separator.+	  // The string is already terminated due to the call to+	  // strcpy_s, which copies the null terminator.+	  if (count != 0) dnsAddresses[offset - 1] = ',';+	  // Copy the IP address, including the null terminator.+	  strcpy_s(dnsAddresses + offset, copySize, head->IpAddress.String);+	  if (spaceAvailable == 0) break;+	} else+	  break;++        offset += copySize;+	count++;+        head = head->Next;+      }++    }++    if (pFixedInfo) FREE(pFixedInfo);+    return dwRetVal;+}++/*++// Test with 'gcc -o dnsServer -Wall -Werror -pedantic -liphlpapi -Iinclude dns.c' on a+// Windows machine.++int main(){+    printf(getWindowsDefDnsServers()->dnsAddresses);+    return 0;+}*/
dns.cabal view
@@ -1,91 +1,138 @@-Name:                   dns-Version:                0.3.8-Author:                 Kazu Yamamoto <kazu@iij.ad.jp>-Maintainer:             Kazu Yamamoto <kazu@iij.ad.jp>-License:                BSD3-License-File:           LICENSE-Synopsis:               DNS library in Haskell-Description:            DNS library for clients and servers.-Category:               Network-Cabal-Version:          >= 1.10-Build-Type:             Simple+cabal-version:      2.0+name:               dns+version:            4.2.0+license:            BSD3+license-file:       LICENSE+maintainer:         Kazu Yamamoto <kazu@iij.ad.jp>+author:             Kazu Yamamoto <kazu@iij.ad.jp>+tested-with:+    ghc ==8.0.2 ghc ==8.2.2 ghc ==8.4.4 ghc ==8.6.5 ghc ==8.8.1 -Library-  Default-Language:     Haskell2010-  GHC-Options:          -Wall-  Exposed-Modules:      Network.DNS-                        Network.DNS.Lookup-                        Network.DNS.Resolver-                        Network.DNS.Types-                        Network.DNS.Encode-                        Network.DNS.Decode-  Other-Modules:        Network.DNS.Internal-                        Network.DNS.StateBinary-  if impl(ghc >= 7)-    Build-Depends:      base >= 4 && < 5-                      , attoparsec-                      , attoparsec-conduit-                      , binary-                      , blaze-builder-                      , bytestring-                      , conduit >= 0.5-                      , containers-                      , iproute >= 1.2.4-                      , mtl-                      , network >= 2.3-                      , network-conduit-                      , random-  else-    Build-Depends:      base >= 4 && < 5-                      , attoparsec-                      , attoparsec-conduit-                      , binary-                      , blaze-builder-                      , bytestring-                      , conduit-                      , containers-                      , iproute >= 1.2.4-                      , mtl-                      , network-                      , network-bytestring-                      , network-conduit-                      , random+synopsis:           DNS library in Haskell+description:+    A thread-safe DNS library for both clients and servers written+    in pure Haskell. -Test-Suite network-  Type:                 exitcode-stdio-1.0-  Default-Language:     Haskell2010-  Hs-Source-Dirs:       test2-  Ghc-Options:          -Wall-  Main-Is:              Spec.hs-  Other-Modules:        LookupSpec-  Build-Depends:        dns-                      , base-                      , bytestring-                      , hspec+category:           Network+build-type:         Simple+extra-source-files:+    Changelog.md+    cabal.project+    cbits/dns.c -Test-Suite spec-  Type:                 exitcode-stdio-1.0-  Default-Language:     Haskell2010-  Hs-Source-Dirs:       test, .-  Ghc-Options:          -Wall-  Main-Is:              Spec.hs-  Other-Modules:        EncodeSpec-  Build-Depends:        base-                      , attoparsec-                      , attoparsec-conduit-                      , binary-                      , blaze-builder-                      , bytestring-                      , conduit >= 0.5-                      , containers-                      , dns-                      , hspec-                      , iproute >= 1.2.4-                      , mtl-                      , network >= 2.3-                      , network-conduit-                      , random+source-repository head+    type:     git+    location: https://github.com/kazu-yamamoto/dns.git -Source-Repository head-  Type:                 git-  Location:             git://github.com/kazu-yamamoto/dns.git+library+    exposed-modules:+        Network.DNS+        Network.DNS.Lookup+        Network.DNS.LookupRaw+        Network.DNS.Resolver+        Network.DNS.Utils+        Network.DNS.Types+        Network.DNS.Decode+        Network.DNS.Encode+        Network.DNS.IO++    other-modules:    Network.DNS.Transport+    default-language: Haskell2010+    ghc-options:      -Wall+    build-depends:+        dns-internal,+        base >=4 && <5,+        array,+        async,+        attoparsec,+        auto-update,+        base16-bytestring,+        base64-bytestring,+        bytestring,+        containers,+        crypton,+        hourglass,+        iproute >=1.3.2,+        mtl,+        network >=2.3,+        psqueues++library dns-internal+    exposed-modules:+        Network.DNS.Imports+        Network.DNS.Types.Internal+        Network.DNS.Types.Resolver+        Network.DNS.Resolver.Internal+        Network.DNS.Decode.Parsers+        Network.DNS.Decode.Internal+        Network.DNS.Encode.Builders+        Network.DNS.Encode.Internal+        Network.DNS.StateBinary+        Network.DNS.Memo+        Network.DNS.Base32Hex++    hs-source-dirs:   internal+    default-language: Haskell2010+    ghc-options:      -Wall+    build-depends:+        base,+        array,+        async,+        attoparsec,+        auto-update,+        base16-bytestring,+        base64-bytestring,+        bytestring,+        case-insensitive,+        containers,+        crypton,+        hourglass,+        iproute,+        mtl,+        network,+        psqueues++    if os(windows)+        c-sources:       cbits/dns.c+        extra-libraries: iphlpapi++test-suite network-tests+    type:               exitcode-stdio-1.0+    main-is:            Spec.hs+    build-tool-depends: hspec-discover:hspec-discover+    hs-source-dirs:     test2+    other-modules:+        LookupSpec+        IOSpec++    default-language:   Haskell2010+    ghc-options:        -Wall+    build-depends:+        dns,+        dns-internal,+        base,+        hspec,+        network++test-suite spec-tests+    type:               exitcode-stdio-1.0+    main-is:            Spec.hs+    build-tool-depends: hspec-discover:hspec-discover+    hs-source-dirs:     test+    other-modules:+        EncodeSpec+        DecodeSpec+        RoundTripSpec++    default-language:   Haskell2010+    ghc-options:        -Wall+    build-depends:+        dns,+        dns-internal,+        QuickCheck >=2.9,+        base,+        bytestring,+        case-insensitive,+        hspec,+        iproute >=1.3.2,+        word8
+ internal/Network/DNS/Base32Hex.hs view
@@ -0,0 +1,50 @@+module Network.DNS.Base32Hex (encode) where++import qualified Data.Array.MArray as A+import qualified Data.Array.IArray as A+import qualified Data.Array.ST     as A+import qualified Data.ByteString   as B++import Network.DNS.Imports++-- | Encode ByteString using the+-- <https://tools.ietf.org/html/rfc4648#section-7 RFC4648 base32hex>+-- encoding with no padding as specified for the+-- <https://tools.ietf.org/html/rfc5155#section-3.3 RFC5155 Next Hashed Owner Name>+-- field.+--+encode :: B.ByteString -- ^ input buffer+       -> B.ByteString -- ^ base32hex output+encode bs =+    let len = (8 * B.length bs + 4) `div` 5+        ws  = B.unpack bs+     in B.pack $ A.elems $ A.runSTUArray $ do+        a <- A.newArray (0 :: Int, len-1) 0+        go ws a 0+  where+    toHex32 w | w < 10    = 48 + w+              | otherwise = 55 + w++    load8  a i   = A.readArray  a i+    store8 a i v = A.writeArray a i v++    -- Encode a list of 8-bit words at bit offset @n@+    -- into an array 'a' of 5-bit words.+    go [] a _ = A.mapArray toHex32 a+    go (w:ws) a n = do+        -- Split 8 bits into left, middle and right parts.  The+        -- right part only gets written when the 8-bit input word+        -- splits across three different 5-bit words.+        --+        let (q, r) = n `divMod` 5+            wl =  w `shiftR` ( 3 + r)+            wm = (w `shiftL` ( 5 - r))  `shiftR` 3+            wr = (w `shiftL` (10 - r)) `shiftR` 3+        al <- case r of+              0 -> pure wl+              _ -> (wl .|.) <$> load8 a q+        store8 a q al+        store8 a (q + 1) wm+        when (r > 2) $ store8 a (q+2) wr+        go ws a $ n + 8+{-# INLINE encode #-}
+ internal/Network/DNS/Decode/Internal.hs view
@@ -0,0 +1,64 @@+{-# OPTIONS_HADDOCK hide #-}++module Network.DNS.Decode.Internal (+    -- ** Internal message component decoders for tests+    decodeDNSHeader+  , decodeDNSFlags+  , decodeDomain+  , decodeMailbox+  , decodeResourceRecordAt+  , decodeResourceRecord+  ) where++import Network.DNS.Decode.Parsers+import Network.DNS.Imports+import Network.DNS.StateBinary+import Network.DNS.Types.Internal++----------------------------------------------------------------++-- | Decode the 'DNSFlags' field of 'DNSHeader'.  This is an internal function+-- exposed only for testing.+--+decodeDNSFlags :: ByteString -> Either DNSError DNSFlags+decodeDNSFlags bs = fst <$> runSGet getDNSFlags bs++-- | Decode the 'DNSHeader' of a message.  This is an internal function.+-- exposed only for testing.+--+decodeDNSHeader :: ByteString -> Either DNSError DNSHeader+decodeDNSHeader bs = fst <$> runSGet getHeader bs++-- | Decode a domain name.  Since DNS names may use name compression, it is not+-- generally possible to decode the names separately from the enclosing DNS+-- message.  This is an internal function exposed only for testing.+--+decodeDomain :: ByteString -> Either DNSError Domain+decodeDomain bs = fst <$> runSGet getDomain bs++-- | Decode a mailbox name (e.g. the SOA record /rname/ field).  Since DNS names+-- may use name compression, it is not generally possible to decode the names+-- separately from the enclosing DNS message.  This is an internal function.+--+decodeMailbox :: ByteString -> Either DNSError Mailbox+decodeMailbox bs = fst <$> runSGet getMailbox bs++-- | Decoding resource records.++-- | Decode a resource record (RR) with any DNS timestamps interpreted at the+-- nominal epoch time (see 'decodeAt').  Since RRs may use name compression,+-- it is not generally possible to decode resource record separately from the+-- enclosing DNS message.  This is an internal function.+--+decodeResourceRecord :: ByteString -> Either DNSError ResourceRecord+decodeResourceRecord bs = fst <$> runSGet getResourceRecord bs++-- | Decode a resource record (RR) with DNS timestamps interpreted at the+-- supplied epoch time.  Since RRs may use DNS name compression, it is not+-- generally possible to decode resource record separately from the enclosing+-- DNS message.  This is an internal function.+--+decodeResourceRecordAt :: Int64      -- ^ current epoch time+                       -> ByteString -- ^ encoded resource record+                       -> Either DNSError ResourceRecord+decodeResourceRecordAt t bs = fst <$> runSGetAt t getResourceRecord bs
+ internal/Network/DNS/Decode/Parsers.hs view
@@ -0,0 +1,508 @@+{-# LANGUAGE BangPatterns, LambdaCase, OverloadedStrings #-}++module Network.DNS.Decode.Parsers (+    getResponse+  , getDNSFlags+  , getHeader+  , getResourceRecord+  , getResourceRecords+  , getDomain+  , getMailbox+  ) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BS+import qualified Data.CaseInsensitive as CI+import qualified Data.IP+import Data.IP (IP(..), toIPv4, toIPv6b, makeAddrRange)++import Network.DNS.Imports+import Network.DNS.StateBinary+import Network.DNS.Types.Internal++----------------------------------------------------------------++getResponse :: SGet DNSMessage+getResponse = do+    hm <- getHeader+    qdCount <- getInt16+    anCount <- getInt16+    nsCount <- getInt16+    arCount <- getInt16+    queries <- getQueries qdCount+    answers <- getResourceRecords anCount+    authrrs <- getResourceRecords nsCount+    addnrrs <- getResourceRecords arCount+    let (opts, rest) = partition ((==) OPT. rrtype) addnrrs+        flgs         = flags hm+        rc           = fromRCODE $ rcode flgs+        (eh, erc)    = getEDNS rc opts+        hd           = hm { flags = flgs { rcode = erc } }+    pure $ DNSMessage hd eh queries answers authrrs $ ifEDNS eh rest addnrrs++  where++    -- | Get EDNS pseudo-header and the high eight bits of the extended RCODE.+    --+    getEDNS :: Word16 -> AdditionalRecords -> (EDNSheader, RCODE)+    getEDNS rc rrs = case rrs of+        [rr] | Just (edns, erc) <- optEDNS rr+               -> (EDNSheader edns, toRCODE erc)+        []     -> (NoEDNS, toRCODE rc)+        _      -> (InvalidEDNS, BadRCODE)++      where++        -- | Extract EDNS information from an OPT RR.+        --+        optEDNS :: ResourceRecord -> Maybe (EDNS, Word16)+        optEDNS (ResourceRecord "." OPT udpsiz ttl' (RD_OPT opts)) =+            let hrc      = fromIntegral rc .&. 0x0f+                erc      = shiftR (ttl' .&. 0xff000000) 20 .|. hrc+                secok    = ttl' `testBit` 15+                vers     = fromIntegral $ shiftR (ttl' .&. 0x00ff0000) 16+             in Just (EDNS vers udpsiz secok opts, fromIntegral erc)+        optEDNS _ = Nothing++----------------------------------------------------------------++getDNSFlags :: SGet DNSFlags+getDNSFlags = do+    flgs <- get16+    oc <- getOpcode flgs+    return $ DNSFlags (getQorR flgs)+                      oc+                      (getAuthAnswer flgs)+                      (getTrunCation flgs)+                      (getRecDesired flgs)+                      (getRecAvailable flgs)+                      (getRcode flgs)+                      (getAuthenData flgs)+                      (getChkDisable flgs)+  where+    getQorR w = if testBit w 15 then QR_Response else QR_Query+    getOpcode w =+        case shiftR w 11 .&. 0x0f of+            n | Just opc <- toOPCODE n+              -> pure opc+              | otherwise+              -> failSGet $ "Unsupported header opcode: " ++ show n+    getAuthAnswer w = testBit w 10+    getTrunCation w = testBit w 9+    getRecDesired w = testBit w 8+    getRecAvailable w = testBit w 7+    getRcode w = toRCODE $ w .&. 0x0f+    getAuthenData w = testBit w 5+    getChkDisable w = testBit w 4++----------------------------------------------------------------++getHeader :: SGet DNSHeader+getHeader =+    DNSHeader <$> decodeIdentifier <*> getDNSFlags+  where+    decodeIdentifier = get16++----------------------------------------------------------------++getQueries :: Int -> SGet [Question]+getQueries n = replicateM n getQuery++getTYPE :: SGet TYPE+getTYPE = toTYPE <$> get16++-- XXX: Include the class when implemented, or otherwise perhaps check the+-- implicit assumption that the class is classIN.+--+getQuery :: SGet Question+getQuery = Question <$> getDomain+                    <*> getTYPE+                    <*  ignoreClass+  where+    ignoreClass = get16++getResourceRecords :: Int -> SGet [ResourceRecord]+getResourceRecords n = replicateM n getResourceRecord++getResourceRecord :: SGet ResourceRecord+getResourceRecord = do+    dom <- getDomain+    typ <- getTYPE+    cls <- get16+    ttl <- get32+    len <- getInt16+    dat <- fitSGet len $ getRData typ len+    return $ ResourceRecord dom typ cls ttl dat++----------------------------------------------------------------++-- | Helper to find position of RData end, that is, the offset of the first+-- byte /after/ the current RData.+--+rdataEnd :: Int      -- ^ number of bytes left from current position+         -> SGet Int -- ^ end position+rdataEnd !len = (+) len <$> getPosition++getRData :: TYPE -> Int -> SGet RData+getRData NS _    = RD_NS    <$> getDomain+getRData MX _    = RD_MX    <$> get16 <*> getDomain+getRData CNAME _ = RD_CNAME <$> getDomain+getRData DNAME _ = RD_DNAME <$> getDomain+getRData TXT len = RD_TXT   <$> getTXT len+getRData A _     = RD_A . toIPv4 <$> getNBytes 4+getRData AAAA _  = RD_AAAA . toIPv6b <$> getNBytes 16+getRData SOA _   = RD_SOA  <$> getDomain+                           <*> getMailbox+                           <*> decodeSerial+                           <*> decodeRefesh+                           <*> decodeRetry+                           <*> decodeExpire+                           <*> decodeMinimum+  where+    decodeSerial  = get32+    decodeRefesh  = get32+    decodeRetry   = get32+    decodeExpire  = get32+    decodeMinimum = get32+getRData PTR _ = RD_PTR <$> getDomain+getRData SRV _ = RD_SRV <$> decodePriority+                        <*> decodeWeight+                        <*> decodePort+                        <*> getDomain+  where+    decodePriority = get16+    decodeWeight   = get16+    decodePort     = get16+--+getRData RP _   = RD_RP <$> getMailbox+                        <*> getDomain+--+getRData OPT len   = RD_OPT <$> getOpts len+--+getRData TLSA len = RD_TLSA <$> decodeUsage+                            <*> decodeSelector+                            <*> decodeMType+                            <*> decodeADF+  where+    decodeUsage    = get8+    decodeSelector = get8+    decodeMType    = get8+    decodeADF      = getNByteString (len - 3)+--+getRData DS len = RD_DS <$> decodeTag+                        <*> decodeAlg+                        <*> decodeDtyp+                        <*> decodeDval+  where+    decodeTag  = get16+    decodeAlg  = get8+    decodeDtyp = get8+    decodeDval = getNByteString (len - 4)+--+getRData CDS len = RD_CDS <$> decodeTag+                          <*> decodeAlg+                          <*> decodeDtyp+                          <*> decodeDval+  where+    decodeTag  = get16+    decodeAlg  = get8+    decodeDtyp = get8+    decodeDval = getNByteString (len - 4)+--+getRData RRSIG len = RD_RRSIG <$> decodeRRSIG+  where+    decodeRRSIG = do+        -- The signature follows a variable length zone name+        -- and occupies the rest of the RData.  Simplest to+        -- checkpoint the position at the start of the RData,+        -- and after reading the zone name, and subtract that+        -- from the RData length.+        --+        end <- rdataEnd len+        typ <- getTYPE+        alg <- get8+        cnt <- get8+        ttl <- get32+        tex <- getDnsTime+        tin <- getDnsTime+        tag <- get16+        dom <- getDomain -- XXX: Enforce no compression?+        pos <- getPosition+        val <- getNByteString $ end - pos+        return $ RDREP_RRSIG typ alg cnt ttl tex tin tag dom val+    getDnsTime   = do+        tnow <- getAtTime+        tdns <- get32+        return $! dnsTime tdns tnow+--+getRData NULL len = RD_NULL <$> getNByteString len+getRData NSEC len = do+    end <- rdataEnd len+    dom <- getDomain+    pos <- getPosition+    RD_NSEC dom <$> getNsecTypes (end - pos)+--+getRData DNSKEY len = RD_DNSKEY <$> decodeKeyFlags+                                <*> decodeKeyProto+                                <*> decodeKeyAlg+                                <*> decodeKeyBytes+  where+    decodeKeyFlags  = get16+    decodeKeyProto  = get8+    decodeKeyAlg    = get8+    decodeKeyBytes  = getNByteString (len - 4)+--+getRData CDNSKEY len = RD_CDNSKEY <$> decodeKeyFlags+                                  <*> decodeKeyProto+                                  <*> decodeKeyAlg+                                  <*> decodeKeyBytes+  where+    decodeKeyFlags  = get16+    decodeKeyProto  = get8+    decodeKeyAlg    = get8+    decodeKeyBytes  = getNByteString (len - 4)+--+getRData NSEC3 len = do+    dend <- rdataEnd len+    halg <- get8+    flgs <- get8+    iter <- get16+    salt <- getInt8 >>= getNByteString+    hash <- getInt8 >>= getNByteString+    tpos <- getPosition+    RD_NSEC3 halg flgs iter salt hash <$> getNsecTypes (dend - tpos)+--+getRData NSEC3PARAM _ = RD_NSEC3PARAM <$> decodeHashAlg+                                      <*> decodeFlags+                                      <*> decodeIterations+                                      <*> decodeSalt+  where+    decodeHashAlg    = get8+    decodeFlags      = get8+    decodeIterations = get16+    decodeSalt       = getInt8 >>= getNByteString+--+getRData CAA len = do+    dend <- rdataEnd len+    flags <- get8+    tag <- getInt8 >>= getNByteString+    tpos <- getPosition+    RD_CAA flags (CI.mk tag) <$> getNByteString (dend - tpos)+--+getRData _  len = UnknownRData <$> getNByteString len++----------------------------------------------------------------++-- $+--+-- >>> import Network.DNS.StateBinary+-- >>> let Right ((t,_),l) = runSGetWithLeftovers (getTXT 8) "\3foo\3barbaz"+-- >>> (t, l) == ("foobar", "baz")+-- True++-- | Concatenate a sequence of length-prefixed strings of text+-- https://tools.ietf.org/html/rfc1035#section-3.3+--+getTXT :: Int -> SGet ByteString+getTXT !len = B.concat <$> sGetMany "TXT RR string" len getstring+  where+    getstring = getInt8 >>= getNByteString++-- <https://tools.ietf.org/html/rfc6891#section-6.1.2>+-- Parse a list of EDNS options+--+getOpts :: Int -> SGet [OData]+getOpts !len = sGetMany "EDNS option" len getoption+  where+    getoption = do+        code <- toOptCode <$> get16+        olen <- getInt16+        getOData code olen++-- <https://tools.ietf.org/html/rfc4034#section-4.1>+-- Parse a list of NSEC type bitmaps+--+getNsecTypes :: Int -> SGet [TYPE]+getNsecTypes !len = concat <$> sGetMany "NSEC type bitmap" len getbits+  where+    getbits = do+        window <- flip shiftL 8 <$> getInt8+        blocks <- getInt8+        when (blocks > 32) $+            failSGet $ "NSEC bitmap block too long: " ++ show blocks+        concatMap blkTypes. zip [window, window + 8..] <$> getNBytes blocks+      where+        blkTypes (bitOffset, byte) =+            [ toTYPE $ fromIntegral $ bitOffset + i |+              i <- [0..7], byte .&. bit (7-i) /= 0 ]++----------------------------------------------------------------++getOData :: OptCode -> Int -> SGet OData+getOData NSID len = OD_NSID <$> getNByteString len+getOData DAU  len = OD_DAU  <$> getNoctets len+getOData DHU  len = OD_DHU  <$> getNoctets len+getOData N3U  len = OD_N3U  <$> getNoctets len+getOData ClientSubnet len = do+        family  <- get16+        srcBits <- get8+        scpBits <- get8+        addrbs  <- getNByteString (len - 4) -- 4 = 2 + 1 + 1+        --+        -- https://tools.ietf.org/html/rfc7871#section-6+        --+        -- o  ADDRESS, variable number of octets, contains either an IPv4 or+        --    IPv6 address, depending on FAMILY, which MUST be truncated to the+        --    number of bits indicated by the SOURCE PREFIX-LENGTH field,+        --    padding with 0 bits to pad to the end of the last octet needed.+        --+        -- o  A server receiving an ECS option that uses either too few or too+        --    many ADDRESS octets, or that has non-zero ADDRESS bits set beyond+        --    SOURCE PREFIX-LENGTH, SHOULD return FORMERR to reject the packet,+        --    as a signal to the software developer making the request to fix+        --    their implementation.+        --+        -- In order to avoid needless decoding errors, when the ECS encoding+        -- requirements are violated, we construct an OD_ECSgeneric OData,+        -- instread of an IP-specific OD_ClientSubnet OData, which will only+        -- be used for valid inputs.  When the family is neither IPv4(1) nor+        -- IPv6(2), or the address prefix is not correctly encoded (too long+        -- or too short), the OD_ECSgeneric data contains the verbatim input+        -- from the peer.+        --+        case BS.length addrbs == (fromIntegral srcBits + 7) `div` 8 of+            True | Just ip <- bstoip family addrbs srcBits scpBits+                -> pure $ OD_ClientSubnet srcBits scpBits ip+            _   -> pure $ OD_ECSgeneric family srcBits scpBits addrbs+  where+    prefix addr bits = Data.IP.addr $ makeAddrRange addr $ fromIntegral bits+    zeropad = (++ repeat 0). map fromIntegral. B.unpack+    checkBits fromBytes toIP srcBits scpBits bytes =+        let addr       = fromBytes bytes+            maskedAddr = prefix addr srcBits+            maxBits    = fromIntegral $ 8 * length bytes+         in if addr == maskedAddr && scpBits <= maxBits+            then Just $ toIP addr+            else Nothing+    bstoip :: Word16 -> B.ByteString -> Word8 -> Word8 -> Maybe IP+    bstoip family bs srcBits scpBits = case family of+        1 -> checkBits toIPv4  IPv4 srcBits scpBits $ take 4  $ zeropad bs+        2 -> checkBits toIPv6b IPv6 srcBits scpBits $ take 16 $ zeropad bs+        _ -> Nothing+getOData opc len = UnknownOData (fromOptCode opc) <$> getNByteString len++----------------------------------------------------------------++-- | Pointers MUST point back into the packet per RFC1035 Section 4.1.4.  This+-- is further interpreted by the DNS community (from a discussion on the IETF+-- DNSOP mailing list) to mean that they don't point back into the same domain.+-- Therefore, when starting to parse a domain, the current offset is also a+-- strict upper bound on the targets of any pointers that arise while processing+-- the domain.  When following a pointer, the target again becomes a stict upper+-- bound for any subsequent pointers.  This results in a simple loop-prevention+-- algorithm, each sequence of valid pointer values is necessarily strictly+-- decreasing!  The third argument to 'getDomain'' is a strict pointer upper+-- bound, and is set here to the position at the start of parsing the domain+-- or mailbox.+--+-- Note: the separator passed to 'getDomain'' is required to be either \'.\' or+-- \'\@\', or else 'unparseLabel' needs to be modified to handle the new value.+--++getDomain :: SGet Domain+getDomain = getPosition >>= getDomain' dot++getMailbox :: SGet Mailbox+getMailbox = getPosition >>= getDomain' atsign++dot, atsign :: Word8+dot    = fromIntegral $ fromEnum '.' -- 46+atsign = fromIntegral $ fromEnum '@' -- 64++-- $+-- Pathological case: pointer embedded inside a label!  The pointer points+-- behind the start of the domain and is then absorbed into the initial label!+-- Though we don't IMHO have to support this, it is not manifestly illegal, and+-- does exercise the code in an interesting way.  Ugly as this is, it also+-- "works" the same in Perl's Net::DNS and reportedly in ISC's BIND.+--+-- >>> :{+-- let input = "\6\3foo\192\0\3bar\0"+--     parser = skipNBytes 1 >> getDomain' dot 1+--     Right (output, _) = runSGet parser input+--  in output == "foo.\\003foo\\192\\000.bar."+-- :}+-- True+--+-- The case below fails to point far enough back, and triggers the loop+-- prevention code-path.+--+-- >>> :{+-- let input = "\6\3foo\192\1\3bar\0"+--     parser = skipNBytes 1 >> getDomain' dot 1+--     Left (DecodeError err) = runSGet parser input+--  in err+-- :}+-- "invalid name compression pointer"++-- | Get a domain name, using sep1 as the separator between the 1st and 2nd+-- label.  Subsequent labels (and always the trailing label) are terminated+-- with a ".".+--+-- Note: the separator is required to be either \'.\' or \'\@\', or else+-- 'unparseLabel' needs to be modified to handle the new value.+--+-- Domain name compression pointers must always refer to a position that+-- precedes the start of the current domain name.  The starting offsets form a+-- strictly decreasing sequence, which prevents pointer loops.+--+getDomain' :: Word8 -> Int -> SGet ByteString+getDomain' sep1 ptrLimit = do+    pos <- getPosition+    c <- getInt8+    let n = getValue c+    getdomain pos c n+  where+    -- Reprocess the same ByteString starting at the pointer+    -- target (offset).+    getPtr pos offset = do+        msg <- getInput+        let parser = skipNBytes offset >> getDomain' sep1 offset+        case runSGet parser msg of+            Left (DecodeError err) -> failSGet err+            Left err               -> fail $ show err+            Right o                -> do+                -- Cache only the presentation form decoding of domain names,+                -- mailboxes (e.g. SOA rname) are less frequently reused, and+                -- have a different presentation form, so must not share the+                -- same cache.+                when (sep1 == dot) $+                    push pos (fst o)+                return (fst o)++    getdomain pos c n+      | c == 0 = return "." -- Perhaps the root domain?+      | isPointer c = do+          d <- getInt8+          let offset = n * 256 + d+          when (offset >= ptrLimit) $+              failSGet "invalid name compression pointer"+          if sep1 /= dot+              then getPtr pos offset+              else pop offset >>= \case+                  Nothing -> getPtr pos offset+                  Just o  -> return o+      -- As for now, extended labels have no use.+      -- This may change some time in the future.+      | isExtLabel c = return ""+      | otherwise = do+          hs <- unparseLabel sep1 <$> getNByteString n+          ds <- getDomain' dot ptrLimit+          let dom = case ds of -- avoid trailing ".."+                  "." -> hs <> "."+                  _   -> hs <> B.singleton sep1 <> ds+          push pos dom+          return dom+    getValue c = c .&. 0x3f+    isPointer c = testBit c 7 && testBit c 6+    isExtLabel c = not (testBit c 7) && testBit c 6
+ internal/Network/DNS/Encode/Builders.hs view
@@ -0,0 +1,361 @@+{-# LANGUAGE+    BangPatterns+  , RecordWildCards+  , TransformListComp+  #-}++-- | DNS Message builder.+module Network.DNS.Encode.Builders (+    putDNSMessage+  , putDNSFlags+  , putHeader+  , putDomain+  , putMailbox+  , putResourceRecord+  ) where++import Control.Monad.State (State, modify, execState, gets)+import qualified Control.Exception as E+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy.Char8 as LBS+import qualified Data.CaseInsensitive as CI+import qualified Data.IP+import Data.IP (IP(..), fromIPv4, fromIPv6b, makeAddrRange)+import GHC.Exts (the, groupWith)++import Network.DNS.Imports+import Network.DNS.StateBinary+import Network.DNS.Types.Internal++----------------------------------------------------------------++putDNSMessage :: DNSMessage -> SPut+putDNSMessage msg = putHeader hd+                    <> putNums+                    <> mconcat (map putQuestion qs)+                    <> mconcat (map putResourceRecord an)+                    <> mconcat (map putResourceRecord au)+                    <> mconcat (map putResourceRecord ad)+  where+    putNums = mconcat $ fmap putInt16 [ length qs+                                      , length an+                                      , length au+                                      , length ad+                                      ]+    hm = header msg+    fl = flags hm+    eh = ednsHeader msg+    qs = question msg+    an = answer msg+    au = authority msg+    hd = ifEDNS eh hm $ hm { flags = fl { rcode = rc } }+    rc = ifEDNS eh <$> id <*> nonEDNSrcode $ rcode fl+      where+        nonEDNSrcode code | fromRCODE code < 16 = code+                          | otherwise           = FormatErr+    ad = prependOpt $ additional msg+      where+        prependOpt ads = mapEDNS eh (fromEDNS ads $ fromRCODE rc) ads+          where+            fromEDNS :: AdditionalRecords -> Word16 -> EDNS -> AdditionalRecords+            fromEDNS rrs rc' edns = ResourceRecord name' type' class' ttl' rdata' : rrs+              where+                name'  = BS.singleton '.'+                type'  = OPT+                class' = maxUdpSize `min` (minUdpSize `max` ednsUdpSize edns)+                ttl0'  = fromIntegral (rc' .&. 0xff0) `shiftL` 20+                vers'  = fromIntegral (ednsVersion edns) `shiftL` 16+                ttl'+                  | ednsDnssecOk edns = ttl0' `setBit` 15 .|. vers'+                  | otherwise         = ttl0' .|. vers'+                rdata' = RD_OPT $ ednsOptions edns++putHeader :: DNSHeader -> SPut+putHeader hdr = putIdentifier (identifier hdr)+                <> putDNSFlags (flags hdr)+  where+    putIdentifier = put16++putDNSFlags :: DNSFlags -> SPut+putDNSFlags DNSFlags{..} = put16 word+  where+    set :: Word16 -> State Word16 ()+    set byte = modify (.|. byte)++    st :: State Word16 ()+    st = sequence_+              [ set (fromRCODE rcode .&. 0x0f)+              , when chkDisable          $ set (bit 4)+              , when authenData          $ set (bit 5)+              , when recAvailable        $ set (bit 7)+              , when recDesired          $ set (bit 8)+              , when trunCation          $ set (bit 9)+              , when authAnswer          $ set (bit 10)+              , set (fromOPCODE opcode `shiftL` 11)+              , when (qOrR==QR_Response) $ set (bit 15)+              ]++    word = execState st 0++-- XXX: Use question class when implemented+--+putQuestion :: Question -> SPut+putQuestion Question{..} = putDomain qname+                           <> put16 (fromTYPE qtype)+                           <> put16 classIN++putResourceRecord :: ResourceRecord -> SPut+putResourceRecord ResourceRecord{..} = mconcat [+    putDomain rrname+  , put16 (fromTYPE rrtype)+  , put16 rrclass+  , put32 rrttl+  , putResourceRData rdata+  ]+  where+    putResourceRData :: RData -> SPut+    putResourceRData rd = do+        addPositionW 2 -- "simulate" putInt16+        rDataBuilder <- putRData rd+        let rdataLength = fromIntegral . LBS.length . BB.toLazyByteString $ rDataBuilder+        let rlenBuilder = BB.int16BE rdataLength+        return $ rlenBuilder <> rDataBuilder+++putRData :: RData -> SPut+putRData rd = case rd of+    RD_A                 address -> mconcat $ map putInt8 (fromIPv4 address)+    RD_NS                nsdname -> putDomain nsdname+    RD_CNAME               cname -> putDomain cname+    RD_SOA         a b c d e f g -> putSOA a b c d e f g+    RD_NULL                bytes -> putByteString bytes+    RD_PTR              ptrdname -> putDomain ptrdname+    RD_MX              pref exch -> mconcat [put16 pref, putDomain exch]+    RD_TXT            textstring -> putTXT textstring+    RD_RP             mbox dname -> putMailbox mbox <> putDomain dname+    RD_AAAA              address -> mconcat $ map putInt8 (fromIPv6b address)+    RD_SRV       pri wei prt tgt -> putSRV pri wei prt tgt+    RD_DNAME               dname -> putDomain dname+    RD_OPT               options -> mconcat $ fmap putOData options+    RD_DS             kt ka dt d -> putDS kt ka dt d+    RD_CDS            kt ka dt d -> putDS kt ka dt d+    RD_RRSIG               rrsig -> putRRSIG rrsig+    RD_NSEC           next types -> putDomain next <> putNsecTypes types+    RD_DNSKEY        f p alg key -> putDNSKEY f p alg key+    RD_CDNSKEY       f p alg key -> putDNSKEY f p alg key+    RD_NSEC3     a f i s h types -> putNSEC3 a f i s h types+    RD_NSEC3PARAM  a f iter salt -> putNSEC3PARAM a f iter salt+    RD_TLSA           u s m dgst -> putTLSA u s m dgst+    RD_CAA                 f t v -> putCAA f t v+    UnknownRData           bytes -> putByteString bytes+  where+    putSOA mn mr serial refresh retry expire minttl = mconcat+        [ putDomain mn+        , putMailbox mr+        , put32 serial+        , put32 refresh+        , put32 retry+        , put32 expire+        , put32 minttl+        ]+    -- TXT record string fragments are at most 255 bytes+    putTXT textstring =+        let (!h, !t) = BS.splitAt 255 textstring+         in putByteStringWithLength h <> if BS.null t+                then mempty+                else putTXT t+    putSRV priority weight port target = mconcat+        [ put16 priority+        , put16 weight+        , put16 port+        , putDomain target+        ]+    putDS keytag keyalg digestType digest = mconcat+        [ put16 keytag+        , put8 keyalg+        , put8 digestType+        , putByteString digest+        ]+    putRRSIG RDREP_RRSIG{..} = mconcat+        [ put16 $ fromTYPE rrsigType+        , put8 rrsigKeyAlg+        , put8 rrsigNumLabels+        , put32 rrsigTTL+        , put32 $ fromIntegral rrsigExpiration+        , put32 $ fromIntegral rrsigInception+        , put16 rrsigKeyTag+        , putDomain rrsigZone+        , putByteString rrsigValue+        ]+    putDNSKEY flags protocol alg key = mconcat+        [ put16 flags+        , put8 protocol+        , put8 alg+        , putByteString key+        ]+    putNSEC3 alg flags iterations salt hash types = mconcat+        [ put8 alg+        , put8 flags+        , put16 iterations+        , putByteStringWithLength salt+        , putByteStringWithLength hash+        , putNsecTypes types+        ]+    putNSEC3PARAM alg flags iterations salt = mconcat+        [ put8 alg+        , put8 flags+        , put16 iterations+        , putByteStringWithLength salt+        ]+    putTLSA usage selector mtype assocData = mconcat+        [ put8 usage+        , put8 selector+        , put8 mtype+        , putByteString assocData+        ]+    putCAA flags tag value = mconcat+        [ put8 flags+        , putByteStringWithLength (CI.original tag)+        , putByteString value+        ]++-- | Encode DNSSEC NSEC type bits+putNsecTypes :: [TYPE] -> SPut+putNsecTypes types = putTypeList $ map fromTYPE types+  where+    putTypeList :: [Word16] -> SPut+    putTypeList ts =+        mconcat [ putWindow (the top8) bot8 |+                  t <- ts,+                  let top8 = fromIntegral t `shiftR` 8,+                  let bot8 = fromIntegral t .&. 0xff,+                  then group by top8+                       using groupWith ]++    putWindow :: Int -> [Int] -> SPut+    putWindow top8 bot8s =+        let blks = maximum bot8s `shiftR` 3+         in putInt8 top8+            <> put8 (1 + fromIntegral blks)+            <> putBits 0 [ (the block, foldl' mergeBits 0 bot8) |+                           bot8 <- bot8s,+                           let block = bot8 `shiftR` 3,+                           then group by block+                                using groupWith ]+      where+        -- | Combine type bits in network bit order, i.e. bit 0 first.+        mergeBits acc b = setBit acc (7 - b.&.0x07)++    putBits :: Int -> [(Int, Word8)] -> SPut+    putBits _ [] = pure mempty+    putBits n ((block, octet) : rest) =+        putReplicate (block-n) 0+        <> put8 octet+        <> putBits (block + 1) rest++-- | Encode EDNS OPTION consisting of a list of octets.+putODWords :: Word16 -> [Word8] -> SPut+putODWords code ws =+     mconcat [ put16 code+             , putInt16 $ length ws+             , mconcat $ map put8 ws+             ]++-- | Encode an EDNS OPTION byte string.+putODBytes :: Word16 -> ByteString -> SPut+putODBytes code bs =+    mconcat [ put16 code+            , putInt16 $ BS.length bs+            , putByteString bs+            ]++putOData :: OData -> SPut+putOData (OD_NSID nsid) = putODBytes (fromOptCode NSID) nsid+putOData (OD_DAU as) = putODWords (fromOptCode DAU) as+putOData (OD_DHU hs) = putODWords (fromOptCode DHU) hs+putOData (OD_N3U hs) = putODWords (fromOptCode N3U) hs+putOData (OD_ClientSubnet srcBits scpBits ip) =+    -- https://tools.ietf.org/html/rfc7871#section-6+    --+    -- o  ADDRESS, variable number of octets, contains either an IPv4 or+    --    IPv6 address, depending on FAMILY, which MUST be truncated to the+    --    number of bits indicated by the SOURCE PREFIX-LENGTH field,+    --    padding with 0 bits to pad to the end of the last octet needed.+    --+    -- o  A server receiving an ECS option that uses either too few or too+    --    many ADDRESS octets, or that has non-zero ADDRESS bits set beyond+    --    SOURCE PREFIX-LENGTH, SHOULD return FORMERR to reject the packet,+    --    as a signal to the software developer making the request to fix+    --    their implementation.+    --+    let octets = fromIntegral $ (srcBits + 7) `div` 8+        prefix addr = Data.IP.addr $ makeAddrRange addr $ fromIntegral srcBits+        (family, raw) = case ip of+                        IPv4 ip4 -> (1, take octets $ fromIPv4  $ prefix ip4)+                        IPv6 ip6 -> (2, take octets $ fromIPv6b $ prefix ip6)+        dataLen = 2 + 2 + octets+     in mconcat [ put16 $ fromOptCode ClientSubnet+                , putInt16 dataLen+                , put16 family+                , put8 srcBits+                , put8 scpBits+                , mconcat $ fmap putInt8 raw+                ]+putOData (OD_ECSgeneric family srcBits scpBits addr) =+    mconcat [ put16 $ fromOptCode ClientSubnet+            , putInt16 $ 4 + BS.length addr+            , put16 family+            , put8 srcBits+            , put8 scpBits+            , putByteString addr+            ]+putOData (UnknownOData code bs) = putODBytes code bs++-- In the case of the TXT record, we need to put the string length+-- fixme : What happens with the length > 256 ?+putByteStringWithLength :: BS.ByteString -> SPut+putByteStringWithLength bs = putInt8 (fromIntegral $ BS.length bs) -- put the length of the given string+                          <> putByteString bs++----------------------------------------------------------------++rootDomain :: Domain+rootDomain = BS.pack "."++putDomain :: Domain -> SPut+putDomain = putDomain' '.'++putMailbox :: Mailbox -> SPut+putMailbox = putDomain' '@'++putDomain' :: Char -> ByteString -> SPut+putDomain' sep dom+    | BS.null dom || dom == rootDomain = put8 0+    | otherwise = do+        mpos <- wsPop dom+        cur <- gets wsPosition+        case mpos of+            Just pos -> putPointer pos+            Nothing  -> do+                        -- Pointers are limited to 14-bits!+                        when (cur <= 0x3fff) $ wsPush dom cur+                        mconcat [ putPartialDomain hd+                                , putDomain' '.' tl+                                ]+  where+    -- Try with the preferred separator if present, else fall back to '.'.+    (hd, tl) = loop (c2w sep)+      where+        loop w = case parseLabel w dom of+            Right p | w /= 0x2e && BS.null (snd p) -> loop 0x2e+                    | otherwise -> p+            Left e -> E.throw e++    c2w = fromIntegral . fromEnum++putPointer :: Int -> SPut+putPointer pos = putInt16 (pos .|. 0xc000)++putPartialDomain :: Domain -> SPut+putPartialDomain = putByteStringWithLength
+ internal/Network/DNS/Encode/Internal.hs view
@@ -0,0 +1,38 @@+{-# OPTIONS_HADDOCK hide #-}++-- | Internal DNS message component encoders for the test-suite.+module Network.DNS.Encode.Internal (+    encodeDNSHeader+  , encodeDNSFlags+  , encodeDomain+  , encodeMailbox+  , encodeResourceRecord+  ) where++import Network.DNS.Encode.Builders+import Network.DNS.Imports+import Network.DNS.StateBinary+import Network.DNS.Types.Internal++-- | Encode DNS flags.+encodeDNSFlags :: DNSFlags -> ByteString+encodeDNSFlags = runSPut . putDNSFlags++-- | Encode DNS header.+encodeDNSHeader :: DNSHeader -> ByteString+encodeDNSHeader = runSPut . putHeader++-- | Encode a domain.+encodeDomain :: Domain -> ByteString+encodeDomain = runSPut . putDomain++-- | Encode a mailbox name.  The first label is separated from the remaining+-- labels by an @'\@'@ rather than a @.@.  This is used for the contact+-- address in the @SOA@ and @RP@ records.+--+encodeMailbox :: Mailbox -> ByteString+encodeMailbox = runSPut . putMailbox++-- | Encode a ResourceRecord.+encodeResourceRecord :: ResourceRecord -> ByteString+encodeResourceRecord rr = runSPut $ putResourceRecord rr
+ internal/Network/DNS/Imports.hs view
@@ -0,0 +1,31 @@+module Network.DNS.Imports (+    ByteString+  , Int64+  , NonEmpty(..)+  , module Control.Applicative+  , module Control.Monad+  , module Data.Bits+  , module Data.Function+  , module Data.List+  , module Data.Maybe+  , module Data.Monoid+  , module Data.Ord+  , module Data.Typeable+  , module Data.Word+  , module Numeric+  ) where++import Control.Applicative+import Control.Monad+import Data.Bits+import Data.ByteString (ByteString)+import Data.Function+import Data.Int (Int64)+import Data.List+import Data.List.NonEmpty (NonEmpty(..))+import Data.Maybe+import Data.Monoid+import Data.Ord+import Data.Typeable+import Data.Word+import Numeric
+ internal/Network/DNS/Memo.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE RecordWildCards #-}++module Network.DNS.Memo where++import qualified Control.Reaper as R+import qualified Data.ByteString as B+import qualified Data.CaseInsensitive as CI+import Data.Hourglass (Elapsed)+import Data.OrdPSQ (OrdPSQ)+import qualified Data.OrdPSQ as PSQ+import Time.System (timeCurrent)++import Network.DNS.Imports+import Network.DNS.Types.Internal++data Section = Answer | Authority deriving (Eq, Ord, Show)++type Key = (ByteString+           ,TYPE)+type Prio = Elapsed++type Entry = Either DNSError [RData]++type DB = OrdPSQ Key Prio Entry++type Cache = R.Reaper DB (Key,Prio,Entry)++newCache :: Int -> IO Cache+newCache delay = R.mkReaper R.defaultReaperSettings {+    R.reaperEmpty  = PSQ.empty+  , R.reaperCons   = \(k, tim, v) psq -> PSQ.insert k tim v psq+  , R.reaperAction = prune+  , R.reaperDelay  = delay * 1000000+  , R.reaperNull   = PSQ.null+  }++lookupCache :: Key -> Cache -> IO (Maybe (Prio, Entry))+lookupCache key reaper = PSQ.lookup key <$> R.reaperRead reaper++insertCache :: Key -> Prio -> Entry -> Cache -> IO ()+insertCache (dom,typ) tim ent0 reaper = R.reaperAdd reaper (key,tim,ent)+  where+    key = (B.copy dom,typ)+    ent = case ent0 of+      l@(Left _)  -> l+      (Right rds) -> Right $ map copy rds++-- Theoretically speaking, atMostView itself is good enough for pruning.+-- But auto-update assumes a list based db which does not provide atMost+-- functions. So, we need to do this redundant way.+prune :: DB -> IO (DB -> DB)+prune oldpsq = do+    tim <- timeCurrent+    let (_, pruned) = PSQ.atMostView tim oldpsq+    return $ \newpsq -> foldl' ins pruned $ PSQ.toList newpsq+  where+    ins psq (k,p,v) = PSQ.insert k p v psq++copy :: RData -> RData+copy r@(RD_A _)           = r+copy (RD_NS dom)          = RD_NS $ B.copy dom+copy (RD_CNAME dom)       = RD_CNAME $ B.copy dom+copy (RD_SOA mn mr a b c d e) = RD_SOA (B.copy mn) (B.copy mr) a b c d e+copy (RD_PTR dom)         = RD_PTR $ B.copy dom+copy (RD_NULL bytes)      = RD_NULL $ B.copy bytes+copy (RD_MX prf dom)      = RD_MX prf $ B.copy dom+copy (RD_TXT txt)         = RD_TXT $ B.copy txt+copy (RD_RP mbox dname)   = RD_RP (B.copy mbox) (B.copy dname)+copy r@(RD_AAAA _)        = r+copy (RD_SRV a b c dom)   = RD_SRV a b c $ B.copy dom+copy (RD_DNAME dom)       = RD_DNAME $ B.copy dom+copy (RD_OPT od)          = RD_OPT $ map copyOData od+copy (RD_DS t a dt dv)    = RD_DS t a dt $ B.copy dv+copy (RD_CDS t a dt dv)   = RD_CDS t a dt $ B.copy dv+copy (RD_NSEC dom ts)     = RD_NSEC (B.copy dom) ts+copy (RD_DNSKEY f p a k)  = RD_DNSKEY f p a $ B.copy k+copy (RD_CDNSKEY f p a k) = RD_CDNSKEY f p a $ B.copy k+copy (RD_TLSA a b c dgst) = RD_TLSA a b c $ B.copy dgst+copy (RD_NSEC3 a b c s h t) = RD_NSEC3 a b c (B.copy s) (B.copy h) t+copy (RD_NSEC3PARAM a b c salt) = RD_NSEC3PARAM a b c $ B.copy salt+copy (RD_RRSIG sig)       = RD_RRSIG $ copysig sig+  where+    copysig s@RDREP_RRSIG{..} =+        s { rrsigZone = B.copy rrsigZone+          , rrsigValue = B.copy rrsigValue }+copy (RD_CAA f t v)       = RD_CAA f (CI.mk (B.copy (CI.original t))) (B.copy v)+copy (UnknownRData is)    = UnknownRData $ B.copy is++copyOData :: OData -> OData+copyOData (OD_ECSgeneric family srcBits scpBits bs) =+    OD_ECSgeneric family srcBits scpBits $ B.copy bs+copyOData (OD_NSID nsid) = OD_NSID $ B.copy nsid+copyOData (UnknownOData c b)        = UnknownOData c $ B.copy b++-- No copying required for the rest, but avoiding a wildcard pattern match+-- so that if more option types are added in the future, the compiler will+-- complain about a partial function.+--+copyOData o@OD_ClientSubnet {} = o+copyOData o@OD_DAU {} = o+copyOData o@OD_DHU {} = o+copyOData o@OD_N3U {} = o
+ internal/Network/DNS/Resolver/Internal.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE CPP #-}++module Network.DNS.Resolver.Internal (+      getDefaultDnsServers+    ) where++import Network.DNS.Imports++#if !defined(mingw32_HOST_OS)+#define POSIX+#else+#define WIN+#endif++#if defined(WIN)+import Foreign.C.String+import Foreign.Marshal.Alloc (allocaBytes)+#else+import Data.Char (isSpace)+#endif++getDefaultDnsServers :: FilePath -> IO [String]++#if defined(WIN)++foreign import ccall "getWindowsDefDnsServers" getWindowsDefDnsServers :: CString -> Int -> IO Word32++getDefaultDnsServers _ = do+  allocaBytes 256 $ \cString -> do+     res <- getWindowsDefDnsServers cString 256+     case res of+       0 -> split ',' <$> peekCString cString+       _ -> return [] -- TODO: Do proper error handling here.+  where+    split :: Char -> String -> [String]+    split c cs =+        let (h, t) = dropWhile (== c) <$> break (== c) cs+         in if null t+            then if null h then [] else [h]+            else if null h+            then split c t+            else h : split c t++#else++getDefaultDnsServers file = toAddresses <$> readFile file+  where+    toAddresses :: String -> [String]+    toAddresses cs = map extract (filter ("nameserver" `isPrefixOf`) (lines cs))+    extract = reverse . dropWhile isSpace . reverse . dropWhile isSpace . drop 11++#endif
+ internal/Network/DNS/StateBinary.hs view
@@ -0,0 +1,441 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+module Network.DNS.StateBinary (+    PState(..)+  , initialState+  , SPut+  , runSPut+  , put8+  , put16+  , put32+  , putInt8+  , putInt16+  , putInt32+  , putByteString+  , putReplicate+  , SGet+  , failSGet+  , fitSGet+  , runSGet+  , runSGetAt+  , runSGetWithLeftovers+  , runSGetWithLeftoversAt+  , get8+  , get16+  , get32+  , getInt8+  , getInt16+  , getInt32+  , getNByteString+  , sGetMany+  , getPosition+  , getInput+  , getAtTime+  , wsPop+  , wsPush+  , wsPosition+  , addPositionW+  , push+  , pop+  , getNBytes+  , getNoctets+  , skipNBytes+  , parseLabel+  , unparseLabel+  ) where++import qualified Control.Exception as E+import Control.Monad.State.Strict (State, StateT)+import qualified Control.Monad.State.Strict as ST+import qualified Data.Attoparsec.ByteString as A+import qualified Data.Attoparsec.Types as T+import qualified Data.ByteString as BS+import Data.ByteString.Builder (Builder)+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.Lazy as LB+import qualified Data.ByteString.Lazy.Char8 as LBS+import Data.IntMap (IntMap)+import qualified Data.IntMap as IM+import Data.Map (Map)+import qualified Data.Map as M+import Data.Semigroup as Sem++import Network.DNS.Imports+import Network.DNS.Types.Internal++----------------------------------------------------------------++type SPut = State WState Builder++data WState = WState {+    wsDomain :: Map Domain Int+  , wsPosition :: Int+}++initialWState :: WState+initialWState = WState M.empty 0++instance Sem.Semigroup SPut where+    p1 <> p2 = (Sem.<>) <$> p1 <*> p2++instance Monoid SPut where+    mempty = return mempty+#if !(MIN_VERSION_base(4,11,0))+    mappend = (Sem.<>)+#endif++put8 :: Word8 -> SPut+put8 = fixedSized 1 BB.word8++put16 :: Word16 -> SPut+put16 = fixedSized 2 BB.word16BE++put32 :: Word32 -> SPut+put32 = fixedSized 4 BB.word32BE++putInt8 :: Int -> SPut+putInt8 = fixedSized 1 (BB.int8 . fromIntegral)++putInt16 :: Int -> SPut+putInt16 = fixedSized 2 (BB.int16BE . fromIntegral)++putInt32 :: Int -> SPut+putInt32 = fixedSized 4 (BB.int32BE . fromIntegral)++putByteString :: ByteString -> SPut+putByteString = writeSized BS.length BB.byteString++putReplicate :: Int -> Word8 -> SPut+putReplicate n w =+    fixedSized n BB.lazyByteString $ LB.replicate (fromIntegral n) w++addPositionW :: Int -> State WState ()+addPositionW n = do+    (WState m cur) <- ST.get+    ST.put $ WState m (cur+n)++fixedSized :: Int -> (a -> Builder) -> a -> SPut+fixedSized n f a = do addPositionW n+                      return (f a)++writeSized :: (a -> Int) -> (a -> Builder) -> a -> SPut+writeSized n f a = do addPositionW (n a)+                      return (f a)++wsPop :: Domain -> State WState (Maybe Int)+wsPop dom = do+    doms <- ST.gets wsDomain+    return $ M.lookup dom doms++wsPush :: Domain -> Int -> State WState ()+wsPush dom pos = do+    (WState m cur) <- ST.get+    ST.put $ WState (M.insert dom pos m) cur++----------------------------------------------------------------++type SGet = StateT PState (T.Parser ByteString)++data PState = PState {+    psDomain :: IntMap Domain+  , psPosition :: Int+  , psInput :: ByteString+  , psAtTime  :: Int64+  }++----------------------------------------------------------------++getPosition :: SGet Int+getPosition = ST.gets psPosition++getInput :: SGet ByteString+getInput = ST.gets psInput++getAtTime :: SGet Int64+getAtTime = ST.gets psAtTime++addPosition :: Int -> SGet ()+addPosition n | n < 0 = failSGet "internal error: negative position increment"+              | otherwise = do+    PState dom pos inp t <- ST.get+    let !pos' = pos + n+    when (pos' > BS.length inp) $+        failSGet "malformed or truncated input"+    ST.put $ PState dom pos' inp t++push :: Int -> Domain -> SGet ()+push n d = do+    PState dom pos inp t <- ST.get+    ST.put $ PState (IM.insert n d dom) pos inp t++pop :: Int -> SGet (Maybe Domain)+pop n = ST.gets (IM.lookup n . psDomain)++----------------------------------------------------------------++get8 :: SGet Word8+get8  = ST.lift A.anyWord8 <* addPosition 1++get16 :: SGet Word16+get16 = ST.lift getWord16be <* addPosition 2+  where+    word8' = fromIntegral <$> A.anyWord8+    getWord16be = do+        a <- word8'+        b <- word8'+        return $ a * 0x100 + b++get32 :: SGet Word32+get32 = ST.lift getWord32be <* addPosition 4+  where+    word8' = fromIntegral <$> A.anyWord8+    getWord32be = do+        a <- word8'+        b <- word8'+        c <- word8'+        d <- word8'+        return $ a * 0x1000000 + b * 0x10000 + c * 0x100 + d++getInt8 :: SGet Int+getInt8 = fromIntegral <$> get8++getInt16 :: SGet Int+getInt16 = fromIntegral <$> get16++getInt32 :: SGet Int+getInt32 = fromIntegral <$> get32++----------------------------------------------------------------++overrun :: SGet a+overrun = failSGet "malformed or truncated input"++getNBytes :: Int -> SGet [Int]+getNBytes n | n < 0     = overrun+            | otherwise = toInts <$> getNByteString n+  where+    toInts = map fromIntegral . BS.unpack++getNoctets :: Int -> SGet [Word8]+getNoctets n | n < 0     = overrun+             | otherwise = BS.unpack <$> getNByteString n++skipNBytes :: Int -> SGet ()+skipNBytes n | n < 0     = overrun+             | otherwise = ST.lift (A.take n) >> addPosition n++getNByteString :: Int -> SGet ByteString+getNByteString n | n < 0     = overrun+                 | otherwise = ST.lift (A.take n) <* addPosition n++fitSGet :: Int -> SGet a -> SGet a+fitSGet len parser | len < 0   = overrun+                   | otherwise = do+    pos0 <- getPosition+    ret <- parser+    pos' <- getPosition+    if pos' == pos0 + len+    then return $! ret+    else if pos' > pos0 + len+    then failSGet "element size exceeds declared size"+    else failSGet "element shorter than declared size"++-- | Parse a list of elements that takes up exactly a given number of bytes.+-- In order to avoid infinite loops, if an element parser succeeds without+-- moving the buffer offset forward, an error will be returned.+--+sGetMany :: String -- ^ element type for error messages+         -> Int    -- ^ input buffer length+         -> SGet a -- ^ element parser+         -> SGet [a]+sGetMany elemname len parser | len < 0   = overrun+                             | otherwise = go len []+  where+    go n xs+        | n < 0     = failSGet $ elemname ++ " longer than declared size"+        | n == 0    = pure $ reverse xs+        | otherwise = do+            pos0 <- getPosition+            x    <- parser+            pos1 <- getPosition+            if pos1 <= pos0+            then failSGet $ "internal error: in-place success for " ++ elemname+            else go (n + pos0 - pos1) (x : xs)++----------------------------------------------------------------++-- | To get a broad range of correct RRSIG inception and expiration times+-- without over or underflow, we choose a time half way between midnight PDT+-- 2010-07-15 (the day the root zone was signed) and 2^32 seconds later on+-- 2146-08-21.  Since 'decode' and 'runSGet' are pure, we can't peek at the+-- current time while parsing.  Outside this date range the output is off by+-- some non-zero multiple 2\^32 seconds.+--+dnsTimeMid :: Int64+dnsTimeMid = 3426660848++initialState :: Int64 -> ByteString -> PState+initialState t inp = PState IM.empty 0 inp t++-- Construct our own error message, without the unhelpful AttoParsec+-- \"Failed reading: \" prefix.+--+failSGet :: String -> SGet a+failSGet msg = ST.lift (fail "" A.<?> msg)++runSGetAt :: Int64 -> SGet a -> ByteString -> Either DNSError (a, PState)+runSGetAt t parser inp =+    toResult $ A.parse (ST.runStateT parser $ initialState t inp) inp+  where+    toResult :: A.Result r -> Either DNSError r+    toResult (A.Done _ r)        = Right r+    toResult (A.Fail _ ctx msg)  = Left $ DecodeError $ head $ ctx ++ [msg]+    toResult (A.Partial _)       = Left $ DecodeError "incomplete input"++runSGet :: SGet a -> ByteString -> Either DNSError (a, PState)+runSGet = runSGetAt dnsTimeMid++runSGetWithLeftoversAt :: Int64      -- ^ Reference time for DNS clock arithmetic+                       -> SGet a     -- ^ Parser+                       -> ByteString -- ^ Encoded message+                       -> Either DNSError ((a, PState), ByteString)+runSGetWithLeftoversAt t parser inp =+    toResult $ A.parse (ST.runStateT parser $ initialState t inp) inp+  where+    toResult :: A.Result r -> Either DNSError (r, ByteString)+    toResult (A.Done     i r) = Right (r, i)+    toResult (A.Partial  f)   = toResult $ f BS.empty+    toResult (A.Fail _ ctx e) = Left $ DecodeError $ head $ ctx ++ [e]++runSGetWithLeftovers :: SGet a -> ByteString -> Either DNSError ((a, PState), ByteString)+runSGetWithLeftovers = runSGetWithLeftoversAt dnsTimeMid++runSPut :: SPut -> ByteString+runSPut = LBS.toStrict . BB.toLazyByteString . flip ST.evalState initialWState++----------------------------------------------------------------++-- | Decode a domain name in A-label form to a leading label and a tail with+-- the remaining labels, unescaping backlashed chars and decimal triples along+-- the way. Any  U-label conversion belongs at the layer above this code.+--+parseLabel :: Word8 -> ByteString -> Either DNSError (ByteString, ByteString)+parseLabel sep dom =+    if BS.any (== bslash) dom+    then toResult $ A.parse (labelParser sep mempty) dom+    else check $ safeTail <$> BS.break (== sep) dom+  where+    toResult (A.Partial c)  = toResult (c mempty)+    toResult (A.Done tl hd) = check (hd, tl)+    toResult _ = bottom+    safeTail bs | BS.null bs = mempty+                | otherwise = BS.tail bs+    check r@(hd, tl) | not (BS.null hd) || BS.null tl = Right r+                     | otherwise = bottom+    bottom = Left $ DecodeError $ "invalid domain: " ++ S8.unpack dom++labelParser :: Word8 -> ByteString -> A.Parser ByteString+labelParser sep acc = do+    acc' <- mappend acc <$> A.option mempty simple+    labelEnd sep acc' <|> (escaped >>= labelParser sep . BS.snoc acc')+  where+    simple = fst <$> A.match skipUnescaped+      where+        skipUnescaped = A.skipMany1 $ A.satisfy notSepOrBslash+        notSepOrBslash w = w /= sep && w /= bslash++    escaped = do+        A.skip (== bslash)+        either decodeDec pure =<< A.eitherP digit A.anyWord8+      where+        digit = fromIntegral <$> A.satisfyWith (\n -> n - zero) (<=9)+        decodeDec d =+            safeWord8 =<< trigraph d <$> digit <*> digit+          where+            trigraph :: Word -> Word -> Word -> Word+            trigraph x y z = 100 * x + 10 * y + z++            safeWord8 :: Word -> A.Parser Word8+            safeWord8 n | n > 255 = mzero+                        | otherwise = pure $ fromIntegral n++labelEnd :: Word8 -> ByteString -> A.Parser ByteString+labelEnd sep acc =+    A.satisfy (== sep) *> pure acc <|>+    A.endOfInput       *> pure acc++----------------------------------------------------------------++-- | Convert a wire-form label to presentation-form by escaping+-- the separator, special and non-printing characters.  For simple+-- labels with no bytes that require escaping we get back the input+-- bytestring asis with no copying or re-construction.+--+-- Note: the separator is required to be either \'.\' or \'\@\', but this+-- constraint is the caller's responsibility and is not checked here.+--+unparseLabel :: Word8 -> ByteString -> ByteString+unparseLabel sep label =+    if BS.all (isPlain sep) label+    then label+    else toResult $ A.parse (labelUnparser sep mempty) label+  where+    toResult (A.Partial c) = toResult (c mempty)+    toResult (A.Done _ r) = r+    toResult _ = E.throw UnknownDNSError -- can't happen++labelUnparser :: Word8 -> ByteString -> A.Parser ByteString+labelUnparser sep acc = do+    acc' <- mappend acc <$> A.option mempty asis+    A.endOfInput *> pure acc' <|> (esc >>= labelUnparser sep . mappend acc')+  where+    -- Non-printables are escaped as decimal trigraphs, while printable+    -- specials just get a backslash prefix.+    esc = do+        w <- A.anyWord8+        if w <= 32 || w >= 127+        then let (q100, r100) = w `divMod` 100+                 (q10, r10) = r100 `divMod` 10+              in pure $ BS.pack [ bslash, zero + q100, zero + q10, zero + r10 ]+        else pure $ BS.pack [ bslash, w ]++    -- Runs of plain bytes are recognized as a single chunk, which is then+    -- returned as-is.+    asis = fmap fst $ A.match $ A.skipMany1 $ A.satisfy $ isPlain sep++-- | In the presentation form of DNS labels, these characters are escaped by+-- prepending a backlash. (They have special meaning in zone files). Whitespace+-- and other non-printable or non-ascii characters are encoded via "\DDD"+-- decimal escapes. The separator character is also quoted in each label. Note+-- that '@' is quoted even when not the separator.+escSpecials :: ByteString+escSpecials = "\"$();@\\"++-- | Is the given byte the separator or one of the specials?+isSpecial :: Word8 -> Word8 -> Bool+isSpecial sep w = w == sep || BS.elemIndex w escSpecials /= Nothing++-- | Is the given byte a plain byte that reqires no escaping. The tests are+-- ordered to succeed or fail quickly in the most common cases. The test+-- ranges assume the expected numeric values of the named special characters.+-- Note: the separator is assumed to be either '.' or '@' and so not matched by+-- any of the first three fast-path 'True' cases.+isPlain :: Word8 -> Word8 -> Bool+isPlain sep w | w >= 127                 = False -- <DEL> + non-ASCII+              | w > bslash               = True  -- ']'..'_'..'a'..'z'..'~'+              | w >= zero && w < semi    = True  -- '0'..'9'..':'+              | w > atsign && w < bslash = True  -- 'A'..'Z'..'['+              | w <= 32                  = False -- non-printables+              | isSpecial sep w          = False -- one of the specials+              | otherwise                = True  -- plain punctuation++-- | Some numeric byte constants.+zero, semi, atsign, bslash :: Word8+zero = fromIntegral $ fromEnum '0'    -- 48+semi = fromIntegral $ fromEnum ';'    -- 59+atsign = fromIntegral $ fromEnum '@'  -- 64+bslash = fromIntegral $ fromEnum '\\' -- 92
+ internal/Network/DNS/Types/Internal.hs view
@@ -0,0 +1,1407 @@+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE CPP #-}++module Network.DNS.Types.Internal where++import Control.Exception (Exception, IOException)+import qualified Data.ByteString as B+import qualified Data.ByteString.Base16 as B16+import qualified Data.ByteString.Base64 as B64+import qualified Data.ByteString.Char8 as BS+import Data.CaseInsensitive (CI)+import qualified Data.CaseInsensitive as CI+import Data.Char (intToDigit)+import qualified Data.Hourglass as H+import Data.IP (IP(..), IPv4, IPv6)+import qualified Data.Semigroup as Sem++import qualified Network.DNS.Base32Hex as B32+import Network.DNS.Imports++-- $setup+-- >>> import Network.DNS++----------------------------------------------------------------++-- | This type holds the /presentation form/ of fully-qualified DNS domain+-- names encoded as ASCII A-labels, with \'.\' separators between labels.+-- Non-printing characters are escaped as @\\DDD@ (a backslash, followed by+-- three decimal digits). The special characters: @ \", \$, (, ), ;, \@,@ and+-- @\\@ are escaped by prepending a backslash.  The trailing \'.\' is optional+-- on input, but is recommended, and is always added when decoding from+-- /wire form/.+--+-- The encoding of domain names to /wire form/, e.g. for transmission in a+-- query, requires the input encodings to be valid, otherwise a 'DecodeError'+-- may be thrown. Domain names received in wire form in DNS messages are+-- escaped to this presentation form as part of decoding the 'DNSMessage'.+--+-- This form is ASCII-only. Any conversion between A-label 'ByteString's,+-- and U-label 'Text' happens at whatever layer maps user input to DNS+-- names, or presents /friendly/ DNS names to the user.  Not all users+-- can read all scripts, and applications that default to U-label form+-- should ideally give the user a choice to see the A-label form.+-- Examples:+--+-- @+-- www.example.org.           -- Ordinary DNS name.+-- \_25.\_tcp.mx1.example.net.  -- TLSA RR initial labels have \_ prefixes.+-- \\001.exotic.example.       -- First label is Ctrl-A!+-- just\\.one\\.label.example.  -- First label is \"just.one.label\"+-- @+--+type Domain = ByteString++-- | Type for a mailbox encoded on the wire as a DNS name, but the first label+-- is conceptually the local part of an email address, and may contain internal+-- periods that are not label separators. Therefore, in mailboxes \@ is used as+-- the separator between the first and second labels, and any \'.\' characters+-- in the first label are not escaped.  The encoding is otherwise the same as+-- 'Domain' above. This is most commonly seen in the /rname/ of @SOA@ records,+-- and is also employed in the @mbox-dname@ field of @RP@ records.+-- On input, if there is no unescaped \@ character in the 'Mailbox', it is+-- reparsed with \'.\' as the first label separator. Thus the traditional+-- format with all labels separated by dots is also accepted, but decoding from+-- wire form always uses \@ between the first label and the domain-part of the+-- address.  Examples:+--+-- @+-- hostmaster\@example.org.  -- First label is simply @hostmaster@+-- john.smith\@examle.com.   -- First label is @john.smith@+-- @+--+type Mailbox = ByteString++----------------------------------------------------------------++-- | Types for resource records.+newtype TYPE = TYPE {+    -- | From type to number.+    fromTYPE :: Word16+  } deriving (Eq, Ord)++-- https://www.iana.org/assignments/dns-parameters/dns-parameters.xhtml#dns-parameters-4++-- | IPv4 address+pattern A :: TYPE+pattern A          = TYPE   1+-- | An authoritative name serve+pattern NS :: TYPE+pattern NS         = TYPE   2+-- | The canonical name for an alias+pattern CNAME :: TYPE+pattern CNAME      = TYPE   5+-- | Marks the start of a zone of authority+pattern SOA :: TYPE+pattern SOA        = TYPE   6+-- | A null RR (EXPERIMENTAL)+pattern NULL :: TYPE+pattern NULL       = TYPE  10+-- | A domain name pointer+pattern PTR :: TYPE+pattern PTR        = TYPE  12+-- | Mail exchange+pattern MX :: TYPE+pattern MX         = TYPE  15+-- | Text strings+pattern TXT :: TYPE+pattern TXT        = TYPE  16+-- | Responsible Person+pattern RP :: TYPE+pattern RP         = TYPE  17+-- | IPv6 Address+pattern AAAA :: TYPE+pattern AAAA       = TYPE  28+-- | Server Selection (RFC2782)+pattern SRV :: TYPE+pattern SRV        = TYPE  33+-- | DNAME (RFC6672)+pattern DNAME :: TYPE+pattern DNAME      = TYPE  39 -- RFC 6672+-- | OPT (RFC6891)+pattern OPT :: TYPE+pattern OPT        = TYPE  41 -- RFC 6891+-- | Delegation Signer (RFC4034)+pattern DS :: TYPE+pattern DS         = TYPE  43 -- RFC 4034+-- | RRSIG (RFC4034)+pattern RRSIG :: TYPE+pattern RRSIG      = TYPE  46 -- RFC 4034+-- | NSEC (RFC4034)+pattern NSEC :: TYPE+pattern NSEC       = TYPE  47 -- RFC 4034+-- | DNSKEY (RFC4034)+pattern DNSKEY :: TYPE+pattern DNSKEY     = TYPE  48 -- RFC 4034+-- | NSEC3 (RFC5155)+pattern NSEC3 :: TYPE+pattern NSEC3      = TYPE  50 -- RFC 5155+-- | NSEC3PARAM (RFC5155)+pattern NSEC3PARAM :: TYPE+pattern NSEC3PARAM = TYPE  51 -- RFC 5155+-- | TLSA (RFC6698)+pattern TLSA :: TYPE+pattern TLSA       = TYPE  52 -- RFC 6698+-- | Child DS (RFC7344)+pattern CDS :: TYPE+pattern CDS        = TYPE  59 -- RFC 7344+-- | DNSKEY(s) the Child wants reflected in DS (RFC7344)+pattern CDNSKEY :: TYPE+pattern CDNSKEY    = TYPE  60 -- RFC 7344+-- | Child-To-Parent Synchronization (RFC7477)+pattern CSYNC :: TYPE+pattern CSYNC      = TYPE  62 -- RFC 7477+-- | Zone transfer (RFC5936)+pattern AXFR :: TYPE+pattern AXFR       = TYPE 252 -- RFC 5936+-- | A request for all records the server/cache has available+pattern ANY :: TYPE+pattern ANY        = TYPE 255+-- | Certification Authority Authorization (RFC6844)+pattern CAA :: TYPE+pattern CAA        = TYPE 257 -- RFC 6844++-- | From number to type.+toTYPE :: Word16 -> TYPE+toTYPE = TYPE++instance Show TYPE where+    show A          = "A"+    show NS         = "NS"+    show CNAME      = "CNAME"+    show SOA        = "SOA"+    show NULL       = "NULL"+    show PTR        = "PTR"+    show MX         = "MX"+    show TXT        = "TXT"+    show RP         = "RP"+    show AAAA       = "AAAA"+    show SRV        = "SRV"+    show DNAME      = "DNAME"+    show OPT        = "OPT"+    show DS         = "DS"+    show RRSIG      = "RRSIG"+    show NSEC       = "NSEC"+    show DNSKEY     = "DNSKEY"+    show NSEC3      = "NSEC3"+    show NSEC3PARAM = "NSEC3PARAM"+    show TLSA       = "TLSA"+    show CDS        = "CDS"+    show CDNSKEY    = "CDNSKEY"+    show CSYNC      = "CSYNC"+    show AXFR       = "AXFR"+    show ANY        = "ANY"+    show CAA        = "CAA"+    show x          = "TYPE" ++ show (fromTYPE x)++----------------------------------------------------------------++-- | An enumeration of all possible DNS errors that can occur.+data DNSError =+    -- | The sequence number of the answer doesn't match our query. This+    --   could indicate foul play.+    SequenceNumberMismatch+    -- | The question section of the response doesn't match our query. This+    --   could indicate foul play.+  | QuestionMismatch+    -- | A zone tranfer, i.e., a request of type AXFR, was attempted with the+    -- "lookup" interface. Zone transfer is different enough from "normal"+    -- requests that it requires a different interface.+  | InvalidAXFRLookup+    -- | The number of retries for the request was exceeded.+  | RetryLimitExceeded+    -- | TCP fallback request timed out.+  | TimeoutExpired+    -- | The answer has the correct sequence number, but returned an+    --   unexpected RDATA format.+  | UnexpectedRDATA+    -- | The domain for query is illegal.+  | IllegalDomain+    -- | The name server was unable to interpret the query.+  | FormatError+    -- | The name server was unable to process this query due to a+    --   problem with the name server.+  | ServerFailure+    -- | This code signifies that the domain name referenced in the+    --   query does not exist.+  | NameError+    -- | The name server does not support the requested kind of query.+  | NotImplemented+    -- | The name server refuses to perform the specified operation for+    --   policy reasons.  For example, a name+    --   server may not wish to provide the+    --   information to the particular requester,+    --   or a name server may not wish to perform+    --   a particular operation (e.g., zone transfer) for particular data.+  | OperationRefused+    -- | The server does not support the OPT RR version or content+  | BadOptRecord+    -- | Configuration is wrong.+  | BadConfiguration+    -- | Network failure.+  | NetworkFailure IOException+    -- | Error is unknown+  | DecodeError String+  | UnknownDNSError+  deriving (Eq, Show, Typeable)++instance Exception DNSError+++-- | Data type representing the optional EDNS pseudo-header of a 'DNSMessage'+-- When a single well-formed @OPT@ 'ResourceRecord' was present in the+-- message's additional section, it is decoded to an 'EDNS' record and and+-- stored in the message 'ednsHeader' field.  The corresponding @OPT RR@ is+-- then removed from the additional section.+--+-- When the constructor is 'NoEDNS', no @EDNS OPT@ record was present in the+-- message additional section.  When 'InvalidEDNS', the message holds either a+-- malformed OPT record or more than one OPT record, which can still be found+-- in (have not been removed from) the message additional section.+--+-- The EDNS OPT record augments the message error status with an 8-bit field+-- that forms 12-bit extended RCODE when combined with the 4-bit RCODE from the+-- unextended DNS header.  In EDNS messages it is essential to not use just the+-- bare 4-bit 'RCODE' from the original DNS header.  Therefore, in order to+-- avoid potential misinterpretation of the response 'RCODE', when the OPT+-- record is decoded, the upper eight bits of the error status are+-- automatically combined with the 'rcode' of the message header, so that there+-- is only one place in which to find the full 12-bit result.  Therefore, the+-- decoded 'EDNS' pseudo-header, does not hold any error status bits.+--+-- The reverse process occurs when encoding messages.  The low four bits of the+-- message header 'rcode' are encoded into the wire-form DNS header, while the+-- upper eight bits are encoded as part of the OPT record.  In DNS responses with+-- an 'rcode' larger than 15, EDNS extensions SHOULD be enabled by providing a+-- value for 'ednsHeader' with a constructor of 'EDNSheader'.  If EDNS is not+-- enabled in such a message, in order to avoid truncation of 'RCODE' values+-- that don't fit in the non-extended DNS header, the encoded wire-form 'RCODE'+-- is set to 'FormatErr'.+--+-- When encoding messages for transmission, the 'ednsHeader' is used to+-- generate the additional OPT record.  Do not add explicit @OPT@ records+-- to the aditional section, configure EDNS via the 'EDNSheader' instead.+--+-- >>> let getopts eh = mapEDNS eh ednsOptions []+-- >>> let optsin     = [OD_ClientSubnet 24 0 $ read "192.0.2.1"]+-- >>> let masked     = [OD_ClientSubnet 24 0 $ read "192.0.2.0"]+-- >>> let message    = makeEmptyQuery $ ednsSetOptions $ ODataSet optsin+-- >>> let optsout    = getopts. ednsHeader <$> (decode $ encode message)+-- >>> optsout       == Right masked+-- True+--+data EDNSheader = EDNSheader EDNS -- ^ A valid EDNS message+                | NoEDNS          -- ^ A valid non-EDNS message+                | InvalidEDNS     -- ^ Multiple or bad additional @OPT@ RRs+    deriving (Eq, Show)+++-- | Return the second argument for EDNS messages, otherwise the third.+ifEDNS :: EDNSheader -- ^ EDNS pseudo-header+       -> a          -- ^ Value to return for EDNS messages+       -> a          -- ^ Value to return for non-EDNS messages+       -> a+ifEDNS (EDNSheader _) a _ = a+ifEDNS             _  _ b = b+{-# INLINE ifEDNS #-}+++-- | Return the output of a function applied to the EDNS pseudo-header if EDNS+--   is enabled, otherwise return a default value.+mapEDNS :: EDNSheader  -- ^ EDNS pseudo-header+        -> (EDNS -> a) -- ^ Function to apply to 'EDNS' value+        -> a           -- ^ Default result for non-EDNS messages+        -> a+mapEDNS (EDNSheader eh) f _ = f eh+mapEDNS               _ _ a = a+{-# INLINE mapEDNS #-}+++-- | DNS message format for queries and replies.+--+data DNSMessage = DNSMessage {+    header     :: !DNSHeader        -- ^ Header with extended 'RCODE'+  , ednsHeader :: EDNSheader        -- ^ EDNS pseudo-header+  , question   :: [Question]        -- ^ The question for the name server+  , answer     :: Answers           -- ^ RRs answering the question+  , authority  :: AuthorityRecords  -- ^ RRs pointing toward an authority+  , additional :: AdditionalRecords -- ^ RRs holding additional information+  } deriving (Eq, Show)++-- | An identifier assigned by the program that+--   generates any kind of query.+type Identifier = Word16++-- | Raw data format for the header of DNS Query and Response.+data DNSHeader = DNSHeader {+    identifier :: !Identifier -- ^ Query or reply identifier.+  , flags      :: !DNSFlags   -- ^ Flags, OPCODE, and RCODE+  } deriving (Eq, Show)++-- | Raw data format for the flags of DNS Query and Response.+data DNSFlags = DNSFlags {+    qOrR         :: !QorR  -- ^ Query or response.+  , opcode       :: !OPCODE -- ^ Kind of query.+  , authAnswer   :: !Bool  -- ^ AA (Authoritative Answer) bit - this bit is valid in responses,+                           -- and specifies that the responding name server is an+                           -- authority for the domain name in question section.+  , trunCation   :: !Bool  -- ^ TC (Truncated Response) bit - specifies that this message was truncated+                           -- due to length greater than that permitted on the+                           -- transmission channel.+  , recDesired   :: !Bool  -- ^ RD (Recursion Desired) bit - this bit may be set in a query and+                           -- is copied into the response.  If RD is set, it directs+                           -- the name server to pursue the query recursively.+                           -- Recursive query support is optional.+  , recAvailable :: !Bool  -- ^ RA (Recursion Available) bit - this be is set or cleared in a+                           -- response, and denotes whether recursive query support is+                           -- available in the name server.++  , rcode        :: !RCODE -- ^ The full 12-bit extended RCODE when EDNS is in use.+                           -- Should always be zero in well-formed requests.+                           -- When decoding replies, the high eight bits from+                           -- any EDNS response are combined with the 4-bit+                           -- RCODE from the DNS header.  When encoding+                           -- replies, if no EDNS OPT record is provided, RCODE+                           -- values > 15 are mapped to 'FormatErr'.+  , authenData   :: !Bool  -- ^ AD (Authenticated Data) bit - (RFC4035, Section 3.2.3).+  , chkDisable   :: !Bool  -- ^ CD (Checking Disabled) bit - (RFC4035, Section 3.2.2).+  } deriving (Eq, Show)+++-- | Default 'DNSFlags' record suitable for making recursive queries.  By default+-- the RD bit is set, and the AD and CD bits are cleared.+--+defaultDNSFlags :: DNSFlags+defaultDNSFlags = DNSFlags+         { qOrR         = QR_Query+         , opcode       = OP_STD+         , authAnswer   = False+         , trunCation   = False+         , recDesired   = True+         , recAvailable = False+         , authenData   = False+         , chkDisable   = False+         , rcode        = NoErr+         }++----------------------------------------------------------------++-- | Boolean flag operations. These form a 'Monoid'.  When combined via+-- `mappend`, as with function composition, the left-most value has+-- the last say.+--+-- >>> mempty :: FlagOp+-- FlagKeep+-- >>> FlagSet <> mempty+-- FlagSet+-- >>> FlagClear <> FlagSet <> mempty+-- FlagClear+-- >>> FlagReset <> FlagClear <> FlagSet <> mempty+-- FlagReset+data FlagOp = FlagSet   -- ^ Set the flag to 1+            | FlagClear -- ^ Clear the flag to 0+            | FlagReset -- ^ Reset the flag to its default value+            | FlagKeep  -- ^ Leave the flag unchanged+            deriving (Eq, Show)++-- $+-- Test associativity of the semigroup operation:+--+-- >>> let ops = [FlagSet, FlagClear, FlagReset, FlagKeep]+-- >>> foldl (&&) True [(a<>b)<>c == a<>(b<>c) | a <- ops, b <- ops, c <- ops]+-- True+--+instance Sem.Semigroup FlagOp where+    FlagKeep <> op = op+    op       <> _  = op++instance Monoid FlagOp where+    mempty = FlagKeep+#if !(MIN_VERSION_base(4,11,0))+    -- this is redundant starting with base-4.11 / GHC 8.4+    -- if you want to avoid CPP, you can define `mappend = (<>)` unconditionally+    mappend = (Sem.<>)+#endif++-- | We don't show options left at their default value.+--+_skipDefault :: String+_skipDefault = ""++-- | Show non-default flag values+--+_showFlag :: String -> FlagOp -> String+_showFlag nm FlagSet   = nm ++ ":1"+_showFlag nm FlagClear = nm ++ ":0"+_showFlag _  FlagReset = _skipDefault+_showFlag _  FlagKeep  = _skipDefault++-- | Combine a list of options for display, skipping default values+--+_showOpts :: [String] -> String+_showOpts os = intercalate "," $ filter (/= _skipDefault) os++----------------------------------------------------------------++-- | Control over query-related DNS header flags. As with function composition,+-- the left-most value has the last say.+--+data HeaderControls = HeaderControls+    { rdBit :: !FlagOp+    , adBit :: !FlagOp+    , cdBit :: !FlagOp+    }+    deriving (Eq)++instance Sem.Semigroup HeaderControls where+    (HeaderControls rd1 ad1 cd1) <> (HeaderControls rd2 ad2 cd2) =+        HeaderControls (rd1 <> rd2) (ad1 <> ad2) (cd1 <> cd2)++instance Monoid HeaderControls where+    mempty = HeaderControls FlagKeep FlagKeep FlagKeep+#if !(MIN_VERSION_base(4,11,0))+    -- this is redundant starting with base-4.11 / GHC 8.4+    -- if you want to avoid CPP, you can define `mappend = (<>)` unconditionally+    mappend = (Sem.<>)+#endif++instance Show HeaderControls where+    show (HeaderControls rd ad cd) =+        _showOpts+             [ _showFlag "rd" rd+             , _showFlag "ad" ad+             , _showFlag "cd" cd ]++----------------------------------------------------------------++-- | The default EDNS Option list is empty.  We define two operations, one to+-- prepend a list of options, and another to set a specific list of options.+--+data ODataOp = ODataAdd [OData] -- ^ Add the specified options to the list.+             | ODataSet [OData] -- ^ Set the option list as specified.+             deriving (Eq)++-- | Since any given option code can appear at most once in the list, we+-- de-duplicate by the OPTION CODE when combining lists.+--+_odataDedup :: ODataOp -> [OData]+_odataDedup op =+    nubBy ((==) `on` _odataToOptCode) $+        case op of+            ODataAdd os -> os+            ODataSet os -> os++-- $+-- Test associativity of the OData semigroup operation:+--+-- >>> let ip1 = IPv4 $ read "127.0.0.0"+-- >>> let ip2 = IPv4 $ read "192.0.2.0"+-- >>> let cs1 = OD_ClientSubnet 8 0 ip1+-- >>> let cs2 = OD_ClientSubnet 24 0 ip2+-- >>> let cs3 = OD_ECSgeneric 0 24 0 "foo"+-- >>> let dau1 = OD_DAU [3,5,7,8]+-- >>> let dau2 = OD_DAU [13,14]+-- >>> let dhu1 = OD_DHU [1,2]+-- >>> let dhu2 = OD_DHU [3,4]+-- >>> let nsid = OD_NSID ""+-- >>> let ops1 = [ODataAdd [dau1, dau2, cs1], ODataAdd [dau2, cs2, dhu1]]+-- >>> let ops2 = [ODataSet [], ODataSet [dhu2, cs3], ODataSet [nsid]]+-- >>> let ops = ops1 ++ ops2+-- >>> foldl (&&) True [(a<>b)<>c == a<>(b<>c) | a <- ops, b <- ops, c <- ops]+-- True++instance Sem.Semigroup ODataOp where+    ODataAdd as <> ODataAdd bs = ODataAdd $ as ++ bs+    ODataAdd as <> ODataSet bs = ODataSet $ as ++ bs+    ODataSet as <> _ = ODataSet as++instance Monoid ODataOp where+    mempty = ODataAdd []+#if !(MIN_VERSION_base(4,11,0))+    -- this is redundant starting with base-4.11 / GHC 8.4+    -- if you want to avoid CPP, you can define `mappend = (<>)` unconditionally+    mappend = (Sem.<>)+#endif++----------------------------------------------------------------++-- | EDNS query controls.  When EDNS is disabled via @ednsEnabled FlagClear@,+-- all the other EDNS-related overrides have no effect.+--+-- >>> ednsHeader $ makeEmptyQuery $ ednsEnabled FlagClear <> doFlag FlagSet+-- NoEDNS+data EdnsControls = EdnsControls+    { extEn :: !FlagOp         -- ^ Enabled+    , extVn :: !(Maybe Word8)  -- ^ Version+    , extSz :: !(Maybe Word16) -- ^ UDP Size+    , extDO :: !FlagOp         -- ^ DNSSEC OK (DO) bit+    , extOd :: !ODataOp        -- ^ EDNS option list tweaks+    }+    deriving (Eq)++-- | Apply all the query flag overrides to 'defaultDNSFlags', returning the++instance Sem.Semigroup EdnsControls where+    (EdnsControls en1 vn1 sz1 do1 od1) <> (EdnsControls en2 vn2 sz2 do2 od2) =+        EdnsControls (en1 <> en2) (vn1 <|> vn2) (sz1 <|> sz2)+                    (do1 <> do2) (od1 <> od2)++instance Monoid EdnsControls where+    mempty = EdnsControls FlagKeep Nothing Nothing FlagKeep mempty+#if !(MIN_VERSION_base(4,11,0))+    -- this is redundant starting with base-4.11 / GHC 8.4+    -- if you want to avoid CPP, you can define `mappend = (<>)` unconditionally+    mappend = (Sem.<>)+#endif++instance Show EdnsControls where+    show (EdnsControls en vn sz d0 od) =+        _showOpts+            [ _showFlag "edns.enabled" en+            , _showWord "edns.version" vn+            , _showWord "edns.udpsize" sz+            , _showFlag "edns.dobit"   d0+            , _showOdOp "edns.options" $ map (show. _odataToOptCode)+                                       $ _odataDedup od ]+      where+        _showWord :: Show a => String -> Maybe a -> String+        _showWord nm w = maybe _skipDefault (\s -> nm ++ ":" ++ show s) w++        _showOdOp :: String -> [String] -> String+        _showOdOp nm os = case os of+            [] -> ""+            _  -> nm ++ ":[" ++ intercalate "," os ++ "]"++----------------------------------------------------------------++-- | Query controls form a 'Monoid', as with function composition, the+-- left-most value has the last say.  The 'Monoid' is generated by two sets of+-- combinators, one that controls query-related DNS header flags, and another+-- that controls EDNS features.+--+-- The header flag controls are: 'rdFlag', 'adFlag' and 'cdFlag'.+--+-- The EDNS feature controls are: 'doFlag', 'ednsEnabled', 'ednsSetVersion',+-- 'ednsSetUdpSize' and 'ednsSetOptions'.  When EDNS is disabled, all the other+-- EDNS-related controls have no effect.+--+-- __Example:__ Disable DNSSEC checking on the server, and request signatures and+-- NSEC records, perhaps for your own independent validation.  The UDP buffer+-- size is set large, for use with a local loopback nameserver on the same host.+--+-- >>> :{+-- mconcat [ adFlag FlagClear+--         , cdFlag FlagSet+--         , doFlag FlagSet+--         , ednsSetUdpSize (Just 8192) -- IPv4 loopback server?+--         ]+-- :}+-- ad:0,cd:1,edns.udpsize:8192,edns.dobit:1+--+-- __Example:__ Use EDNS version 1 (yet to be specified), request nameserver+-- ids from the server, and indicate a client subnet of "192.0.2.1/24".+--+-- >>> :set -XOverloadedStrings+-- >>> let emptyNSID = ""+-- >>> let mask = 24+-- >>> let ipaddr = read "192.0.2.1"+-- >>> :{+-- mconcat [ ednsSetVersion (Just 1)+--         , ednsSetOptions (ODataAdd [OD_NSID emptyNSID])+--         , ednsSetOptions (ODataAdd [OD_ClientSubnet mask 0 ipaddr])+--         ]+-- :}+-- edns.version:1,edns.options:[NSID,ClientSubnet]++data QueryControls = QueryControls+    { qctlHeader :: !HeaderControls+    , qctlEdns   :: !EdnsControls+    }+    deriving (Eq)++instance Sem.Semigroup QueryControls where+    (QueryControls fl1 ex1) <> (QueryControls fl2 ex2) =+        QueryControls (fl1 <> fl2) (ex1 <> ex2)++instance Monoid QueryControls where+    mempty = QueryControls mempty mempty+#if !(MIN_VERSION_base(4,11,0))+    -- this is redundant starting with base-4.11 / GHC 8.4+    -- if you want to avoid CPP, you can define `mappend = (<>)` unconditionally+    mappend = (Sem.<>)+#endif++instance Show QueryControls where+    show (QueryControls fl ex) = _showOpts [ show fl, show ex ]++----------------------------------------------------------------++-- | Generator of 'QueryControls' that adjusts the RD bit.+--+-- >>> rdFlag FlagClear+-- rd:0+rdFlag :: FlagOp -> QueryControls+rdFlag rd = mempty { qctlHeader = mempty { rdBit = rd } }++-- | Generator of 'QueryControls' that adjusts the AD bit.+--+-- >>> adFlag FlagSet+-- ad:1+adFlag :: FlagOp -> QueryControls+adFlag ad = mempty { qctlHeader = mempty { adBit = ad } }++-- | Generator of 'QueryControls' that adjusts the CD bit.+--+-- >>> cdFlag FlagSet+-- cd:1+cdFlag :: FlagOp -> QueryControls+cdFlag cd = mempty { qctlHeader = mempty { cdBit = cd } }++-- | Generator of 'QueryControls' that enables or disables EDNS support.+--   When EDNS is disabled, the rest of the 'EDNS' controls are ignored.+--+-- >>> ednsHeader $ makeEmptyQuery $ ednsEnabled FlagClear <> doFlag FlagSet+-- NoEDNS+ednsEnabled :: FlagOp -> QueryControls+ednsEnabled en = mempty { qctlEdns = mempty { extEn = en } }++-- | Generator of 'QueryControls' that adjusts the 'EDNS' version.+-- A value of 'Nothing' makes no changes, while 'Just' @v@ sets+-- the EDNS version to @v@.+--+-- >>> ednsSetVersion (Just 1)+-- edns.version:1+ednsSetVersion :: Maybe Word8 -> QueryControls+ednsSetVersion vn = mempty { qctlEdns = mempty { extVn = vn } }++-- | Generator of 'QueryControls' that adjusts the 'EDNS' UDP buffer size.+-- A value of 'Nothing' makes no changes, while 'Just' @n@ sets the EDNS UDP+-- buffer size to @n@.+--+-- >>> ednsSetUdpSize (Just 2048)+-- edns.udpsize:2048+ednsSetUdpSize :: Maybe Word16 -> QueryControls+ednsSetUdpSize sz = mempty { qctlEdns = mempty { extSz = sz } }++-- | Generator of 'QueryControls' that adjusts the 'EDNS' DnssecOk (DO) bit.+--+-- >>> doFlag FlagSet+-- edns.dobit:1+doFlag :: FlagOp -> QueryControls+doFlag d0 = mempty { qctlEdns = mempty { extDO = d0 } }++-- | Generator of 'QueryControls' that adjusts the list of 'EDNS' options.+--+-- >>> :set -XOverloadedStrings+-- >>> ednsSetOptions (ODataAdd [OD_NSID ""])+-- edns.options:[NSID]+ednsSetOptions :: ODataOp -> QueryControls+ednsSetOptions od = mempty { qctlEdns = mempty { extOd = od } }++----------------------------------------------------------------++-- | Query or response.+data QorR = QR_Query    -- ^ Query.+          | QR_Response -- ^ Response.+          deriving (Eq, Show, Enum, Bounded)++-- | Kind of query.+data OPCODE+  = OP_STD -- ^ A standard query.+  | OP_INV -- ^ An inverse query (inverse queries are deprecated).+  | OP_SSR -- ^ A server status request.+  | OP_NOTIFY -- ^ A zone change notification (RFC1996)+  | OP_UPDATE -- ^ An update request (RFC2136)+  deriving (Eq, Show, Enum, Bounded)++-- | Convert a 16-bit DNS OPCODE number to its internal representation+--+toOPCODE :: Word16 -> Maybe OPCODE+toOPCODE i = case i of+  0 -> Just OP_STD+  1 -> Just OP_INV+  2 -> Just OP_SSR+  -- OPCODE 3 is unassigned+  4 -> Just OP_NOTIFY+  5 -> Just OP_UPDATE+  _ -> Nothing++-- | Convert the internal representation of a DNS OPCODE to its 16-bit numeric+-- value.+--+fromOPCODE :: OPCODE -> Word16+fromOPCODE OP_STD    = 0+fromOPCODE OP_INV    = 1+fromOPCODE OP_SSR    = 2+fromOPCODE OP_NOTIFY = 4+fromOPCODE OP_UPDATE = 5++----------------------------------------------------------------++-- | EDNS extended 12-bit response code.  Non-EDNS messages use only the low 4+-- bits.  With EDNS this stores the combined error code from the DNS header and+-- and the EDNS psuedo-header. See 'EDNSheader' for more detail.+newtype RCODE = RCODE {+    -- | Convert an 'RCODE' to its numeric value.+    fromRCODE :: Word16+  } deriving (Eq)++-- | Provide an Enum instance for backwards compatibility+instance Enum RCODE where+    fromEnum = fromIntegral . fromRCODE+    toEnum = RCODE . fromIntegral++-- | No error condition.+pattern NoErr     :: RCODE+pattern NoErr      = RCODE  0+-- | Format error - The name server was+--   unable to interpret the query.+pattern FormatErr :: RCODE+pattern FormatErr  = RCODE  1+-- | Server failure - The name server was+--   unable to process this query due to a+--   problem with the name server.+pattern ServFail  :: RCODE+pattern ServFail   = RCODE  2+-- | Name Error - Meaningful only for+--   responses from an authoritative name+--   server, this code signifies that the+--   domain name referenced in the query does+--   not exist.+pattern NameErr   :: RCODE+pattern NameErr    = RCODE  3+-- | Not Implemented - The name server does+--   not support the requested kind of query.+pattern NotImpl   :: RCODE+pattern NotImpl    = RCODE  4+-- | Refused - The name server refuses to+--   perform the specified operation for+--   policy reasons.  For example, a name+--   server may not wish to provide the+--   information to the particular requester,+--   or a name server may not wish to perform+--   a particular operation (e.g., zone+--   transfer) for particular data.+pattern Refused   :: RCODE+pattern Refused    = RCODE  5+-- | YXDomain - Dynamic update response, a pre-requisite domain that should not+-- exist, does exist.+pattern YXDomain :: RCODE+pattern YXDomain  = RCODE 6+-- | YXRRSet - Dynamic update response, a pre-requisite RRSet that should not+-- exist, does exist.+pattern YXRRSet  :: RCODE+pattern YXRRSet   = RCODE 7+-- | NXRRSet - Dynamic update response, a pre-requisite RRSet that should+-- exist, does not exist.+pattern NXRRSet  :: RCODE+pattern NXRRSet   = RCODE 8+-- | NotAuth - Dynamic update response, the server is not authoritative for the+-- zone named in the Zone Section.+pattern NotAuth  :: RCODE+pattern NotAuth   = RCODE 9+-- | NotZone - Dynamic update response, a name used in the Prerequisite or+-- Update Section is not within the zone denoted by the Zone Section.+pattern NotZone  :: RCODE+pattern NotZone   = RCODE 10+-- | Bad OPT Version (BADVERS, RFC 6891).+pattern BadVers   :: RCODE+pattern BadVers    = RCODE 16+-- | Key not recognized [RFC2845]+pattern BadKey    :: RCODE+pattern BadKey     = RCODE 17+-- | Signature out of time window [RFC2845]+pattern BadTime   :: RCODE+pattern BadTime    = RCODE 18+-- | Bad TKEY Mode [RFC2930]+pattern BadMode   :: RCODE+pattern BadMode    = RCODE 19+-- | Duplicate key name [RFC2930]+pattern BadName   :: RCODE+pattern BadName    = RCODE 20+-- | Algorithm not supported [RFC2930]+pattern BadAlg    :: RCODE+pattern BadAlg     = RCODE 21+-- | Bad Truncation [RFC4635]+pattern BadTrunc  :: RCODE+pattern BadTrunc   = RCODE 22+-- | Bad/missing Server Cookie [RFC7873]+pattern BadCookie :: RCODE+pattern BadCookie  = RCODE 23+-- | Malformed (peer) EDNS message, no RCODE available.  This is not an RCODE+-- that can be sent by a peer.  It lies outside the 12-bit range expressible+-- via EDNS.  The low 12-bits are chosen to coincide with 'FormatErr'.  When+-- an EDNS message is malformed, and we're unable to extract the extended RCODE,+-- the header 'rcode' is set to 'BadRCODE'.+pattern BadRCODE  :: RCODE+pattern BadRCODE   = RCODE 0x1001++-- | Use https://tools.ietf.org/html/rfc2929#section-2.3 names for DNS RCODEs+instance Show RCODE where+    show NoErr     = "NoError"+    show FormatErr = "FormErr"+    show ServFail  = "ServFail"+    show NameErr   = "NXDomain"+    show NotImpl   = "NotImp"+    show Refused   = "Refused"+    show YXDomain  = "YXDomain"+    show YXRRSet   = "YXRRSet"+    show NotAuth   = "NotAuth"+    show NotZone   = "NotZone"+    show BadVers   = "BadVers"+    show BadKey    = "BadKey"+    show BadTime   = "BadTime"+    show BadMode   = "BadMode"+    show BadName   = "BadName"+    show BadAlg    = "BadAlg"+    show BadTrunc  = "BadTrunc"+    show BadCookie = "BadCookie"+    show x         = "RCODE " ++ (show $ fromRCODE x)++-- | Convert a numeric value to a corresponding 'RCODE'.  The behaviour is+-- undefined for values outside the range @[0 .. 0xFFF]@ since the EDNS+-- extended RCODE is a 12-bit value.  Values in the range @[0xF01 .. 0xFFF]@+-- are reserved for private use.+toRCODE :: Word16 -> RCODE+toRCODE = RCODE++----------------------------------------------------------------++-- XXX: The Question really should also include the CLASS+--+-- | Raw data format for DNS questions.+data Question = Question {+    qname  :: Domain -- ^ A domain name+  , qtype  :: TYPE   -- ^ The type of the query+  } deriving (Eq, Show)++----------------------------------------------------------------++-- | Resource record class.+type CLASS = Word16++-- | Resource record class for the Internet.+classIN :: CLASS+classIN = 1++-- | Time to live in second.+type TTL = Word32++-- | Raw data format for resource records.+data ResourceRecord = ResourceRecord {+    rrname  :: !Domain -- ^ Name+  , rrtype  :: !TYPE   -- ^ Resource record type+  , rrclass :: !CLASS  -- ^ Resource record class+  , rrttl   :: !TTL    -- ^ Time to live+  , rdata   :: !RData  -- ^ Resource data+  } deriving (Eq,Show)++----------------------------------------------------------------++-- | Given a 32-bit circle-arithmetic DNS time, and the current absolute epoch+-- time, return the epoch time corresponding to the DNS timestamp.+--+dnsTime :: Word32 -- ^ DNS circle-arithmetic timestamp+        -> Int64  -- ^ current epoch time+        -> Int64  -- ^ absolute DNS timestamp+dnsTime tdns tnow =+    let delta = tdns - fromIntegral tnow+     in if delta > 0x7FFFFFFF -- tdns is in the past?+           then tnow - (0x100000000 - fromIntegral delta)+           else tnow + fromIntegral delta++-- | RRSIG representation.+--+-- As noted in+-- <https://tools.ietf.org/html/rfc4034#section-3.1.5 Section 3.1.5 of RFC 4034>+-- the RRsig inception and expiration times use serial number arithmetic.  As a+-- result these timestamps /are not/ pure values, their meaning is+-- time-dependent!  They depend on the present time and are both at most+-- approximately +\/-68 years from the present.  This ambiguity is not a+-- problem because cached RRSIG records should only persist a few days,+-- signature lifetimes should be *much* shorter than 68 years, and key rotation+-- should result any misconstrued 136-year-old signatures fail to validate.+-- This also means that the interpretation of a time that is exactly half-way+-- around the clock at @now +\/-0x80000000@ is not important, the signature+-- should never be valid.+--+-- The upshot for us is that we need to convert these *impure* relative values+-- to pure absolute values at the moment they are received from from the network+-- (or read from files, ... in some impure I/O context), and convert them back to+-- 32-bit values when encoding.  Therefore, the constructor takes absolute+-- 64-bit representations of the inception and expiration times.+--+-- The 'dnsTime' function performs the requisite conversion.+--+data RD_RRSIG = RDREP_RRSIG+    { rrsigType       :: !TYPE       -- ^ RRtype of RRset signed+    , rrsigKeyAlg     :: !Word8      -- ^ DNSKEY algorithm+    , rrsigNumLabels  :: !Word8      -- ^ Number of labels signed+    , rrsigTTL        :: !Word32     -- ^ Maximum origin TTL+    , rrsigExpiration :: !Int64      -- ^ Time last valid+    , rrsigInception  :: !Int64      -- ^ Time first valid+    , rrsigKeyTag     :: !Word16     -- ^ Signing key tag+    , rrsigZone       :: !Domain     -- ^ Signing domain+    , rrsigValue      :: !ByteString -- ^ Opaque signature+    }+    deriving (Eq, Ord)++instance Show RD_RRSIG where+    show RDREP_RRSIG{..} = unwords+        [ show rrsigType+        , show rrsigKeyAlg+        , show rrsigNumLabels+        , show rrsigTTL+        , showTime rrsigExpiration+        , showTime rrsigInception+        , show rrsigKeyTag+        , BS.unpack rrsigZone+        , _b64encode rrsigValue+        ]+      where+        showTime :: Int64 -> String+        showTime t = H.timePrint fmt $ H.Elapsed $ H.Seconds t+          where+            fmt = [ H.Format_Year4, H.Format_Month2, H.Format_Day2+                  , H.Format_Hour,  H.Format_Minute, H.Format_Second ]++-- | Raw data format for each type.+data RData = RD_A IPv4           -- ^ IPv4 address+           | RD_NS Domain        -- ^ An authoritative name serve+           | RD_CNAME Domain     -- ^ The canonical name for an alias+           | RD_SOA Domain Mailbox Word32 Word32 Word32 Word32 Word32+                                 -- ^ Marks the start of a zone of authority+           | RD_NULL ByteString  -- ^ NULL RR (EXPERIMENTAL, RFC1035).+           | RD_PTR Domain       -- ^ A domain name pointer+           | RD_MX Word16 Domain -- ^ Mail exchange+           | RD_TXT ByteString   -- ^ Text strings+           | RD_RP Mailbox Domain -- ^ Responsible Person (RFC1183)+           | RD_AAAA IPv6        -- ^ IPv6 Address+           | RD_SRV Word16 Word16 Word16 Domain+                                 -- ^ Server Selection (RFC2782)+           | RD_DNAME Domain     -- ^ DNAME (RFC6672)+           | RD_OPT [OData]      -- ^ OPT (RFC6891)+           | RD_DS Word16 Word8 Word8 ByteString -- ^ Delegation Signer (RFC4034)+           | RD_RRSIG RD_RRSIG   -- ^ DNSSEC signature+           | RD_NSEC Domain [TYPE] -- ^ DNSSEC denial of existence NSEC record+           | RD_DNSKEY Word16 Word8 Word8 ByteString+                                 -- ^ DNSKEY (RFC4034)+           | RD_NSEC3 Word8 Word8 Word16 ByteString ByteString [TYPE]+                                 -- ^ DNSSEC hashed denial of existence (RFC5155)+           | RD_NSEC3PARAM Word8 Word8 Word16 ByteString+                                 -- ^ NSEC3 zone parameters (RFC5155)+           | RD_TLSA Word8 Word8 Word8 ByteString+                                 -- ^ TLSA (RFC6698)+           | RD_CDS Word16 Word8 Word8 ByteString+                                 -- ^ Child DS (RFC7344)+           | RD_CDNSKEY Word16 Word8 Word8 ByteString+                                 -- ^ Child DNSKEY (RFC7344)+           | RD_CAA Word8 (CI ByteString) ByteString+                                 -- ^ CAA (RFC 6844)+           --RD_CSYNC+           | UnknownRData ByteString   -- ^ Unknown resource data+    deriving (Eq, Ord)++instance Show RData where+  show rd = case rd of+      RD_A                  address -> show address+      RD_NS                 nsdname -> showDomain nsdname+      RD_CNAME                cname -> showDomain cname+      RD_SOA          a b c d e f g -> showSOA a b c d e f g+      RD_NULL                 bytes -> showOpaque bytes+      RD_PTR               ptrdname -> showDomain ptrdname+      RD_MX               pref exch -> showMX pref exch+      RD_TXT             textstring -> showTXT textstring+      RD_RP              mbox dname -> showRP mbox dname+      RD_AAAA               address -> show address+      RD_SRV        pri wei prt tgt -> showSRV pri wei prt tgt+      RD_DNAME               target -> showDomain target+      RD_OPT                options -> show options+      RD_DS          tag alg dalg d -> showDS tag alg dalg d+      RD_RRSIG                rrsig -> show rrsig+      RD_NSEC            next types -> showNSEC next types+      RD_DNSKEY             f p a k -> showDNSKEY f p a k+      RD_NSEC3      a f i s h types -> showNSEC3 a f i s h types+      RD_NSEC3PARAM         a f i s -> showNSEC3PARAM a f i s+      RD_TLSA               u s m d -> showTLSA u s m d+      RD_CDS         tag alg dalg d -> showDS tag alg dalg d+      RD_CDNSKEY            f p a k -> showDNSKEY f p a k+      RD_CAA                  f t v -> showCAA f t v+      UnknownRData            bytes -> showOpaque bytes+    where+      showSalt ""    = "-"+      showSalt salt  = _b16encode salt+      showDomain = BS.unpack+      showSOA mname rname serial refresh retry expire minttl =+          showDomain mname ++ " " ++ showDomain rname ++ " " +++          show serial ++ " " ++ show refresh ++ " " +++          show retry ++ " " ++ show expire ++ " " ++ show minttl+      showMX preference exchange =+          show preference ++ " " ++ showDomain exchange+      showTXT bs = '"' : B.foldr dnsesc ['"'] bs+        where+          c2w = fromIntegral . fromEnum+          w2c = toEnum . fromIntegral+          doubleQuote = c2w '"'+          backSlash   = c2w '\\'+          dnsesc c s+              | c == doubleQuote   = '\\' : w2c c : s+              | c == backSlash     = '\\' : w2c c : s+              | c >= 32 && c < 127 =        w2c c : s+              | otherwise          = '\\' : ddd c   s+          ddd c s =+              let (q100, r100) = divMod (fromIntegral c) 100+                  (q10, r10) = divMod r100 10+               in intToDigit q100 : intToDigit q10 : intToDigit r10 : s+      showRP mbox dname = showDomain mbox ++ " " ++ showDomain dname+      showSRV priority weight port target =+          show priority ++ " " ++ show weight ++ " " +++          show port ++ " " ++ BS.unpack target+      showDS keytag alg digestType digest =+          show keytag ++ " " ++ show alg ++ " " +++          show digestType ++ " " ++ _b16encode digest+      showNSEC next types =+          unwords $ showDomain next : map show types+      showDNSKEY flags protocol alg key =+          show flags ++ " " ++ show protocol ++ " " +++          show alg ++ " " ++ _b64encode key+      -- | <https://tools.ietf.org/html/rfc5155#section-3.2>+      showNSEC3 hashalg flags iterations salt nexthash types =+          unwords $ show hashalg : show flags : show iterations :+                    showSalt salt : _b32encode nexthash : map show types+      showNSEC3PARAM hashAlg flags iterations salt =+          show hashAlg ++ " " ++ show flags ++ " " +++          show iterations ++ " " ++ showSalt salt+      showTLSA usage selector mtype digest =+          show usage ++ " " ++ show selector ++ " " +++          show mtype ++ " " ++ _b16encode digest+      showCAA flags tag value =+          show flags ++ " " ++ BS.unpack (CI.original tag) ++ " " ++ show value+      -- | Opaque RData: <https://tools.ietf.org/html/rfc3597#section-5>+      showOpaque bs = unwords ["\\#", show (BS.length bs), _b16encode bs]++_b16encode, _b32encode, _b64encode :: ByteString -> String+_b16encode = BS.unpack. B16.encode+_b32encode = BS.unpack. B32.encode+_b64encode = BS.unpack. B64.encode++-- | Type alias for resource records in the answer section.+type Answers = [ResourceRecord]++-- | Type alias for resource records in the answer section.+type AuthorityRecords = [ResourceRecord]++-- | Type for resource records in the additional section.+type AdditionalRecords = [ResourceRecord]++----------------------------------------------------------------++-- | A 'DNSMessage' template for queries with default settings for+-- the message 'DNSHeader' and 'EDNSheader'.  This is the initial+-- query message state, before customization via 'QueryControls'.+--+defaultQuery :: DNSMessage+defaultQuery = DNSMessage {+    header = DNSHeader {+       identifier = 0+     , flags = defaultDNSFlags+     }+  , ednsHeader = EDNSheader defaultEDNS+  , question   = []+  , answer     = []+  , authority  = []+  , additional = []+  }++-- | Default response.  When responding to EDNS queries, the response must+-- either be an EDNS response, or else FormatErr must be returned.  The default+-- response message has EDNS disabled ('ednsHeader' set to 'NoEDNS'), it should+-- be updated as appropriate.+--+-- Do not explicitly add OPT RRs to the additional section, instead let the+-- encoder compute and add the OPT record based on the EDNS pseudo-header.+--+-- The 'RCODE' in the 'DNSHeader' should be set to the appropriate 12-bit+-- extended value, which will be split between the primary header and EDNS OPT+-- record during message encoding (low 4 bits in DNS header, high 8 bits in+-- EDNS OPT record).  See 'EDNSheader' for more details.+--+defaultResponse :: DNSMessage+defaultResponse = DNSMessage {+    header = DNSHeader {+       identifier = 0+     , flags = defaultDNSFlags {+              qOrR = QR_Response+            , authAnswer = True+            , recAvailable = True+            , authenData = False+       }+     }+  , ednsHeader = NoEDNS+  , question   = []+  , answer     = []+  , authority  = []+  , additional = []+  }++-- | A query template with 'QueryControls' overrides applied,+-- with just the 'Question' and query 'Identifier' remaining+-- to be filled in.+--+makeEmptyQuery :: QueryControls -- ^ Flag and EDNS overrides+               -> DNSMessage+makeEmptyQuery ctls = defaultQuery {+      header = header'+    , ednsHeader = queryEdns ehctls+    }+  where+    hctls = qctlHeader ctls+    ehctls = qctlEdns ctls+    header' = (header defaultQuery) { flags = queryDNSFlags hctls }++    -- | Apply the given 'FlagOp' to a default boolean value to produce the final+    -- setting.+    --+    applyFlag :: FlagOp -> Bool -> Bool+    applyFlag FlagSet   _ = True+    applyFlag FlagClear _ = False+    applyFlag _         v = v++    -- | Construct a list of 0 or 1 EDNS OPT RRs based on EdnsControls setting.+    --+    queryEdns :: EdnsControls -> EDNSheader+    queryEdns (EdnsControls en vn sz d0 od) =+        let d  = defaultEDNS+         in if en == FlagClear+            then NoEDNS+            else EDNSheader $ d { ednsVersion = fromMaybe (ednsVersion d) vn+                                , ednsUdpSize = fromMaybe (ednsUdpSize d) sz+                                , ednsDnssecOk = applyFlag d0 (ednsDnssecOk d)+                                , ednsOptions  = _odataDedup od+                                }++    -- | Apply all the query flag overrides to 'defaultDNSFlags', returning the+    -- resulting 'DNSFlags' suitable for making queries with the requested flag+    -- settings.  This is only needed if you're creating your own 'DNSMessage',+    -- the 'Network.DNS.LookupRaw.lookupRawCtl' function takes a 'QueryControls'+    -- argument and handles this conversion internally.+    --+    -- Default overrides can be specified in the resolver configuration by setting+    -- the 'Network.DNS.resolvQueryControls' field of the+    -- 'Network.DNS.Resolver.ResolvConf' argument to+    -- 'Network.DNS.Resolver.makeResolvSeed'.  These then apply to lookups via+    -- resolvers based on the resulting configuration, with the exception of+    -- 'Network.DNS.LookupRaw.lookupRawCtl' which takes an additional+    -- 'QueryControls' argument to augment the default overrides.+    --+    queryDNSFlags :: HeaderControls -> DNSFlags+    queryDNSFlags (HeaderControls rd ad cd) = d {+          recDesired = applyFlag rd $ recDesired d+        , authenData = applyFlag ad $ authenData d+        , chkDisable = applyFlag cd $ chkDisable d+        }+      where+        d = defaultDNSFlags++-- | Construct a complete query 'DNSMessage', by combining the 'defaultQuery'+-- template with the specified 'Identifier', and 'Question'.  The+-- 'QueryControls' can be 'mempty' to leave all header and EDNS settings at+-- their default values, or some combination of overrides.  A default set of+-- overrides can be enabled via the 'Network.DNS.Resolver.resolvQueryControls'+-- field of 'Network.DNS.Resolver.ResolvConf'.  Per-query overrides are+-- possible by using 'Network.DNS.LookupRaw.loookupRawCtl'.+--+makeQuery :: Identifier        -- ^ Crypto random request id+          -> Question          -- ^ Question name and type+          -> QueryControls     -- ^ Custom RD\/AD\/CD flags and EDNS settings+          -> DNSMessage+makeQuery idt q ctls = empqry {+      header = (header empqry) { identifier = idt }+    , question = [q]+    }+  where+    empqry = makeEmptyQuery ctls++-- | Construct a query response 'DNSMessage'.+makeResponse :: Identifier+             -> Question+             -> Answers+             -> DNSMessage+makeResponse idt q as = defaultResponse {+      header = header' { identifier = idt }+    , question = [q]+    , answer   = as+    }+  where+    header' = header defaultResponse++----------------------------------------------------------------+-- EDNS (RFC 6891, EDNS(0))+----------------------------------------------------------------++-- | EDNS information defined in RFC 6891.+data EDNS = EDNS {+    -- | EDNS version, presently only version 0 is defined.+    ednsVersion :: !Word8+    -- | Supported UDP payload size.+  , ednsUdpSize  :: !Word16+    -- | Request DNSSEC replies (with RRSIG and NSEC records as as appropriate)+    -- from the server.  Generally, not needed (except for diagnostic purposes)+    -- unless the signatures will be validated.  Just setting the 'AD' bit in+    -- the query and checking it in the response is sufficient (but often+    -- subject to man-in-the-middle forgery) if all that's wanted is whether+    -- the server validated the response.+  , ednsDnssecOk :: !Bool+    -- | EDNS options (e.g. 'OD_NSID', 'OD_ClientSubnet', ...)+  , ednsOptions  :: ![OData]+  } deriving (Eq, Show)++-- | The default EDNS pseudo-header for queries.  The UDP buffer size is set to+--   1216 bytes, which should result in replies that fit into the 1280 byte+--   IPv6 minimum MTU.  Since IPv6 only supports fragmentation at the source,+--   and even then not all gateways forward IPv6 pre-fragmented IPv6 packets,+--   it is best to keep DNS packet sizes below this limit when using IPv6+--   nameservers.  A larger value may be practical when using IPv4 exclusively.+--+-- @+-- defaultEDNS = EDNS+--     { ednsVersion = 0      -- The default EDNS version is 0+--     , ednsUdpSize = 1232   -- IPv6-safe UDP MTU (RIPE recommendation)+--     , ednsDnssecOk = False -- We don't do DNSSEC validation+--     , ednsOptions = []     -- No EDNS options by default+--     }+-- @+--+defaultEDNS :: EDNS+defaultEDNS = EDNS+    { ednsVersion = 0      -- The default EDNS version is 0+    , ednsUdpSize = 1232   -- IPv6-safe UDP MTU+    , ednsDnssecOk = False -- We don't do DNSSEC validation+    , ednsOptions = []     -- No EDNS options by default+    }++-- | Maximum UDP size that can be advertised.  If the 'ednsUdpSize' of 'EDNS'+--   is larger, then this value is sent instead.  This value is likely to work+--   only for local nameservers on the loopback network.  Servers may enforce+--   a smaller limit.+--+-- >>> maxUdpSize+-- 16384+maxUdpSize :: Word16+maxUdpSize = 16384++-- | Minimum UDP size to advertise. If 'ednsUdpSize' of 'EDNS' is smaller,+--   then this value is sent instead.+--+-- >>> minUdpSize+-- 512+minUdpSize :: Word16+minUdpSize = 512++----------------------------------------------------------------++-- | EDNS Option Code (RFC 6891).+newtype OptCode = OptCode {+    -- | From option code to number.+    fromOptCode :: Word16+  } deriving (Eq,Ord)++-- | NSID (RFC5001, section 2.3)+pattern NSID :: OptCode+pattern NSID = OptCode 3++-- | DNSSEC algorithm support (RFC6974, section 3)+pattern DAU :: OptCode+pattern DAU = OptCode 5+pattern DHU :: OptCode+pattern DHU = OptCode 6+pattern N3U :: OptCode+pattern N3U = OptCode 7++-- | Client subnet (RFC7871)+pattern ClientSubnet :: OptCode+pattern ClientSubnet = OptCode 8++instance Show OptCode where+    show NSID         = "NSID"+    show DAU          = "DAU"+    show DHU          = "DHU"+    show N3U          = "N3U"+    show ClientSubnet = "ClientSubnet"+    show x            = "OptCode" ++ (show $ fromOptCode x)++-- | From number to option code.+toOptCode :: Word16 -> OptCode+toOptCode = OptCode++----------------------------------------------------------------++-- | RData formats for a few EDNS options, and an opaque catchall+data OData =+      -- | Name Server Identifier (RFC5001).  Bidirectional, empty from client.+      -- (opaque octet-string).  May contain binary data, which MUST be empty+      -- in queries.+      OD_NSID ByteString+      -- | DNSSEC Algorithm Understood (RFC6975).  Client to server.+      -- (array of 8-bit numbers). Lists supported DNSKEY algorithms.+    | OD_DAU [Word8]+      -- | DS Hash Understood (RFC6975).  Client to server.+      -- (array of 8-bit numbers). Lists supported DS hash algorithms.+    | OD_DHU [Word8]+      -- | NSEC3 Hash Understood (RFC6975).  Client to server.+      -- (array of 8-bit numbers). Lists supported NSEC3 hash algorithms.+    | OD_N3U [Word8]+      -- | Client subnet (RFC7871).  Bidirectional.+      -- (source bits, scope bits, address).+      -- The address is masked and truncated when encoding queries.  The+      -- address is zero-padded when decoding.  Invalid input encodings+      -- result in an 'OD_ECSgeneric' value instead.+      --+    | OD_ClientSubnet Word8 Word8 IP+      -- | Unsupported or malformed IP client subnet option.  Bidirectional.+      -- (address family, source bits, scope bits, opaque address).+    | OD_ECSgeneric Word16 Word8 Word8 ByteString+      -- | Generic EDNS option.+      -- (numeric 'OptCode', opaque content)+    | UnknownOData Word16 ByteString+    deriving (Eq,Ord)+++-- | Recover the (often implicit) 'OptCode' from a value of the 'OData' sum+-- type.+_odataToOptCode :: OData -> OptCode+_odataToOptCode OD_NSID {}            = NSID+_odataToOptCode OD_DAU {}             = DAU+_odataToOptCode OD_DHU {}             = DHU+_odataToOptCode OD_N3U {}             = N3U+_odataToOptCode OD_ClientSubnet {}    = ClientSubnet+_odataToOptCode OD_ECSgeneric {}      = ClientSubnet+_odataToOptCode (UnknownOData code _) = toOptCode code++instance Show OData where+    show (OD_NSID nsid) = _showNSID nsid+    show (OD_DAU as)    = _showAlgList "DAU" as+    show (OD_DHU hs)    = _showAlgList "DHU" hs+    show (OD_N3U hs)    = _showAlgList "N3U" hs+    show (OD_ClientSubnet b1 b2 ip@(IPv4 _)) = _showECS 1 b1 b2 $ show ip+    show (OD_ClientSubnet b1 b2 ip@(IPv6 _)) = _showECS 2 b1 b2 $ show ip+    show (OD_ECSgeneric fam b1 b2 a) = _showECS fam b1 b2 $ _b16encode a+    show (UnknownOData code bs) =+        "UnknownOData " ++ show code ++ " " ++ _b16encode bs++_showAlgList :: String -> [Word8] -> String+_showAlgList nm ws = nm ++ " " ++ intercalate "," (map show ws)++_showNSID :: ByteString -> String+_showNSID nsid = "NSID" ++ " " ++ _b16encode nsid ++ ";" ++ printable nsid+  where+    printable = BS.unpack. BS.map (\c -> if c < ' ' || c > '~' then '?' else c)++_showECS :: Word16 -> Word8 -> Word8 -> String -> String+_showECS family srcBits scpBits address =+    show family ++ " " ++ show srcBits+                ++ " " ++ show scpBits ++ " " ++ address
+ internal/Network/DNS/Types/Resolver.hs view
@@ -0,0 +1,136 @@+module Network.DNS.Types.Resolver where++import Network.Socket (AddrInfo(..), PortNumber, HostName)++import Network.DNS.Imports+import Network.DNS.Memo+import Network.DNS.Types.Internal++----------------------------------------------------------------++-- | The type to specify a cache server.+data FileOrNumericHost = RCFilePath FilePath -- ^ A path for \"resolv.conf\"+                                             -- where one or more IP addresses+                                             -- of DNS servers should be found+                                             -- on Unix.+                                             -- Default DNS servers are+                                             -- automatically detected+                                             -- on Windows regardless of+                                             -- the value of the file name.+                       | RCHostName HostName -- ^ A numeric IP address. /Warning/: host names are invalid.+                       | RCHostNames [HostName] -- ^ Numeric IP addresses. /Warning/: host names are invalid.+                       | RCHostPort HostName PortNumber -- ^ A numeric IP address and port number. /Warning/: host names are invalid.+                       deriving Show++----------------------------------------------------------------++-- | Cache configuration for responses.+data CacheConf = CacheConf {+    -- | If RR's TTL is higher than this value, this value is used instead.+    maximumTTL  :: TTL+    -- | Cache pruning interval in seconds.+  , pruningDelay  :: Int+  } deriving Show++-- | Default cache configuration.+--+-- >>> defaultCacheConf+-- CacheConf {maximumTTL = 300, pruningDelay = 10}+defaultCacheConf :: CacheConf+defaultCacheConf = CacheConf 300 10++----------------------------------------------------------------++-- | Type for resolver configuration.+--  Use 'defaultResolvConf' to create a new value.+--+--  An example to use Google's public DNS cache instead of resolv.conf:+--+--  >>> let conf = defaultResolvConf { resolvInfo = RCHostName "8.8.8.8" }+--+--  An example to use multiple Google's public DNS cache concurrently:+--+--  >>> let conf = defaultResolvConf { resolvInfo = RCHostNames ["8.8.8.8","8.8.4.4"], resolvConcurrent = True }+--+--  An example to disable EDNS:+--+--  >>> let conf = defaultResolvConf { resolvQueryControls = ednsEnabled FlagClear }+--+--  An example to enable query result caching:+--+--  >>> let conf = defaultResolvConf { resolvCache = Just defaultCacheConf }+--+-- An example to disable requesting recursive service.+--+--  >>> let conf = defaultResolvConf { resolvQueryControls = rdFlag FlagClear }+--+-- An example to set the AD bit in all queries by default.+--+--  >>> let conf = defaultResolvConf { resolvQueryControls = adFlag FlagSet }+--+-- An example to set the both the AD and CD bits in all queries by default.+--+--  >>> let conf = defaultResolvConf { resolvQueryControls = adFlag FlagSet <> cdFlag FlagSet }+--+-- An example with an EDNS buffer size of 1216 bytes, which is more robust with+-- IPv6, and the DO bit set to request DNSSEC responses.+--+--  >>> let conf = defaultResolvConf { resolvQueryControls = ednsSetUdpSize (Just 1216) <> doFlag FlagSet }+--+data ResolvConf = ResolvConf {+   -- | Server information.+    resolvInfo       :: FileOrNumericHost+   -- | Timeout in micro seconds.+  , resolvTimeout    :: Int+   -- | The number of retries including the first try.+  , resolvRetry      :: Int+   -- | Concurrent queries if multiple DNS servers are specified.+  , resolvConcurrent :: Bool+   -- | Cache configuration.+  , resolvCache      :: Maybe CacheConf+   -- | Overrides for the default flags used for queries via resolvers that use+   -- this configuration.+  , resolvQueryControls :: QueryControls+} deriving Show++-- | Return a default 'ResolvConf':+--+-- * 'resolvInfo' is 'RCFilePath' \"\/etc\/resolv.conf\".+-- * 'resolvTimeout' is 3,000,000 micro seconds.+-- * 'resolvRetry' is 3.+-- * 'resolvConcurrent' is False.+-- * 'resolvCache' is Nothing.+-- * 'resolvQueryControls' is an empty set of overrides.+defaultResolvConf :: ResolvConf+defaultResolvConf = ResolvConf {+    resolvInfo       = RCFilePath "/etc/resolv.conf"+  , resolvTimeout    = 3 * 1000 * 1000+  , resolvRetry      = 3+  , resolvConcurrent = False+  , resolvCache      = Nothing+  , resolvQueryControls = mempty+}++----------------------------------------------------------------++-- | Intermediate abstract data type for resolvers.+--   IP address information of DNS servers is generated+--   according to 'resolvInfo' internally.+--   This value can be safely reused for 'withResolver'.+--+--   The naming is confusing for historical reasons.+data ResolvSeed = ResolvSeed {+    resolvconf  :: ResolvConf+  , nameservers :: NonEmpty AddrInfo+}++----------------------------------------------------------------++-- | Abstract data type of DNS Resolver.+--   This includes newly seeded identifier generators for all+--   specified DNS servers and a cache database.+data Resolver = Resolver {+    resolvseed :: ResolvSeed+  , genIds     :: NonEmpty (IO Word16)+  , cache      :: Maybe Cache+}
+ test/DecodeSpec.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE OverloadedStrings #-}++module DecodeSpec where++import Data.ByteString.Internal (ByteString(..), unsafeCreate)+import qualified Data.ByteString.Char8 as BC+import Data.Word8+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Ptr (plusPtr)+import Foreign.Storable (peek, poke, peekByteOff)+import Test.Hspec++import Network.DNS+import Network.DNS.Imports++----------------------------------------------------------------++test_doublePointer :: ByteString+test_doublePointer = "f7eb8500000100010007000404736563330561706e696303636f6d0000010001c00c0001000100001c200004ca0c1c8cc0110002000100001c20000f036e73310561706e6963036e657400c0300002000100001c200006036e7333c040c0300002000100001c200006036e7334c040c0300002000100001c20001004736563310561706e696303636f6d00c0300002000100001c20001704736563310761757468646e730472697065036e657400c0300002000100001c20001004736563320561706e696303636f6d00c0300002000100001c2000070473656333c0bfc07b0001000100001c200004ca0c1d3bc07b001c000100001c20001020010dc02001000a4608000000000059c0ba0001000100001c200004ca0c1d3cc0d6001c000100001c20001020010dc0000100004777000000000140"+-- DNSMessage {header = DNSHeader {identifier = 63467, flags = DNSFlags {qOrR = QR_Response, opcode = OP_STD, authAnswer = True, trunCation = False, recDesired = True, recAvailable = False, rcode = NoErr, authenData = False}}, question = [Question {qname = "sec3.apnic.com.", qtype = A}], answer = [ResourceRecord {rrname = "sec3.apnic.com.", rrtype = A, rrttl = 7200, rdata = 202.12.28.140}], authority = [ResourceRecord {rrname = "apnic.com.", rrtype = NS, rrttl = 7200, rdata = ns1.apnic.net.},ResourceRecord {rrname = "apnic.com.", rrtype = NS, rrttl = 7200, rdata = ns3.apnic.net.},ResourceRecord {rrname = "apnic.com.", rrtype = NS, rrttl = 7200, rdata = ns4.apnic.net.},ResourceRecord {rrname = "apnic.com.", rrtype = NS, rrttl = 7200, rdata = sec1.apnic.com.},ResourceRecord {rrname = "apnic.com.", rrtype = NS, rrttl = 7200, rdata = sec1.authdns.ripe.net.},ResourceRecord {rrname = "apnic.com.", rrtype = NS, rrttl = 7200, rdata = sec2.apnic.com.},ResourceRecord {rrname = "apnic.com.", rrtype = NS, rrttl = 7200, rdata = sec3.apnic.com.}], additional = [ResourceRecord {rrname = "sec1.apnic.com.", rrtype = A, rrttl = 7200, rdata = 202.12.29.59},ResourceRecord {rrname = "sec1.apnic.com.", rrtype = AAAA, rrttl = 7200, rdata = 2001:dc0:2001:a:4608::59},ResourceRecord {rrname = "sec2.apnic.com.", rrtype = A, rrttl = 7200, rdata = 202.12.29.60},ResourceRecord {rrname = "sec3.apnic.com.", rrtype = AAAA, rrttl = 7200, rdata = 2001:dc0:1:0:4777::140}]})++test_txt :: ByteString+test_txt = "463181800001000100000000076e69636f6c6173046b766462076e647072696d6102696f0000100001c00c0010000100000e10000d0c6e69636f6c61732e6b766462"+-- DNSMessage {header = DNSHeader {identifier = 17969, flags = DNSFlags {qOrR = QR_Response, opcode = OP_STD, authAnswer = False, trunCation = False, recDesired = True, recAvailable = True, rcode = NoErr, authenData = False}}+--              , question = [Question {qname = "nicolas.kvdb.ndprima.io.", qtype = TXT}]+--              , answer = [ResourceRecord {rrname = "nicolas.kvdb.ndprima.io.", rrtype = TXT, rrttl = 3600, rdata = nicolas.kvdb}]+--              , authority = []+--              , additional = []})++test_dname :: ByteString+test_dname = "b3c0818000010005000200010377777706376b616e616c02636f02696c0000010001c0100027000100000003000c0769737261656c3702727500c00c0005000100000003000603777777c02ec046000500010000255b0002c02ec02e000100010000003d000451daf938c02e000100010000003d0004c33ce84ac02e000200010005412b000c036e7332026137036f726700c02e000200010005412b0006036e7331c08a0000291000000000000000"+-- DNSMessage {header = DNSHeader {identifier = 46016, flags = DNSFlags {qOrR = QR_Response, opcode = OP_STD, authAnswer = False, trunCation = False, recDesired = True, recAvailable = True, rcode = NoErr, authenData = False}}, question = [Question {qname = "www.7kanal.co.il.", qtype = A}], answer = [ResourceRecord {rrname = "7kanal.co.il.", rrtype = DNAME, rrttl = 3, rdata = israel7.ru.},ResourceRecord {rrname = "www.7kanal.co.il.", rrtype = CNAME, rrttl = 3, rdata = www.israel7.ru.},ResourceRecord {rrname = "www.israel7.ru.", rrtype = CNAME, rrttl = 9563, rdata = israel7.ru.},ResourceRecord {rrname = "israel7.ru.", rrtype = A, rrttl = 61, rdata = 81.218.249.56},ResourceRecord {rrname = "israel7.ru.", rrtype = A, rrttl = 61, rdata = 195.60.232.74}], authority = [ResourceRecord {rrname = "israel7.ru.", rrtype = NS, rrttl = 344363, rdata = ns2.a7.org.},ResourceRecord {rrname = "israel7.ru.", rrtype = NS, rrttl = 344363, rdata = ns1.a7.org.}], additional = [OptRecord {orudpsize = 4096, ordnssecok = False, orversion = 0, rdata = []}]})++test_mx :: ByteString+test_mx = "f03681800001000100000001036d6577036f726700000f0001c00c000f000100000df10009000a046d61696cc00c0000291000000000000000"+-- DNSMessage {header = DNSHeader {identifier = 61494, flags = DNSFlags {qOrR = QR_Response, opcode = OP_STD, authAnswer = False, trunCation = False, recDesired = True, recAvailable = True, rcode = NoErr, authenData = False}}+--              , question = [Question {qname = "mew.org.", qtype = MX}]+--              , answer = [ResourceRecord {rrname = "mew.org.", rrtype = MX, rrttl = 3569, rdata = 10 mail.mew.org.}]+--              , authority = []+--              , additional = [OptRecord {orudpsize = 4096, ordnssecok = False, orversion = 0, rdata = []}]})++-- Message with question domain == SOA rname, testing correct decoding of+-- of the rname to presentation form when it encoded in compressed form+-- as a pointer to the question domain.+test_soa_in :: DNSMessage+test_soa_in =+    let soard = RD_SOA "ns1.example.com." "hostmaster.example.com." 0 0 0 0 0+        soarr = ResourceRecord "example.com." SOA 1 3600 soard+     in defaultResponse { question = [Question "hostmaster.example.com." A]+                        , authority = [soarr] }++-- Expected decoded presentation form of the 'test_soa' message.+test_soa_out :: DNSMessage+test_soa_out =+    let soard = RD_SOA "ns1.example.com." "hostmaster@example.com." 0 0 0 0 0+        soarr = ResourceRecord "example.com." SOA 1 3600 soard+     in defaultResponse { question = [Question "hostmaster.example.com." A]+                        , authority = [soarr] }++-- Expected compressed encoding of the 'test_soa' message+test_soa_bytes :: ByteString+test_soa_bytes = "0000858000010000000100000a686f73746d6173746572076578616d706c6503636f6d0000010001c0170006000100000e10001c036e7331c017c00c0000000000000000000000000000000000000000"++----------------------------------------------------------------++spec :: Spec+spec = do+    describe "decode" $ do+        it "decodes double pointers correctly" $+            tripleDecodeTest test_doublePointer+        it "decodes dname" $+            tripleDecodeTest test_dname+        it "decodes txt" $+            tripleDecodeTest test_txt+        it "decodes mx" $+            tripleDecodeTest test_mx+        it "detect excess" $+            case decode (encode defaultQuery <> "\0") of+                Left (DecodeError {}) -> True+                _ -> error "Excess input not detected"+        it "detect truncation" $+            case decode (BC.init $ encode defaultQuery) of+                Left (DecodeError {}) -> True+                _ -> error "Excess input not detected"+        it "soa mailbox presentation form" $+            case encode test_soa_in of+                enc | enc /= fromHexString test_soa_bytes+                    -> error "Unexpected test_soa encoding"+                    | otherwise -> case decode enc of+                        Left err  -> error $ "Error decoding test_soa: " ++ show err+                        Right m | m /= test_soa_out+                                  -> error $ "Wrong decode of test_soa: " ++ show m+                                | otherwise -> True++tripleDecodeTest :: ByteString -> IO ()+tripleDecodeTest hexbs =+    ecase (decode $ fromHexString hexbs) fail' $ \ x1 ->+        ecase (decode $ encode x1) fail' $ \ x2 ->+            ecase (decode $ encode x2) fail' $ \ x3 ->+                x3 `shouldBe` x2+  where+    fail' (DecodeError err) = fail err+    fail' _                 = error "fail'"++ecase :: Either a b -> (a -> c) -> (b -> c) -> c+ecase (Left  a) f _ = f a+ecase (Right b) _ g = g b++----------------------------------------------------------------++fromHexString :: ByteString -> ByteString+fromHexString (PS fptr off len) = unsafeCreate size $ \dst ->+    withForeignPtr fptr $ \src -> go (src `plusPtr` off) dst 0+  where+    size = len `div` 2+    go from to bytes+      | bytes == size = return ()+      | otherwise    = do+          w1 <- peek from+          w2 <- peekByteOff from 1+          let w = hex2w (w1,w2)+          poke to w+          go (from `plusPtr` 2) (to `plusPtr` 1) (bytes + 1)++hex2w :: (Word8, Word8) -> Word8+hex2w (w1,w2) = h2w w1 * 16 + h2w w2++h2w :: Word8 -> Word8+h2w w+  | isDigit w = w - _0+  | otherwise = w - _a + 10
test/EncodeSpec.hs view
@@ -3,31 +3,33 @@ module EncodeSpec where  import Data.IP-import Network.DNS-import Network.DNS.Internal (defaultQuery, makeQuestion) import Test.Hspec +import Network.DNS+ spec :: Spec spec = do     describe "encode" $ do-        it "encodes DNSFormat correctly" $ do+        it "encodes DNSMessage correctly" $ do             check1 testQueryA             check1 testQueryAAAA             check1 testResponseA+            check1 testResponseTXT      describe "decode" $ do-        it "decodes DNSFormat correctly" $ do+        it "decodes DNSMessage correctly" $ do             check2 testQueryA             check2 testQueryAAAA             check2 testResponseA+            check2 testResponseTXT -check1 :: DNSFormat -> Expectation+check1 :: DNSMessage -> Expectation check1 inp = out `shouldBe` Right inp   where     bs = encode inp     out = decode bs -check2 :: DNSFormat -> Expectation+check2 :: DNSMessage -> Expectation check2 inp = bs' `shouldBe` bs   where     bs = encode inp@@ -37,26 +39,24 @@ defaultHeader :: DNSHeader defaultHeader = header defaultQuery -testQueryA :: DNSFormat+testQueryA :: DNSMessage testQueryA = defaultQuery {     header = defaultHeader {          identifier = 1000-       , qdCount = 1        }-  , question = [makeQuestion "www.mew.org." A]+  , question = [Question "www.mew.org." A]   } -testQueryAAAA :: DNSFormat+testQueryAAAA :: DNSMessage testQueryAAAA = defaultQuery {     header = defaultHeader {-         identifier = 1000-       , qdCount = 1+         identifier = 1001        }-  , question = [makeQuestion "www.mew.org." AAAA]+  , question = [Question "www.mew.org." AAAA]   } -testResponseA :: DNSFormat-testResponseA = DNSFormat {+testResponseA :: DNSMessage+testResponseA = DNSMessage {     header = DNSHeader {          identifier = 61046        , flags = DNSFlags {@@ -67,116 +67,71 @@          , recDesired = True          , recAvailable = True          , rcode = NoErr+         , authenData = False+         , chkDisable = False          }-       , qdCount = 1-       , anCount = 8-       , nsCount = 2-       , arCount = 4        }+  , ednsHeader = NoEDNS   , question = [Question {                      qname = "492056364.qzone.qq.com."                    , qtype = A                    }                 ]-  , answer = [ResourceRecord {-                   rrname = "492056364.qzone.qq.com."-                 , rrtype = A-                 , rrttl = 568-                 , rdlen = 4-                 , rdata = RD_A $ toIPv4 [119, 147, 15, 122]-                 }-            , ResourceRecord {-                   rrname = "492056364.qzone.qq.com."-                 , rrtype = A-                 , rrttl = 568-                 , rdlen = 4-                 , rdata = RD_A $ toIPv4 [119, 147, 79, 106]-                 }-            , ResourceRecord {-                   rrname = "492056364.qzone.qq.com."-                 , rrtype = A-                 , rrttl = 568-                 , rdlen = 4-                 , rdata = RD_A $ toIPv4 [183, 60, 55, 43]-                 }-            , ResourceRecord {-                   rrname = "492056364.qzone.qq.com."-                 , rrtype = A-                 , rrttl = 568-                 , rdlen = 4-                 , rdata = RD_A $ toIPv4 [183, 60, 55, 107]-                 }-            , ResourceRecord {-                   rrname = "492056364.qzone.qq.com."-                 , rrtype = A-                 , rrttl = 568-                 , rdlen = 4-                 , rdata = RD_A $ toIPv4 [113, 108, 7, 172]-                 }-            , ResourceRecord {-                   rrname = "492056364.qzone.qq.com."-                 , rrtype = A-                 , rrttl = 568-                 , rdlen = 4-                 , rdata = RD_A $ toIPv4 [113, 108, 7, 174]-                 }-            , ResourceRecord {-                   rrname = "492056364.qzone.qq.com."-                 , rrtype = A-                 , rrttl = 568-                 , rdlen = 4-                 , rdata = RD_A $ toIPv4 [113, 108, 7, 175]-                 }-            , ResourceRecord {-                   rrname = "492056364.qzone.qq.com."-                 , rrtype = A-                 , rrttl = 568-                 , rdlen = 4-                 , rdata = RD_A $ toIPv4 [119, 147, 15, 100]-                 }-            ]-  , authority = [ ResourceRecord {-                       rrname = "qzone.qq.com."-                     , rrtype = NS-                     , rrttl = 45919-                     , rdlen = 10-                     , rdata = RD_NS "ns-tel2.qq.com."-                     }-                , ResourceRecord {-                       rrname = "qzone.qq.com."-                     , rrtype = NS-                     , rrttl = 45919-                     , rdlen = 10-                     , rdata = RD_NS "ns-tel1.qq.com."-                     }+  , answer =+        [ ResourceRecord "492056364.qzone.qq.com." A classIN 568 (RD_A $ toIPv4 [119, 147, 15, 122])+        , ResourceRecord "492056364.qzone.qq.com." A classIN 568 (RD_A $ toIPv4 [119, 147, 79, 106])+        , ResourceRecord "492056364.qzone.qq.com." A classIN 568 (RD_A $ toIPv4 [183, 60, 55, 43])+        , ResourceRecord "492056364.qzone.qq.com." A classIN 568 (RD_A $ toIPv4 [183, 60, 55, 107])+        , ResourceRecord "492056364.qzone.qq.com." A classIN 568 (RD_A $ toIPv4 [113, 108, 7, 172])+        , ResourceRecord "492056364.qzone.qq.com." A classIN 568 (RD_A $ toIPv4 [113, 108, 7, 174])+        , ResourceRecord "492056364.qzone.qq.com." A classIN 568 (RD_A $ toIPv4 [113, 108, 7, 175])+        , ResourceRecord "492056364.qzone.qq.com." A classIN 568 (RD_A $ toIPv4 [119, 147, 15, 100])+        ]+  , authority =+        [ ResourceRecord "qzone.qq.com." NS classIN 45919 (RD_NS "ns-tel2.qq.com.")+        , ResourceRecord "qzone.qq.com." NS classIN 45919 (RD_NS "ns-tel1.qq.com.")+        ]+  , additional =+        [ ResourceRecord "ns-tel1.qq.com." A classIN 46520 (RD_A $ toIPv4 [121, 14, 73, 115])+        , ResourceRecord "ns-tel2.qq.com." A classIN 2890 (RD_A $ toIPv4 [222, 73, 76, 226])+        , ResourceRecord "ns-tel2.qq.com." A classIN 2890 (RD_A $ toIPv4 [183, 60, 3, 202])+        , ResourceRecord "ns-tel2.qq.com." A classIN 2890 (RD_A $ toIPv4 [218, 30, 72, 180])+        ]+  }++testResponseTXT :: DNSMessage+testResponseTXT = DNSMessage {+    header = DNSHeader {+         identifier = 48724+       , flags = DNSFlags {+           qOrR = QR_Response+         , opcode = OP_STD+         , authAnswer = False+         , trunCation = False+         , recDesired = True+         , recAvailable = True+         , rcode = NoErr+         , authenData = False+         , chkDisable = False+         }+       }+  , ednsHeader = EDNSheader defaultEDNS+  , question = [Question {+                     qname = "492056364.qzone.qq.com."+                   , qtype = TXT+                   }                 ]-  , additional = [ ResourceRecord {-                        rrname = "ns-tel1.qq.com."-                      , rrtype = A-                      , rrttl = 46520-                      , rdlen = 4-                      , rdata = RD_A $ toIPv4 [121, 14, 73, 115]-                      }-                 , ResourceRecord {-                        rrname = "ns-tel2.qq.com."-                      , rrtype = A-                      , rrttl = 2890-                      , rdlen = 4-                      , rdata = RD_A $ toIPv4 [222, 73, 76, 226]-                      }-                 , ResourceRecord {-                        rrname = "ns-tel2.qq.com."-                      , rrtype = A-                      , rrttl = 2890-                      , rdlen = 4-                      , rdata = RD_A $ toIPv4 [183, 60, 3, 202]-                      }-                 , ResourceRecord {-                        rrname = "ns-tel2.qq.com."-                      , rrtype = A-                      , rrttl = 2890-                      , rdlen = 4-                      , rdata = RD_A $ toIPv4 [218, 30, 72, 180]-                      }-                 ]+  , answer =+        [ ResourceRecord "492056364.qzone.qq.com." TXT classIN 0 (RD_TXT "simple txt line")+        ]+  , authority =+        [ ResourceRecord "qzone.qq.com." NS classIN 45919 (RD_NS "ns-tel2.qq.com.")+        , ResourceRecord "qzone.qq.com." NS classIN 45919 (RD_NS "ns-tel1.qq.com.")+        ]+  , additional =+        [ ResourceRecord "ns-tel1.qq.com." A classIN 46520 (RD_A $ toIPv4 [121, 14, 73, 115])+        , ResourceRecord "ns-tel2.qq.com." A classIN 2890 (RD_A $ toIPv4 [222, 73, 76, 226])+        , ResourceRecord "ns-tel2.qq.com." A classIN 2890 (RD_A $ toIPv4 [183, 60, 3, 202])+        , ResourceRecord "ns-tel2.qq.com." A classIN 2890 (RD_A $ toIPv4 [218, 30, 72, 180])+        ]   }
+ test/RoundTripSpec.hs view
@@ -0,0 +1,267 @@+{-# LANGUAGE OverloadedStrings, TransformListComp #-}++module RoundTripSpec where++import qualified Data.IP+import Data.IP (Addr, IP(..), IPv4, IPv6, toIPv4, toIPv6, makeAddrRange)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BS+import qualified Data.CaseInsensitive as CI+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck (Gen, arbitrary, elements, forAll, frequency, listOf, oneof)+import GHC.Exts (the, groupWith)++import Network.DNS.Decode+import Network.DNS.Decode.Internal+import Network.DNS.Encode+import Network.DNS.Encode.Internal+import Network.DNS.Imports+import Network.DNS.Types++spec :: Spec+spec = do+    prop "IPv4" . forAll genIPv4 $ \ ip4 -> do+        let str = show ip4+        read str `shouldBe` ip4+        show (read str :: IPv4) `shouldBe` str++    prop "IPv6" . forAll genIPv6 $ \ ip6 -> do+        let str = show ip6+        read str `shouldBe` ip6+        show (read str :: IPv6) `shouldBe` str++    prop "TYPE" . forAll genTYPE $ \ t ->+        toTYPE (fromTYPE t) `shouldBe` t++    prop "Domain" . forAll genDomain $ \ dom -> do+        let bs = encodeDomain dom+        decodeDomain bs `shouldBe` Right dom+        fmap encodeDomain (decodeDomain bs) `shouldBe` Right bs++    prop "Mailbox" . forAll genMailbox $ \ dom -> do+        let bs = encodeMailbox dom+        decodeMailbox bs `shouldBe` Right dom+        fmap encodeMailbox (decodeMailbox bs) `shouldBe` Right bs++    prop "DNSFlags" . forAll (genDNSFlags 0x0f) $ \ flgs -> do+        let bs = encodeDNSFlags flgs+        decodeDNSFlags bs `shouldBe` Right flgs+        fmap encodeDNSFlags (decodeDNSFlags bs) `shouldBe` Right bs++    prop "ResourceRecord" . forAll genResourceRecord $ \ rr -> do+        let bs = encodeResourceRecord rr+        decodeResourceRecord bs `shouldBe` Right rr+        fmap encodeResourceRecord (decodeResourceRecord bs) `shouldBe` Right bs++    prop "DNSHeader" . forAll (genDNSHeader 0x0f) $ \ hdr ->+        decodeDNSHeader (encodeDNSHeader hdr) `shouldBe` Right hdr++    prop "DNSMessage" . forAll genDNSMessage $ \ msg ->+        decode (encode msg) `shouldBe` Right msg++    prop "EDNS" . forAll genEDNSHeader $ \(edns, hdr) -> do+        let eh = EDNSheader edns+            Right m = decode. encode $ DNSMessage hdr eh [] [] [] []+        ednsHeader m `shouldBe` eh++----------------------------------------------------------------++genDNSMessage :: Gen DNSMessage+genDNSMessage =+    DNSMessage <$> genDNSHeader 0x0f <*> makeEDNS <*> listOf genQuestion+               <*> listOf genResourceRecord  <*> listOf genResourceRecord+               <*> listOf genResourceRecord+  where+    makeEDNS :: Gen EDNSheader+    makeEDNS = genBool >>= \t ->+        if t then EDNSheader <$> genEDNS+             else pure NoEDNS+++genQuestion :: Gen Question+genQuestion = Question <$> genDomain <*> genTYPE++genTYPE :: Gen TYPE+genTYPE = frequency+    [ (20, elements+            [ A, AAAA, NS, TXT, MX, CNAME, SOA, PTR, SRV, DNAME, OPT, DS, RRSIG+            , NSEC, DNSKEY, NSEC3, NSEC3PARAM, TLSA, CDS, CDNSKEY, CSYNC+            ])+    , (1, toTYPE <$> genWord16)+    ]++genResourceRecord :: Gen ResourceRecord+genResourceRecord = frequency+    [ (8, genRR)+    ]+  where+    genRR = do+      dom <- genDomain+      t <- elements [A, AAAA, NS, TXT, MX, CNAME, SOA, PTR, SRV, DNAME, DS,+                     TLSA, NSEC, NSEC3]+      ResourceRecord dom t classIN <$> genWord32 <*> mkRData dom t++mkRData :: Domain -> TYPE -> Gen RData+mkRData dom typ =+    case typ of+        A -> RD_A <$> genIPv4+        AAAA -> RD_AAAA <$> genIPv6+        NS -> pure $ RD_NS dom+        TXT -> RD_TXT <$> genTextString+        MX -> RD_MX <$> genWord16 <*> genDomain+        CNAME -> pure $ RD_CNAME dom+        SOA -> RD_SOA dom <$> genMailbox <*> genWord32 <*> genWord32 <*> genWord32 <*> genWord32 <*> genWord32+        PTR -> RD_PTR <$> genDomain+        SRV -> RD_SRV <$> genWord16 <*> genWord16 <*> genWord16 <*> genDomain+        DNAME -> RD_DNAME <$> genDomain+        DS -> RD_DS <$> genWord16 <*> genWord8 <*> genWord8 <*> genByteString+        NSEC -> RD_NSEC <$> genDomain <*> genNsecTypes+        NSEC3 -> genNSEC3+        TLSA -> RD_TLSA <$> genWord8 <*> genWord8 <*> genWord8 <*> genByteString+        CAA -> RD_CAA <$> genWord8 <*> (CI.mk <$> genByteString) <*> genByteString++        _ -> pure . RD_TXT $ "Unhandled type " <> BS.pack (show typ)+  where+    genNSEC3 = do+        (alg, hlen)  <- elements [(1,32),(2,64)]+        flgs <- elements [0,1]+        iter <- elements [0..100]+        salt <- elements ["", "AB"]+        hash <- B.pack <$> replicateM hlen genWord8+        RD_NSEC3 alg flgs iter salt hash <$> genNsecTypes+    genTextString = do+        len <- elements [0, 1, 63, 255, 256, 511, 512, 1023, 1024]+        B.pack <$> replicateM len genWord8+    genNsecTypes = do+        ntypes <- elements [0..15]+        types <- sequence $ replicate ntypes $ toTYPE <$> elements [1..1024]+        return $ [ the t |+                   t <- types,+                   then group by (fromTYPE t)+                        using groupWith ]++genIPv4 :: Gen IPv4+genIPv4 = toIPv4 <$> replicateM 4 (fromIntegral <$> genWord8)++genIPv6 :: Gen IPv6+genIPv6 = toIPv6 <$> replicateM 8 (fromIntegral <$> genWord16)++genByteString :: Gen BS.ByteString+genByteString = elements+    [ "", "a", "a.b", "abc", "a.b.c", "a\\.b.c", "\\001.a.b", "\\$.a.b" ]++genMboxString :: Gen BS.ByteString+genMboxString = elements+    [ "", "a", "a@b", "abc", "a@b.c", "first.last@example.org" ]++genDomain :: Gen Domain+genDomain = do+    bs <- genByteString+    pure $ bs <> "."++genMailbox :: Gen Mailbox+genMailbox = do+    bs <- genMboxString+    pure $ bs <> "."++genDNSHeader :: Word16 -> Gen DNSHeader+genDNSHeader maxrc = DNSHeader <$> genWord16 <*> genDNSFlags maxrc++genDNSFlags :: Word16 -> Gen DNSFlags+genDNSFlags maxrc =+  DNSFlags <$> genQorR <*> genOPCODE <*> genBool        <*> genBool+           <*> genBool <*> genBool   <*> genRCODE maxrc <*> genBool <*> genBool++genWord16 :: Gen Word16+genWord16 = arbitrary++genWord32 :: Gen Word32+genWord32 = arbitrary++genWord8 :: Gen Word8+genWord8 = arbitrary++genBool :: Gen Bool+genBool = elements [True, False]++genQorR :: Gen QorR+genQorR = elements [minBound .. maxBound]++genOPCODE :: Gen OPCODE+genOPCODE  = elements [OP_STD, OP_INV, OP_SSR, OP_NOTIFY, OP_UPDATE]++genRCODE :: Word16 -> Gen RCODE+genRCODE maxrc = elements $ map toRCODE [0..maxrc]++genEDNS :: Gen EDNS+genEDNS = do+    vers <- genWord8+    ok <- genBool+    od <- genOData+    us <- elements [minUdpSize..maxUdpSize]+    return $ defaultEDNS {+        ednsVersion  = vers+      , ednsUdpSize  = us+      , ednsDnssecOk = ok+      , ednsOptions  = [od]+      }++genOData :: Gen OData+genOData = oneof+    [ genOD_Unknown+    , genOD_ECS+    ]+  where+    -- | Choose from the range reserved for local use+    -- https://tools.ietf.org/html/rfc6891#section-9+    genOD_Unknown = UnknownOData <$> elements [65001, 65534] <*> genByteString++    -- | Only valid ECS prefixes round-trip, make sure the prefix is+    -- is consistent with the mask.+    genOD_ECS = do+        usev4 <- genBool+        if usev4+        then genFuzzed genIPv4 IPv4 Data.IP.fromIPv4  1 32+        else genFuzzed genIPv6 IPv6 Data.IP.fromIPv6b 2 128+      where+        genFuzzed :: Addr a+                  => Gen a+                  -> (a -> IP)+                  -> (a -> [Int])+                  -> Word16+                  -> Word8+                  -> Gen OData+        genFuzzed gen toIP toBytes fam alen = do+            ip <- gen+            bits1 <- elements [1 .. alen]+            bits2 <- elements [0 .. alen]+            fuzzSrcBits <- genBool+            fuzzScpBits <- genBool+            srcBits <- if not fuzzSrcBits+                       then pure bits1+                       else flip mod alen. (+) bits1 <$> elements [1..alen-1]+            scpBits <- if not fuzzScpBits+                       then pure bits2+                       else elements [alen+1 .. 0xFF]+            let addr  = Data.IP.addr. makeAddrRange ip $ fromIntegral bits1+                bytes = map fromIntegral $ toBytes addr+                len   = (fromIntegral bits1 + 7) `div` 8+                less  = take (len - 1) bytes+                more  = less ++ [0xFF]+            if srcBits == bits1+            then if scpBits == bits2+                 then pure $ OD_ClientSubnet bits1 scpBits $ toIP addr+                 else pure $ OD_ECSgeneric fam bits1 scpBits $ B.pack bytes+            else if srcBits < bits1+                 then pure $ OD_ECSgeneric fam srcBits scpBits $ B.pack more+                 else pure $ OD_ECSgeneric fam srcBits scpBits $ B.pack less++genExtRCODE :: Gen RCODE+genExtRCODE = elements $ map toRCODE [0..4095]++genEDNSHeader :: Gen (EDNS, DNSHeader)+genEDNSHeader = do+    edns <- genEDNS+    hdr <- genDNSHeader 0xF00+    return (edns, hdr)
+ test2/IOSpec.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE OverloadedStrings #-}++module IOSpec where++import Network.Socket hiding (send)+import Test.Hspec++import Network.DNS.IO as DNS+import Network.DNS.Imports+import Network.DNS.Types as DNS++spec :: Spec+spec = describe "send/receive" $ do++    it "resolves well with UDP" $ do+        sock <- connectedSocket Datagram+        -- Google's resolvers support the AD and CD bits+        let qry = encodeQuestion 1 (Question "www.mew.org" A) $+                  adFlag FlagSet <> ednsEnabled FlagClear+        send sock qry+        ans <- receive sock+        identifier (header ans) `shouldBe` 1++    it "resolves well with TCP" $ do+        sock <- connectedSocket Stream+        let qry = encodeQuestion 1 (Question "www.mew.org" A) $+                  adFlag FlagClear <> cdFlag FlagSet <> doFlag FlagSet+        sendVC sock qry+        ans <- receiveVC sock+        identifier (header ans) `shouldBe` 1++connectedSocket :: SocketType -> IO Socket+connectedSocket typ = do+    let hints = defaultHints { addrFamily = AF_INET, addrSocketType = typ, addrFlags = [AI_NUMERICHOST]}+    addr:_ <- getAddrInfo (Just hints) (Just "8.8.8.8") (Just "domain")+    sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)+    connect sock $ addrAddress addr+    return sock
test2/LookupSpec.hs view
@@ -2,66 +2,58 @@  module LookupSpec where -import Control.Applicative-import qualified Data.ByteString.Char8 as BS-import Data.List-import Network.DNS as DNS import Test.Hspec +import Network.DNS as DNS+ spec :: Spec-spec = do-    describe "lookupA" $ do-        it "gets IPv4 addresses" $ do-            rs <- makeResolvSeed defaultResolvConf-            withResolver rs $ \resolver ->-                DNS.lookupA resolver "www.mew.org" `shouldReturn` Just ["202.232.15.101"]+spec = describe "lookup" $ do -        it "gets IPv4 addresses via CNAME" $ do-            rs <- makeResolvSeed defaultResolvConf-            withResolver rs $ \resolver ->-                DNS.lookupA resolver "www.kame.net" `shouldReturn` Just ["203.178.141.194"]+    it "lookupA" $ do+        rs <- makeResolvSeed defaultResolvConf+        withResolver rs $ \resolver -> do+            addrs <- DNS.lookupA resolver "mew.org"+            -- mew.org has one or more IPv6 addresses+            fmap null addrs `shouldBe` Right False -    describe "lookupAAAA" $ do-        it "gets IPv6 addresses" $ do-            rs <- makeResolvSeed defaultResolvConf-            withResolver rs $ \resolver -> do-                DNS.lookupAAAA resolver "mew.org" `shouldReturn` Nothing-                DNS.lookupAAAA resolver "www.mew.org" `shouldReturn` Just ["2001:240:11e:c00::101"]+    it "lookupAAAA" $ do+        rs <- makeResolvSeed defaultResolvConf+        withResolver rs $ \resolver -> do+            -- google.com has one or more IPv6 addresses+            addrs <- DNS.lookupAAAA resolver "google.com"+            fmap null addrs `shouldBe` Right False -    describe "lookupNS" $ do-        it "gets NS" $ do-            rs <- makeResolvSeed defaultResolvConf-            withResolver rs $ \resolver -> do-                actual <- DNS.lookupNS resolver "mew.org"-                let expected = Just ["ns1.mew.org.", "ns2.mew.org."]-                -- The order of NS records is variable, so we sort the-                -- result.-                sort <$> actual `shouldBe` expected+    it "lookupAAAA with emty result" $ do+        rs <- makeResolvSeed defaultResolvConf+        withResolver rs $ \resolver -> do+            addrs <- DNS.lookupAAAA resolver "ipv4.tlund.se"+            -- mew.org does not have any IPv6 addresses+            fmap null addrs `shouldBe` Right True -    describe "lookupTXT" $ do-        it "gets TXT" $ do-            rs <- makeResolvSeed defaultResolvConf-            withResolver rs $ \resolver ->-                DNS.lookupTXT resolver "mew.org" `shouldReturn` Just ["v=spf1 +mx -all"]+    it "lookupMX" $ do+        rs <- makeResolvSeed defaultResolvConf+        withResolver rs $ \resolver -> do+            addrs <- DNS.lookupMX resolver "mew.org"+            -- mew.org has one or more MX records.+            fmap null addrs `shouldBe` Right False -    describe "lookupAviaMX" $ do-        it "gets IPv4 addresses via MX" $ do-            rs <- makeResolvSeed defaultResolvConf-            withResolver rs $ \resolver -> do-                as <- DNS.lookupAviaMX resolver "mixi.jp"-                sort <$> as `shouldBe` Just ["202.32.29.4", "202.32.29.5"]+    it "lookupTXT" $ do+        rs <- makeResolvSeed defaultResolvConf+        withResolver rs $ \resolver -> do+            addrs <- DNS.lookupTXT resolver "mew.org"+            -- mew.org has one or more TXT records.+            fmap null addrs `shouldBe` Right False -    describe "lookupPTR" $ do-        it "gets PTR" $ do-            rs <- makeResolvSeed defaultResolvConf-            withResolver rs $ \resolver -> do-                let target = "210.130.137.80"-                    rev = BS.intercalate "." (reverse (BS.split '.' target))-                            `BS.append` ".in-addr.arpa"-                DNS.lookupPTR resolver rev `shouldReturn` Just ["www-v4.iij.ad.jp."]+    it "lookupSOA" $ do+        rs <- makeResolvSeed defaultResolvConf+        withResolver rs $ \resolver -> do+            addrs <- DNS.lookupTXT resolver "mew.org"+            -- mew.org has a SOA record.+            fmap null addrs `shouldBe` Right False -    describe "lookupSRV" $ do-        it "gets SRV" $ do-            rs <- makeResolvSeed defaultResolvConf-            withResolver rs $ \resolver ->-                DNS.lookupSRV resolver "_sip._tcp.cisco.com" `shouldReturn` Just [(1,0,5060,"vcsgw.cisco.com.")]+    it "lookupNS" $ do+        rs <- makeResolvSeed defaultResolvConf+        withResolver rs $ \resolver -> do+            addrs <- DNS.lookupNS resolver "mew.org"+            -- mew.org has one or more NS records.+            fmap null addrs `shouldBe` Right False