dns 3.0.4 → 4.0.0

raw patch · 27 files changed

+3725/−1698 lines, 27 filesdep +arraydep +base16-bytestringdep +hourglassdep −binarydep −safedep −timedep ~basebuild-type:Customsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: array, base16-bytestring, hourglass

Dependencies removed: binary, safe, time

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Changelog.md +135/−0
• Network/DNS.hs +6/−3
• Network/DNS/Base32Hex.hs +50/−0
• Network/DNS/Decode.hs +86/−41
• Network/DNS/Decode/Internal.hs +46/−259
• Network/DNS/Decode/Parsers.hs +470/−0
• Network/DNS/Encode.hs +24/−229
• Network/DNS/Encode/Builders.hs +347/−0
• Network/DNS/Encode/Internal.hs +38/−0
• Network/DNS/IO.hs +94/−101
• Network/DNS/Imports.hs +2/−0
• Network/DNS/Lookup.hs +3/−1
• Network/DNS/LookupRaw.hs +55/−31
• Network/DNS/Memo.hs +26/−5
• Network/DNS/Resolver.hs +2/−6
• Network/DNS/StateBinary.hs +248/−20
• Network/DNS/Transport.hs +78/−55
• Network/DNS/Types.hs +1778/−845
• Network/DNS/Types/Internal.hs +25/−10
• Network/DNS/Utils.hs +4/−9
• Setup.hs +31/−0
• dns.cabal +21/−10
• test/DecodeSpec.hs +12/−3
• test/EncodeSpec.hs +4/−0
• test/RoundTripSpec.hs +114/−47
• test2/IOSpec.hs +16/−10
• test2/doctests.hs +10/−13

@@ -1,3 +1,138 @@+# 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)

@@ -4,7 +4,7 @@ --   convenience. --   Applications will most likely use the high-level interface, while --   library/daemon authors may need to use the lower-level one.---   EDNS0 and TCP fallback are supported.+--   EDNS and TCP fallback are supported. -- --   Examples: --@@ -31,8 +31,8 @@    -- * Middle level   , module Network.DNS.LookupRaw-  -- | This provides 'lookup', 'lookupAuth', or 'lookupRaw' functions-  --   for any resource records.+  -- | This provides the 'lookup', 'lookupAuth', 'lookupRaw' and+  --   'lookupRawCtl' functions for any resource records.    -- * Low level   , module Network.DNS.Encode@@ -53,3 +53,6 @@ import Network.DNS.Resolver import Network.DNS.Types import Network.DNS.Utils++-- $setup+-- >>> :set -XOverloadedStrings

@@ -0,0 +1,50 @@+module Network.DNS.Base32Hex (encode) where++import Control.Monad (when)+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 Data.Bits++-- | 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 #-}

@@ -1,58 +1,103 @@--- | Decoders for DNS.+-- | 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 (-    -- * Decoder-    decode+    -- * Decoding a single DNS message+    decodeAt+  , decode+    -- * Decoding multple length-encoded DNS messages,+    -- e.g., from TCP traffic.+  , decodeManyAt   , decodeMany-    -- ** Decoder for Each Part-  , decodeResourceRecord-  , decodeDNSHeader-  , decodeDNSFlags-  , decodeDomain-  , decodeMailbox   ) where -import Network.DNS.Decode.Internal+import qualified Data.ByteString as B++import Network.DNS.Decode.Parsers import Network.DNS.Imports import Network.DNS.StateBinary import Network.DNS.Types  ---------------------------------------------------------------- --- | Decoding DNS query or response.+-- | 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 :: ByteString -> Either DNSError DNSMessage-decode bs = fst <$> runSGet 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 --- | Parse many length-encoded DNS records, for example, from TCP traffic.+-- | 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 -decodeMany :: ByteString -> Either DNSError ([DNSMessage], ByteString)-decodeMany bs = do+-- | 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+++-- | 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 decode bss+    msgs <- mapM decoder bss     return (msgs, leftovers)   where-    -- Read a list of length-encoded lazy bytestrings+    -- Read a list of length-encoded bytestrings     lengthEncoded :: SGet [ByteString]-    lengthEncoded = many $ do-      len <- getInt16-      getNByteString len---- | Decoding DNS flags.-decodeDNSFlags :: ByteString -> Either DNSError DNSFlags-decodeDNSFlags bs = fst <$> runSGet getDNSFlags bs---- | Decoding DNS header.-decodeDNSHeader :: ByteString -> Either DNSError DNSHeader-decodeDNSHeader bs = fst <$> runSGet getHeader bs---- | Decoding domain.-decodeDomain :: ByteString -> Either DNSError Domain-decodeDomain bs = fst <$> runSGet getDomain bs---- | Decoding mailbox.-decodeMailbox :: ByteString -> Either DNSError Mailbox-decodeMailbox bs = fst <$> runSGet getMailbox bs---- | Decoding resource record.-decodeResourceRecord :: ByteString -> Either DNSError ResourceRecord-decodeResourceRecord bs = fst <$> runSGet getResourceRecord bs+    lengthEncoded = many $ getInt16 >>= getNByteString

@@ -1,277 +1,64 @@-{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_HADDOCK hide #-}  module Network.DNS.Decode.Internal (-    getResponse-  , getDNSFlags-  , getHeader-  , getResourceRecord-  , getResourceRecords-  , getDomain-  , getMailbox+    -- ** Internal message component decoders for tests+    decodeDNSHeader+  , decodeDNSFlags+  , decodeDomain+  , decodeMailbox+  , decodeResourceRecordAt+  , decodeResourceRecord   ) where -import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BS-import Data.IP (IP(..), toIPv4, toIPv6b)-import qualified Safe- import Network.DNS.Imports import Network.DNS.StateBinary import Network.DNS.Types--------------------------------------------------------------------getResponse :: SGet DNSMessage-getResponse = do-    hd <- getHeader-    qdCount <- getInt16-    anCount <- getInt16-    nsCount <- getInt16-    arCount <- getInt16-    DNSMessage hd <$> getQueries qdCount-                  <*> getResourceRecords anCount-                  <*> getResourceRecords nsCount-                  <*> getResourceRecords arCount--------------------------------------------------------------------getDNSFlags :: SGet DNSFlags-getDNSFlags = do-    word <- get16-    maybe (fail $ "Unsupported flags: 0x" ++ showHex word "") pure (toFlags word)-  where-    toFlags :: Word16 -> Maybe DNSFlags-    toFlags flgs = do-      oc <- getOpcode flgs-      let rc = getRcode flgs-      return $ DNSFlags (getQorR flgs)-                        oc-                        (getAuthAnswer flgs)-                        (getTrunCation flgs)-                        (getRecDesired flgs)-                        (getRecAvailable flgs)-                        rc-                        (getAuthenData flgs)-    getQorR w = if testBit w 15 then QR_Response else QR_Query-    getOpcode w = Safe.toEnumMay (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 = toRCODEforHeader $ fromIntegral w-    getAuthenData w = testBit w 5--------------------------------------------------------------------getHeader :: SGet DNSHeader-getHeader =-    DNSHeader <$> decodeIdentifier <*> getDNSFlags-  where-    decodeIdentifier = get16+import Network.DNS.Decode.Parsers  ---------------------------------------------------------------- -getQueries :: Int -> SGet [Question]-getQueries n = replicateM n getQuery--getTYPE :: SGet TYPE-getTYPE = toTYPE <$> get16--getOptCode :: SGet OptCode-getOptCode = toOptCode <$> get16---- XXX: Include the class when implemented, or otherwise perhaps check the--- implicit assumption that the class is classIN.+-- | Decode the 'DNSFlags' field of 'DNSHeader'.  This is an internal function+-- exposed only for testing. ---getQuery :: SGet Question-getQuery = Question <$> getDomain-                    <*> getTYPE-                    <*  ignoreClass--getResourceRecords :: Int -> SGet [ResourceRecord]-getResourceRecords n = replicateM n getResourceRecord--getResourceRecord :: SGet ResourceRecord-getResourceRecord = do-    dom <- getDomain-    typ <- getTYPE-    cls <- decodeCLASS-    ttl <- decodeTTL-    len <- decodeRLen-    dat <- getRData typ len-    return $ ResourceRecord dom typ cls ttl dat-  where-    decodeCLASS = get16-    decodeTTL   = get32-    decodeRLen  = getInt16+decodeDNSFlags :: ByteString -> Either DNSError DNSFlags+decodeDNSFlags bs = fst <$> runSGet getDNSFlags bs -getRData :: TYPE -> Int -> SGet RData-getRData NS _ = RD_NS <$> getDomain-getRData MX _ = RD_MX <$> decodePreference <*> getDomain-  where-    decodePreference = get16-getRData CNAME _ = RD_CNAME <$> getDomain-getRData DNAME _ = RD_DNAME <$> getDomain-getRData TXT len = (RD_TXT . ignoreLength) <$> getNByteString len-  where-    ignoreLength = BS.drop 1-getRData A len-  | len == 4  = (RD_A . toIPv4) <$> getNBytes len-  | otherwise = fail "IPv4 addresses must be 4 bytes long"-getRData AAAA len-  | len == 16 = (RD_AAAA . toIPv6b) <$> getNBytes len-  | otherwise = fail "IPv6 addresses must be 16 bytes long"-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 OPT ol = RD_OPT <$> decode' ol-  where-    decode' :: Int -> SGet [OData]-    decode' l-        | l  < 0 = fail $ "decodeOPTData: length inconsistency (" ++ show l ++ ")"-        | l == 0 = pure []-        | otherwise = do-            optCode <- getOptCode-            optLen <- getInt16-            dat <- getOData optCode optLen-            (dat:) <$> decode' (l - optLen - 4)----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 NULL len = const RD_NULL <$> getNByteString len----getRData DNSKEY len = RD_DNSKEY <$> decodeKeyFlags-                                <*> decodeKeyProto-                                <*> decodeKeyAlg-                                <*> decodeKeyBytes-  where-    decodeKeyFlags  = get16-    decodeKeyProto  = get8-    decodeKeyAlg    = get8-    decodeKeyBytes  = getNByteString (len - 4)----getRData NSEC3PARAM len = RD_NSEC3PARAM <$> decodeHashAlg-                                <*> decodeFlags-                                <*> decodeIterations-                                <*> decodeSalt-  where-    decodeHashAlg    = get8-    decodeFlags      = get8-    decodeIterations = get16-    decodeSalt       = do-        let n = len - 5-        slen <- get8-        guard $ fromIntegral slen == n-        if (n == 0)-        then return B.empty-        else getNByteString n+-- | Decode the 'DNSHeader' of a message.  This is an internal function.+-- exposed only for testing. ---getRData _  len = UnknownRData <$> getNByteString len--getOData :: OptCode -> Int -> SGet OData-getOData ClientSubnet len = do-        fam <- getInt16-        srcMask <- get8-        scpMask <- get8-        rawip <- fmap fromIntegral . B.unpack <$> getNByteString (len - 4) -- 4 = 2 + 1 + 1-        ip <- case fam of-                    1 -> pure . IPv4 . toIPv4 $ take 4 (rawip ++ repeat 0)-                    2 -> pure . IPv6 . toIPv6b $ take 16 (rawip ++ repeat 0)-                    _ -> fail "Unsupported address family"-        pure $ OD_ClientSubnet srcMask scpMask ip-getOData opc len = UnknownOData opc <$> getNByteString len+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 -getDomain :: SGet Domain-getDomain = do-    lim <- B.length <$> getInput-    getDomain' '.' lim 0+-- | Decode a mailbox name (the SOA record /mrname/ 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 -getMailbox :: SGet Mailbox-getMailbox = do-    lim <- B.length <$> getInput-    getDomain' '@' lim 0+-- | Decoding resource records. --- | Get a domain name, using sep1 as the separate between the 1st and 2nd--- label.  Subsequent labels (and always the trailing label) are terminated--- with a ".".-getDomain' :: Char -> Int -> Int -> SGet ByteString-getDomain' sep1 lim loopcnt-  -- 127 is the logical limitation of pointers.-  | loopcnt >= 127 = fail "pointer recursion limit exceeded"-  | otherwise      = do-      pos <- getPosition-      c <- getInt8-      let n = getValue c-      getdomain pos c n-  where-    getdomain pos c n-      | c == 0 = return "." -- Perhaps the root domain?-      | isPointer c = do-          d <- getInt8-          let offset = n * 256 + d-          when (offset >= lim) $ fail "pointer is too large"-          mo <- pop offset-          case mo of-              Nothing -> do-                  target <- B.drop offset <$> getInput-                  case runSGet (getDomain' sep1 lim (loopcnt + 1)) target of-                        Left (DecodeError err) -> fail err-                        Left err               -> fail $ show err-                        Right o  -> push pos (fst o) >> return (fst o)-              Just o -> push pos 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 <- getNByteString n-          ds <- getDomain' '.' lim (loopcnt + 1)-          let dom = case ds of -- avoid trailing ".."-                  "." -> hs `BS.append` "."-                  _   -> hs `BS.append` BS.singleton sep1 `BS.append` 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+-- | 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 -ignoreClass :: SGet ()-ignoreClass = () <$ get16+-- | 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

@@ -0,0 +1,470 @@+{-# LANGUAGE BangPatterns, 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.IP+import Data.IP (IP(..), toIPv4, toIPv6b, makeAddrRange)+import Data.List (partition)++import Network.DNS.Imports+import Network.DNS.StateBinary+import Network.DNS.Types++-- $setup+-- >>> :set -XOverloadedStrings++----------------------------------------------------------------++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 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 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 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 _  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+    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"+          mo <- pop offset+          case mo of+              Nothing -> do+                  msg <- getInput+                  -- Reprocess the same ByteString starting at the pointer+                  -- target (offset).+                  let parser = skipNBytes offset >> getDomain' sep1 offset+                  case runSGet parser msg of+                      Left (DecodeError err) -> failSGet err+                      Left err               -> fail $ show err+                      Right o  -> push pos (fst o) >> return (fst o)+              Just o -> push pos 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

@@ -1,239 +1,34 @@-{-# LANGUAGE RecordWildCards #-}---- | Encoders for DNS.+-- | 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 (-    -- * Encoder+    -- * Encode a DNS query (or response).     encode-    -- ** Encoder for Each Part-  , encodeResourceRecord-  , encodeDNSHeader-  , encodeDNSFlags-  , encodeDomain-  , encodeMailbox   ) where -import Control.Monad.State (State, modify, execState, gets)-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 (IP(..), fromIPv4, fromIPv6b)- import Network.DNS.Imports import Network.DNS.StateBinary import Network.DNS.Types------------------------------------------------------------------+import Network.DNS.Encode.Builders --- | Encoding DNS query or response.+-- | 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---- | Encoding DNS flags.-encodeDNSFlags :: DNSFlags -> ByteString-encodeDNSFlags = runSPut . putDNSFlags---- | Encoding DNS header.-encodeDNSHeader :: DNSHeader -> ByteString-encodeDNSHeader = runSPut . putHeader---- | Encoding domain.-encodeDomain :: Domain -> ByteString-encodeDomain = runSPut . putDomain---- | Encoding mailbox.-encodeMailbox :: Mailbox -> ByteString-encodeMailbox = runSPut . putMailbox---- | Encoding resource record.-encodeResourceRecord :: ResourceRecord -> ByteString-encodeResourceRecord rr = runSPut $ putResourceRecord rr--------------------------------------------------------------------putDNSMessage :: DNSMessage -> SPut-putDNSMessage msg = putHeader hdr-                    <> 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-                                         ]-    hdr = header msg-    qs = question msg-    an = answer msg-    au = authority msg-    ad = additional msg--putHeader :: DNSHeader -> SPut-putHeader hdr = putIdentifier (identifier hdr)-                <> putDNSFlags (flags hdr)-  where-    putIdentifier = put16--putDNSFlags :: DNSFlags -> SPut-putDNSFlags 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 (fromIntegral $ fromRCODEforHeader rcode)-              , 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 (word16 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 ip         -> mconcat $ map putInt8 (fromIPv4 ip)-    RD_AAAA ip      -> mconcat $ map putInt8 (fromIPv6b ip)-    RD_NS dom       -> putDomain dom-    RD_CNAME dom    -> putDomain dom-    RD_DNAME dom    -> putDomain dom-    RD_PTR dom      -> putDomain dom-    RD_MX prf dom   -> mconcat [put16 prf, putDomain dom]-    RD_TXT txt      -> putByteStringWithLength txt-    RD_OPT opts     -> mconcat $ fmap putOData opts-    RD_SOA mn mr serial refresh retry expire min' -> mconcat-        [ putDomain mn-        , putMailbox mr-        , put32 serial-        , put32 refresh-        , put32 retry-        , put32 expire-        , put32 min'-        ]-    RD_SRV prio weight port dom -> mconcat-        [ put16 prio-        , put16 weight-        , put16 port-        , putDomain dom-        ]-    RD_TLSA u s m d -> mconcat-        [ put8 u-        , put8 s-        , put8 m-        , putByteString d-        ]-    RD_DS t a dt dv -> mconcat-        [ put16 t-        , put8 a-        , put8 dt-        , putByteString dv-        ]-    RD_NULL -> pure mempty-    (RD_DNSKEY f p a k) -> mconcat-        [ put16 f-        , put8 p-        , put8 a-        , putByteString k-        ]-    (RD_NSEC3PARAM h f i s) -> mconcat-        [ put8 h-        , put8 f-        , put16 i-        , putByteStringWithLength s-        ]-    UnknownRData bytes -> putByteString bytes--putOData :: OData -> SPut-putOData (OD_ClientSubnet srcNet scpNet ip) =-    let dropZeroes = dropWhileEnd (==0)-        (fam,raw) = case ip of-                        IPv4 ip4 -> (1,dropZeroes $ fromIPv4 ip4)-                        IPv6 ip6 -> (2,dropZeroes $ fromIPv6b ip6)-        dataLen = 2 + 2 + length raw-     in mconcat [ put16 $ fromOptCode ClientSubnet-                , putInt16 dataLen-                , putInt16 fam-                , put8 srcNet-                , put8 scpNet-                , mconcat $ fmap putInt8 raw-                ]-putOData (UnknownOData code bs) =-    mconcat [ put16 $ fromOptCode code-            , putInt16 $ BS.length bs-            , putByteString 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  -> wsPush dom cur >>-                        mconcat [ putPartialDomain hd-                                , putDomain' '.' tl-                                ]-  where-    (hd, tl') = case sep of-        '.' -> BS.break (== '.') dom-        _ | sep `BS.elem` dom -> BS.break (== sep) dom-          | otherwise -> BS.break (== '.') dom-    tl = if BS.null tl' then tl' else BS.drop 1 tl'--putPointer :: Int -> SPut-putPointer pos = putInt16 (pos .|. 0xc000)--putPartialDomain :: Domain -> SPut-putPartialDomain = putByteStringWithLength

@@ -0,0 +1,347 @@+{-# 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 Data.ByteString.Builder as BB+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy.Char8 as LBS+import qualified Data.IP+import Data.List (foldl')+import Data.IP (IP(..), fromIPv4, fromIPv6b, makeAddrRange)+import GHC.Exts (the, groupWith)++import Network.DNS.Imports+import Network.DNS.StateBinary+import Network.DNS.Types++----------------------------------------------------------------++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_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_RRSIG               rrsig -> putRRSIG rrsig+    RD_NSEC           next types -> putDomain next <> putNsecTypes types+    RD_DNSKEY        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+    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+        ]++-- | 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  -> wsPush dom cur >>+                        mconcat [ putPartialDomain hd+                                , putDomain' '.' tl+                                ]+  where+    -- Try with the preferred separator if present, else fall back to '.'.+    (hd, tl) =+        let p = parseLabel (c2w sep) dom+         in if sep /= '.' && BS.null (snd p)+            then parseLabel (c2w '.') dom+            else p+    c2w = fromIntegral . fromEnum++putPointer :: Int -> SPut+putPointer pos = putInt16 (pos .|. 0xc000)++putPartialDomain :: Domain -> SPut+putPartialDomain = putByteStringWithLength

@@ -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++-- | 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@ record.+--+encodeMailbox :: Mailbox -> ByteString+encodeMailbox = runSPut . putMailbox++-- | Encode a ResourceRecord.+encodeResourceRecord :: ResourceRecord -> ByteString+encodeResourceRecord rr = runSPut $ putResourceRecord rr

@@ -2,78 +2,72 @@ {-# LANGUAGE OverloadedStrings #-}  module Network.DNS.IO (-    -- * Receiving from socket+    -- * Receiving DNS messages     receive   , receiveVC-    -- * Sending to socket+    -- * Sending pre-encoded messages   , send   , sendVC-    -- ** Creating Query-  , encodeQuestions-  , composeQuery-  , composeQueryAD-    -- ** Creating Response+  , sendAll+    -- ** Encoding queries for transmission+  , encodeQuestion+  , encodeVC+    -- ** Creating query response messages   , responseA   , responseAAAA   ) where -#if !defined(mingw32_HOST_OS)-#define POSIX-#else-#define WIN-#endif--#if __GLASGOW_HASKELL__ < 709-#define GHC708-#endif- import qualified Control.Exception as E+import Control.Monad (void)+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.Char (ord) import Data.IP (IPv4, IPv6)+import Time.System (timeCurrent)+import Time.Types (Elapsed(..), Seconds(..)) import Network.Socket (Socket)+import Network.Socket.ByteString (recv)+import qualified Network.Socket.ByteString as Socket import System.IO.Error  -#if defined(WIN) && defined(GHC708)-import Network.Socket (send, recv)-import qualified Data.ByteString.Char8 as BS-#else-import Network.Socket.ByteString (sendAll, recv)-#endif--import Network.DNS.Decode (decode)+import Network.DNS.Decode (decodeAt) import Network.DNS.Encode (encode) import Network.DNS.Imports import Network.DNS.Types  ---------------------------------------------------------------- --- | Receiving DNS data from 'Socket' and parse it.-+-- | 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.+-- receive :: Socket -> IO DNSMessage receive sock = do     let bufsiz = fromIntegral maxUdpSize     bs <- recv sock bufsiz `E.catch` \e -> E.throwIO $ NetworkFailure e-    case decode bs of+    Elapsed (Seconds now) <- timeCurrent+    case decodeAt now bs of         Left  e   -> E.throwIO e         Right msg -> return msg --- | Receive and parse a single virtual-circuit (TCP) query or response.---   It is up to the caller to implement any desired timeout.-+-- | 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-    case decode bs of+    Elapsed (Seconds now) <- timeCurrent+    case decodeAt now bs of         Left e    -> E.throwIO e         Right msg -> return msg   where-    toLen bs = case map ord $ BS.unpack bs of-        [hi, lo] -> 256 * hi + lo+    toLen bs = case B.unpack bs of+        [hi, lo] -> 256 * (fromIntegral hi) + (fromIntegral lo)         _        -> 0              -- never reached  recvDNS :: Socket -> Int -> IO ByteString@@ -103,83 +97,82 @@  ---------------------------------------------------------------- --- | Sending composed query or response to 'Socket'.+-- | 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 sock legacyQuery = sendAll sock legacyQuery+send = (void .). Socket.send+{-# INLINE send #-} --- | Sending composed query or response to a single virtual-circuit (TCP).+-- | 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 vc legacyQuery = sendAll vc $ encodeVC legacyQuery---- | Encoding for virtual circuit.-encodeVC :: ByteString -> ByteString-encodeVC legacyQuery =-    let len = LBS.toStrict . BB.toLazyByteString $ BB.int16BE $ fromIntegral $ BS.length legacyQuery-    in len <> legacyQuery+sendVC = (. encodeVC). sendAll+{-# INLINE sendVC #-} -#if defined(WIN) && defined(GHC708)--- Windows does not support sendAll in Network.ByteString for older GHCs.+-- | 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 sock bs = do-  sent <- send sock (BS.unpack bs)-  when (sent < fromIntegral (BS.length bs)) $ sendAll sock (BS.drop (fromIntegral sent) bs)-#endif------------------------------------------------------------------+sendAll = Socket.sendAll+{-# INLINE sendAll #-} --- | Creating query.-encodeQuestions :: Identifier-                -> [Question]-                -> [ResourceRecord] -- ^ Additional RRs for EDNS.-                -> Bool             -- ^ Authentication+-- | 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-encodeQuestions idt qs adds auth = encode qry-  where-      hdr = header defaultQuery-      flg = flags hdr-      qry = defaultQuery {-          header = hdr {-              identifier = idt,-              flags = flg {-                  authenData = auth-              }-           }-        , question = qs-        , additional = adds-        }--{-# DEPRECATED composeQuery "Use encodeQuestions instead" #-}--- | Composing query without EDNS0.-composeQuery :: Identifier -> [Question] -> ByteString-composeQuery idt qs = encodeQuestions idt qs [] False+encodeQuestion idt q ctls = encode $ makeQuery idt q ctls -{-# DEPRECATED composeQueryAD "Use encodeQuestions instead" #-}--- | Composing query with authentic data flag set without EDNS0.-composeQueryAD :: Identifier -> [Question] -> ByteString-composeQueryAD idt qs = encodeQuestions idt qs [] True+-- | 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 #-}  ---------------------------------------------------------------- --- | Composing a response from IPv4 addresses+-- | 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 ident q ips =-  let hd = header defaultResponse-      dom = qname q-      an = ResourceRecord dom A classIN 300 . RD_A <$> ips-  in  defaultResponse {-          header = hd { identifier=ident }-        , question = [q]-        , answer = an-      }+responseA idt q ips = makeResponse idt q as+  where+    dom = qname q+    as  = ResourceRecord dom A classIN 300 . RD_A <$> ips --- | Composing a response from IPv6 addresses+-- | 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 ident q ips =-  let hd = header defaultResponse-      dom = qname q-      an = ResourceRecord dom AAAA classIN 300 . RD_AAAA <$> ips-  in  defaultResponse {-          header = hd { identifier=ident }-        , question = [q]-        , answer = an-      }+responseAAAA idt q ips = makeResponse idt q as+  where+    dom = qname q+    as  = ResourceRecord dom AAAA classIN 300 . RD_AAAA <$> ips

@@ -1,5 +1,6 @@ module Network.DNS.Imports (     ByteString+  , Int64   , NonEmpty(..)   , module Control.Applicative   , module Control.Monad@@ -17,6 +18,7 @@ import Control.Monad import Data.Bits import Data.ByteString (ByteString)+import Data.Int (Int64) import Data.List import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe

@@ -58,7 +58,7 @@ --   for more information. In the following examples, --   we assuem this extension is enabled. -----   All lookup functions eventually call 'lookupRaw'. See its manual+--   All lookup functions eventually call 'lookupRaw'. See its documentation --   to understand the concrete lookup behavior. module Network.DNS.Lookup (     lookupA, lookupAAAA@@ -80,6 +80,8 @@ import Network.DNS.Resolver as DNS import Network.DNS.Types +-- $setup+-- >>> :set -XOverloadedStrings  ---------------------------------------------------------------- 

@@ -1,17 +1,18 @@ {-# LANGUAGE RecordWildCards #-}  module Network.DNS.LookupRaw (-  -- * Looking up functions+  -- * Lookups returning requested RData     lookup   , lookupAuth-  -- * Raw looking up function+  -- * Lookups returning DNS Messages   , lookupRaw-  , lookupRawAD+  , lookupRawCtl+  -- * DNS Message procesing   , fromDNSMessage-  , fromDNSFormat   ) where -import Data.Time (getCurrentTime, addUTCTime)+import Data.Hourglass (timeAdd, Seconds)+import Time.System (timeCurrent) import Prelude hiding (lookup)  import Network.DNS.IO@@ -22,6 +23,7 @@ import Network.DNS.Types.Internal  -- $setup+-- >>> :set -XOverloadedStrings -- >>> import Network.DNS.Resolver  ----------------------------------------------------------------@@ -29,7 +31,7 @@ -- | Look up resource records of a specified type for a domain, --   collecting the results --   from the ANSWER section of the response.---   See manual the manual of 'lookupRaw'+--   See the documentation of 'lookupRaw' --   to understand the concrete behavior. --   Cache is used if 'resolvCache' is 'Just'. --@@ -45,7 +47,7 @@ -- | Look up resource records of a specified type for a domain, --   collecting the results --   from the AUTHORITY section of the response.---   See manual the manual of 'lookupRaw'+--   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])@@ -134,9 +136,11 @@  insertPositive :: CacheConf -> Cache -> Key -> Entry -> TTL -> IO () insertPositive CacheConf{..} c k v ttl = when (ttl /= 0) $ do-    tim <- addUTCTime life <$> getCurrentTime+    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 ()@@ -148,9 +152,11 @@  insertNegative :: CacheConf -> Cache -> Key -> Entry -> TTL -> IO () insertNegative CacheConf{..} c k v ttl = when (ttl /= 0) $ do-    tim <- addUTCTime life <$> getCurrentTime+    ctime <- timeCurrent+    let tim = ctime `timeAdd` life     insertCache k tim v c   where+    life :: Seconds     life = fromIntegral ttl  isTypeOf :: TYPE -> ResourceRecord -> Bool@@ -158,23 +164,23 @@  ---------------------------------------------------------------- --- | Look up a name and return the entire DNS Response+-- | Look up a name and return the entire DNS Response. -----  For a given DNS server, the queries are done:+-- 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 EDNS0 if specifiecd).---    If it appear that the target DNS server does not support EDNS0,+--    (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---    locla port is created. Then exactly one TCP query is retried.+--    local port is created. Then exactly one TCP query is retried. -- ----- If multiple DNS server are specified 'ResolvConf' ('RCHostNames ')+-- If multiple DNS servers are specified 'ResolvConf' ('RCHostNames ') -- or found ('RCFilePath'), either sequential lookup or -- concurrent lookup is carried out: --@@ -191,6 +197,7 @@ -- --  Cache is not used even if 'resolvCache' is 'Just'. --+-- --   The example code: -- --   @@@ -226,21 +233,42 @@ --             additional = []}) --  @ ---lookupRaw :: Resolver -> Domain -> TYPE -> IO (Either DNSError DNSMessage)-lookupRaw rslv dom typ = resolve dom typ rslv False receive+--  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 --- | Same as 'lookupRaw' but the query sets the AD bit, which solicits the---   the authentication status in the server reply.  In most applications---   (other than diagnostic tools) that want authenticated data It is---   unwise to trust the AD bit in the responses of non-local servers, this---   interface should in most cases only be used with a loopback resolver.+-- | 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. ---lookupRawAD :: Resolver -> Domain -> TYPE -> IO (Either DNSError DNSMessage)-lookupRawAD rslv dom typ = resolve dom typ rslv True receive+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 dom typ rslv ctls receive  ---------------------------------------------------------------- --- | Extract necessary information from 'DNSMessage'+-- | 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@@ -249,12 +277,8 @@     NameErr   -> Left NameError     NotImpl   -> Left NotImplemented     Refused   -> Left OperationRefused-    BadOpt    -> Left BadOptRecord+    BadVers   -> Left BadOptRecord+    BadRCODE  -> Left $ DecodeError "Malformed EDNS message"     _         -> Left UnknownDNSError   where     errcode = rcode . flags . header--{-# DEPRECATED fromDNSFormat "Use fromDNSMessage instead" #-}--- | For backward compatibility.-fromDNSFormat :: DNSMessage -> (DNSMessage -> a) -> Either DNSError a-fromDNSFormat = fromDNSMessage

@@ -1,10 +1,13 @@+{-# LANGUAGE RecordWildCards #-}+ module Network.DNS.Memo where  import qualified Control.Reaper as R import qualified Data.ByteString as B+import Data.Hourglass (Elapsed) import Data.OrdPSQ (OrdPSQ) import qualified Data.OrdPSQ as PSQ-import Data.Time (UTCTime, getCurrentTime)+import Time.System (timeCurrent)  import Network.DNS.Imports import Network.DNS.Types@@ -13,7 +16,7 @@  type Key = (ByteString            ,TYPE)-type Prio = UTCTime+type Prio = Elapsed  type Entry = Either DNSError [RData] @@ -46,7 +49,7 @@ -- functions. So, we need to do this redundant way. prune :: DB -> IO (DB -> DB) prune oldpsq = do-    tim <- getCurrentTime+    tim <- timeCurrent     let (_, pruned) = PSQ.atMostView tim oldpsq     return $ \newpsq -> foldl' ins pruned $ PSQ.toList newpsq   where@@ -58,7 +61,7 @@ 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              = RD_NULL+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 r@(RD_AAAA _)        = r@@ -66,11 +69,29 @@ 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_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_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 (UnknownRData is)    = UnknownRData $ B.copy is  copyOData :: OData -> OData-copyOData o@(OD_ClientSubnet _ _ _) = o+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

@@ -11,9 +11,9 @@   , resolvInfo   , resolvTimeout   , resolvRetry-  , resolvEDNS   , resolvConcurrent   , resolvCache+  , resolvQueryControls   -- ** Specifying DNS servers   , FileOrNumericHost(..)   -- ** Configuring cache@@ -36,10 +36,6 @@ #define WIN #endif -#if __GLASGOW_HASKELL__ < 709-#define GHC708-#endif- import Control.Exception as E import qualified Crypto.Random as C import qualified Data.ByteString as BS@@ -47,7 +43,7 @@ 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 hiding (lookup)+import Prelude  #if defined(WIN) import qualified Data.List.Split as Split

@@ -1,5 +1,7 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Network.DNS.StateBinary (     PState(..)@@ -13,9 +15,14 @@   , putInt16   , putInt32   , putByteString+  , putReplicate   , SGet+  , failSGet+  , fitSGet   , runSGet+  , runSGetAt   , runSGetWithLeftovers+  , runSGetWithLeftoversAt   , get8   , get16   , get32@@ -23,8 +30,10 @@   , getInt16   , getInt32   , getNByteString+  , sGetMany   , getPosition   , getInput+  , getAtTime   , wsPop   , wsPush   , wsPosition@@ -32,15 +41,22 @@   , push   , pop   , getNBytes+  , getNoctets+  , skipNBytes+  , parseLabel+  , unparseLabel   ) where -import Control.Monad.State (State, StateT)-import qualified Control.Monad.State as ST+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 qualified Data.ByteString.Char8 as S8 import Data.ByteString.Builder (Builder) import qualified Data.ByteString.Builder as BB+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@@ -93,6 +109,10 @@ 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@@ -124,28 +144,36 @@     psDomain :: IntMap Domain   , psPosition :: Int   , psInput :: ByteString+  , psAtTime  :: Int64   }  ----------------------------------------------------------------  getPosition :: SGet Int-getPosition = psPosition <$> ST.get+getPosition = ST.gets psPosition  getInput :: SGet ByteString-getInput = psInput <$> ST.get+getInput = ST.gets psInput +getAtTime :: SGet Int64+getAtTime = ST.gets psAtTime+ addPosition :: Int -> SGet ()-addPosition n = do-    PState dom pos inp <- ST.get-    ST.put $ PState dom (pos + n) inp+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 <- ST.get-    ST.put $ PState (IM.insert n d dom) pos inp+    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 = IM.lookup n . psDomain <$> ST.get+pop n = ST.gets (IM.lookup n . psDomain)  ---------------------------------------------------------------- @@ -183,34 +211,234 @@  ---------------------------------------------------------------- +overrun :: SGet a+overrun = failSGet "malformed or truncated input"+ getNBytes :: Int -> SGet [Int]-getNBytes len = toInts <$> getNByteString len+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 = ST.lift (A.take n) <* addPosition n+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)+ ---------------------------------------------------------------- -initialState :: ByteString -> PState-initialState inp = PState IM.empty 0 inp+-- | 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 -runSGet :: SGet a -> ByteString -> Either DNSError (a, PState)-runSGet parser inp = toResult $ A.parse (ST.runStateT parser $ initialState inp) inp+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 _ _ msg)    = Left $ DecodeError msg+    toResult (A.Fail _ ctx msg)  = Left $ DecodeError $ head $ ctx ++ [msg]     toResult (A.Partial _)       = Left $ DecodeError "incomplete input" -runSGetWithLeftovers :: SGet a -> ByteString -> Either DNSError ((a, PState), ByteString)-runSGetWithLeftovers parser inp = toResult $ A.parse (ST.runStateT parser $ initialState inp) inp+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 _ _ err) = Left $ DecodeError err+    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.+--+-- This function is pure, but is not total, it throws an error when presented+-- with malformed input+--+parseLabel :: Word8 -> ByteString -> (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 = r+                     | otherwise = bottom+    bottom = E.throw $ 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

@@ -22,29 +22,37 @@ -- | 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 resp =-   (identifier (header resp) == seqno) && (q == (question resp))+checkResp :: Question -> Identifier -> DNSMessage -> Bool+checkResp q seqno = isNothing . checkRespM q seqno +checkRespM :: Question -> Identifier -> DNSMessage -> Maybe DNSError+checkRespM q seqno resp+  | identifier (header resp) /= seqno = Just SequenceNumberMismatch+  | [q] /= question resp              = Just QuestionMismatch+  | otherwise                         = Nothing+ ----------------------------------------------------------------  data TCPFallback = TCPFallback deriving (Show, Typeable) instance Exception TCPFallback -type Rslv0 = Bool -> (Socket -> IO DNSMessage)+type Rslv0 = QueryControls -> (Socket -> IO DNSMessage)            -> IO (Either DNSError DNSMessage) -type Rslv1 = [Question]-          -> [ResourceRecord]+type Rslv1 = Question           -> Int -- Timeout           -> Int -- Retry           -> Rslv0 -type TcpRslv = Identifier -> AddrInfo -> [Question] -> Int -- Timeout-            -> Bool -> IO DNSMessage+type TcpRslv = AddrInfo+            -> Question+            -> Int -- Timeout+            -> QueryControls+            -> IO DNSMessage -type UdpRslv = [ResourceRecord] -> Int -- Retry-            -> (Socket -> IO DNSMessage) -> TcpRslv+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.@@ -60,58 +68,67 @@ -- -- 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 :: Domain -> TYPE -> Resolver -> Rslv0-resolve dom typ rlv ad rcv+resolve dom typ rlv qctls rcv   | isIllegal dom = return $ Left IllegalDomain-  | onlyOne       = resolveOne        (head nss) (head gens) q edns tm retry ad rcv-  | concurrent    = resolveConcurrent nss        gens        q edns tm retry ad rcv-  | otherwise     = resolveSequential nss        gens        q edns tm retry ad rcv+  | 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]+          '.' -> 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-    edns       = resolvEDNS conf + resolveSequential :: [AddrInfo] -> [IO Identifier] -> Rslv1-resolveSequential nss gs q edns tm retry ad rcv = loop nss gs+resolveSequential nss gs q tm retry ctls rcv = loop nss gs   where-    loop [ai]     [gen] = resolveOne ai gen q edns tm retry ad rcv+    loop [ai]     [gen] = resolveOne ai gen q tm retry ctls rcv     loop (ai:ais) (gen:gens) = do-        eres <- resolveOne ai gen q edns tm retry ad rcv+        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 edns tm retry ad rcv = do+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 edns tm retry ad rcv+    mkAsync (ai,gen) = async $ resolveOne ai gen q tm retry ctls rcv  resolveOne :: AddrInfo -> IO Identifier -> Rslv1-resolveOne ai gen q edns tm retry ad rcv = do-    ident <- gen-    E.try $ udpTcpLookup edns retry rcv ident ai q tm ad+resolveOne ai gen q tm retry ctls rcv =+    E.try $ udpTcpLookup gen retry rcv ai q tm ctls  ---------------------------------------------------------------- -udpTcpLookup :: UdpRslv-udpTcpLookup edns retry rcv ident ai q tm ad =-    udpLookup edns retry rcv ident ai q tm ad `E.catch` \TCPFallback ->-        tcpLookup ident ai q tm ad+-- 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  ---------------------------------------------------------------- @@ -129,30 +146,29 @@     return sock  -- This throws DNSError or TCPFallback.-udpLookup :: UdpRslv-udpLookup edns retry rcv ident ai q tm ad = do-    let qry = encodeQuestions ident q edns ad-        ednsRetry = not $ null edns+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 ednsRetry 0 RetryLimitExceeded)+      bracket (udpOpen ai) close (loop qry ctls 0 RetryLimitExceeded)   where-    loop qry ednsRetry cnt err sock+    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 ednsRetry (cnt + 1) RetryLimitExceeded sock+              Nothing  -> loop qry lctls (cnt + 1) RetryLimitExceeded sock               Just res -> do-                      let flgs = flags$ header res-                          truncated = trunCation flgs-                          rc = rcode flgs-                      if truncated then-                          E.throwIO TCPFallback-                      else if ednsRetry && rc == FormatErr then-                          let nonednsQuery = encodeQuestions ident q [] ad-                          in loop nonednsQuery False cnt RetryLimitExceeded sock-                      else-                          return res+                      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.@@ -179,22 +195,29 @@ -- Perform a DNS query over TCP, if we were successful in creating -- the TCP socket. -- This throws DNSError only.-tcpLookup :: TcpRslv-tcpLookup ident ai q tm ad =-    E.handle (ioErrorToDNSError ai "TCP") $ bracket (tcpOpen addr) close perform+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 vc = do-        let qry = encodeQuestions ident q [] ad+    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-                | checkResp q ident res -> return res-                | otherwise             -> E.throwIO SequenceNumberMismatch+            Nothing  -> E.throwIO TimeoutExpired+            Just res -> maybe (return res) E.throwIO (checkRespM q ident res)  ---------------------------------------------------------------- 

@@ -1,848 +1,1781 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}---- | Data types for DNS Query and Response.---   For more information, see <http://www.ietf.org/rfc/rfc1035>.--module Network.DNS.Types (-  -- * Resource Records-    ResourceRecord (..)-  -- ** 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-  , ANY-  )-  , fromTYPE-  , toTYPE-  -- ** Resource Data-  , RData (..)-  -- * DNS Message-  , DNSMessage (..)-  , defaultQuery-  , defaultResponse-  , DNSFormat-  -- ** DNS Header-  , DNSHeader (..)-  , Identifier-  , QorR (..)-  , DNSFlags (..)-  , OPCODE (..)-  , RCODE (-    NoErr-  , FormatErr-  , ServFail-  , NameErr-  , NotImpl-  , Refused-  , YXDomain-  , YXRRSet-  , NXRRSet-  , NotAuth-  , NotZone-  , BadOpt-  )-  , fromRCODE-  , toRCODE-  , fromRCODEforHeader-  , toRCODEforHeader-  -- ** DNS Body-  , Question (..)-  -- * DNS Error-  , DNSError (..)-  -- * EDNS0-  , EDNS0-  , defaultEDNS0-  , maxUdpSize-  , minUdpSize-  -- ** Accessors-  , udpSize-  , extRCODE-  , dnssecOk-  , options-  -- ** Converters-  , fromEDNS0-  , toEDNS0-  -- * EDNS0 option data-  , OData (..)-  , OptCode (-    ClientSubnet-  )-  , fromOptCode-  , toOptCode-  -- * Other types-  , Mailbox-  ) where--import Control.Exception (Exception, IOException)-import qualified Data.ByteString.Base64 as B64 (encode)-import qualified Data.ByteString.Char8 as BS-import qualified Data.ByteString.Builder as L-import qualified Data.ByteString.Lazy as L-import Data.IP (IP, IPv4, IPv6)--import Network.DNS.Imports---------------------------------------------------------------------- | Type for domain.-type Domain = ByteString---- | Type for a mailbox encoded on the wire as a DNS name, but the first label--- is conceptually the user name, and sometimes has contains internal periods--- that are not label separators. Therefore, in mailboxes \@ is used as the--- separator between the first and second labels.-type Mailbox = ByteString--------------------------------------------------------------------#if __GLASGOW_HASKELL__ >= 802--- | 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--- | 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--- | A request for all records the server/cache has available-pattern ANY :: TYPE-pattern ANY        = TYPE 255--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 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 ANY        = "ANY"-    show x          = "TYPE " ++ (show $ fromTYPE x)---- | From number to type.-toTYPE :: Word16 -> TYPE-toTYPE = TYPE-#else--- | Types for resource records.-data TYPE = A          -- ^ IPv4 address-          | NS         -- ^ An authoritative name serve-          | CNAME      -- ^ The canonical name for an alias-          | SOA        -- ^ Marks the start of a zone of authority-          | NULL       -- ^ A null RR (EXPERIMENTAL)-          | PTR        -- ^ A domain name pointer-          | MX         -- ^ Mail exchange-          | TXT        -- ^ Text strings-          | AAAA       -- ^ IPv6 Address-          | SRV        -- ^ Server Selection (RFC2782)-          | DNAME      -- ^ DNAME (RFC6672)-          | OPT        -- ^ OPT (RFC6891)-          | DS         -- ^ Delegation Signer (RFC4034)-          | RRSIG      -- ^ RRSIG (RFC4034)-          | NSEC       -- ^ NSEC (RFC4034)-          | DNSKEY     -- ^ DNSKEY (RFC4034)-          | NSEC3      -- ^ NSEC3 (RFC5155)-          | NSEC3PARAM -- ^ NSEC3PARAM (RFC5155)-          | TLSA       -- ^ TLSA (RFC6698)-          | CDS        -- ^ Child DS (RFC7344)-          | CDNSKEY    -- ^ DNSKEY(s) the Child wants reflected in DS (RFC7344)-          | CSYNC      -- ^ Child-To-Parent Synchronization (RFC7477)-          | ANY        -- ^ A request for all records the server/cache-                       --   has available-          | UnknownTYPE Word16  -- ^ Unknown type-          deriving (Eq, Ord, Show, Read)---- | From type to number.-fromTYPE :: TYPE -> Word16-fromTYPE A          =  1-fromTYPE NS         =  2-fromTYPE CNAME      =  5-fromTYPE SOA        =  6-fromTYPE NULL       = 10-fromTYPE PTR        = 12-fromTYPE MX         = 15-fromTYPE TXT        = 16-fromTYPE AAAA       = 28-fromTYPE SRV        = 33-fromTYPE DNAME      = 39-fromTYPE OPT        = 41-fromTYPE DS         = 43-fromTYPE RRSIG      = 46-fromTYPE NSEC       = 47-fromTYPE DNSKEY     = 48-fromTYPE NSEC3      = 50-fromTYPE NSEC3PARAM = 51-fromTYPE TLSA       = 52-fromTYPE CDS        = 59-fromTYPE CDNSKEY    = 60-fromTYPE CSYNC      = 62-fromTYPE ANY        = 255-fromTYPE (UnknownTYPE x) = x---- | From number to type.-toTYPE :: Word16 -> TYPE-toTYPE  1 = A-toTYPE  2 = NS-toTYPE  5 = CNAME-toTYPE  6 = SOA-toTYPE 10 = NULL-toTYPE 12 = PTR-toTYPE 15 = MX-toTYPE 16 = TXT-toTYPE 28 = AAAA-toTYPE 33 = SRV-toTYPE 39 = DNAME-toTYPE 41 = OPT-toTYPE 43 = DS-toTYPE 46 = RRSIG-toTYPE 47 = NSEC-toTYPE 48 = DNSKEY-toTYPE 50 = NSEC3-toTYPE 51 = NSEC3PARAM-toTYPE 52 = TLSA-toTYPE 59 = CDS-toTYPE 60 = CDNSKEY-toTYPE 62 = CSYNC-toTYPE 255 = ANY-toTYPE x   = UnknownTYPE x-#endif---------------------------------------------------------------------- | 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 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 detected a malformed OPT RR.-  | BadOptRecord-    -- | Configuration is wrong.-  | BadConfiguration-    -- | Network failure.-  | NetworkFailure IOException-    -- | Error is unknown-  | DecodeError String-  | UnknownDNSError-  deriving (Eq, Show, Typeable)--instance Exception DNSError---- | Raw data format for DNS Query and Response.-data DNSMessage = DNSMessage {-    header     :: DNSHeader        -- ^ Header-  , question   :: [Question]       -- ^ The question for the name server-  , answer     :: [ResourceRecord] -- ^ RRs answering the question-  , authority  :: [ResourceRecord] -- ^ RRs pointing toward an authority-  , additional :: [ResourceRecord] -- ^ RRs holding additional information-  } deriving (Eq, Show)--{-# DEPRECATED DNSFormat "Use DNSMessage instead" #-}--- | For backward compatibility.-type DNSFormat = DNSMessage---- | 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 -- ^ An identifier.-  , flags      :: DNSFlags   -- ^ The second 16bit word.-  } 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   -- ^ Authoritative Answer - 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   -- ^ TrunCation - specifies that this message was truncated-                           -- due to length greater than that permitted on the-                           -- transmission channel.-  , recDesired   :: Bool   -- ^ Recursion Desired - 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   -- ^ Recursion Available - this be is set or cleared in a-                           -- response, and denotes whether recursive query support is-                           -- available in the name server.--  , rcode        :: RCODE  -- ^ Response code.-  , authenData   :: Bool   -- ^ Authentic Data (RFC4035).-  } deriving (Eq, Show)---------------------------------------------------------------------- | 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.-  | OP_SSR -- ^ A server status request.-  deriving (Eq, Show, Enum, Bounded)--------------------------------------------------------------------#if __GLASGOW_HASKELL__ >= 802--- | Response code including EDNS0's 12bit ones.-newtype RCODE = RCODE {-    -- | From rcode to number.-    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 (RFC 6891) or TSIG Signature Failure (RFC2845).-pattern BadOpt    :: RCODE-pattern BadOpt     = RCODE 16---- | 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 BadOpt    = "BADVERS"-    show x         = "RCODE " ++ (show $ fromRCODE x)---- | From number to rcode.-toRCODE :: Word16 -> RCODE-toRCODE = RCODE---- | From rcode to number for header (4bits only).-fromRCODEforHeader :: RCODE -> Word16-fromRCODEforHeader (RCODE w) = w .&. 0x0f---- | From number in header to rcode (4bits only).-toRCODEforHeader :: Word16 -> RCODE-toRCODEforHeader w = RCODE (w .&. 0x0f)-#else--- | Response code.-data RCODE-  = NoErr     -- ^ No error condition.-  | FormatErr -- ^ Format error - The name server was-              --   unable to interpret the query.-  | ServFail  -- ^ Server failure - The name server was-              --   unable to process this query due to a-              --   problem with the name server.-  | NameErr   -- ^ 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.-  | NotImpl   -- ^ Not Implemented - The name server does-              --   not support the requested kind of query.-  | Refused   -- ^ 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.-  | YXDomain  -- ^ Dynamic update response, a pre-requisite-              --   domain that should not exist, does exist.-  | YXRRSet   -- ^ Dynamic update response, a pre-requisite-              --   RRSet that should not exist, does exist.-  | NXRRSet   -- ^ Dynamic update response, a pre-requisite-              --   RRSet that should exist, does not exist.-  | NotAuth   -- ^ Dynamic update response, the server is not-              --   authoritative for the zone named in the Zone Section.-  | NotZone   -- ^ Dynamic update response, a name used in the-              --   Prerequisite or Update Section is not within the zone-              --   denoted by the Zone Section.-  | BadOpt    -- ^ Bad OPT Version (RFC 6891) or TSIG Signature-              --   Failure (RFC2845).-  | UnknownRCODE Word16-  deriving (Eq, Ord, Show)---- | From rcode to number.-fromRCODE :: RCODE -> Word16-fromRCODE NoErr     =  0-fromRCODE FormatErr =  1-fromRCODE ServFail  =  2-fromRCODE NameErr   =  3-fromRCODE NotImpl   =  4-fromRCODE Refused   =  5-fromRCODE YXDomain  =  6-fromRCODE YXRRSet   =  7-fromRCODE NXRRSet   =  8-fromRCODE NotAuth   =  9-fromRCODE NotZone   = 10-fromRCODE BadOpt    = 16-fromRCODE (UnknownRCODE x) = x---- | From number to rcode.-toRCODE :: Word16 -> RCODE-toRCODE  0 = NoErr-toRCODE  1 = FormatErr-toRCODE  2 = ServFail-toRCODE  3 = NameErr-toRCODE  4 = NotImpl-toRCODE  5 = Refused-toRCODE  6 = YXDomain-toRCODE  7 = YXRRSet-toRCODE  8 = NXRRSet-toRCODE  9 = NotAuth-toRCODE 10 = NotZone-toRCODE 16 = BadOpt-toRCODE  x = UnknownRCODE x---- | From rcode to number for header (4bits only).-fromRCODEforHeader :: RCODE -> Word16-fromRCODEforHeader rc = fromRCODE rc .&. 0x0f---- | From number in header to rcode (4bits only).-toRCODEforHeader :: Word16 -> RCODE-toRCODEforHeader w = toRCODE (w .&. 0x0f)-#endif---------------------------------------------------------------------- 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)---- | 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             -- ^ A null RR (EXPERIMENTAL).-                                 -- Anything can be in a NULL record,-                                 -- for now we just drop this data.-           | RD_PTR Domain       -- ^ A domain name pointer-           | RD_MX Word16 Domain -- ^ Mail exchange-           | RD_TXT ByteString   -- ^ Text strings-           | 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_NSEC-           | RD_DNSKEY Word16 Word8 Word8 ByteString-                                 -- ^ DNSKEY (RFC4034)-           --RD_NSEC3-           | RD_NSEC3PARAM Word8 Word8 Word16 ByteString-           | RD_TLSA Word8 Word8 Word8 ByteString-                                 -- ^ TLSA (RFC6698)-           --RD_CDS-           --RD_CDNSKEY-           --RD_CSYNC-           | UnknownRData ByteString   -- ^ Unknown resource data-    deriving (Eq, Ord)--instance Show RData where-  show (RD_NS dom) = BS.unpack dom-  show (RD_MX prf dom) = show prf ++ " " ++ BS.unpack dom-  show (RD_CNAME dom) = BS.unpack dom-  show (RD_DNAME 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 mr serial refresh retry expire mi) = BS.unpack mn ++ " " ++ BS.unpack mr ++ " " ++-                                                       show serial ++ " " ++ show refresh ++ " " ++-                                                       show retry ++ " " ++ show expire ++ " " ++ 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_OPT od) = show od-  show (UnknownRData is) = show is-  show (RD_TLSA use sel mtype dgst) = show use ++ " " ++ show sel ++ " " ++ show mtype ++ " " ++ hexencode dgst-  show (RD_DS t a dt dv) = show t ++ " " ++ show a ++ " " ++ show dt ++ " " ++ hexencode dv-  show RD_NULL = "NULL"-  show (RD_DNSKEY f p a k) = show f ++ " " ++ show p ++ " " ++ show a ++ " " ++ b64encode k-  show (RD_NSEC3PARAM h f i s) = show h ++ " " ++ show f ++ " " ++ show i ++ " " ++ showSalt s-    where-      showSalt ""    = "-"-      showSalt salt  = hexencode salt--hexencode :: ByteString -> String-hexencode = BS.unpack . L.toStrict . L.toLazyByteString . L.byteStringHex--b64encode :: ByteString -> String-b64encode = BS.unpack . B64.encode---------------------------------------------------------------------- | Default query.-defaultQuery :: DNSMessage-defaultQuery = DNSMessage {-    header = DNSHeader {-       identifier = 0-     , flags = DNSFlags {-           qOrR         = QR_Query-         , opcode       = OP_STD-         , authAnswer   = False-         , trunCation   = False-         , recDesired   = True-         , recAvailable = False-         , rcode        = NoErr-         , authenData   = False-         }-     }-  , question   = []-  , answer     = []-  , authority  = []-  , additional = []-  }---- | Default response.-defaultResponse :: DNSMessage-defaultResponse =-  let hd = header defaultQuery-      flg = flags hd-  in  defaultQuery {-        header = hd {-          flags = flg {-              qOrR = QR_Response-            , authAnswer = True-            , recAvailable = True-            , authenData = False-            }-        }-      }--------------------------------------------------------------------- EDNS0 (RFC 6891)--------------------------------------------------------------------- | EDNS0 infromation defined in RFC 6891.-data EDNS0 = EDNS0 {-    -- | UDP payload size.-    udpSize  :: Word16-    -- | Extended RCODE.-  , extRCODE :: RCODE-    -- | Is DNSSEC OK?-  , dnssecOk :: Bool-    -- | EDNS0 option data.-  , options  :: [OData]-  } deriving (Eq, Show)--#if __GLASGOW_HASKELL__ >= 802--- | Default information for EDNS0.------ >>> defaultEDNS0--- EDNS0 {udpSize = 4096, extRCODE = NoError, dnssecOk = False, options = []}-#else--- | Default information for EDNS0.------ >>> defaultEDNS0--- EDNS0 {udpSize = 4096, extRCODE = NoErr, dnssecOk = False, options = []}-#endif-defaultEDNS0 :: EDNS0-defaultEDNS0 = EDNS0 4096 NoErr False []---- | Maximum UDP size. If 'udpSize' of 'EDNS0' is larger than this,---   'fromEDNS0' uses this value instead.------ >>> maxUdpSize--- 16384-maxUdpSize :: Word16-maxUdpSize = 16384---- | Minimum UDP size. If 'udpSize' of 'EDNS0' is smaller than this,---   'fromEDNS0' uses this value instead.------ >>> minUdpSize--- 512-minUdpSize :: Word16-minUdpSize = 512---- | Generating a resource record for the additional section based on EDNS0.--- 'DNSFlags' is not generated.--- Just set the same 'RCODE' to 'DNSFlags'.-fromEDNS0 :: EDNS0 -> ResourceRecord-fromEDNS0 edns = ResourceRecord name' type' class' ttl' rdata'-  where-    name'  = "."-    type'  = OPT-    class' = maxUdpSize `min` (minUdpSize `max` udpSize edns)-    ttl0'   = fromIntegral (fromRCODE (extRCODE edns) .&. 0x0ff0) `shiftL` 20-    ttl'-      | dnssecOk edns = ttl0' `setBit` 15-      | otherwise     = ttl0'-    rdata' = RD_OPT $ options edns---- | Generating EDNS0 information from the OPT RR.-toEDNS0 :: DNSFlags -> ResourceRecord -> Maybe EDNS0-toEDNS0 flgs (ResourceRecord "." OPT udpsiz ttl' (RD_OPT opts)) =-    Just $ EDNS0 udpsiz (toRCODE erc) secok opts-  where-    lp = fromRCODEforHeader $ rcode flgs-    up = shiftR (ttl' .&. 0xff000000) 20-    erc = fromIntegral up .|. lp-    secok = ttl' `testBit` 15-toEDNS0 _ _ = Nothing--------------------------------------------------------------------#if __GLASGOW_HASKELL__ >= 802--- | EDNS0 Option Code (RFC 6891).-newtype OptCode = OptCode {-    -- | From option code to number.-    fromOptCode :: Word16-  } deriving (Eq,Ord)---- | Client subnet (RFC7871)-pattern ClientSubnet :: OptCode-pattern ClientSubnet = OptCode 8--instance Show OptCode where-    show ClientSubnet = "ClientSubnet"-    show x            = "OptCode " ++ (show $ fromOptCode x)---- | From number to option code.-toOptCode :: Word16 -> OptCode-toOptCode = OptCode-#else--- | Option Code (RFC 6891).-data OptCode = ClientSubnet          -- ^ Client subnet (RFC7871)-             | UnknownOptCode Word16 -- ^ Unknown option code-    deriving (Eq, Ord, Show)---- | From option code to number.-fromOptCode :: OptCode -> Word16-fromOptCode ClientSubnet = 8-fromOptCode (UnknownOptCode x) = x---- | From number to option code.-toOptCode :: Word16 -> OptCode-toOptCode 8 = ClientSubnet-toOptCode x = UnknownOptCode x-#endif---------------------------------------------------------------------- | Optional resource data.-data OData = OD_ClientSubnet Word8 Word8 IP   -- ^ Client subnet (RFC7871)-           | UnknownOData OptCode ByteString  -- ^ Unknown optional type-    deriving (Eq,Show,Ord)+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE CPP #-}++-- | Data types for DNS Query and Response.+--   For more information, see <http://www.ietf.org/rfc/rfc1035>.++module Network.DNS.Types (+  -- * 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 (..)+  , Identifier+  -- *** DNS flags+  , DNSFlags (..)+  , QorR (..)+  , defaultDNSFlags+  -- *** OPCODE and RCODE+  , OPCODE (..)+  , 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 (..)+  -- * DNS Error+  , DNSError (..)+  -- * Other types+  , Mailbox+  ) where++import Control.Exception (Exception, IOException)+import Control.Applicative ((<|>))+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BS+import Data.Char (intToDigit)+import Data.Function (on)+import qualified Data.Hourglass as H+import Data.IP (IP(..), IPv4, IPv6)+import qualified Data.List as List+import           Data.Maybe (fromMaybe)+import qualified Data.Semigroup as Sem++import qualified Data.ByteString.Base16 as B16+import qualified Network.DNS.Base32Hex as B32+import qualified Data.ByteString.Base64 as B64++import Network.DNS.Imports++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> 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 /mrname/ of @SOA@ 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++----------------------------------------------------------------++#if __GLASGOW_HASKELL__ >= 800+-- | 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+-- | 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+#else+-- | Types for resource records.+data TYPE = A          -- ^ IPv4 address+          | NS         -- ^ An authoritative name serve+          | CNAME      -- ^ The canonical name for an alias+          | SOA        -- ^ Marks the start of a zone of authority+          | NULL       -- ^ A null RR (EXPERIMENTAL)+          | PTR        -- ^ A domain name pointer+          | MX         -- ^ Mail exchange+          | TXT        -- ^ Text strings+          | AAAA       -- ^ IPv6 Address+          | SRV        -- ^ Server Selection (RFC2782)+          | DNAME      -- ^ DNAME (RFC6672)+          | OPT        -- ^ OPT (RFC6891)+          | DS         -- ^ Delegation Signer (RFC4034)+          | RRSIG      -- ^ RRSIG (RFC4034)+          | NSEC       -- ^ NSEC (RFC4034)+          | DNSKEY     -- ^ DNSKEY (RFC4034)+          | NSEC3      -- ^ NSEC3 (RFC5155)+          | NSEC3PARAM -- ^ NSEC3PARAM (RFC5155)+          | TLSA       -- ^ TLSA (RFC6698)+          | CDS        -- ^ Child DS (RFC7344)+          | CDNSKEY    -- ^ DNSKEY(s) the Child wants reflected in DS (RFC7344)+          | CSYNC      -- ^ Child-To-Parent Synchronization (RFC7477)+          | AXFR       -- ^ Zone transfer (RFC5936)+          | ANY        -- ^ A request for all records the server/cache+                       --   has available+          | CAA        -- ^ Certification Authority Authorization (RFC6844)+          | UnknownTYPE Word16  -- ^ Unknown type+          deriving (Eq, Ord, Read)++-- | From type to number.+fromTYPE :: TYPE -> Word16+fromTYPE A          =  1+fromTYPE NS         =  2+fromTYPE CNAME      =  5+fromTYPE SOA        =  6+fromTYPE NULL       = 10+fromTYPE PTR        = 12+fromTYPE MX         = 15+fromTYPE TXT        = 16+fromTYPE AAAA       = 28+fromTYPE SRV        = 33+fromTYPE DNAME      = 39+fromTYPE OPT        = 41+fromTYPE DS         = 43+fromTYPE RRSIG      = 46+fromTYPE NSEC       = 47+fromTYPE DNSKEY     = 48+fromTYPE NSEC3      = 50+fromTYPE NSEC3PARAM = 51+fromTYPE TLSA       = 52+fromTYPE CDS        = 59+fromTYPE CDNSKEY    = 60+fromTYPE CSYNC      = 62+fromTYPE AXFR       = 252+fromTYPE ANY        = 255+fromTYPE CAA        = 257+fromTYPE (UnknownTYPE x) = x++-- | From number to type.+toTYPE :: Word16 -> TYPE+toTYPE  1 = A+toTYPE  2 = NS+toTYPE  5 = CNAME+toTYPE  6 = SOA+toTYPE 10 = NULL+toTYPE 12 = PTR+toTYPE 15 = MX+toTYPE 16 = TXT+toTYPE 28 = AAAA+toTYPE 33 = SRV+toTYPE 39 = DNAME+toTYPE 41 = OPT+toTYPE 43 = DS+toTYPE 46 = RRSIG+toTYPE 47 = NSEC+toTYPE 48 = DNSKEY+toTYPE 50 = NSEC3+toTYPE 51 = NSEC3PARAM+toTYPE 52 = TLSA+toTYPE 59 = CDS+toTYPE 60 = CDNSKEY+toTYPE 62 = CSYNC+toTYPE 252 = AXFR+toTYPE 255 = ANY+toTYPE 257 = CAA+toTYPE x   = UnknownTYPE x+#endif++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 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)++-- | 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++-- $+-- 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 = List.intercalate "," $ List.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 ]++-- | 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++----------------------------------------------------------------++-- | 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 =+    List.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 ++ ":[" ++ List.intercalate "," os ++ "]"++-- | 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+                            }++----------------------------------------------------------------++-- | 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++----------------------------------------------------------------++#if __GLASGOW_HASKELL__ >= 800+-- | 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+#else+-- | 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.+data RCODE+  = NoErr     -- ^ No error condition.+  | FormatErr -- ^ Format error - The name server was+              --   unable to interpret the query.+  | ServFail  -- ^ Server failure - The name server was+              --   unable to process this query due to a+              --   problem with the name server.+  | NameErr   -- ^ 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.+  | NotImpl   -- ^ Not Implemented - The name server does+              --   not support the requested kind of query.+  | Refused   -- ^ 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.+  | YXDomain  -- ^ Dynamic update response, a pre-requisite+              --   domain that should not exist, does exist.+  | YXRRSet   -- ^ Dynamic update response, a pre-requisite+              --   RRSet that should not exist, does exist.+  | NXRRSet   -- ^ Dynamic update response, a pre-requisite+              --   RRSet that should exist, does not exist.+  | NotAuth   -- ^ Dynamic update response, the server is not+              --   authoritative for the zone named in the Zone Section.+  | NotZone   -- ^ Dynamic update response, a name used in the+              --   Prerequisite or Update Section is not within the zone+              --   denoted by the Zone Section.+  | BadVers   -- ^ Bad OPT Version (RFC 6891)+  | BadKey    -- ^ Key not recognized [RFC2845]+  | BadTime   -- ^ Signature out of time window [RFC2845]+  | BadMode   -- ^ Bad TKEY Mode [RFC2930]+  | BadName   -- ^ Duplicate key name [RFC2930]+  | BadAlg    -- ^ Algorithm not supported [RFC2930]+  | BadTrunc  -- ^ Bad Truncation [RFC4635]+  | BadCookie -- ^ Bad/missing Server Cookie [RFC7873]+  | BadRCODE  -- ^ 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 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'.+  | UnknownRCODE Word16+  deriving (Eq, Ord, Show)++-- | Convert an 'RCODE' to its numeric value.+fromRCODE :: RCODE -> Word16+fromRCODE NoErr     =  0+fromRCODE FormatErr =  1+fromRCODE ServFail  =  2+fromRCODE NameErr   =  3+fromRCODE NotImpl   =  4+fromRCODE Refused   =  5+fromRCODE YXDomain  =  6+fromRCODE YXRRSet   =  7+fromRCODE NXRRSet   =  8+fromRCODE NotAuth   =  9+fromRCODE NotZone   = 10+fromRCODE BadVers   = 16+fromRCODE BadKey    = 17+fromRCODE BadTime   = 18+fromRCODE BadMode   = 19+fromRCODE BadName   = 20+fromRCODE BadAlg    = 21+fromRCODE BadTrunc  = 22+fromRCODE BadCookie = 23+fromRCODE BadRCODE  = 0x1001+fromRCODE (UnknownRCODE x) = 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  0 = NoErr+toRCODE  1 = FormatErr+toRCODE  2 = ServFail+toRCODE  3 = NameErr+toRCODE  4 = NotImpl+toRCODE  5 = Refused+toRCODE  6 = YXDomain+toRCODE  7 = YXRRSet+toRCODE  8 = NXRRSet+toRCODE  9 = NotAuth+toRCODE 10 = NotZone+toRCODE 16 = BadVers+toRCODE 17 = BadKey+toRCODE 18 = BadTime+toRCODE 19 = BadMode+toRCODE 20 = BadName+toRCODE 21 = BadAlg+toRCODE 22 = BadTrunc+toRCODE 23 = BadCookie+toRCODE 0x1001 = BadRCODE+toRCODE  x = UnknownRCODE x+#endif++----------------------------------------------------------------++-- 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++-- | Convert epoch time to a YYYYMMDDHHMMSS string:+--+-- >>> :{+-- let testVector =+--         [ ( "19230704085602", -1467299038)+--         , ( "19331017210945", -1142563815)+--         , ( "19480919012827", -671668293 )+--         , ( "19631210171455", -191227505 )+--         , ( "20060819001740", 1155946660 )+--         , ( "20180723061122", 1532326282 )+--         , ( "20281019005024", 1855529424 )+--         , ( "20751108024632", 3340406792 )+--         , ( "21240926071415", 4883008455 )+--         , ( "21270331070215", 4962150135 )+--         , ( "21371220015305", 5300560385 )+--         , ( "21680118121052", 6249787852 )+--         , ( "21811012210032", 6683202032 )+--         , ( "22060719093224", 7464648744 )+--         , ( "22100427121648", 7583717808 )+--         , ( "22530821173957", 8950757997 )+--         , ( "23010804210243", 10463979763)+--         , ( "23441111161706", 11829514626)+--         , ( "23750511175551", 12791843751)+--         , ( "23860427060801", 13137746881) ]+--  in (==) <$> map (showTime.snd) <*> map fst $ testVector+-- :}+-- True+--++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 ]++-- | 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+        ]++-- | 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_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+           --RD_CDNSKEY+           --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_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+      UnknownRData            bytes -> showOpaque bytes+    where+      showSalt ""    = "-"+      showSalt salt  = b16encode salt+      showDomain = BS.unpack+      showSOA mname mrname serial refresh retry expire minttl =+          showDomain mname ++ " " ++ showDomain mrname ++ " " +++          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+      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+      -- | 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 }++-- | 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 = 1216   -- IPv6-safe UDP MTU+--     , 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 = 1216   -- 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++----------------------------------------------------------------++#if __GLASGOW_HASKELL__ >= 800+-- | 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+#else+-- | Option Code (RFC 6891).+data OptCode = NSID                  -- ^ Name Server Identifier (RFC5001)+             | DAU                   -- ^ DNSSEC Algorithm understood (RFC6975)+             | DHU                   -- ^ DNSSEC Hash Understood (RFC6975)+             | N3U                   -- ^ NSEC3 Hash Understood (RFC6975)+             | ClientSubnet          -- ^ Client subnet (RFC7871)+             | UnknownOptCode Word16 -- ^ Unknown option code+    deriving (Eq, Ord, Show)++-- | From option code to number.+fromOptCode :: OptCode -> Word16+fromOptCode NSID         = 3+fromOptCode DAU          = 5+fromOptCode DHU          = 6+fromOptCode N3U          = 7+fromOptCode ClientSubnet = 8+fromOptCode (UnknownOptCode x) = x++-- | From number to option code.+toOptCode :: Word16 -> OptCode+toOptCode 3 = NSID+toOptCode 5 = DAU+toOptCode 6 = DHU+toOptCode 7 = N3U+toOptCode 8 = ClientSubnet+toOptCode x = UnknownOptCode x+#endif++----------------------------------------------------------------++-- | RData formats for a few EDNS options, and an opaque catcall+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) = showUnknown code bs++showAlgList :: String -> [Word8] -> String+showAlgList nm ws = nm ++ " " ++ List.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++showUnknown :: Word16 -> ByteString -> String+showUnknown code bs = "UnknownOData " ++ show code ++ " " ++ b16encode bs

@@ -52,17 +52,31 @@ -- --  >>> let conf = defaultResolvConf { resolvInfo = RCHostNames ["8.8.8.8","8.8.4.4"], resolvConcurrent = True } -----  An example to disable EDNS0:+--  An example to disable EDNS: -----  >>> let conf = defaultResolvConf { resolvEDNS = [] }+--  >>> let conf = defaultResolvConf { resolvQueryControls = ednsEnabled FlagClear } -----  An example to enable EDNS0 with a 1,280-bytes buffer:+--  An example to enable query result caching: -----  >>> let conf = defaultResolvConf { resolvEDNS = [fromEDNS0 defaultEDNS0 { udpSize = 1280 }] }+--  >>> let conf = defaultResolvConf { resolvCache = Just defaultCacheConf } -----  An example to enable cache:+-- An example to disable requesting recursive service. -----  >>> let conf = defaultResolvConf { resolvCache = Just defaultCacheConf }+--  >>> 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@@ -70,12 +84,13 @@   , resolvTimeout    :: Int    -- | The number of retries including the first try.   , resolvRetry      :: Int-   -- | Additional resource records to specify EDNS.-  , resolvEDNS       :: [ResourceRecord]    -- | 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':@@ -83,17 +98,17 @@ -- * 'resolvInfo' is 'RCFilePath' \"\/etc\/resolv.conf\". -- * 'resolvTimeout' is 3,000,000 micro seconds. -- * 'resolvRetry' is 3.--- * 'resolvEDNS' is EDNS0 with a 4,096-bytes buffer. -- * '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-  , resolvEDNS       = [fromEDNS0 defaultEDNS0]   , resolvConcurrent = False   , resolvCache      = Nothing+  , resolvQueryControls = mempty }  ----------------------------------------------------------------

@@ -6,12 +6,7 @@   , normalizeRoot   ) where -import qualified Data.ByteString.Char8 as BS (-    append-  , last-  , map-  , null-  , pack )+import qualified Data.ByteString.Char8 as BS import Data.Char (toLower)  import Network.DNS.Types (Domain)@@ -37,7 +32,7 @@ -- --   Ensure that we don't crash on the empty 'Domain': -----   >>> import qualified Data.ByteString.Char8 as BS ( empty )+--   >>> import qualified Data.ByteString.Char8 as BS --   >>> normalize BS.empty --   "." --@@ -70,7 +65,7 @@ -- --   Ensure that we don't crash on the empty 'Domain': -----   >>> import qualified Data.ByteString.Char8 as BS ( empty )+--   >>> import qualified Data.ByteString.Char8 as BS --   >>> normalizeCase BS.empty --   "" --@@ -124,7 +119,7 @@ -- --   Ensure that we don't crash on the empty 'Domain': -----   >>> import qualified Data.ByteString.Char8 as BS ( empty )+--   >>> import qualified Data.ByteString.Char8 as BS --   >>> normalizeRoot BS.empty --   "." --

@@ -1,2 +1,33 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wall #-}+module Main (main) where++#ifndef MIN_VERSION_cabal_doctest+#define MIN_VERSION_cabal_doctest(x,y,z) 0+#endif++#if MIN_VERSION_cabal_doctest(1,0,0)++import Distribution.Extra.Doctest ( defaultMainWithDoctests )+main :: IO ()+main = defaultMainWithDoctests "doctests"++#else++#ifdef MIN_VERSION_Cabal+-- If the macro is defined, we have new cabal-install,+-- but for some reason we don't have cabal-doctest in package-db+--+-- Probably we are running cabal sdist, when otherwise using new-build+-- workflow+#warning You are configuring this package without cabal-doctest installed. \+         The doctests test-suite will not work as a result. \+         To fix this, install cabal-doctest before configuring.+#endif+ import Distribution.Simple++main :: IO () main = defaultMain++#endif

@@ -1,5 +1,5 @@ Name:                   dns-Version:                3.0.4+Version:                4.0.0 Author:                 Kazu Yamamoto <kazu@iij.ad.jp> Maintainer:             Kazu Yamamoto <kazu@iij.ad.jp> License:                BSD3@@ -10,10 +10,18 @@   in pure Haskell. Category:               Network Cabal-Version:          >= 1.10-Build-Type:             Simple+Build-Type:             Custom Extra-Source-Files:     Changelog.md                         cbits/dns.c+Tested-With:            GHC == 7.10.3+                      , GHC == 8.0.2+                      , GHC == 8.2.2+                      , GHC == 8.4.4+                      , GHC == 8.6.5 +Custom-Setup+  Setup-Depends:        base, Cabal, cabal-doctest >=1.0.6 && <1.1+ Library   Default-Language:     Haskell2010   GHC-Options:          -Wall@@ -23,10 +31,14 @@                         Network.DNS.Resolver                         Network.DNS.Utils                         Network.DNS.Types-                        Network.DNS.Encode                         Network.DNS.Decode+                        Network.DNS.Decode.Internal+                        Network.DNS.Encode+                        Network.DNS.Encode.Internal                         Network.DNS.IO-  Other-Modules:        Network.DNS.Decode.Internal+  Other-Modules:        Network.DNS.Base32Hex+                        Network.DNS.Decode.Parsers+                        Network.DNS.Encode.Builders                         Network.DNS.Imports                         Network.DNS.Memo                         Network.DNS.StateBinary@@ -35,20 +47,20 @@   if impl(ghc < 8)     Build-Depends:      semigroups   Build-Depends:        base >= 4 && < 5+                      , array                       , async-                      , auto-update                       , attoparsec+                      , auto-update+                      , base16-bytestring                       , base64-bytestring-                      , binary                       , bytestring                       , containers                       , cryptonite+                      , hourglass                       , iproute >= 1.3.2                       , mtl                       , network >= 2.3                       , psqueues-                      , safe == 0.3.*-                      , time   if os(windows)     Build-Depends:    split     C-Sources:        cbits/dns.c@@ -64,7 +76,6 @@                         IOSpec   Build-Depends:        dns                       , base-                      , bytestring                       , hspec                       , network @@ -85,7 +96,7 @@                       , iproute >= 1.2.4                       , word8 -Test-Suite doctest+Test-Suite doctests   Type:                 exitcode-stdio-1.0   Default-Language:     Haskell2010   Hs-Source-Dirs:       test2

@@ -3,9 +3,11 @@ module DecodeSpec where  import Data.ByteString.Internal (ByteString(..), unsafeCreate)+import qualified Data.ByteString.Char8 as BC #if !MIN_VERSION_bytestring(0,10,0) import qualified Data.ByteString as BS #endif+import Data.Monoid ((<>)) import Data.Word8 import Foreign.ForeignPtr (withForeignPtr) import Foreign.Ptr (plusPtr)@@ -20,10 +22,10 @@ -- 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 = "463181800001000100000000076e69636f6c6173046b766462076e647072696d6102696f0000100001c00c0010000100000e10000c6e69636f6c61732e6b766462"+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 = icolas.kvdb}]+--              , answer = [ResourceRecord {rrname = "nicolas.kvdb.ndprima.io.", rrtype = TXT, rrttl = 3600, rdata = nicolas.kvdb}] --              , authority = [] --              , additional = []}) @@ -52,7 +54,14 @@             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"  tripleDecodeTest :: ByteString -> IO () tripleDecodeTest hexbs =

@@ -68,8 +68,10 @@          , recAvailable = True          , rcode = NoErr          , authenData = False+         , chkDisable = False          }        }+  , ednsHeader = NoEDNS   , question = [Question {                      qname = "492056364.qzone.qq.com."                    , qtype = A@@ -110,8 +112,10 @@          , recAvailable = True          , rcode = NoErr          , authenData = False+         , chkDisable = False          }        }+  , ednsHeader = EDNSheader defaultEDNS   , question = [Question {                      qname = "492056364.qzone.qq.com."                    , qtype = TXT

@@ -1,18 +1,23 @@-{-# LANGUAGE OverloadedStrings, CPP #-}+{-# LANGUAGE OverloadedStrings, CPP, TransformListComp #-}  module RoundTripSpec where  import Control.Monad (replicateM)-import Data.IP (IP (..), IPv4, IPv6, toIPv4, toIPv6)+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 Network.DNS.Decode+import Network.DNS.Decode.Internal import Network.DNS.Encode+import Network.DNS.Encode.Internal import Network.DNS.Types import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck (Gen, arbitrary, elements, forAll, frequency, listOf, oneof) import Data.Word (Word8, Word16, Word32) import Data.Monoid ((<>))+import GHC.Exts (the, groupWith)  #if __GLASGOW_HASKELL__ < 709 import Control.Applicative@@ -44,7 +49,7 @@         decodeMailbox bs `shouldBe` Right dom         fmap encodeMailbox (decodeMailbox bs) `shouldBe` Right bs -    prop "DNSFlags" . forAll genDNSFlags $ \ flgs -> do+    prop "DNSFlags" . forAll (genDNSFlags 0x0f) $ \ flgs -> do         let bs = encodeDNSFlags flgs         decodeDNSFlags bs `shouldBe` Right flgs         fmap encodeDNSFlags (decodeDNSFlags bs) `shouldBe` Right bs@@ -54,32 +59,33 @@         decodeResourceRecord bs `shouldBe` Right rr         fmap encodeResourceRecord (decodeResourceRecord bs) `shouldBe` Right bs -    prop "DNSHeader" . forAll genDNSHeader $ \ hdr ->+    prop "DNSHeader" . forAll (genDNSHeader 0x0f) $ \ hdr ->         decodeDNSHeader (encodeDNSHeader hdr) `shouldBe` Right hdr      prop "DNSMessage" . forAll genDNSMessage $ \ msg ->         decode (encode msg) `shouldBe` Right msg -    prop "EDNS0" . forAll genEDNS0Header $ \(edns0,hdr) -> do-        let rr0 = fromEDNS0 edns0-            msg0 = DNSMessage hdr [] [] [] [rr0]-            Right msg1 = decode $ encode msg0-            medns1 = toEDNS0 (flags $ header msg0) (head $ additional msg1)-        medns1 `shouldBe` Just edns0+    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 <*> listOf genQuestion <*> listOf genResourceRecord-                <*> listOf genResourceRecord <*> listOf genResourceRecord+    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 = do-    typ <- genTYPE-    dom <- genDomain-    pure $ Question dom typ+genQuestion = Question <$> genDomain <*> genTYPE  genTYPE :: Gen TYPE genTYPE = frequency@@ -97,7 +103,8 @@   where     genRR = do       dom <- genDomain-      t <- elements [A , AAAA, NS, TXT, MX, CNAME, SOA, PTR, SRV, DNAME, DS]+      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@@ -106,7 +113,7 @@         A -> RD_A <$> genIPv4         AAAA -> RD_AAAA <$> genIPv6         NS -> pure $ RD_NS dom-        TXT -> RD_TXT <$> genByteString+        TXT -> RD_TXT <$> genTextString         MX -> RD_MX <$> genWord16 <*> genDomain         CNAME -> pure $ RD_CNAME dom         SOA -> RD_SOA dom <$> genMailbox <*> genWord32 <*> genWord32 <*> genWord32 <*> genWord32 <*> genWord32@@ -114,9 +121,29 @@         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          _ -> 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)@@ -126,11 +153,11 @@  genByteString :: Gen BS.ByteString genByteString = elements-    [ "", "a", "a.b", "abc", "a.b.c" ]+    [ "", "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" ]+    [ "", "a", "a@b", "abc", "a@b.c", "first.last@example.org" ]  genDomain :: Gen Domain genDomain = do@@ -142,13 +169,13 @@     bs <- genMboxString     pure $ bs <> "." -genDNSHeader :: Gen DNSHeader-genDNSHeader = DNSHeader <$> genWord16 <*> genDNSFlags+genDNSHeader :: Word16 -> Gen DNSHeader+genDNSHeader maxrc = DNSHeader <$> genWord16 <*> genDNSFlags maxrc -genDNSFlags :: Gen DNSFlags-genDNSFlags =-  DNSFlags <$> genQorR <*> genOPCODE <*> genBool <*> genBool-            <*> genBool <*> genBool <*> genRCODE <*> genBool+genDNSFlags :: Word16 -> Gen DNSFlags+genDNSFlags maxrc =+  DNSFlags <$> genQorR <*> genOPCODE <*> genBool        <*> genBool+           <*> genBool <*> genBool   <*> genRCODE maxrc <*> genBool <*> genBool  genWord16 :: Gen Word16 genWord16 = arbitrary@@ -166,39 +193,79 @@ genQorR = elements [minBound .. maxBound]  genOPCODE :: Gen OPCODE-genOPCODE  = elements [minBound .. maxBound]+genOPCODE  = elements [OP_STD, OP_INV, OP_SSR, OP_NOTIFY, OP_UPDATE] -genRCODE :: Gen RCODE-genRCODE = elements $ map toRCODE [0..15]+genRCODE :: Word16 -> Gen RCODE+genRCODE maxrc = elements $ map toRCODE [0..maxrc] -genEDNS0 :: Gen EDNS0-genEDNS0 = do-    erc <- genExtRCODE+genEDNS :: Gen EDNS+genEDNS = do+    vers <- genWord8     ok <- genBool     od <- genOData-    return $ defaultEDNS0 {-        extRCODE = erc-      , dnssecOk = ok-      , options  = [od]+    us <- elements [minUdpSize..maxUdpSize]+    return $ defaultEDNS {+        ednsVersion  = vers+      , ednsUdpSize  = us+      , ednsDnssecOk = ok+      , ednsOptions  = [od]       }  genOData :: Gen OData genOData = oneof     [ genOD_Unknown-    , OD_ClientSubnet <$> genWord8 <*> genWord8 <*> oneof [ IPv4 <$> genIPv4, IPv6 <$> genIPv6 ]+    , genOD_ECS     ]   where-    genOD_Unknown = do-      bs <- genByteString-      let opc = toOptCode $ fromIntegral $ BS.length bs-      pure $ UnknownOData opc bs+    -- | 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] -genEDNS0Header :: Gen (EDNS0, DNSHeader)-genEDNS0Header = do-    edns <- genEDNS0-    hdr <- genDNSHeader-    let flg = flags hdr-    return (edns, hdr { flags =  flg { rcode = extRCODE edns } })+genEDNSHeader :: Gen (EDNS, DNSHeader)+genEDNSHeader = do+    edns <- genEDNS+    hdr <- genDNSHeader 0xF00+    return (edns, hdr)

@@ -2,6 +2,7 @@  module IOSpec where +import Data.Monoid ((<>)) import Network.DNS.IO as DNS import Network.DNS.Types as DNS import Network.Socket hiding (send)@@ -11,21 +12,26 @@ spec = describe "send/receive" $ do      it "resolves well with UDP" $ do-        let hints = defaultHints { addrFamily = AF_INET, addrSocketType = Datagram, 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-        let qry = encodeQuestions 1 [Question "www.mew.org" A] [] False+        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-        let hints = defaultHints { addrFamily = AF_INET, addrSocketType = Stream, 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-        let qry = encodeQuestions 1 [Question "www.mew.org" A] [] False+        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

@@ -1,17 +1,14 @@ module Main where -import Test.DocTest+import Build_doctests (flags, pkgs, module_sources)+import Test.DocTest (doctest)  main :: IO ()-main = doctest [-    "-XOverloadedStrings"-  {--    Both 'iproute' and 'network-data' provide-    ‘Data.IP’ package:-      Ambiguous interface for ‘Data.IP’:-        it was found in multiple packages: network-data-0.5.3 iproute-1.7.0-    We ignore network-data to make tests pass.-  -}-  , "-ignore-package=network-data"-  , "Network/DNS.hs"-  ]+main = do+    putStrLn $ unwords $ "\ndoctest args: " : args+    doctest args+  where+    args = [ "-XCPP" ] +++           flags +++           pkgs +++           module_sources