diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -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) diff --git a/Network/DNS.hs b/Network/DNS.hs --- a/Network/DNS.hs +++ b/Network/DNS.hs @@ -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 diff --git a/Network/DNS/Base32Hex.hs b/Network/DNS/Base32Hex.hs new file mode 100644 --- /dev/null +++ b/Network/DNS/Base32Hex.hs @@ -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 +-- +-- encoding with no padding as specified for the +-- +-- 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 #-} diff --git a/Network/DNS/Decode.hs b/Network/DNS/Decode.hs --- a/Network/DNS/Decode.hs +++ b/Network/DNS/Decode.hs @@ -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 diff --git a/Network/DNS/Decode/Internal.hs b/Network/DNS/Decode/Internal.hs --- a/Network/DNS/Decode/Internal.hs +++ b/Network/DNS/Decode/Internal.hs @@ -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 diff --git a/Network/DNS/Decode/Parsers.hs b/Network/DNS/Decode/Parsers.hs new file mode 100644 --- /dev/null +++ b/Network/DNS/Decode/Parsers.hs @@ -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 + +-- +-- 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 + +-- +-- 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 diff --git a/Network/DNS/Encode.hs b/Network/DNS/Encode.hs --- a/Network/DNS/Encode.hs +++ b/Network/DNS/Encode.hs @@ -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 diff --git a/Network/DNS/Encode/Builders.hs b/Network/DNS/Encode/Builders.hs new file mode 100644 --- /dev/null +++ b/Network/DNS/Encode/Builders.hs @@ -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 diff --git a/Network/DNS/Encode/Internal.hs b/Network/DNS/Encode/Internal.hs new file mode 100644 --- /dev/null +++ b/Network/DNS/Encode/Internal.hs @@ -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 diff --git a/Network/DNS/IO.hs b/Network/DNS/IO.hs --- a/Network/DNS/IO.hs +++ b/Network/DNS/IO.hs @@ -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 diff --git a/Network/DNS/Imports.hs b/Network/DNS/Imports.hs --- a/Network/DNS/Imports.hs +++ b/Network/DNS/Imports.hs @@ -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 diff --git a/Network/DNS/Lookup.hs b/Network/DNS/Lookup.hs --- a/Network/DNS/Lookup.hs +++ b/Network/DNS/Lookup.hs @@ -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 ---------------------------------------------------------------- diff --git a/Network/DNS/LookupRaw.hs b/Network/DNS/LookupRaw.hs --- a/Network/DNS/LookupRaw.hs +++ b/Network/DNS/LookupRaw.hs @@ -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 diff --git a/Network/DNS/Memo.hs b/Network/DNS/Memo.hs --- a/Network/DNS/Memo.hs +++ b/Network/DNS/Memo.hs @@ -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 diff --git a/Network/DNS/Resolver.hs b/Network/DNS/Resolver.hs --- a/Network/DNS/Resolver.hs +++ b/Network/DNS/Resolver.hs @@ -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 diff --git a/Network/DNS/StateBinary.hs b/Network/DNS/StateBinary.hs --- a/Network/DNS/StateBinary.hs +++ b/Network/DNS/StateBinary.hs @@ -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 -- + 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 diff --git a/Network/DNS/Transport.hs b/Network/DNS/Transport.hs --- a/Network/DNS/Transport.hs +++ b/Network/DNS/Transport.hs @@ -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) ---------------------------------------------------------------- diff --git a/Network/DNS/Types.hs b/Network/DNS/Types.hs --- a/Network/DNS/Types.hs +++ b/Network/DNS/Types.hs @@ -1,848 +1,1781 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} - --- | Data types for DNS Query and Response. --- For more information, see . - -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 . + +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 +-- +-- 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 + -- | + 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: + 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 diff --git a/Network/DNS/Types/Internal.hs b/Network/DNS/Types/Internal.hs --- a/Network/DNS/Types/Internal.hs +++ b/Network/DNS/Types/Internal.hs @@ -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 } ---------------------------------------------------------------- diff --git a/Network/DNS/Utils.hs b/Network/DNS/Utils.hs --- a/Network/DNS/Utils.hs +++ b/Network/DNS/Utils.hs @@ -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 -- "." -- diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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 diff --git a/dns.cabal b/dns.cabal --- a/dns.cabal +++ b/dns.cabal @@ -1,5 +1,5 @@ Name: dns -Version: 3.0.4 +Version: 4.0.0 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto 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 diff --git a/test/DecodeSpec.hs b/test/DecodeSpec.hs --- a/test/DecodeSpec.hs +++ b/test/DecodeSpec.hs @@ -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 = diff --git a/test/EncodeSpec.hs b/test/EncodeSpec.hs --- a/test/EncodeSpec.hs +++ b/test/EncodeSpec.hs @@ -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 diff --git a/test/RoundTripSpec.hs b/test/RoundTripSpec.hs --- a/test/RoundTripSpec.hs +++ b/test/RoundTripSpec.hs @@ -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) diff --git a/test2/IOSpec.hs b/test2/IOSpec.hs --- a/test2/IOSpec.hs +++ b/test2/IOSpec.hs @@ -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 diff --git a/test2/doctests.hs b/test2/doctests.hs --- a/test2/doctests.hs +++ b/test2/doctests.hs @@ -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