diff --git a/Changelog b/Changelog deleted file mode 100644 --- a/Changelog +++ /dev/null @@ -1,41 +0,0 @@ -2.0.13 - - Testing with AppVeyor. - - Fixing sendAll on Windows [#72](https://github.com/kazu-yamamoto/dns/pull/72) - - Implementing RetryLimitExceeded [#73](https://github.com/kazu-yamamoto/dns/pull/73) - -2.0.12 - - Fixing Windows build again -2.0.11 - - Fixing the StateBinary.get32 parser [#57](https://github.com/kazu-yamamoto/dns/pull/57) - - Removing bytestring-builder dependency [#61](https://github.com/kazu-yamamoto/dns/pull/61) - - Fixing Windows build [#62](https://github.com/kazu-yamamoto/dns/pull/62) -2.0.10 - - Cleaning up the code. [#47](https://github.com/kazu-yamamoto/dns/pull/47) -2.0.9 - - Implemented TCP fallback after a truncated UDP response. [#46](https://github.com/kazu-yamamoto/dns/pull/46) -2.0.8 - - Better handling of encoding and decoding the "root" domain ".". [#45](https://github.com/kazu-yamamoto/dns/pull/45) -2.0.7 - - Add length checks for A and AAAA records. [#43](https://github.com/kazu-yamamoto/dns/pull/43) -2.0.6 - - Adding Ord instance. [#41](https://github.com/kazu-yamamoto/dns/pull/41) - - Adding DNSSEC-related RRTYPEs [#40](https://github.com/kazu-yamamoto/dns/pull/40) -2.0.5 - - Supporting DNS-SEC AD (authenticated data). [#38](https://github.com/kazu-yamamoto/dns/pull/38) - - Removing the dependency to blaze-builder. -2.0.4 - - Renaming a variable to fix preprocessor conflicts [#37](https://github.com/kazu-yamamoto/dns/pull/37) -2.0.3 - - Handle invalid opcodes gracefully. [#36](https://github.com/kazu-yamamoto/dns/pull/36) -2.0.2 - - Providing a new API: decodeMany. -2.0.1 - - Updating document. -2.0.0 - - DNSMessage is now monomorphic - - RDATA is now monomorphic - - Removed traversal instance for DNSMessage - - EDNS0 encoding/decoding is now supported - - Removed dnsMapWithType and dnsTraverseWithType functions - - responseA and responseAAAA now take lists of IP addresses as their arguments - - DNSHeader type no longer has qdCount, anCount, nsCount, and arCount fields diff --git a/Changelog.md b/Changelog.md new file mode 100644 --- /dev/null +++ b/Changelog.md @@ -0,0 +1,66 @@ +# 3.0.0 + +- The version introduces some breaking changes internally. But upper layer APIs in the `Lookup` module remain the same. +- Breaking change: `Network.DNS.Types` is redesigned. `ResourceRecord` is not a sum type anymore. It holds only normal RRs. For EDNS0, a new scheme is implemented. [#63](https://github.com/kazu-yamamoto/dns/issues/63) +- Breaking change: the `Encode` and `Decode` modules use strict ByteString instead of lazy one. [#59](https://github.com/kazu-yamamoto/dns/issues/59) +- Default DNS servers are detected automatically on Windows if `RCFilePath` is used. Use vanilla `defaultResolvConf` on Windows! [#83](https://github.com/kazu-yamamoto/dns/pull/83) +- Multiple DNS servers can be used. You can choose either sequential lookup or concurrent lookup. See `resolvConcurrent`. [#81](https://github.com/kazu-yamamoto/dns/pull/81) +- EDNS0 queries are used by default. [#95](https://github.com/kazu-yamamoto/dns/pull/95) +- `lookupSOA` is defined. [#93](https://github.com/kazu-yamamoto/dns/pull/93) +- Cache mechanism is provided. See `resolvCache`. +- Some constructors such as ANY are added in the `Types` module. +- Some bug fixes and code clean-up. + +# 2.0.13 +- Testing with AppVeyor. +- Detecting a default DNS server on Windows. +- Fixing sendAll on Windows [#72](https://github.com/kazu-yamamoto/dns/pull/72) + +# 2.0.12 +- Fixing Windows build again + +# 2.0.11 +- Fixing the StateBinary.get32 parser [#57](https://github.com/kazu-yamamoto/dns/pull/57) +- Removing bytestring-builder dependency [#61](https://github.com/kazu-yamamoto/dns/pull/61) +- Fixing Windows build [#62](https://github.com/kazu-yamamoto/dns/pull/62) + +# 2.0.10 +- Cleaning up the code. [#47](https://github.com/kazu-yamamoto/dns/pull/47) + +# 2.0.9 +- Implemented TCP fallback after a truncated UDP response. [#46](https://github.com/kazu-yamamoto/dns/pull/46) + +# 2.0.8 +- Better handling of encoding and decoding the "root" domain ".". [#45](https://github.com/kazu-yamamoto/dns/pull/45) + +# 2.0.7 +- Add length checks for A and AAAA records. [#43](https://github.com/kazu-yamamoto/dns/pull/43) + +# 2.0.6 +- Adding Ord instance. [#41](https://github.com/kazu-yamamoto/dns/pull/41) +- Adding DNSSEC-related RRTYPEs [#40](https://github.com/kazu-yamamoto/dns/pull/40) + +# 2.0.5 +- Supporting DNS-SEC AD (authenticated data). [#38](https://github.com/kazu-yamamoto/dns/pull/38) +- Removing the dependency to blaze-builder. + +# 2.0.4 +- Renaming a variable to fix preprocessor conflicts [#37](https://github.com/kazu-yamamoto/dns/pull/37) + +# 2.0.3 +- Handle invalid opcodes gracefully. [#36](https://github.com/kazu-yamamoto/dns/pull/36) + +# 2.0.2 +- Providing a new API: decodeMany. + +# 2.0.1 +- Updating document. + +# 2.0.0 +- DNSMessage is now monomorphic +- RDATA is now monomorphic +- Removed traversal instance for DNSMessage +- EDNS0 encoding/decoding is now supported +- Removed dnsMapWithType and dnsTraverseWithType functions +- responseA and responseAAAA now take lists of IP addresses as their arguments +- DNSHeader type no longer has qdCount, anCount, nsCount, and arCount fields diff --git a/Network/DNS.hs b/Network/DNS.hs --- a/Network/DNS.hs +++ b/Network/DNS.hs @@ -4,41 +4,52 @@ -- 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 not supported yet. +-- EDNS0 and TCP fallback are supported. -- +-- Examples: +-- +-- >>> rs <- makeResolvSeed defaultResolvConf +-- >>> withResolver rs $ \resolver -> lookupA resolver "www.mew.org" +-- Right [210.130.207.72] module Network.DNS ( -- * High level module Network.DNS.Lookup - -- | The "Network.DNS.Lookup" module contains simple functions to + -- | This module contains simple functions to -- perform various DNS lookups. If you simply want to resolve a -- hostname ('lookupA'), or find a domain's MX record -- ('lookupMX'), this is the easiest way to do it. , module Network.DNS.Resolver - -- | The "Network.DNS.Resolver" module is slightly more low-level - -- than "Network.DNS.Lookup". If you need to do something unusual, - -- you may need to use the 'lookup', 'lookupAuth', or 'lookupRaw' - -- functions. + -- | Resolver related data types. + , module Network.DNS.Types + -- | All of the types that the other modules use. + , module Network.DNS.Utils - -- | The "Network.DNS.Utils" module contains utility functions used + -- | This module contains utility functions used -- for processing DNS data. - , module Network.DNS.Types - -- | All of the types that the other modules use. + -- * Middle level + , module Network.DNS.LookupRaw + -- | This provides 'lookup', 'lookupAuth', or 'lookupRaw' functions + -- for any resource records. -- * Low level - , module Network.DNS.Decode - -- | Decoding a response. - , module Network.DNS.Encode - -- | Encoding a query. + -- | Encoding a query or response. - ) where + , module Network.DNS.Decode + -- | Decoding a qurey or response. + , module Network.DNS.IO + -- | Sending and receiving. +) where + +import Network.DNS.Decode +import Network.DNS.Encode +import Network.DNS.IO import Network.DNS.Lookup +import Network.DNS.LookupRaw import Network.DNS.Resolver -import Network.DNS.Utils import Network.DNS.Types -import Network.DNS.Decode -import Network.DNS.Encode +import Network.DNS.Utils diff --git a/Network/DNS/Decode.hs b/Network/DNS/Decode.hs --- a/Network/DNS/Decode.hs +++ b/Network/DNS/Decode.hs @@ -1,31 +1,23 @@ -{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, CPP #-} +{-# LANGUAGE CPP #-} +-- | Decoders for DNS. module Network.DNS.Decode ( + -- * Decoder decode , decodeMany - , receive - , receiveVC + -- ** Decoder for Each Part + , decodeResourceRecord + , decodeDNSHeader + , decodeDNSFlags + , decodeDomain + , decodeMailbox ) where import Control.Applicative (many) -import Control.Monad (replicateM) -import Control.Monad.Trans.Resource (ResourceT, runResourceT) -import qualified Control.Exception as ControlException -import Data.Bits ((.&.), shiftR, testBit) import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy as BL -import Data.Conduit (($$), ($$+), ($$+-), (=$), Source) -import Data.Conduit.Network (sourceSocket) -import qualified Data.Conduit.Binary as CB -import Data.IP (IP(..), toIPv4, toIPv6b) -import Data.Typeable (Typeable) -import Data.Word (Word16) -import Network (Socket) -import Network.DNS.Internal import Network.DNS.StateBinary -import qualified Safe +import Network.DNS.Types +import Network.DNS.Decode.Internal #if __GLASGOW_HASKELL__ < 709 import Control.Applicative @@ -33,283 +25,41 @@ ---------------------------------------------------------------- - -data RDATAParseError = RDATAParseError String - deriving (Show, Typeable) - -instance ControlException.Exception RDATAParseError - - --- | Receiving DNS data from 'Socket' and parse it. - -receive :: Socket -> IO DNSMessage -receive = receiveDNSFormat . sourceSocket - --- | Receive and parse a single virtual-circuit (TCP) response. It --- is up to the caller to implement any desired timeout. This --- (and the other response decoding functions) may throw ParseError --- when the server response is incomplete or malformed. - -receiveVC :: Socket -> IO DNSMessage -receiveVC sock = runResourceT $ do - (src, lenbytes) <- sourceSocket sock $$+ CB.take 2 - let len = case (map fromIntegral $ BL.unpack lenbytes) of - hi:lo:[] -> 256 * hi + lo - _ -> 0 - src $$+- CB.isolate len =$ sinkSGet decodeResponse >>= return . fst - ----------------------------------------------------------------- - --- | Parsing DNS data. +-- | Decoding DNS query or response. -decode :: BL.ByteString -> Either String DNSMessage -decode bs = fst <$> runSGet decodeResponse bs +decode :: ByteString -> Either String DNSMessage +decode bs = fst <$> runSGet getResponse bs -- | Parse many length-encoded DNS records, for example, from TCP traffic. -decodeMany :: BL.ByteString -> Either String ([DNSMessage], BL.ByteString) +decodeMany :: ByteString -> Either String ([DNSMessage], ByteString) decodeMany bs = do ((bss, _), leftovers) <- runSGetWithLeftovers lengthEncoded bs msgs <- mapM decode bss return (msgs, leftovers) where -- Read a list of length-encoded lazy bytestrings - lengthEncoded :: SGet [BL.ByteString] + lengthEncoded :: SGet [ByteString] lengthEncoded = many $ do len <- getInt16 - fmap BL.fromStrict (getNByteString len) - ----------------------------------------------------------------- -receiveDNSFormat :: Source (ResourceT IO) ByteString -> IO DNSMessage -receiveDNSFormat src = fst <$> runResourceT (src $$ sink) - where - sink = sinkSGet decodeResponse - ----------------------------------------------------------------- - -decodeResponse :: SGet DNSMessage -decodeResponse = do - (hd,qdCount,anCount,nsCount,arCount) <- decodeHeader - DNSMessage hd <$> decodeQueries qdCount - <*> decodeRRs anCount - <*> decodeRRs nsCount - <*> decodeRRs arCount - ----------------------------------------------------------------- - -decodeFlags :: SGet DNSFlags -decodeFlags = do - word <- get16 - maybe (fail "Unsupported flags") pure (toFlags word) - where - toFlags :: Word16 -> Maybe DNSFlags - toFlags flgs = do - opcode_ <- getOpcode flgs - rcode_ <- getRcode flgs - return $ DNSFlags (getQorR flgs) - opcode_ - (getAuthAnswer flgs) - (getTrunCation flgs) - (getRecDesired flgs) - (getRecAvailable flgs) - rcode_ - (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 = Safe.toEnumMay (fromIntegral (w .&. 0x0f)) - getAuthenData w = testBit w 5 - ----------------------------------------------------------------- - -decodeHeader :: SGet (DNSHeader,Int,Int,Int,Int) -decodeHeader = do - hd <- DNSHeader <$> decodeIdentifier - <*> decodeFlags - qdCount <- decodeQdCount - anCount <- decodeAnCount - nsCount <- decodeNsCount - arCount <- decodeArCount - pure (hd - ,qdCount - ,anCount - ,nsCount - ,arCount - ) - where - decodeIdentifier = getInt16 - decodeQdCount = getInt16 - decodeAnCount = getInt16 - decodeNsCount = getInt16 - decodeArCount = getInt16 - ----------------------------------------------------------------- - -decodeQueries :: Int -> SGet [Question] -decodeQueries n = replicateM n decodeQuery - -decodeType :: SGet TYPE -decodeType = intToType <$> getInt16 - -decodeOptType :: SGet OPTTYPE -decodeOptType = intToOptType <$> getInt16 - -decodeQuery :: SGet Question -decodeQuery = Question <$> decodeDomain - <*> decodeType - <* ignoreClass - -decodeRRs :: Int -> SGet [ResourceRecord] -decodeRRs n = replicateM n decodeRR - -decodeRR :: SGet ResourceRecord -decodeRR = do - dom <- decodeDomain - typ <- decodeType - decodeRR' dom typ - where - decodeRR' _ OPT = do - udps <- decodeUDPSize - _ <- decodeERCode - ver <- decodeOPTVer - dok <- decodeDNSOK - len <- decodeRLen - dat <- decodeRData OPT len - return OptRecord { orudpsize = udps - , ordnssecok = dok - , orversion = ver - , rdata = dat - } - - decodeRR' dom t = do - ignoreClass - ttl <- decodeTTL - len <- decodeRLen - dat <- decodeRData t len - return ResourceRecord { rrname = dom - , rrtype = t - , rrttl = ttl - , rdata = dat - } - decodeUDPSize = fromIntegral <$> getInt16 - decodeERCode = getInt8 - decodeOPTVer = fromIntegral <$> getInt8 - decodeDNSOK = flip testBit 15 <$> getInt16 - decodeTTL = fromIntegral <$> get32 - decodeRLen = getInt16 + getNByteString len -decodeRData :: TYPE -> Int -> SGet RData -decodeRData NS _ = RD_NS <$> decodeDomain -decodeRData MX _ = RD_MX <$> decodePreference <*> decodeDomain - where - decodePreference = getInt16 -decodeRData CNAME _ = RD_CNAME <$> decodeDomain -decodeRData DNAME _ = RD_DNAME <$> decodeDomain -decodeRData TXT len = (RD_TXT . ignoreLength) <$> getNByteString len - where - ignoreLength = BS.tail -decodeRData A len - | len == 4 = (RD_A . toIPv4) <$> getNBytes len - | otherwise = fail "IPv4 addresses must be 4 bytes long" -decodeRData AAAA len - | len == 16 = (RD_AAAA . toIPv6b) <$> getNBytes len - | otherwise = fail "IPv6 addresses must be 16 bytes long" -decodeRData SOA _ = RD_SOA <$> decodeDomain - <*> decodeDomain - <*> decodeSerial - <*> decodeRefesh - <*> decodeRetry - <*> decodeExpire - <*> decodeMinumun - where - decodeSerial = getInt32 - decodeRefesh = getInt32 - decodeRetry = getInt32 - decodeExpire = getInt32 - decodeMinumun = getInt32 -decodeRData PTR _ = RD_PTR <$> decodeDomain -decodeRData SRV _ = RD_SRV <$> decodePriority - <*> decodeWeight - <*> decodePort - <*> decodeDomain - where - decodePriority = getInt16 - decodeWeight = getInt16 - decodePort = getInt16 -decodeRData OPT ol = RD_OPT <$> decode' ol - where - decode' :: Int -> SGet [OData] - decode' l - | l < 0 = fail "decodeOPTData: length inconsistency" - | l == 0 = pure [] - | otherwise = do - optCode <- decodeOptType - optLen <- getInt16 - dat <- decodeOData optCode optLen - (dat:) <$> decode' (l - optLen - 4) --- -decodeRData TLSA len = RD_TLSA <$> decodeUsage - <*> decodeSelector - <*> decodeMType - <*> decodeADF - where - decodeUsage = get8 - decodeSelector = get8 - decodeMType = get8 - decodeADF = getNByteString (len - 3) -decodeRData _ len = RD_OTH <$> getNByteString len +-- | Decoding DNS flags. +decodeDNSFlags :: ByteString -> Either String DNSFlags +decodeDNSFlags bs = fst <$> runSGet getDNSFlags bs -decodeOData :: OPTTYPE -> Int -> SGet OData -decodeOData ClientSubnet len = do - fam <- getInt16 - srcMask <- getInt8 - scpMask <- getInt8 - 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 -decodeOData (OUNKNOWN i) len = OD_Unknown i <$> getNByteString len +-- | Decoding DNS header. +decodeDNSHeader :: ByteString -> Either String DNSHeader +decodeDNSHeader bs = fst <$> runSGet getHeader bs ----------------------------------------------------------------- +-- | Decoding domain. +decodeDomain :: ByteString -> Either String Domain +decodeDomain bs = fst <$> runSGet getDomain bs -decodeDomain :: SGet Domain -decodeDomain = do - pos <- getPosition - c <- getInt8 - let n = getValue c - -- Syntax hack to avoid using MultiWayIf - case () of - _ | c == 0 -> return "." -- Perhaps the root domain? - _ | isPointer c -> do - d <- getInt8 - let offset = n * 256 + d - mo <- pop offset - case mo of - Nothing -> fail $ "decodeDomain: " ++ show offset - -- A pointer may refer to another pointer. - -- So, register this position for the domain. - 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 <- decodeDomain - let dom = - case ds of -- avoid trailing ".." - "." -> hs `BS.append` "." - _ -> hs `BS.append` "." `BS.append` ds - push pos dom - return dom - where - getValue c = c .&. 0x3f - isPointer c = testBit c 7 && testBit c 6 - isExtLabel c = (not $ testBit c 7) && testBit c 6 +-- | Decoding mailbox. +decodeMailbox :: ByteString -> Either String Mailbox +decodeMailbox bs = fst <$> runSGet getMailbox bs -ignoreClass :: SGet () -ignoreClass = () <$ get16 +-- | Decoding resource record. +decodeResourceRecord :: ByteString -> Either String ResourceRecord +decodeResourceRecord bs = fst <$> runSGet getResourceRecord bs diff --git a/Network/DNS/Decode/Internal.hs b/Network/DNS/Decode/Internal.hs new file mode 100644 --- /dev/null +++ b/Network/DNS/Decode/Internal.hs @@ -0,0 +1,255 @@ +{-# LANGUAGE OverloadedStrings, CPP #-} + +module Network.DNS.Decode.Internal ( + getResponse + , getDNSFlags + , getHeader + , getResourceRecord + , getResourceRecords + , getDomain + , getMailbox + ) where + +import Control.Monad (replicateM) +import Data.Bits ((.&.), shiftR, testBit) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BS +import Data.IP (IP(..), toIPv4, toIPv6b) +import Data.Word (Word16) +import Network.DNS.StateBinary +import Network.DNS.Types +import Numeric (showHex) +import qualified Safe + +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative +#endif + +---------------------------------------------------------------- + +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 + +---------------------------------------------------------------- + +getQueries :: Int -> SGet [Question] +getQueries n = replicateM n getQuery + +getTYPE :: SGet TYPE +getTYPE = toTYPE <$> get16 + +getOptCode :: SGet OptCode +getOptCode = toOptCode <$> get16 + +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 + +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 _ 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 + +---------------------------------------------------------------- + +getDomain :: SGet Domain +getDomain = getDomain' '.' + +getMailbox :: SGet Mailbox +getMailbox = getDomain' '@' + +-- | 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 -> SGet ByteString +getDomain' sep1 = do + pos <- getPosition + c <- getInt8 + let n = getValue c + -- Syntax hack to avoid using MultiWayIf + case () of + _ | c == 0 -> return "." -- Perhaps the root domain? + _ | isPointer c -> do + d <- getInt8 + let offset = n * 256 + d + mo <- pop offset + case mo of + Nothing -> fail $ "getDomain: " ++ show offset + -- A pointer may refer to another pointer. + -- So, register this position for the domain. + 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 "" + _ -> do + hs <- getNByteString n + ds <- getDomain' '.' + let dom = + case ds of -- avoid trailing ".." + "." -> hs `BS.append` "." + _ -> hs `BS.append` BS.singleton sep1 `BS.append` ds + push pos dom + return dom + where + getValue c = c .&. 0x3f + isPointer c = testBit c 7 && testBit c 6 + isExtLabel c = not (testBit c 7) && testBit c 6 + +ignoreClass :: SGet () +ignoreClass = () <$ get16 diff --git a/Network/DNS/Encode.hs b/Network/DNS/Encode.hs --- a/Network/DNS/Encode.hs +++ b/Network/DNS/Encode.hs @@ -1,25 +1,30 @@ {-# LANGUAGE RecordWildCards, CPP #-} +-- | Encoders for DNS. module Network.DNS.Encode ( + -- * Encoder encode - , encodeVC - , composeQuery - , composeQueryAD + -- ** Encoder for Each Part + , encodeResourceRecord + , encodeDNSHeader + , encodeDNSFlags + , encodeDomain + , encodeMailbox ) where import Control.Monad (when) import Control.Monad.State (State, modify, execState, gets) import Data.Binary (Word16) -import Data.Bits ((.|.), bit, shiftL, setBit) +import Data.Bits ((.|.), bit, shiftL) import qualified Data.ByteString.Builder as BB +import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy as BL -import Data.ByteString.Lazy.Char8 (ByteString) -import Data.IP (IP(..),fromIPv4, fromIPv6b) +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.IP (IP(..), fromIPv4, fromIPv6b) import Data.List (dropWhileEnd) import Data.Monoid ((<>)) -import Network.DNS.Internal import Network.DNS.StateBinary +import Network.DNS.Types #if __GLASGOW_HASKELL__ < 709 import Data.Monoid (mconcat) @@ -27,57 +32,41 @@ ---------------------------------------------------------------- --- | Composing query. First argument is a number to identify response. - -composeQuery :: Int -> [Question] -> ByteString -composeQuery idt qs = encode qry - where - hdr = header defaultQuery - qry = defaultQuery { - header = hdr { - identifier = idt - } - , question = qs - } +-- | Encoding DNS query or response. +encode :: DNSMessage -> ByteString +encode = runSPut . putDNSMessage -composeQueryAD :: Int -> [Question] -> ByteString -composeQueryAD idt qs = encode qry - where - hdr = header defaultQuery - flg = flags hdr - qry = defaultQuery { - header = hdr { - identifier = idt, - flags = flg { - authenData = True - } - } - , question = qs - } +-- | Encoding DNS flags. +encodeDNSFlags :: DNSFlags -> ByteString +encodeDNSFlags = runSPut . putDNSFlags ----------------------------------------------------------------- +-- | Encoding DNS header. +encodeDNSHeader :: DNSHeader -> ByteString +encodeDNSHeader = runSPut . putHeader --- | Composing DNS data. +-- | Encoding domain. +encodeDomain :: Domain -> ByteString +encodeDomain = runSPut . putDomain -encode :: DNSMessage -> ByteString -encode msg = runSPut (encodeDNSMessage msg) +-- | Encoding mailbox. +encodeMailbox :: Mailbox -> ByteString +encodeMailbox = runSPut . putMailbox -encodeVC :: ByteString -> ByteString -encodeVC query = - let len = BB.toLazyByteString $ BB.int16BE $ fromIntegral $ BL.length query - in len <> query +-- | Encoding resource record. +encodeResourceRecord :: ResourceRecord -> ByteString +encodeResourceRecord rr = runSPut $ putResourceRecord rr ---------------------------------------------------------------- -encodeDNSMessage :: DNSMessage -> SPut -encodeDNSMessage msg = encodeHeader hdr - <> encodeNums - <> mconcat (map encodeQuestion qs) - <> mconcat (map encodeRR an) - <> mconcat (map encodeRR au) - <> mconcat (map encodeRR ad) +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 - encodeNums = mconcat $ fmap putInt16 [length qs + putNums = mconcat $ fmap putInt16 [length qs ,length an ,length au ,length ad @@ -88,14 +77,14 @@ au = authority msg ad = additional msg -encodeHeader :: DNSHeader -> SPut -encodeHeader hdr = encodeIdentifier (identifier hdr) - <> encodeFlags (flags hdr) +putHeader :: DNSHeader -> SPut +putHeader hdr = putIdentifier (identifier hdr) + <> putDNSFlags (flags hdr) where - encodeIdentifier = putInt16 + putIdentifier = put16 -encodeFlags :: DNSFlags -> SPut -encodeFlags DNSFlags{..} = put16 word +putDNSFlags :: DNSFlags -> SPut +putDNSFlags DNSFlags{..} = put16 word where word16 :: Enum a => a -> Word16 word16 = toEnum . fromEnum @@ -105,7 +94,7 @@ st :: State Word16 () st = sequence_ - [ set (word16 rcode) + [ set (fromIntegral $ fromRCODEforHeader rcode) , when authenData $ set (bit 5) , when recAvailable $ set (bit 7) , when recDesired $ set (bit 8) @@ -117,90 +106,98 @@ word = execState st 0 -encodeQuestion :: Question -> SPut -encodeQuestion Question{..} = encodeDomain qname - <> putInt16 (typeToInt qtype) +putQuestion :: Question -> SPut +putQuestion Question{..} = putDomain qname + <> put16 (fromTYPE qtype) <> put16 1 -putRData :: RData -> SPut -putRData rd = do - addPositionW 2 -- "simulate" putInt16 - rDataBuilder <- encodeRDATA rd - -- fixmed: SPut must hold length - let rdataLength = fromIntegral . BL.length . BB.toLazyByteString $ rDataBuilder - let rlenBuilder = BB.int16BE rdataLength - return rlenBuilder <> return rDataBuilder +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 -encodeRR :: ResourceRecord -> SPut -encodeRR ResourceRecord{..} = mconcat [ encodeDomain rrname - , putInt16 (typeToInt rrtype) - , put16 1 - , putInt32 rrttl - , putRData rdata - ] -encodeRR OptRecord{..} = mconcat [ encodeDomain BS.empty - , putInt16 (typeToInt OPT) - , putInt16 orudpsize - , putInt32 $ if ordnssecok - then setBit 0 15 - else 0 - , putRData rdata - ] - -encodeRDATA :: RData -> SPut -encodeRDATA rd = case rd of - (RD_A ip) -> mconcat $ map putInt8 (fromIPv4 ip) - (RD_AAAA ip) -> mconcat $ map putInt8 (fromIPv6b ip) - (RD_NS dom) -> encodeDomain dom - (RD_CNAME dom) -> encodeDomain dom - (RD_DNAME dom) -> encodeDomain dom - (RD_PTR dom) -> encodeDomain dom - (RD_MX prf dom) -> mconcat [putInt16 prf, encodeDomain dom] - (RD_TXT txt) -> putByteStringWithLength txt - (RD_OTH bytes) -> putByteString bytes - (RD_OPT opts) -> mconcat $ fmap encodeOData opts - (RD_SOA d1 d2 serial refresh retry expire min') -> mconcat - [ encodeDomain d1 - , encodeDomain d2 - , putInt32 serial - , putInt32 refresh - , putInt32 retry - , putInt32 expire - , putInt32 min' +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 - [ putInt16 prio - , putInt16 weight - , putInt16 port - , encodeDomain dom + RD_SRV prio weight port dom -> mconcat + [ put16 prio + , put16 weight + , put16 port + , putDomain dom ] - (RD_TLSA u s m d) -> mconcat + 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 + ] + UnknownRData bytes -> putByteString bytes -encodeOData :: OData -> SPut -encodeOData (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 [putInt16 (optTypeToInt ClientSubnet) - ,putInt16 dataLen - ,putInt16 fam - ,putInt8 srcNet - ,putInt8 scpNet - ,mconcat $ fmap putInt8 raw - ] -encodeOData (OD_Unknown code bs) = mconcat [putInt16 code - ,putInt16 $ BS.length bs - ,putByteString bs - ] +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 @@ -210,24 +207,33 @@ rootDomain :: Domain rootDomain = BS.pack "." -encodeDomain :: Domain -> SPut -encodeDomain dom - | (BS.null dom || dom == rootDomain) = put8 0 +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 -> encodePointer pos + Just pos -> putPointer pos Nothing -> wsPush dom cur >> - mconcat [ encodePartialDomain hd - , encodeDomain tl + mconcat [ putPartialDomain hd + , putDomain' '.' tl ] where - (hd, tl') = BS.break (=='.') dom + (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' -encodePointer :: Int -> SPut -encodePointer pos = putInt16 (pos .|. 0xc000) +putPointer :: Int -> SPut +putPointer pos = putInt16 (pos .|. 0xc000) -encodePartialDomain :: Domain -> SPut -encodePartialDomain = putByteStringWithLength +putPartialDomain :: Domain -> SPut +putPartialDomain = putByteStringWithLength diff --git a/Network/DNS/IO.hs b/Network/DNS/IO.hs new file mode 100644 --- /dev/null +++ b/Network/DNS/IO.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE CPP #-} + +module Network.DNS.IO ( + -- * Receiving from socket + receive + , receiveVC + -- * Sending to socket + , send + , sendVC + -- ** Creating Query + , encodeQuestions + , composeQuery + , composeQueryAD + -- ** Creating Response + , responseA + , responseAAAA + ) where + +#if !defined(mingw32_HOST_OS) +#define POSIX +#else +#define WIN +#endif + +#if __GLASGOW_HASKELL__ < 709 +#define GHC708 +#endif + +import qualified Control.Monad.State as ST +import Data.ByteString (ByteString) +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.Conduit (($$), ($$+), ($$+-), (=$), Sink) +import Data.Conduit.Attoparsec (sinkParser) +import qualified Data.Conduit.Binary as CB +import Data.Conduit.Network (sourceSocket) +import Data.IP (IPv4, IPv6) +import Data.Monoid ((<>)) +import Network (Socket) + +#ifdef GHC708 +import Control.Applicative ((<$>)) +#endif + +#if defined(WIN) && defined(GHC708) +import Network.Socket (send) +import qualified Data.ByteString.Char8 as BS +import Control.Monad (when) +#else +import Network.Socket.ByteString (sendAll) +#endif + +import Network.DNS.Types +import Network.DNS.Encode (encode) +import Network.DNS.Decode.Internal (getResponse) +import Network.DNS.StateBinary (PState, initialState) + +---------------------------------------------------------------- + +sink :: Sink ByteString IO (DNSMessage, PState) +sink = sinkParser $ ST.runStateT getResponse initialState + +-- | Receiving DNS data from 'Socket' and parse it. + +receive :: Socket -> IO DNSMessage +receive sock = fst <$> (sourceSocket sock $$ sink) + +-- | Receive and parse a single virtual-circuit (TCP) query or response. +-- It is up to the caller to implement any desired timeout. + +receiveVC :: Socket -> IO DNSMessage +receiveVC sock = do + (src, lenbytes) <- sourceSocket sock $$+ CB.take 2 + let len = case map ord $ LBS.unpack lenbytes of + [hi, lo] -> 256 * hi + lo + _ -> 0 + fst <$> (src $$+- CB.isolate len =$ sink) + +---------------------------------------------------------------- + +-- | Sending composed query or response to 'Socket'. +send :: Socket -> ByteString -> IO () +send sock legacyQuery = sendAll sock legacyQuery + +-- | Sending composed query or response to a single virtual-circuit (TCP). +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 + +#if defined(WIN) && defined(GHC708) +-- Windows does not support sendAll in Network.ByteString for older GHCs. +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 + +---------------------------------------------------------------- + +-- | Creating query. +encodeQuestions :: Identifier + -> [Question] + -> [ResourceRecord] -- ^ Additional RRs for EDNS. + -> Bool -- ^ Authentication + -> 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 + +{-# 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 + +---------------------------------------------------------------- + +-- | Composing a response from IPv4 addresses +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 + } + +-- | Composing a response from IPv6 addresses +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 + } diff --git a/Network/DNS/Internal.hs b/Network/DNS/Internal.hs deleted file mode 100644 --- a/Network/DNS/Internal.hs +++ /dev/null @@ -1,315 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} - -module Network.DNS.Internal where - -import Control.Exception (Exception) -import Data.ByteString (ByteString) -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 Data.Maybe (fromMaybe) -import Data.Typeable (Typeable) -import Data.Word (Word8) - ----------------------------------------------------------------- - --- | Type for domain. -type Domain = ByteString - --- | Return type of composeQuery from Encode, needed in Resolver -type Query = L.ByteString - ----------------------------------------------------------------- - --- | Types for resource records. -data TYPE = A - | AAAA - | NS - | TXT - | MX - | CNAME - | SOA - | PTR - | SRV - | DNAME - | OPT - | DS - | RRSIG - | NSEC - | DNSKEY - | NSEC3 - | NSEC3PARAM - | TLSA - | CDS - | CDNSKEY - | CSYNC - | UNKNOWN Int deriving (Eq, Show, Read) - --- https://www.iana.org/assignments/dns-parameters/dns-parameters.xhtml#dns-parameters-4 --- -rrDB :: [(TYPE, Int)] -rrDB = [ - (A, 1) - , (NS, 2) - , (CNAME, 5) - , (SOA, 6) - , (PTR, 12) - , (MX, 15) - , (TXT, 16) - , (AAAA, 28) - , (SRV, 33) - , (DNAME, 39) -- RFC 6672 - , (OPT, 41) -- RFC 6891 - , (DS, 43) -- RFC 4034 - , (RRSIG, 46) -- RFC 4034 - , (NSEC, 47) -- RFC 4034 - , (DNSKEY, 48) -- RFC 4034 - , (NSEC3, 40) -- RFC 5155 - , (NSEC3PARAM, 51) -- RFC 5155 - , (TLSA, 52) -- RFC 6698 - , (CDS, 59) -- RFC 7344 - , (CDNSKEY, 60) -- RFC 7344 - , (CSYNC, 62) -- RFC 7477 - ] - -data OPTTYPE = ClientSubnet - | OUNKNOWN Int - deriving (Eq) - -orDB :: [(OPTTYPE, Int)] -orDB = [ - (ClientSubnet, 8) - ] - -rookup :: (Eq b) => b -> [(a,b)] -> Maybe a -rookup _ [] = Nothing -rookup key ((x,y):xys) - | key == y = Just x - | otherwise = rookup key xys - -intToType :: Int -> TYPE -intToType n = fromMaybe (UNKNOWN n) $ rookup n rrDB -typeToInt :: TYPE -> Int -typeToInt (UNKNOWN x) = x -typeToInt t = fromMaybe (error "typeToInt") $ lookup t rrDB - -intToOptType :: Int -> OPTTYPE -intToOptType n = fromMaybe (OUNKNOWN n) $ rookup n orDB -optTypeToInt :: OPTTYPE -> Int -optTypeToInt (OUNKNOWN x) = x -optTypeToInt t = fromMaybe (error "optTypeToInt") $ lookup t orDB - ----------------------------------------------------------------- - --- | 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 - -- | The request simply 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 - deriving (Eq, Show, Typeable) - -instance Exception DNSError - --- | Raw data format for DNS Query and Response. -data DNSMessage = DNSMessage { - header :: DNSHeader - , question :: [Question] - , answer :: [ResourceRecord] - , authority :: [ResourceRecord] - , additional :: [ResourceRecord] - } deriving (Eq, Show) - --- | For backward compatibility. -type DNSFormat = DNSMessage - --- | Raw data format for the header of DNS Query and Response. -data DNSHeader = DNSHeader { - identifier :: Int - , flags :: DNSFlags - } deriving (Eq, Show) - --- | Raw data format for the flags of DNS Query and Response. -data DNSFlags = DNSFlags { - qOrR :: QorR - , opcode :: OPCODE - , authAnswer :: Bool - , trunCation :: Bool - , recDesired :: Bool - , recAvailable :: Bool - , rcode :: RCODE - , authenData :: Bool - } deriving (Eq, Show) - ----------------------------------------------------------------- - -data QorR = QR_Query | QR_Response deriving (Eq, Show) - -data OPCODE - = OP_STD - | OP_INV - | OP_SSR - deriving (Eq, Show, Enum, Bounded) - -data RCODE - = NoErr - | FormatErr - | ServFail - | NameErr - | NotImpl - | Refused - | BadOpt - deriving (Eq, Ord, Show, Enum, Bounded) - ----------------------------------------------------------------- - --- | Raw data format for DNS questions. -data Question = Question { - qname :: Domain - , qtype :: TYPE - } deriving (Eq, Show) - --- | Making "Question". -makeQuestion :: Domain -> TYPE -> Question -makeQuestion = Question - ----------------------------------------------------------------- - --- | Raw data format for resource records. -data ResourceRecord = ResourceRecord { - rrname :: Domain - , rrtype :: TYPE - , rrttl :: Int - , rdata :: RData - } - | OptRecord { - orudpsize :: Int - , ordnssecok :: Bool - , orversion :: Int - , rdata :: RData - } - deriving (Eq,Show) - --- | Raw data format for each type. -data RData = RD_NS Domain - | RD_CNAME Domain - | RD_DNAME Domain - | RD_MX Int Domain - | RD_PTR Domain - | RD_SOA Domain Domain Int Int Int Int Int - | RD_A IPv4 - | RD_AAAA IPv6 - | RD_TXT ByteString - | RD_SRV Int Int Int Domain - | RD_OPT [OData] - | RD_OTH ByteString - | RD_TLSA Word8 Word8 Word8 ByteString - 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 _ _ _ _ _ mi) = BS.unpack mn ++ " " ++ show mi - show (RD_PTR dom) = BS.unpack dom - show (RD_SRV pri wei prt dom) = show pri ++ " " ++ show wei ++ " " ++ show prt ++ BS.unpack dom - show (RD_OPT od) = show od - show (RD_OTH is) = show is - show (RD_TLSA use sel mtype dgst) = show use ++ " " ++ show sel ++ " " ++ show mtype ++ " " ++ (BS.unpack $ L.toStrict . L.toLazyByteString . L.byteStringHex $ dgst) - - -data OData = OD_ClientSubnet Int Int IP - | OD_Unknown Int ByteString - deriving (Eq,Show,Ord) - ----------------------------------------------------------------- - -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 = [] - } - -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 - } - } - } - -responseA :: Int -> Question -> [IPv4] -> DNSMessage -responseA ident q ips = - let hd = header defaultResponse - dom = qname q - an = fmap (ResourceRecord dom A 300 . RD_A) ips - in defaultResponse { - header = hd { identifier=ident } - , question = [q] - , answer = an - } - -responseAAAA :: Int -> Question -> [IPv6] -> DNSMessage -responseAAAA ident q ips = - let hd = header defaultResponse - dom = qname q - an = fmap (ResourceRecord dom AAAA 300 . RD_AAAA) ips - in defaultResponse { - header = hd { identifier=ident } - , question = [q] - , answer = an - } diff --git a/Network/DNS/Lookup.hs b/Network/DNS/Lookup.hs --- a/Network/DNS/Lookup.hs +++ b/Network/DNS/Lookup.hs @@ -1,13 +1,13 @@ --- | Simple, high-level DNS lookup functions. +-- | Simple, high-level DNS lookup functions for clients. -- --- All of the lookup functions necessary run in IO, since they +-- All of the lookup functions necessary run in IO since they -- interact with the network. The return types are similar, but -- differ in what can be returned from a successful lookup. -- --- We can think of the return type as \"either what I asked for, or --- an error\". For example, the 'lookupA' function, if successful, +-- We can think of the return type as either \"what I asked for\" or +-- \"an error\". For example, the 'lookupA' function, if successful, -- will return a list of 'IPv4'. The 'lookupMX' function will --- instead return a list of @('Domain',Int)@ pairs, where each pair +-- instead return a list of @('Domain','Int')@ pairs, where each pair -- represents a hostname and its associated priority. -- -- The order of multiple results may not be consistent between @@ -42,27 +42,31 @@ -- one millisecond and a very limited number of retries: -- -- >>> let hostname = Data.ByteString.Char8.pack "www.example.com" --- >>> let badrc = defaultResolvConf { resolvTimeout = 1, resolvRetry = 1 } +-- >>> let badrc = defaultResolvConf { resolvTimeout = 0, resolvRetry = 1 } -- >>> -- >>> rs <- makeResolvSeed badrc -- >>> withResolver rs $ \resolver -> lookupA resolver hostname -- Left RetryLimitExceeded -- -- As is the convention, successful results will always be wrapped --- in a 'Right', while errors will be wrapped in a 'Left'. +-- in a 'Right' while errors will be wrapped in a 'Left'. -- --- For convenience, you may wish to enable GHC's OverloadedStrings +-- For convenience, you may wish to enable GHC\'s OverloadedStrings -- extension. This will allow you to avoid calling -- 'Data.ByteString.Char8.pack' on each domain name. See --- --- for more information. +-- +-- for more information. In the following examples, +-- we assuem this extension is enabled. -- +-- All lookup functions eventually call 'lookupRaw'. See its manual +-- to understand the concrete lookup behavior. module Network.DNS.Lookup ( lookupA, lookupAAAA , lookupMX, lookupAviaMX, lookupAAAAviaMX , lookupNS , lookupNSAuth , lookupTXT + , lookupSOA , lookupPTR , lookupRDNS , lookupSRV @@ -72,7 +76,9 @@ import qualified Data.ByteString.Char8 as BS import Data.IP (IPv4, IPv6) import Network.DNS.Resolver as DNS +import Network.DNS.LookupRaw as DNS import Network.DNS.Types +import Data.Word (Word16, Word32) ---------------------------------------------------------------- @@ -80,19 +86,15 @@ -- -- A straightforward example: -- --- >>> let hostname = Data.ByteString.Char8.pack "www.mew.org" --- >>> -- >>> rs <- makeResolvSeed defaultResolvConf --- >>> withResolver rs $ \resolver -> lookupA resolver hostname +-- >>> withResolver rs $ \resolver -> lookupA resolver "www.mew.org" -- Right [210.130.207.72] -- -- This function will also follow a CNAME and resolve its target if -- one exists for the queries hostname: -- --- >>> let hostname = Data.ByteString.Char8.pack "www.kame.net" --- >>> -- >>> rs <- makeResolvSeed defaultResolvConf --- >>> withResolver rs $ \resolver -> lookupA resolver hostname +-- >>> withResolver rs $ \resolver -> lookupA resolver "www.kame.net" -- Right [203.178.141.194] -- lookupA :: Resolver -> Domain -> IO (Either DNSError [IPv4]) @@ -112,10 +114,8 @@ -- -- Examples: -- --- >>> let hostname = Data.ByteString.Char8.pack "www.wide.ad.jp" --- >>> -- >>> rs <- makeResolvSeed defaultResolvConf --- >>> withResolver rs $ \resolver -> lookupAAAA resolver hostname +-- >>> withResolver rs $ \resolver -> lookupAAAA resolver "www.wide.ad.jp" -- Right [2001:200:dff:fff1:216:3eff:fe4b:651c] -- lookupAAAA :: Resolver -> Domain -> IO (Either DNSError [IPv6]) @@ -141,18 +141,14 @@ -- examples posted on the internet). But remember, \"no results\" is -- still a successful result. -- --- >>> let hostname = Data.ByteString.Char8.pack "example.com" --- >>> -- >>> rs <- makeResolvSeed defaultResolvConf --- >>> withResolver rs $ \resolver -> lookupMX resolver hostname +-- >>> withResolver rs $ \resolver -> lookupMX resolver "example.com" -- Right [] -- -- The domain \"mew.org\" does however have a single MX: -- --- >>> let hostname = Data.ByteString.Char8.pack "mew.org" --- >>> -- >>> rs <- makeResolvSeed defaultResolvConf --- >>> withResolver rs $ \resolver -> lookupMX resolver hostname +-- >>> withResolver rs $ \resolver -> lookupMX resolver "mew.org" -- Right [("mail.mew.org.",10)] -- -- Also note that all hostnames are returned with a trailing dot to @@ -167,7 +163,7 @@ Right rds -> return $ mapM unTag rds where unTag :: RData -> Either DNSError (Domain,Int) - unTag (RD_MX pr dm) = Right (dm,pr) + unTag (RD_MX pr dm) = Right (dm, fromIntegral pr) unTag _ = Left UnexpectedRDATA -- | Look up all \'MX\' records for the given hostname, and then @@ -177,10 +173,8 @@ -- Examples: -- -- >>> import Data.List (sort) --- >>> let hostname = Data.ByteString.Char8.pack "wide.ad.jp" --- >>> -- >>> rs <- makeResolvSeed defaultResolvConf --- >>> ips <- withResolver rs $ \resolver -> lookupAviaMX resolver hostname +-- >>> ips <- withResolver rs $ \resolver -> lookupAviaMX resolver "wide.ad.jp" -- >>> fmap sort ips -- Right [133.138.10.39,203.178.136.30] -- @@ -253,10 +247,8 @@ -- Examples: -- -- >>> import Data.List (sort) --- >>> let hostname = Data.ByteString.Char8.pack "mew.org" --- >>> -- >>> rs <- makeResolvSeed defaultResolvConf --- >>> ns <- withResolver rs $ \resolver -> lookupNS resolver hostname +-- >>> ns <- withResolver rs $ \resolver -> lookupNS resolver "mew.org" -- >>> fmap sort ns -- Right ["ns1.mew.org.","ns2.mew.org."] -- @@ -277,12 +269,10 @@ -- the IP address of which was found beforehand: -- -- >>> import Data.List (sort) --- >>> let hostname = Data.ByteString.Char8.pack "example.com" --- >>> -- >>> let ri = RCHostName "192.5.6.30" -- a.gtld-servers.net -- >>> let rc = defaultResolvConf { resolvInfo = ri } -- >>> rs <- makeResolvSeed rc --- >>> ns <- withResolver rs $ \resolver -> lookupNSAuth resolver hostname +-- >>> ns <- withResolver rs $ \resolver -> lookupNSAuth resolver "example.com" -- >>> fmap sort ns -- Right ["a.iana-servers.net.","b.iana-servers.net."] -- @@ -300,10 +290,8 @@ -- . As an -- example, we find the SPF record for \"mew.org\": -- --- >>> let hostname = Data.ByteString.Char8.pack "mew.org" --- >>> -- >>> rs <- makeResolvSeed defaultResolvConf --- >>> withResolver rs $ \resolver -> lookupTXT resolver hostname +-- >>> withResolver rs $ \resolver -> lookupTXT resolver "mew.org" -- Right ["v=spf1 +mx -all"] -- lookupTXT :: Resolver -> Domain -> IO (Either DNSError [ByteString]) @@ -320,6 +308,31 @@ ---------------------------------------------------------------- +-- | Look up the \'SOA\' record for the given domain. The results include the +-- domain, mailbox, serial number, refresh time, retry time, expiration +-- time, and minimum TTL. +-- +-- This can be useful to validate TTLs for a server or get an abuse +-- contact address for a domain. +-- +-- >>> rs <- makeResolvSeed defaultResolvConf +-- >>> withResolver rs $ \resolver -> lookupSOA resolver "mew.org" +-- Right [("ns1.mew.org.","kazu@mew.org.",201406240,3600,300,3600000,3600)] +-- +lookupSOA :: Resolver -> Domain -> IO (Either DNSError [(Domain,Mailbox,Word32,Word32,Word32,Word32,Word32)]) +lookupSOA rlv dom = do + erds <- DNS.lookup rlv dom SOA + case erds of + -- See lookupXviaMX for an explanation of this construct. + Left err -> return (Left err) + Right rds -> return $ mapM unTag rds + where + unTag :: RData -> Either DNSError (Domain,Mailbox,Word32,Word32,Word32,Word32,Word32) + unTag (RD_SOA mn mr serial refresh retry expire mini) = Right (mn, mr, serial, refresh, retry, expire, mini) + unTag _ = Left UnexpectedRDATA + +---------------------------------------------------------------- + -- | Look up all \'PTR\' records for the given hostname. To perform a -- reverse lookup on an IP address, you must first reverse its -- octets and then append the suffix \".in-addr.arpa.\" @@ -327,10 +340,8 @@ -- We look up the PTR associated with the IP address -- 210.130.137.80, i.e., 80.137.130.210.in-addr.arpa: -- --- >>> let hostname = Data.ByteString.Char8.pack "164.2.232.202.in-addr.arpa" --- >>> -- >>> rs <- makeResolvSeed defaultResolvConf --- >>> withResolver rs $ \resolver -> lookupPTR resolver hostname +-- >>> withResolver rs $ \resolver -> lookupPTR resolver "164.2.232.202.in-addr.arpa" -- Right ["www.iij.ad.jp."] -- -- The 'lookupRDNS' function is more suited to this particular task. @@ -354,10 +365,8 @@ -- We repeat the example from 'lookupPTR', except now we pass the IP -- address directly: -- --- >>> let hostname = Data.ByteString.Char8.pack "202.232.2.164" --- >>> -- >>> rs <- makeResolvSeed defaultResolvConf --- >>> withResolver rs $ \resolver -> lookupRDNS resolver hostname +-- >>> withResolver rs $ \resolver -> lookupRDNS resolver "202.232.2.164" -- Right ["www.iij.ad.jp."] -- lookupRDNS :: Resolver -> Domain -> IO (Either DNSError [Domain]) @@ -392,10 +401,8 @@ -- -- Examples: -- --- >>> let q = Data.ByteString.Char8.pack "_xmpp-server._tcp.jabber.ietf.org" --- >>> -- >>> rs <- makeResolvSeed defaultResolvConf --- >>> withResolver rs $ \resolver -> lookupSRV resolver q +-- >>> withResolver rs $ \resolver -> lookupSRV resolver "_xmpp-server._tcp.jabber.ietf.org" -- Right [(5,0,5269,"jabber.ietf.org.")] -- Though the "jabber.ietf.orgs" SRV record may prove reasonably stable, as @@ -404,7 +411,7 @@ -- example should be displayed in a format that is not recognized as a test -- by "doctest". -lookupSRV :: Resolver -> Domain -> IO (Either DNSError [(Int,Int,Int,Domain)]) +lookupSRV :: Resolver -> Domain -> IO (Either DNSError [(Word16, Word16, Word16, Domain)]) lookupSRV rlv dom = do erds <- DNS.lookup rlv dom SRV case erds of @@ -412,6 +419,6 @@ Left err -> return (Left err) Right rds -> return $ mapM unTag rds where - unTag :: RData -> Either DNSError (Int,Int,Int,Domain) + unTag :: RData -> Either DNSError (Word16, Word16, Word16, Domain) unTag (RD_SRV pri wei prt dm) = Right (pri,wei,prt,dm) unTag _ = Left UnexpectedRDATA diff --git a/Network/DNS/LookupRaw.hs b/Network/DNS/LookupRaw.hs new file mode 100644 --- /dev/null +++ b/Network/DNS/LookupRaw.hs @@ -0,0 +1,261 @@ +{-# LANGUAGE RecordWildCards #-} + +module Network.DNS.LookupRaw ( + -- * Looking up functions + lookup + , lookupAuth + -- * Raw looking up function + , lookupRaw + , lookupRawAD + , fromDNSMessage + , fromDNSFormat + ) where + +import Control.Monad (when) +import Data.Time (getCurrentTime, addUTCTime) + +import Network.DNS.IO +import Network.DNS.Memo +import Network.DNS.Transport +import Network.DNS.Types +import Network.DNS.Types.Internal + +import Prelude hiding (lookup) + +-- $setup +-- >>> import Network.DNS.Resolver + +---------------------------------------------------------------- + +-- | Look up resource records of a specified type for a domain, +-- collecting the results +-- from the ANSWER section of the response. +-- See manual the manual of 'lookupRaw' +-- to understand the concrete behavior. +-- Cache is used if 'resolvCache' is 'Just'. +-- +-- Example: +-- +-- >>> rs <- makeResolvSeed defaultResolvConf +-- >>> withResolver rs $ \resolver -> lookup resolver "www.example.com" A +-- Right [93.184.216.34] +-- +lookup :: Resolver -> Domain -> TYPE -> IO (Either DNSError [RData]) +lookup = lookupSection Answer + +-- | Look up resource records of a specified type for a domain, +-- collecting the results +-- from the AUTHORITY section of the response. +-- See manual the manual of 'lookupRaw' +-- to understand the concrete behavior. +-- Cache is used even if 'resolvCache' is 'Just'. +lookupAuth :: Resolver -> Domain -> TYPE -> IO (Either DNSError [RData]) +lookupAuth = lookupSection Authority + +---------------------------------------------------------------- + +-- | Looking up resource records of a domain. The first parameter is one of +-- the field accessors of the 'DNSMessage' type -- this allows you to +-- choose which section (answer, authority, or additional) you would like +-- to inspect for the result. + +lookupSection :: Section + -> Resolver + -> Domain + -> TYPE + -> IO (Either DNSError [RData]) +lookupSection section rlv dom typ + | section == Authority = lookupFreshSection rlv dom typ section + | otherwise = case mcacheConf of + Nothing -> lookupFreshSection rlv dom typ section + Just cacheconf -> lookupCacheSection rlv dom typ cacheconf + where + mcacheConf = resolvCache $ resolvconf $ resolvseed rlv + +lookupFreshSection :: Resolver + -> Domain + -> TYPE + -> Section + -> IO (Either DNSError [RData]) +lookupFreshSection rlv dom typ section = do + eans <- lookupRaw rlv dom typ + case eans of + Left err -> return $ Left err + Right ans -> return $ fromDNSMessage ans toRData + where + correct ResourceRecord{..} = rrtype == typ + toRData = map rdata . filter correct . sectionF + sectionF = case section of + Answer -> answer + Authority -> authority + +lookupCacheSection :: Resolver + -> Domain + -> TYPE + -> CacheConf + -> IO (Either DNSError [RData]) +lookupCacheSection rlv dom typ cconf = do + mx <- lookupCache (dom,typ) c + case mx of + Nothing -> do + eans <- lookupRaw rlv dom typ + case eans of + Left err -> + -- Probably a network error happens. + -- We do not cache anything. + return $ Left err + Right ans -> do + let ex = fromDNSMessage ans toRR + case ex of + Left NameError -> do + let v = Left NameError + cacheNegative cconf c key v ans + return v + Left e -> return $ Left e + Right [] -> do + let v = Right [] + cacheNegative cconf c key v ans + return v + Right rss -> do + cachePositive cconf c key rss + return $ Right $ map rdata rss + Just (_,x) -> return x + where + toRR = filter (typ `isTypeOf`) . answer + Just c = cache rlv + key = (dom,typ) + +cachePositive :: CacheConf -> Cache -> Key -> [ResourceRecord] -> IO () +cachePositive cconf c key rss + | ttl == 0 = return () -- does not cache anything + | otherwise = insertPositive cconf c key (Right rds) ttl + where + rds = map rdata rss + ttl = minimum $ map rrttl rss -- rss is non-empty + +insertPositive :: CacheConf -> Cache -> Key -> Entry -> TTL -> IO () +insertPositive CacheConf{..} c k v ttl = when (ttl /= 0) $ do + tim <- addUTCTime life <$> getCurrentTime + insertCache k tim v c + where + life = fromIntegral (maximumTTL `min` ttl) + +cacheNegative :: CacheConf -> Cache -> Key -> Entry -> DNSMessage -> IO () +cacheNegative cconf c key v ans = case soas of + [] -> return () -- does not cache anything + soa:_ -> insertNegative cconf c key v $ rrttl soa + where + soas = filter (SOA `isTypeOf`) $ authority ans + +insertNegative :: CacheConf -> Cache -> Key -> Entry -> TTL -> IO () +insertNegative CacheConf{..} c k v ttl = when (ttl /= 0) $ do + tim <- addUTCTime life <$> getCurrentTime + insertCache k tim v c + where + life = fromIntegral ttl + +isTypeOf :: TYPE -> ResourceRecord -> Bool +isTypeOf t ResourceRecord{..} = rrtype == t + +---------------------------------------------------------------- + +-- | Look up a name and return the entire DNS Response +-- +-- For a given DNS server, the queries are done: +-- +-- * A new UDP socket bound to a new local port is created and +-- a new identifier is created atomically from the cryptographically +-- secure pseudo random number generator for the target DNS server. +-- Then UDP queries are tried with the limitation of 'resolvRetry' +-- (use EDNS0 if specifiecd). +-- If it appear that the target DNS server does not support EDNS0, +-- 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. +-- +-- +-- If multiple DNS server are specified 'ResolvConf' ('RCHostNames ') +-- or found ('RCFilePath'), either sequential lookup or +-- concurrent lookup is carried out: +-- +-- * In sequential lookup ('resolvConcurrent' is False), +-- the query procedure above is processed +-- in the order of the DNS servers sequentially until a successful +-- response is received. +-- +-- * In concurrent lookup ('resolvConcurrent' is True), +-- the query procedure above is processed +-- for each DNS server concurrently. +-- The first received response is accepted even if +-- it is an error. +-- +-- Cache is not used even if 'resolvCache' is 'Just'. +-- +-- The example code: +-- +-- @ +-- rs <- makeResolvSeed defaultResolvConf +-- withResolver rs $ \\resolver -> lookupRaw resolver \"www.example.com\" A +-- @ +-- +-- And the (formatted) expected output: +-- +-- @ +-- Right (DNSMessage +-- { header = DNSHeader +-- { identifier = 1, +-- flags = DNSFlags +-- { qOrR = QR_Response, +-- opcode = OP_STD, +-- authAnswer = False, +-- trunCation = False, +-- recDesired = True, +-- recAvailable = True, +-- rcode = NoErr, +-- authenData = False +-- }, +-- }, +-- question = [Question { qname = \"www.example.com.\", +-- qtype = A}], +-- answer = [ResourceRecord {rrname = \"www.example.com.\", +-- rrtype = A, +-- rrttl = 800, +-- rdlen = 4, +-- rdata = 93.184.216.119}], +-- authority = [], +-- additional = []}) +-- @ +-- +lookupRaw :: Resolver -> Domain -> TYPE -> IO (Either DNSError DNSMessage) +lookupRaw rslv dom typ = resolve dom typ rslv False receive + +-- | 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. +-- +lookupRawAD :: Resolver -> Domain -> TYPE -> IO (Either DNSError DNSMessage) +lookupRawAD rslv dom typ = resolve dom typ rslv True receive + +---------------------------------------------------------------- + +-- | Extract necessary information from 'DNSMessage' +fromDNSMessage :: DNSMessage -> (DNSMessage -> a) -> Either DNSError a +fromDNSMessage ans conv = case errcode ans of + NoErr -> Right $ conv ans + FormatErr -> Left FormatError + ServFail -> Left ServerFailure + NameErr -> Left NameError + NotImpl -> Left NotImplemented + Refused -> Left OperationRefused + BadOpt -> Left BadOptRecord + _ -> 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 new file mode 100644 --- /dev/null +++ b/Network/DNS/Memo.hs @@ -0,0 +1,77 @@ +module Network.DNS.Memo where + +import Control.Applicative ((<$>)) +import qualified Control.Reaper as R +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.List (foldl') +import Data.OrdPSQ (OrdPSQ) +import qualified Data.OrdPSQ as PSQ +import Data.Time (UTCTime, getCurrentTime) + +import Network.DNS.Types + +data Section = Answer | Authority deriving (Eq, Ord, Show) + +type Key = (ByteString + ,TYPE) +type Prio = UTCTime + +type Entry = Either DNSError [RData] + +type DB = OrdPSQ Key Prio Entry + +type Cache = R.Reaper DB (Key,Prio,Entry) + +newCache :: Int -> IO Cache +newCache delay = R.mkReaper R.defaultReaperSettings { + R.reaperEmpty = PSQ.empty + , R.reaperCons = \(k, tim, v) psq -> PSQ.insert k tim v psq + , R.reaperAction = prune + , R.reaperDelay = delay * 1000000 + , R.reaperNull = PSQ.null + } + +lookupCache :: Key -> Cache -> IO (Maybe (Prio, Entry)) +lookupCache key reaper = PSQ.lookup key <$> R.reaperRead reaper + +insertCache :: Key -> Prio -> Entry -> Cache -> IO () +insertCache (dom,typ) tim ent0 reaper = R.reaperAdd reaper (key,tim,ent) + where + key = (B.copy dom,typ) + ent = case ent0 of + l@(Left _) -> l + (Right rds) -> Right $ map copy rds + +-- Theoretically speaking, atMostView itself is good enough for pruning. +-- But auto-update assumes a list based db which does not provide atMost +-- functions. So, we need to do this redundant way. +prune :: DB -> IO (DB -> DB) +prune oldpsq = do + tim <- getCurrentTime + let (_, pruned) = PSQ.atMostView tim oldpsq + return $ \newpsq -> foldl' ins pruned $ PSQ.toList newpsq + where + ins psq (k,p,v) = PSQ.insert k p v psq + +copy :: RData -> RData +copy r@(RD_A _) = r +copy (RD_NS dom) = RD_NS $ B.copy dom +copy (RD_CNAME dom) = RD_CNAME $ B.copy dom +copy (RD_SOA mn mr a b c d e) = RD_SOA (B.copy mn) (B.copy mr) a b c d e +copy (RD_PTR dom) = RD_PTR $ B.copy dom +copy RD_NULL = RD_NULL +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 +copy (RD_SRV a b c dom) = RD_SRV a b c $ B.copy dom +copy (RD_DNAME dom) = RD_DNAME $ B.copy dom +copy (RD_OPT od) = RD_OPT $ map copyOData od +copy (RD_DS t a dt dv) = RD_DS t a dt $ B.copy dv +copy (RD_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 (UnknownRData is) = UnknownRData $ B.copy is + +copyOData :: OData -> OData +copyOData o@(OD_ClientSubnet _ _ _) = o +copyOData (UnknownOData c b) = UnknownOData c $ B.copy b diff --git a/Network/DNS/Resolver.hs b/Network/DNS/Resolver.hs --- a/Network/DNS/Resolver.hs +++ b/Network/DNS/Resolver.hs @@ -1,22 +1,34 @@ -{-# LANGUAGE CPP, OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} --- | DNS Resolver and generic (lower-level) lookup functions. +-- | Resolver related data types. module Network.DNS.Resolver ( - -- * Documentation - -- ** Configuration for resolver - FileOrNumericHost(..), ResolvConf(..), defaultResolvConf - -- ** Intermediate data type for resolver - , ResolvSeed, makeResolvSeed - -- ** Type and function for resolver - , Resolver(..), withResolver, withResolvers - -- ** Looking up functions - , lookup - , lookupAuth - -- ** Raw looking up function - , lookupRaw - , lookupRawAD - , fromDNSMessage - , fromDNSFormat + -- * Configuration for resolver + ResolvConf + , defaultResolvConf + -- ** Accessors + , resolvInfo + , resolvTimeout + , resolvRetry + , resolvEDNS + , resolvConcurrent + , resolvCache + -- ** Specifying DNS servers + , FileOrNumericHost(..) + -- ** Configuring cache + , CacheConf + , defaultCacheConf + , maximumTTL + , pruningDelay + -- * Intermediate data type for resolver + , ResolvSeed + , makeResolvSeed + -- * Type and function for resolver + , Resolver + , withResolver + , withResolvers ) where #if !defined(mingw32_HOST_OS) @@ -29,111 +41,40 @@ #define GHC708 #endif -import Control.Exception (bracket) -import Data.Char (isSpace) -import Data.List (isPrefixOf) -import Data.Maybe (fromMaybe) +import qualified Data.ByteString as BS +import Control.Exception as E +import Control.Monad (forM, replicateM) +import Data.Maybe (isJust, maybe) +import qualified Crypto.Random as C +import Data.IORef (IORef) +import qualified Data.IORef as I +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NE +import Data.Word (Word16) import Network.BSD (getProtocolNumber) -import Network.DNS.Decode -import Network.DNS.Encode -import Network.DNS.Internal -import qualified Data.ByteString.Char8 as BS -import Network.Socket (HostName, Socket, SocketType(Stream, Datagram)) -import Network.Socket (AddrInfoFlag(..), AddrInfo(..), SockAddr(..)) -import Network.Socket (Family(AF_INET, AF_INET6), PortNumber(..)) -import Network.Socket (close, socket, connect, getPeerName, getAddrInfo) -import Network.Socket (defaultHints, defaultProtocol) +import Network.DNS.Transport +import Network.DNS.Types +import Network.DNS.Types.Internal +import Network.DNS.Memo +import Network.Socket (AddrInfoFlag(..), AddrInfo(..), PortNumber(..), HostName, SocketType(Datagram), getAddrInfo, defaultHints) import Prelude hiding (lookup) -import System.Random (getStdRandom, randomR) -import System.Timeout (timeout) + #ifdef GHC708 import Control.Applicative ((<$>), (<*>), pure) #endif -#if defined(WIN) && defined(GHC708) -import Network.Socket (send) -import qualified Data.ByteString.Lazy.Char8 as LB -import Control.Monad (when) +#if defined(WIN) +import qualified Data.List.Split as Split +import Foreign.C.String +import Foreign.Marshal.Alloc (allocaBytes) +import Data.Word #else -import Network.Socket.ByteString.Lazy (sendAll) +import Data.Char (isSpace) +import Data.List (isPrefixOf) #endif ---------------------------------------------------------------- - --- | Union type for 'FilePath' and 'HostName'. Specify 'FilePath' to --- \"resolv.conf\" or numeric IP address in 'String' form. --- --- /Warning/: Only numeric IP addresses are valid @RCHostName@s. --- --- Example (using Google's public DNS cache): --- --- >>> let cache = RCHostName "8.8.8.8" --- -data FileOrNumericHost = RCFilePath FilePath -- ^ A path for \"resolv.conf\" - | RCHostName HostName -- ^ A numeric IP address - | RCHostPort HostName PortNumber -- ^ A numeric IP address and port number - --- | Type for resolver configuration. The easiest way to construct a --- @ResolvConf@ object is to modify the 'defaultResolvConf'. -data ResolvConf = ResolvConf { - resolvInfo :: FileOrNumericHost - -- | Timeout in micro seconds. - , resolvTimeout :: Int - -- | The number of retries including the first try. - , resolvRetry :: Int - -- | This field was obsoleted. - , resolvBufsize :: Integer -} - - --- | Return a default 'ResolvConf': --- --- * 'resolvInfo' is 'RCFilePath' \"\/etc\/resolv.conf\". --- --- * 'resolvTimeout' is 3,000,000 micro seconds. --- --- * 'resolvRetry' is 3. --- --- * 'resolvBufsize' is 512. (obsoleted) --- --- Example (use Google's public DNS cache instead of resolv.conf): --- --- >>> let cache = RCHostName "8.8.8.8" --- >>> let rc = defaultResolvConf { resolvInfo = cache } --- -defaultResolvConf :: ResolvConf -defaultResolvConf = ResolvConf { - resolvInfo = RCFilePath "/etc/resolv.conf" - , resolvTimeout = 3 * 1000 * 1000 - , resolvRetry = 3 - , resolvBufsize = 512 -} - ----------------------------------------------------------------- - --- | Abstract data type of DNS Resolver seed. --- When implementing a DNS cache, this should be re-used. -data ResolvSeed = ResolvSeed { - addrInfo :: AddrInfo - , rsTimeout :: Int - , rsRetry :: Int - , rsBufsize :: Integer -} - --- | Abstract data type of DNS Resolver --- When implementing a DNS cache, this MUST NOT be re-used. -data Resolver = Resolver { - genId :: IO Int - , dnsSock :: Socket - , dnsTimeout :: Int - , dnsRetry :: Int - , dnsBufsize :: Integer -} - ----------------------------------------------------------------- - - -- | Make a 'ResolvSeed' from a 'ResolvConf'. -- -- Examples: @@ -141,328 +82,78 @@ -- >>> rs <- makeResolvSeed defaultResolvConf -- makeResolvSeed :: ResolvConf -> IO ResolvSeed -makeResolvSeed conf = ResolvSeed <$> addr - <*> pure (resolvTimeout conf) - <*> pure (resolvRetry conf) - <*> pure (resolvBufsize conf) +makeResolvSeed conf = ResolvSeed conf <$> findAddresses where - addr = case resolvInfo conf of - RCHostName numhost -> makeAddrInfo numhost Nothing - RCHostPort numhost mport -> makeAddrInfo numhost $ Just mport - RCFilePath file -> toAddr <$> readFile file >>= \i -> makeAddrInfo i Nothing - toAddr cs = let l:_ = filter ("nameserver" `isPrefixOf`) $ lines cs - in extract l + findAddresses :: IO (NonEmpty AddrInfo) + findAddresses = case resolvInfo conf of + RCHostName numhost -> (:| []) <$> makeAddrInfo numhost Nothing + RCHostPort numhost mport -> (:| []) <$> makeAddrInfo numhost (Just mport) + RCHostNames nss -> mkAddrs nss + RCFilePath file -> getDefaultDnsServers file >>= mkAddrs + mkAddrs [] = E.throwIO BadConfiguration + mkAddrs (l:ls) = (:|) <$> makeAddrInfo l Nothing <*> forM ls (`makeAddrInfo` Nothing) + +getDefaultDnsServers :: FilePath -> IO [String] +#if defined(WIN) +foreign import ccall "getWindowsDefDnsServers" getWindowsDefDnsServers :: CString -> Int -> IO Word32 +getDefaultDnsServers _ = do + allocaBytes 128 $ \cString -> do + res <- getWindowsDefDnsServers cString 128 + case res of + 0 -> do + addresses <- peekCString cString + return $ filter (not . null) . Split.splitOn "," $ addresses + _ -> do + -- TODO: Do proper error handling here. + return mempty +#else +getDefaultDnsServers file = toAddresses <$> readFile file + where + toAddresses :: String -> [String] + toAddresses cs = map extract (filter ("nameserver" `isPrefixOf`) (lines cs)) extract = reverse . dropWhile isSpace . reverse . dropWhile isSpace . drop 11 +#endif makeAddrInfo :: HostName -> Maybe PortNumber -> IO AddrInfo makeAddrInfo addr mport = do proto <- getProtocolNumber "udp" - let hints = defaultHints { - addrFlags = [AI_ADDRCONFIG, AI_NUMERICHOST, AI_PASSIVE] + let flags = [AI_ADDRCONFIG, AI_NUMERICHOST, AI_PASSIVE] + hints = defaultHints { + addrFlags = if isJust mport then AI_NUMERICSERV : flags else flags , addrSocketType = Datagram , addrProtocol = proto } - a:_ <- getAddrInfo (Just hints) (Just addr) (Just "domain") - let connectPort = case addrAddress a of - SockAddrInet pn ha -> SockAddrInet (fromMaybe pn mport) ha - SockAddrInet6 pn fi ha sid -> SockAddrInet6 (fromMaybe pn mport) fi ha sid - unixAddr -> unixAddr - return $ a { addrAddress = connectPort } + serv = maybe "domain" show mport + head <$> getAddrInfo (Just hints) (Just addr) (Just serv) ---------------------------------------------------------------- - -- | Giving a thread-safe 'Resolver' to the function of the second --- argument. A socket for UDP is opened inside and is surely closed. --- Multiple 'withResolver's can be used concurrently. --- Multiple lookups must be done sequentially with a given --- 'Resolver'. If multiple 'Resolver's are necessary for --- concurrent purpose, use 'withResolvers'. +-- argument. withResolver :: ResolvSeed -> (Resolver -> IO a) -> IO a -withResolver seed func = bracket (openSocket seed) close $ \sock -> do - connectSocket sock seed - func $ makeResolver seed sock +withResolver seed f = makeResolver seed >>= f +{-# DEPRECATED withResolvers "Use withResolver with resolvConcurrent set to True" #-} -- | Giving thread-safe 'Resolver's to the function of the second --- argument. Sockets for UDP are opened inside and are surely closed. --- For each 'Resolver', multiple lookups must be done sequentially. --- 'Resolver's can be used concurrently. +-- argument. For each 'Resolver', multiple lookups must be done +-- sequentially. 'Resolver's can be used concurrently. withResolvers :: [ResolvSeed] -> ([Resolver] -> IO a) -> IO a -withResolvers seeds func = bracket openSockets closeSockets $ \socks -> do - mapM_ (uncurry connectSocket) $ zip socks seeds - let resolvs = zipWith makeResolver seeds socks - func resolvs - where - openSockets = mapM openSocket seeds - closeSockets = mapM close - -openSocket :: ResolvSeed -> IO Socket -openSocket seed = socket (addrFamily ai) (addrSocketType ai) (addrProtocol ai) - where - ai = addrInfo seed - -connectSocket :: Socket -> ResolvSeed -> IO () -connectSocket sock seed = connect sock (addrAddress ai) - where - ai = addrInfo seed - -makeResolver :: ResolvSeed -> Socket -> Resolver -makeResolver seed sock = Resolver { - genId = getRandom - , dnsSock = sock - , dnsTimeout = rsTimeout seed - , dnsRetry = rsRetry seed - , dnsBufsize = rsBufsize seed - } - -getRandom :: IO Int -getRandom = getStdRandom (randomR (0,65535)) - ----------------------------------------------------------------- - --- | Looking up resource records of a domain. The first parameter is one of --- the field accessors of the 'DNSMessage' type -- this allows you to --- choose which section (answer, authority, or additional) you would like --- to inspect for the result. - -lookupSection :: (DNSMessage -> [ResourceRecord]) - -> Resolver - -> Domain - -> TYPE - -> IO (Either DNSError [RData]) -lookupSection section rlv dom typ = do - eans <- lookupRaw rlv dom typ - case eans of - Left err -> return $ Left err - Right ans -> return $ fromDNSMessage ans toRData - where - {- CNAME hack - dom' = if "." `isSuffixOf` dom then dom else dom ++ "." - correct r = rrname r == dom' && rrtype r == typ - -} - correct r = rrtype r == typ - toRData = map rdata . filter correct . section - --- | Extract necessary information from 'DNSMessage' -fromDNSMessage :: DNSMessage -> (DNSMessage -> a) -> Either DNSError a -fromDNSMessage ans conv = case errcode ans of - NoErr -> Right $ conv ans - FormatErr -> Left FormatError - ServFail -> Left ServerFailure - NameErr -> Left NameError - NotImpl -> Left NotImplemented - Refused -> Left OperationRefused - BadOpt -> Left BadOptRecord - where - errcode = rcode . flags . header - --- | For backward compatibility. -fromDNSFormat :: DNSMessage -> (DNSMessage -> a) -> Either DNSError a -fromDNSFormat = fromDNSMessage - --- | Look up resource records for a domain, collecting the results --- from the ANSWER section of the response. --- --- We repeat an example from "Network.DNS.Lookup": --- --- >>> let hostname = Data.ByteString.Char8.pack "www.example.com" --- >>> rs <- makeResolvSeed defaultResolvConf --- >>> withResolver rs $ \resolver -> lookup resolver hostname A --- Right [93.184.216.34] --- -lookup :: Resolver -> Domain -> TYPE -> IO (Either DNSError [RData]) -lookup = lookupSection answer - --- | Look up resource records for a domain, collecting the results --- from the AUTHORITY section of the response. -lookupAuth :: Resolver -> Domain -> TYPE -> IO (Either DNSError [RData]) -lookupAuth = lookupSection authority - - --- | Look up a name and return the entire DNS Response. If the --- initial UDP query elicits a truncated answer, the query is --- retried over TCP. The TCP retry may extend the total time --- taken by one more timeout beyond timeout * tries. --- --- Sample output is included below, however it is /not/ tested --- the sequence number is unpredictable (it has to be!). --- --- The example code: --- --- @ --- let hostname = Data.ByteString.Char8.pack \"www.example.com\" --- rs <- makeResolvSeed defaultResolvConf --- withResolver rs $ \resolver -> lookupRaw resolver hostname A --- @ --- --- And the (formatted) expected output: --- --- @ --- Right (DNSMessage --- { header = DNSHeader --- { identifier = 1, --- flags = DNSFlags --- { qOrR = QR_Response, --- opcode = OP_STD, --- authAnswer = False, --- trunCation = False, --- recDesired = True, --- recAvailable = True, --- rcode = NoErr, --- authenData = False --- }, --- }, --- question = [Question { qname = \"www.example.com.\", --- qtype = A}], --- answer = [ResourceRecord {rrname = \"www.example.com.\", --- rrtype = A, --- rrttl = 800, --- rdlen = 4, --- rdata = 93.184.216.119}], --- authority = [], --- additional = []}) --- @ --- -lookupRaw :: Resolver -> Domain -> TYPE -> IO (Either DNSError DNSMessage) -lookupRaw = lookupRawInternal receive False - --- | 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. --- -lookupRawAD :: Resolver -> Domain -> TYPE -> IO (Either DNSError DNSMessage) -lookupRawAD = lookupRawInternal receive True - --- Lookup loop, we try UDP until we get a response. If the response --- is truncated, we try TCP once, with no further UDP retries. --- EDNS0 support would significantly reduce the need for TCP retries. --- --- For now, we optimize for low latency high-availability caches --- (e.g. running on a loopback interface), where TCP is cheap --- enough. We could attempt to complete the TCP lookup within the --- original time budget of the truncated UDP query, by wrapping both --- within a a single 'timeout' thereby staying within the original --- time budget, but it seems saner to give TCP a full opportunity to --- return results. TCP latency after a truncated UDP reply will be --- atypical. --- --- Future improvements might also include support for TCP on the --- initial query, and of course support for multiple nameservers. - -lookupRawInternal :: - (Socket -> IO DNSMessage) - -> Bool - -> Resolver - -> Domain - -> TYPE - -> IO (Either DNSError DNSMessage) -lookupRawInternal _ _ _ dom _ - | isIllegal dom = return $ Left IllegalDomain -lookupRawInternal rcv ad rlv dom typ = do - seqno <- genId rlv - let query = (if ad then composeQueryAD else composeQuery) seqno [q] - checkSeqno = check seqno - loop query checkSeqno 0 False - where - loop query checkSeqno cnt mismatch - | cnt == retry = do - let ret | mismatch = SequenceNumberMismatch - | otherwise = RetryLimitExceeded - return $ Left ret - | otherwise = do - sendAll sock query - response <- timeout tm (rcv sock) - case response of - Nothing -> loop query checkSeqno (cnt + 1) False - Just res -> do - let valid = checkSeqno res - case valid of - False -> loop query checkSeqno (cnt + 1) False - True | not $ trunCation $ flags $ header res - -> return $ Right res - _ -> tcpRetry query sock tm - sock = dnsSock rlv - tm = dnsTimeout rlv - retry = dnsRetry rlv - q = makeQuestion dom typ - check seqno res = identifier (header res) == seqno - --- Create a TCP socket `just like` our UDP socket and retry the same --- query over TCP. Since TCP is a reliable transport, and we just --- got a (truncated) reply from the server over UDP (so it has the --- answer, but it is just too large for UDP), we expect to succeed --- quickly on the first try. There will be no further retries. - -tcpRetry :: - Query - -> Socket - -> Int - -> IO (Either DNSError DNSMessage) -tcpRetry query sock tm = do - peer <- getPeerName sock - bracket (tcpOpen peer) - (maybe (return ()) close) - (tcpLookup query peer tm) - --- Create a TCP socket with the given socket address (taken from a --- corresponding UDP socket). This might throw an I/O Exception --- if we run out of file descriptors. Should this use tryIOError, --- and return "Nothing" also in that case? If so, perhaps similar --- code is needed in openSocket, but that has to wait until we --- refactor `withResolver` to not do "early" socket allocation, and --- instead allocate a fresh UDP socket for each `lookupRawInternal` --- invocation. It would be bad to fail an entire `withResolver` --- action, if the socket shortage is transient, and the user intends --- to make many DNS queries with the same resolver handle. - -tcpOpen :: SockAddr -> IO (Maybe Socket) -tcpOpen peer = do - case (peer) of - SockAddrInet _ _ -> - socket AF_INET Stream defaultProtocol >>= return . Just - SockAddrInet6 _ _ _ _ -> - socket AF_INET6 Stream defaultProtocol >>= return . Just - _ -> return Nothing -- Only IPv4 and IPv6 are possible - --- Perform a DNS query over TCP, if we were successful in creating --- the TCP socket. The socket creation can only fail if we run out --- of file descriptors, we're not making connections here. Failure --- is reported as "server" failure, though it is really our stub --- resolver that's failing. This is likely good enough. - -tcpLookup :: - Query - -> SockAddr - -> Int - -> Maybe Socket - -> IO (Either DNSError DNSMessage) -tcpLookup _ _ _ Nothing = return $ Left ServerFailure -tcpLookup query peer tm (Just vc) = do - response <- timeout tm $ do - connect vc $ peer - sendAll vc $ encodeVC query - receiveVC vc - case response of - Nothing -> return $ Left TimeoutExpired - Just res -> return $ Right res +withResolvers seeds f = mapM makeResolver seeds >>= f -#if defined(WIN) && defined(GHC708) --- Windows does not support sendAll in Network.ByteString for older GHCs. -sendAll :: Socket -> BS.ByteString -> IO () -sendAll sock bs = do - sent <- send sock (LB.unpack bs) - when (sent < fromIntegral (LB.length bs)) $ sendAll sock (LB.drop (fromIntegral sent) bs) -#endif +makeResolver :: ResolvSeed -> IO Resolver +makeResolver seed = do + let n = NE.length $ nameservers seed + refs <- replicateM n (C.drgNew >>= I.newIORef) + let gens = NE.fromList $ map getRandom refs + case resolvCache $ resolvconf seed of + Just cacheconf -> do + c <- newCache $ pruningDelay cacheconf + return $ Resolver seed gens $ Just c + Nothing -> return $ Resolver seed gens Nothing -isIllegal :: Domain -> Bool -isIllegal "" = True -isIllegal dom - | '.' `BS.notElem` dom = True - | ':' `BS.elem` dom = True - | '/' `BS.elem` dom = True - | BS.length dom > 253 = True - | any (\x -> BS.length x > 63) - (BS.split '.' dom) = True -isIllegal _ = False +getRandom :: IORef C.ChaChaDRG -> IO Word16 +getRandom ref = I.atomicModifyIORef' ref $ \gen -> + let (bs, gen') = C.randomBytesGenerate 2 gen + [u,l] = map fromIntegral $ BS.unpack bs + !seqno = u * 256 + l + in (gen', seqno) diff --git a/Network/DNS/StateBinary.hs b/Network/DNS/StateBinary.hs --- a/Network/DNS/StateBinary.hs +++ b/Network/DNS/StateBinary.hs @@ -1,19 +1,46 @@ {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP #-} -module Network.DNS.StateBinary where +module Network.DNS.StateBinary ( + PState(..) + , initialState + , SPut + , runSPut + , put8 + , put16 + , put32 + , putInt8 + , putInt16 + , putInt32 + , putByteString + , SGet + , runSGet + , runSGetWithLeftovers + , get8 + , get16 + , get32 + , getInt8 + , getInt16 + , getInt32 + , getNByteString + , getPosition + , wsPop + , wsPush + , wsPosition + , addPositionW + , push + , pop + , getNBytes + ) where import Control.Monad.State (State, StateT) import qualified Control.Monad.State as ST -import Control.Monad.Trans.Resource (ResourceT) import qualified Data.Attoparsec.ByteString as A -import qualified Data.Attoparsec.ByteString.Lazy as AL + import qualified Data.Attoparsec.Types as T import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.ByteString.Builder (Builder) import qualified Data.ByteString.Builder as BB -import qualified Data.ByteString.Lazy as BL -import Data.Conduit (Sink) -import Data.Conduit.Attoparsec (sinkParser) +import qualified Data.ByteString.Lazy.Char8 as LBS import Data.IntMap (IntMap) import qualified Data.IntMap as IM import Data.Map (Map) @@ -162,18 +189,16 @@ initialState :: PState initialState = PState IM.empty 0 -sinkSGet :: SGet a -> Sink ByteString (ResourceT IO) (a, PState) -sinkSGet parser = sinkParser (ST.runStateT parser initialState) - -runSGet :: SGet a -> BL.ByteString -> Either String (a, PState) -runSGet parser bs = AL.eitherResult $ AL.parse (ST.runStateT parser initialState) bs +runSGet :: SGet a -> ByteString -> Either String (a, PState) +runSGet parser bs = A.eitherResult $ A.parse (ST.runStateT parser initialState) bs -runSGetWithLeftovers :: SGet a -> BL.ByteString -> Either String ((a, PState), BL.ByteString) -runSGetWithLeftovers parser bs = toResult $ AL.parse (ST.runStateT parser initialState) bs +runSGetWithLeftovers :: SGet a -> ByteString -> Either String ((a, PState), ByteString) +runSGetWithLeftovers parser bs = toResult $ A.parse (ST.runStateT parser initialState) bs where - toResult :: AL.Result r -> Either String (r, BL.ByteString) - toResult (AL.Done i r) = Right (r, i) - toResult (AL.Fail _ _ err) = Left err + toResult :: A.Result r -> Either String (r, ByteString) + toResult (A.Done i r) = Right (r, i) + toResult (A.Partial f) = toResult $ f BS.empty + toResult (A.Fail _ _ err) = Left err -runSPut :: SPut -> BL.ByteString -runSPut = BB.toLazyByteString . flip ST.evalState initialWState +runSPut :: SPut -> ByteString +runSPut = LBS.toStrict . BB.toLazyByteString . flip ST.evalState initialWState diff --git a/Network/DNS/Transport.hs b/Network/DNS/Transport.hs new file mode 100644 --- /dev/null +++ b/Network/DNS/Transport.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module Network.DNS.Transport ( + Resolver(..) + , resolve + ) where + +import Control.Concurrent.Async (async, waitAnyCancel) +import Control.Exception as E +import qualified Data.ByteString.Char8 as BS +import qualified Data.List.NonEmpty as NE +import Data.Typeable +import Network.DNS.IO +import Network.DNS.Types +import Network.DNS.Types.Internal +import Network.Socket (AddrInfo(..), SockAddr(..), Family(AF_INET, AF_INET6), Socket, SocketType(Stream), close, socket, connect, defaultProtocol) +import System.IO.Error (annotateIOError) +import System.Timeout (timeout) + +-- | Check response for a matching identifier. If we ever do pipelined TCP, +-- we'll also need to match the QNAME, CLASS and QTYPE. See: +-- https://tools.ietf.org/html/rfc7766#section-7 +checkResp :: Question -> Identifier -> DNSMessage -> Bool +checkResp _ seqno resp = identifier (header resp) == seqno + +---------------------------------------------------------------- + +data TCPFallback = TCPFallback deriving (Show, Typeable) +instance Exception TCPFallback + +type Rslv0 = Bool -> (Socket -> IO DNSMessage) + -> IO (Either DNSError DNSMessage) + +type Rslv1 = Question + -> [ResourceRecord] + -> Int -- Timeout + -> Int -- Retry + -> Rslv0 + +type TcpRslv = Identifier -> AddrInfo -> Question -> Int -- Timeout + -> Bool -> IO DNSMessage + +type UdpRslv = [ResourceRecord] -> Int -- Retry + -> (Socket -> IO DNSMessage) -> TcpRslv + +-- In lookup loop, we try UDP until we get a response. If the response +-- is truncated, we try TCP once, with no further UDP retries. +-- +-- For now, we optimize for low latency high-availability caches +-- (e.g. running on a loopback interface), where TCP is cheap +-- enough. We could attempt to complete the TCP lookup within the +-- original time budget of the truncated UDP query, by wrapping both +-- within a a single 'timeout' thereby staying within the original +-- time budget, but it seems saner to give TCP a full opportunity to +-- return results. TCP latency after a truncated UDP reply will be +-- atypical. +-- +-- Future improvements might also include support for TCP on the +-- initial query. +resolve :: Domain -> TYPE -> Resolver -> Rslv0 +resolve dom typ rlv ad 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 + where + q = Question dom typ + + gens = NE.toList $ genIds rlv + + seed = resolvseed rlv + nss = NE.toList $ nameservers seed + onlyOne = length nss == 1 + + 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 + where + loop [ai] [gen] = resolveOne ai gen q edns tm retry ad rcv + loop (ai:ais) (gen:gens) = do + eres <- resolveOne ai gen q edns tm retry ad 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 + asyncs <- mapM mkAsync $ zip nss gens + snd <$> waitAnyCancel asyncs + where + mkAsync (ai,gen) = async $ resolveOne ai gen q edns tm retry ad 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 + +---------------------------------------------------------------- + +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 + +---------------------------------------------------------------- + +ioErrorToDNSError :: AddrInfo -> String -> IOError -> IO DNSMessage +ioErrorToDNSError ai tag ioe = throwIO $ NetworkFailure aioe + where + aioe = annotateIOError ioe (show ai) Nothing $ Just tag + +---------------------------------------------------------------- + +udpOpen :: AddrInfo -> IO Socket +udpOpen ai = do + sock <- socket (addrFamily ai) (addrSocketType ai) (addrProtocol ai) + connect sock (addrAddress ai) + return sock + +-- This throws DNSError or TCPFallback. +udpLookup :: UdpRslv +udpLookup edns retry rcv ident ai q tm ad = do + let qry = encodeQuestions ident [q] edns ad + ednsRetry = not $ null edns + E.handle (ioErrorToDNSError ai "UDP") $ + bracket (udpOpen ai) close (loop qry ednsRetry 0 RetryLimitExceeded) + where + loop qry ednsRetry cnt err sock + | cnt == retry = E.throwIO err + | otherwise = do + mres <- timeout tm (send sock qry >> rcv sock) + case mres of + Nothing -> loop qry ednsRetry (cnt + 1) RetryLimitExceeded sock + Just res + | checkResp q ident 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 + | otherwise -> loop qry ednsRetry (cnt + 1) SequenceNumberMismatch sock + +---------------------------------------------------------------- + +-- Create a TCP socket with the given socket address. +tcpOpen :: SockAddr -> IO Socket +tcpOpen peer = case peer of + SockAddrInet{} -> socket AF_INET Stream defaultProtocol + SockAddrInet6{} -> socket AF_INET6 Stream defaultProtocol + _ -> E.throwIO ServerFailure + +-- Perform a DNS query over TCP, if we were successful in creating +-- the TCP socket. +-- This throws DNSError only. +tcpLookup :: TcpRslv +tcpLookup ident ai q tm ad = + E.handle (ioErrorToDNSError ai "TCP") $ bracket (tcpOpen addr) close perform + where + addr = addrAddress ai + perform vc = do + let qry = encodeQuestions ident [q] [] ad + 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 + +---------------------------------------------------------------- + +badLength :: Domain -> Bool +badLength dom + | BS.null dom = True + | BS.last dom == '.' = BS.length dom > 254 + | otherwise = BS.length dom > 253 + +isIllegal :: Domain -> Bool +isIllegal dom + | badLength dom = True + | '.' `BS.notElem` dom = True + | ':' `BS.elem` dom = True + | '/' `BS.elem` dom = True + | any (\x -> BS.length x > 63) + (BS.split '.' dom) = True + | otherwise = False diff --git a/Network/DNS/Types.hs b/Network/DNS/Types.hs --- a/Network/DNS/Types.hs +++ b/Network/DNS/Types.hs @@ -1,30 +1,824 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} + -- | Data types for DNS Query and Response. -- For more information, see . module Network.DNS.Types ( - -- * Domain - Domain -- * Resource Records - , ResourceRecord (..) - , RData (..), OData (..) - -- ** Resource Record Type - , TYPE (..), intToType, typeToInt - , OPTTYPE (..), intToOptType, optTypeToInt - -- * DNS Error - , DNSError (..) + 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 + -- ** DNS Header , DNSHeader (..) - -- * DNS Flags - , DNSFlags (..) - -- * DNS Body + , Identifier , QorR (..) + , DNSFlags (..) , OPCODE (..) - , RCODE (..) + , RCODE ( + NoErr + , FormatErr + , ServFail + , NameErr + , NotImpl + , Refused + , YXDomain + , YXRRSet + , NXRRSet + , NotAuth + , NotZone + , BadOpt + ) + , fromRCODE + , toRCODE + , fromRCODEforHeader + , toRCODEforHeader + -- ** DNS Body , Question (..) - , responseA, responseAAAA + -- * DNS Error + , DNSError (..) + -- * EDNS0 + , EDNS0 + , defaultEDNS0 + -- ** Accessors + , udpSize + , extRCODE + , dnssecOk + , options + -- ** Converters + , fromEDNS0 + , toEDNS0 + -- * EDNS0 option data + , OData (..) + , OptCode ( + ClientSubnet + ) + , fromOptCode + , toOptCode + -- * Other types + , Mailbox ) where -import Network.DNS.Internal +import Control.Exception (Exception, IOException) +import Data.Bits ((.&.), (.|.), shiftR, shiftL, testBit, setBit) +import Data.ByteString (ByteString) +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 Data.Typeable (Typeable) +import Data.Word (Word8, Word16, Word32) + +---------------------------------------------------------------- + +-- | 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 internal '.' characters +-- that are not label separators. +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 +-- | 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 + | 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__ >= 800 +-- | 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 + +---------------------------------------------------------------- + +-- | 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 + | 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 + +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__ >= 800 +-- | 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 [] + +-- | 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' = 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__ >= 800 +-- | 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) diff --git a/Network/DNS/Types/Internal.hs b/Network/DNS/Types/Internal.hs new file mode 100644 --- /dev/null +++ b/Network/DNS/Types/Internal.hs @@ -0,0 +1,122 @@ +module Network.DNS.Types.Internal where + +import Data.List.NonEmpty (NonEmpty(..)) +import Network.Socket (AddrInfo(..), PortNumber(..), HostName) +import Data.Word (Word16) + +import Network.DNS.Memo +import Network.DNS.Types + +---------------------------------------------------------------- + +-- | The type to specify a cache server. +data FileOrNumericHost = RCFilePath FilePath -- ^ A path for \"resolv.conf\" + -- where one or more IP addresses + -- of DNS servers should be found + -- on Unix. + -- Default DNS servers are + -- automatically detected + -- on Windows regardless of + -- the value of the file name. + | RCHostName HostName -- ^ A numeric IP address. /Warning/: host names are invalid. + | RCHostNames [HostName] -- ^ Numeric IP addresses. /Warning/: host names are invalid. + | RCHostPort HostName PortNumber -- ^ A numeric IP address and port number. /Warning/: host names are invalid. + deriving Show + +---------------------------------------------------------------- + +-- | Cache configuration for responses. +data CacheConf = CacheConf { + -- | If RR's TTL is higher than this value, this value is used instead. + maximumTTL :: TTL + -- | Cache pruning interval in seconds. + , pruningDelay :: Int + } deriving Show + +-- | Default cache configuration. +-- +-- >>> defaultCacheConf +-- CacheConf {maximumTTL = 300, pruningDelay = 10} +defaultCacheConf :: CacheConf +defaultCacheConf = CacheConf 300 10 + +---------------------------------------------------------------- + +-- | Type for resolver configuration. +-- Use 'defaultResolvConf' to create a new value. +-- +-- An example to use Google's public DNS cache instead of resolv.conf: +-- +-- >>> let conf = defaultResolvConf { resolvInfo = RCHostName "8.8.8.8" } +-- +-- An example to use multiple Google's public DNS cache concurrently: +-- +-- >>> let conf = defaultResolvConf { resolvInfo = RCHostNames ["8.8.8.8","8.8.4.4"], resolvConcurrent = True } +-- +-- An example to disable EDNS0: +-- +-- >>> let conf = defaultResolvConf { resolvEDNS = [] } +-- +-- An example to enable EDNS0 with a 1,280-bytes buffer: +-- +-- >>> let conf = defaultResolvConf { resolvEDNS = [fromEDNS0 defaultEDNS0 { udpSize = 1280 }] } +-- +-- An example to enable cache: +-- +-- >>> let conf = defaultResolvConf { resolvCache = Just defaultCacheConf } +data ResolvConf = ResolvConf { + -- | Server information. + resolvInfo :: FileOrNumericHost + -- | Timeout in micro seconds. + , 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 +} deriving Show + +-- | Return a default 'ResolvConf': +-- +-- * '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. +defaultResolvConf :: ResolvConf +defaultResolvConf = ResolvConf { + resolvInfo = RCFilePath "/etc/resolv.conf" + , resolvTimeout = 3 * 1000 * 1000 + , resolvRetry = 3 + , resolvEDNS = [fromEDNS0 defaultEDNS0] + , resolvConcurrent = False + , resolvCache = Nothing +} + +---------------------------------------------------------------- + +-- | Intermediate abstract data type for resolvers. +-- IP address information of DNS servers is generated +-- according to 'resolvInfo' internally. +-- This value can be safely reused for 'withResolver'. +-- +-- The naming is confusing for historical reasons. +data ResolvSeed = ResolvSeed { + resolvconf :: ResolvConf + , nameservers :: NonEmpty AddrInfo +} + +---------------------------------------------------------------- + +-- | Abstract data type of DNS Resolver. +-- This includes newly seeded identifier generators for all +-- specified DNS servers and a cache database. +data Resolver = Resolver { + resolvseed :: ResolvSeed + , genIds :: NonEmpty (IO Word16) + , cache :: Maybe Cache +} diff --git a/cbits/dns.c b/cbits/dns.c new file mode 100644 --- /dev/null +++ b/cbits/dns.c @@ -0,0 +1,77 @@ +#include +#include +#include +#include +#include + +#define MALLOC(x) HeapAlloc(GetProcessHeap(), 0, (x)) +#define FREE(x) HeapFree(GetProcessHeap(), 0, (x)) + +// Fills `dnsAddresses` with the DNS addresses found, up to `bufferLen`. +// Returns NO_ERROR (0x0) in case the operation succeeds, otherwise a non-zero +// error code. See: https://msdn.microsoft.com/en-us/library/windows/desktop/ms681382(v=vs.85).aspx +DWORD getWindowsDefDnsServers(char* dnsAddresses, size_t bufferLen) { + FIXED_INFO *pFixedInfo; + ULONG ulOutBufLen; + DWORD dwRetVal; + + if (bufferLen <= 0) return ERROR_NOT_ENOUGH_MEMORY; + + pFixedInfo = (FIXED_INFO *) MALLOC(sizeof (FIXED_INFO)); + if (pFixedInfo == NULL) + return ERROR_NOT_ENOUGH_MEMORY; + ulOutBufLen = sizeof (FIXED_INFO); + + // Make an initial call to GetAdaptersInfo to get the necessary size into the + // ulOutBufLen variable + if (GetNetworkParams(pFixedInfo, &ulOutBufLen) == ERROR_BUFFER_OVERFLOW) { + FREE(pFixedInfo); + pFixedInfo = (FIXED_INFO *) MALLOC(ulOutBufLen); + if (pFixedInfo == NULL) + return ERROR_NOT_ENOUGH_MEMORY; + } + + dwRetVal = GetNetworkParams(pFixedInfo, &ulOutBufLen); + + if (dwRetVal == NO_ERROR) { + int offset = 0; + int spaceAvailable = bufferLen; + IP_ADDR_STRING* head = &pFixedInfo->DnsServerList; + int count = 0; + + while (head != NULL) { + int ipLen = strlen(head->IpAddress.String); + int copySize = ipLen + 1; + + spaceAvailable -= copySize; + if (spaceAvailable >= 0) { + // Write the separator. + // The string is already terminated due to the call to + // strcpy_s, which copies the null terminator. + if (count != 0) dnsAddresses[offset - 1] = ','; + // Copy the IP address, including the null terminator. + strcpy_s(dnsAddresses + offset, copySize, head->IpAddress.String); + if (spaceAvailable == 0) break; + } else + break; + + offset += copySize; + count++; + head = head->Next; + } + + } + + if (pFixedInfo) FREE(pFixedInfo); + return dwRetVal; +} + +/* + +// Test with 'gcc -o dnsServer -Wall -Werror -pedantic -liphlpapi -Iinclude dns.c' on a +// Windows machine. + +int main(){ + printf(getWindowsDefDnsServers()->dnsAddresses); + return 0; +}*/ diff --git a/dns.cabal b/dns.cabal --- a/dns.cabal +++ b/dns.cabal @@ -1,5 +1,5 @@ Name: dns -Version: 2.0.13 +Version: 3.0.0 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -11,49 +11,49 @@ Category: Network Cabal-Version: >= 1.10 Build-Type: Simple -Extra-Source-Files: Changelog +Extra-Source-Files: Changelog.md + cbits/dns.c Library Default-Language: Haskell2010 GHC-Options: -Wall Exposed-Modules: Network.DNS Network.DNS.Lookup + Network.DNS.LookupRaw Network.DNS.Resolver Network.DNS.Utils Network.DNS.Types Network.DNS.Encode Network.DNS.Decode - Other-Modules: Network.DNS.Internal + Network.DNS.IO + Other-Modules: Network.DNS.Decode.Internal + Network.DNS.Memo Network.DNS.StateBinary - if impl(ghc >= 7) - Build-Depends: base >= 4 && < 5 + Network.DNS.Transport + Network.DNS.Types.Internal + if impl(ghc < 8) + Build-Depends: semigroups + Build-Depends: base >= 4 && < 5 + , async + , auto-update , attoparsec + , base64-bytestring , binary , bytestring , conduit >= 1.1 , conduit-extra >= 1.1 , containers + , cryptonite , iproute >= 1.3.2 , mtl , network >= 2.3 - , random - , resourcet - , safe == 0.3.* - else - Build-Depends: base >= 4 && < 5 - , attoparsec - , binary - , bytestring - , conduit >= 1.1 - , conduit-extra >= 1.1 - , containers - , iproute >= 1.2.4 - , mtl - , network - , network-bytestring - , random - , resourcet + , psqueues , safe == 0.3.* + , time + if os(windows) + Build-Depends: split + C-Sources: cbits/dns.c + Extra-Libraries: iphlpapi Test-Suite network Type: exitcode-stdio-1.0 @@ -65,33 +65,23 @@ Build-Depends: dns , base , bytestring - , bytestring-builder , hspec Test-Suite spec Type: exitcode-stdio-1.0 Default-Language: Haskell2010 - Hs-Source-Dirs: test, . + Hs-Source-Dirs: test Ghc-Options: -Wall Main-Is: Spec.hs Other-Modules: EncodeSpec DecodeSpec - Build-Depends: base - , attoparsec - , binary + RoundTripSpec + Build-Depends: dns + , QuickCheck >= 2.9 + , base , bytestring - , bytestring-builder - , conduit >= 1.1 - , conduit-extra >= 1.1 - , containers - , dns , hspec , iproute >= 1.2.4 - , mtl - , network >= 2.3 - , random - , resourcet - , safe == 0.3.* , word8 Test-Suite doctest diff --git a/test/DecodeSpec.hs b/test/DecodeSpec.hs --- a/test/DecodeSpec.hs +++ b/test/DecodeSpec.hs @@ -6,60 +6,69 @@ #if !MIN_VERSION_bytestring(0,10,0) import qualified Data.ByteString as BS #endif -import qualified Data.ByteString.Lazy as BL import Data.Word8 import Foreign.ForeignPtr (withForeignPtr) import Foreign.Ptr (plusPtr) import Foreign.Storable (peek, poke, peekByteOff) -import Network.DNS.Decode -import Network.DNS.Encode +import Network.DNS import Test.Hspec ---------------------------------------------------------------- -test_doublePointer :: BL.ByteString +test_doublePointer :: ByteString test_doublePointer = "f7eb8500000100010007000404736563330561706e696303636f6d0000010001c00c0001000100001c200004ca0c1c8cc0110002000100001c20000f036e73310561706e6963036e657400c0300002000100001c200006036e7333c040c0300002000100001c200006036e7334c040c0300002000100001c20001004736563310561706e696303636f6d00c0300002000100001c20001704736563310761757468646e730472697065036e657400c0300002000100001c20001004736563320561706e696303636f6d00c0300002000100001c2000070473656333c0bfc07b0001000100001c200004ca0c1d3bc07b001c000100001c20001020010dc02001000a4608000000000059c0ba0001000100001c200004ca0c1d3cc0d6001c000100001c20001020010dc0000100004777000000000140" +-- DNSMessage {header = DNSHeader {identifier = 63467, flags = DNSFlags {qOrR = QR_Response, opcode = OP_STD, authAnswer = True, trunCation = False, recDesired = True, recAvailable = False, rcode = NoErr, authenData = False}}, question = [Question {qname = "sec3.apnic.com.", qtype = A}], answer = [ResourceRecord {rrname = "sec3.apnic.com.", rrtype = A, rrttl = 7200, rdata = 202.12.28.140}], authority = [ResourceRecord {rrname = "apnic.com.", rrtype = NS, rrttl = 7200, rdata = ns1.apnic.net.},ResourceRecord {rrname = "apnic.com.", rrtype = NS, rrttl = 7200, rdata = ns3.apnic.net.},ResourceRecord {rrname = "apnic.com.", rrtype = NS, rrttl = 7200, rdata = ns4.apnic.net.},ResourceRecord {rrname = "apnic.com.", rrtype = NS, rrttl = 7200, rdata = sec1.apnic.com.},ResourceRecord {rrname = "apnic.com.", rrtype = NS, rrttl = 7200, rdata = sec1.authdns.ripe.net.},ResourceRecord {rrname = "apnic.com.", rrtype = NS, rrttl = 7200, rdata = sec2.apnic.com.},ResourceRecord {rrname = "apnic.com.", rrtype = NS, rrttl = 7200, rdata = sec3.apnic.com.}], additional = [ResourceRecord {rrname = "sec1.apnic.com.", rrtype = A, rrttl = 7200, rdata = 202.12.29.59},ResourceRecord {rrname = "sec1.apnic.com.", rrtype = AAAA, rrttl = 7200, rdata = 2001:dc0:2001:a:4608::59},ResourceRecord {rrname = "sec2.apnic.com.", rrtype = A, rrttl = 7200, rdata = 202.12.29.60},ResourceRecord {rrname = "sec3.apnic.com.", rrtype = AAAA, rrttl = 7200, rdata = 2001:dc0:1:0:4777::140}]}) -test_txt :: BL.ByteString +test_txt :: ByteString test_txt = "463181800001000100000000076e69636f6c6173046b766462076e647072696d6102696f0000100001c00c0010000100000e10000c6e69636f6c61732e6b766462" +-- 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}] +-- , authority = [] +-- , additional = []}) -test_dname :: BL.ByteString +test_dname :: ByteString test_dname = "b3c0818000010005000200010377777706376b616e616c02636f02696c0000010001c0100027000100000003000c0769737261656c3702727500c00c0005000100000003000603777777c02ec046000500010000255b0002c02ec02e000100010000003d000451daf938c02e000100010000003d0004c33ce84ac02e000200010005412b000c036e7332026137036f726700c02e000200010005412b0006036e7331c08a0000291000000000000000" +-- DNSMessage {header = DNSHeader {identifier = 46016, flags = DNSFlags {qOrR = QR_Response, opcode = OP_STD, authAnswer = False, trunCation = False, recDesired = True, recAvailable = True, rcode = NoErr, authenData = False}}, question = [Question {qname = "www.7kanal.co.il.", qtype = A}], answer = [ResourceRecord {rrname = "7kanal.co.il.", rrtype = DNAME, rrttl = 3, rdata = israel7.ru.},ResourceRecord {rrname = "www.7kanal.co.il.", rrtype = CNAME, rrttl = 3, rdata = www.israel7.ru.},ResourceRecord {rrname = "www.israel7.ru.", rrtype = CNAME, rrttl = 9563, rdata = israel7.ru.},ResourceRecord {rrname = "israel7.ru.", rrtype = A, rrttl = 61, rdata = 81.218.249.56},ResourceRecord {rrname = "israel7.ru.", rrtype = A, rrttl = 61, rdata = 195.60.232.74}], authority = [ResourceRecord {rrname = "israel7.ru.", rrtype = NS, rrttl = 344363, rdata = ns2.a7.org.},ResourceRecord {rrname = "israel7.ru.", rrtype = NS, rrttl = 344363, rdata = ns1.a7.org.}], additional = [OptRecord {orudpsize = 4096, ordnssecok = False, orversion = 0, rdata = []}]}) +test_mx :: ByteString +test_mx = "f03681800001000100000001036d6577036f726700000f0001c00c000f000100000df10009000a046d61696cc00c0000291000000000000000" +-- DNSMessage {header = DNSHeader {identifier = 61494, flags = DNSFlags {qOrR = QR_Response, opcode = OP_STD, authAnswer = False, trunCation = False, recDesired = True, recAvailable = True, rcode = NoErr, authenData = False}} +-- , question = [Question {qname = "mew.org.", qtype = MX}] +-- , answer = [ResourceRecord {rrname = "mew.org.", rrtype = MX, rrttl = 3569, rdata = 10 mail.mew.org.}] +-- , authority = [] +-- , additional = [OptRecord {orudpsize = 4096, ordnssecok = False, orversion = 0, rdata = []}]}) + ---------------------------------------------------------------- spec :: Spec spec = do describe "decode" $ do - it "decodes double pointers correctly" $ do - let Right x1 = decode $ fromHexString test_doublePointer - Right x2 = decode (encode x1) - Right x3 = decode (encode x2) - x3 `shouldBe` x2 - it "decodes dname" $ do - let Right x1 = decode $ fromHexString test_dname - Right x2 = decode (encode x1) - Right x3 = decode (encode x2) - print x1 - x3 `shouldBe` x2 - it "decodes txt" $ do - let Right x1 = decode $ fromHexString test_txt - Right x2 = decode (encode x1) - Right x3 = decode (encode x2) - print x1 - x3 `shouldBe` x2 + it "decodes double pointers correctly" $ + tripleDecodeTest test_doublePointer + it "decodes dname" $ + tripleDecodeTest test_dname + it "decodes txt" $ + tripleDecodeTest test_txt + it "decodes mx" $ + tripleDecodeTest test_mx ----------------------------------------------------------------- -fromHexString :: BL.ByteString -> BL.ByteString -#if MIN_VERSION_bytestring(0,10,0) -fromHexString = BL.fromStrict . fromHexString' . BL.toStrict -#else -fromHexString = BL.pack . BS.unpack . fromHexString' . BS.pack . BL.unpack -#endif +tripleDecodeTest :: ByteString -> IO () +tripleDecodeTest hexbs = + ecase (decode $ fromHexString hexbs) fail $ \ x1 -> + ecase (decode $ encode x1) fail $ \ x2 -> + ecase (decode $ encode x2) fail $ \ x3 -> + x3 `shouldBe` x2 -fromHexString' :: ByteString -> ByteString -fromHexString' (PS fptr off len) = unsafeCreate size $ \dst -> +ecase :: Either a b -> (a -> c) -> (b -> c) -> c +ecase (Left a) f _ = f a +ecase (Right b) _ g = g b + +---------------------------------------------------------------- + +fromHexString :: ByteString -> ByteString +fromHexString (PS fptr off len) = unsafeCreate size $ \dst -> withForeignPtr fptr $ \src -> go (src `plusPtr` off) dst 0 where size = len `div` 2 diff --git a/test/EncodeSpec.hs b/test/EncodeSpec.hs --- a/test/EncodeSpec.hs +++ b/test/EncodeSpec.hs @@ -4,7 +4,7 @@ import Data.IP import Network.DNS -import Network.DNS.Internal (defaultQuery, makeQuestion) +import Network.DNS.Types (defaultQuery, Question(..)) import Test.Hspec spec :: Spec @@ -44,15 +44,15 @@ header = defaultHeader { identifier = 1000 } - , question = [makeQuestion "www.mew.org." A] + , question = [Question "www.mew.org." A] } testQueryAAAA :: DNSMessage testQueryAAAA = defaultQuery { header = defaultHeader { - identifier = 1000 + identifier = 1001 } - , question = [makeQuestion "www.mew.org." AAAA] + , question = [Question "www.mew.org." AAAA] } testResponseA :: DNSMessage @@ -75,93 +75,26 @@ , qtype = A } ] - , answer = [ResourceRecord { - rrname = "492056364.qzone.qq.com." - , rrtype = A - , rrttl = 568 - , rdata = RD_A $ toIPv4 [119, 147, 15, 122] - } - , ResourceRecord { - rrname = "492056364.qzone.qq.com." - , rrtype = A - , rrttl = 568 - , rdata = RD_A $ toIPv4 [119, 147, 79, 106] - } - , ResourceRecord { - rrname = "492056364.qzone.qq.com." - , rrtype = A - , rrttl = 568 - , rdata = RD_A $ toIPv4 [183, 60, 55, 43] - } - , ResourceRecord { - rrname = "492056364.qzone.qq.com." - , rrtype = A - , rrttl = 568 - , rdata = RD_A $ toIPv4 [183, 60, 55, 107] - } - , ResourceRecord { - rrname = "492056364.qzone.qq.com." - , rrtype = A - , rrttl = 568 - , rdata = RD_A $ toIPv4 [113, 108, 7, 172] - } - , ResourceRecord { - rrname = "492056364.qzone.qq.com." - , rrtype = A - , rrttl = 568 - , rdata = RD_A $ toIPv4 [113, 108, 7, 174] - } - , ResourceRecord { - rrname = "492056364.qzone.qq.com." - , rrtype = A - , rrttl = 568 - , rdata = RD_A $ toIPv4 [113, 108, 7, 175] - } - , ResourceRecord { - rrname = "492056364.qzone.qq.com." - , rrtype = A - , rrttl = 568 - , rdata = RD_A $ toIPv4 [119, 147, 15, 100] - } - ] - , authority = [ ResourceRecord { - rrname = "qzone.qq.com." - , rrtype = NS - , rrttl = 45919 - , rdata = RD_NS "ns-tel2.qq.com." - } - , ResourceRecord { - rrname = "qzone.qq.com." - , rrtype = NS - , rrttl = 45919 - , rdata = RD_NS "ns-tel1.qq.com." - } - ] - , additional = [ ResourceRecord { - rrname = "ns-tel1.qq.com." - , rrtype = A - , rrttl = 46520 - , rdata = RD_A $ toIPv4 [121, 14, 73, 115] - } - , ResourceRecord { - rrname = "ns-tel2.qq.com." - , rrtype = A - , rrttl = 2890 - , rdata = RD_A $ toIPv4 [222, 73, 76, 226] - } - , ResourceRecord { - rrname = "ns-tel2.qq.com." - , rrtype = A - , rrttl = 2890 - , rdata = RD_A $ toIPv4 [183, 60, 3, 202] - } - , ResourceRecord { - rrname = "ns-tel2.qq.com." - , rrtype = A - , rrttl = 2890 - , rdata = RD_A $ toIPv4 [218, 30, 72, 180] - } - ] + , answer = + [ ResourceRecord "492056364.qzone.qq.com." A classIN 568 (RD_A $ toIPv4 [119, 147, 15, 122]) + , ResourceRecord "492056364.qzone.qq.com." A classIN 568 (RD_A $ toIPv4 [119, 147, 79, 106]) + , ResourceRecord "492056364.qzone.qq.com." A classIN 568 (RD_A $ toIPv4 [183, 60, 55, 43]) + , ResourceRecord "492056364.qzone.qq.com." A classIN 568 (RD_A $ toIPv4 [183, 60, 55, 107]) + , ResourceRecord "492056364.qzone.qq.com." A classIN 568 (RD_A $ toIPv4 [113, 108, 7, 172]) + , ResourceRecord "492056364.qzone.qq.com." A classIN 568 (RD_A $ toIPv4 [113, 108, 7, 174]) + , ResourceRecord "492056364.qzone.qq.com." A classIN 568 (RD_A $ toIPv4 [113, 108, 7, 175]) + , ResourceRecord "492056364.qzone.qq.com." A classIN 568 (RD_A $ toIPv4 [119, 147, 15, 100]) + ] + , authority = + [ ResourceRecord "qzone.qq.com." NS classIN 45919 (RD_NS "ns-tel2.qq.com.") + , ResourceRecord "qzone.qq.com." NS classIN 45919 (RD_NS "ns-tel1.qq.com.") + ] + , additional = + [ ResourceRecord "ns-tel1.qq.com." A classIN 46520 (RD_A $ toIPv4 [121, 14, 73, 115]) + , ResourceRecord "ns-tel2.qq.com." A classIN 2890 (RD_A $ toIPv4 [222, 73, 76, 226]) + , ResourceRecord "ns-tel2.qq.com." A classIN 2890 (RD_A $ toIPv4 [183, 60, 3, 202]) + , ResourceRecord "ns-tel2.qq.com." A classIN 2890 (RD_A $ toIPv4 [218, 30, 72, 180]) + ] } testResponseTXT :: DNSMessage @@ -184,49 +117,17 @@ , qtype = TXT } ] - , answer = [ResourceRecord { - rrname = "492056364.qzone.qq.com." - , rrtype = TXT - , rrttl = 0 - , rdata = RD_TXT "simple txt line" - } - ] - , authority = [ ResourceRecord { - rrname = "qzone.qq.com." - , rrtype = NS - , rrttl = 45919 - , rdata = RD_NS "ns-tel2.qq.com." - } - , ResourceRecord { - rrname = "qzone.qq.com." - , rrtype = NS - , rrttl = 45919 - , rdata = RD_NS "ns-tel1.qq.com." - } - ] - , additional = [ ResourceRecord { - rrname = "ns-tel1.qq.com." - , rrtype = A - , rrttl = 46520 - , rdata = RD_A $ toIPv4 [121, 14, 73, 115] - } - , ResourceRecord { - rrname = "ns-tel2.qq.com." - , rrtype = A - , rrttl = 2890 - , rdata = RD_A $ toIPv4 [222, 73, 76, 226] - } - , ResourceRecord { - rrname = "ns-tel2.qq.com." - , rrtype = A - , rrttl = 2890 - , rdata = RD_A $ toIPv4 [183, 60, 3, 202] - } - , ResourceRecord { - rrname = "ns-tel2.qq.com." - , rrtype = A - , rrttl = 2890 - , rdata = RD_A $ toIPv4 [218, 30, 72, 180] - } - ] + , answer = + [ ResourceRecord "492056364.qzone.qq.com." TXT classIN 0 (RD_TXT "simple txt line") + ] + , authority = + [ ResourceRecord "qzone.qq.com." NS classIN 45919 (RD_NS "ns-tel2.qq.com.") + , ResourceRecord "qzone.qq.com." NS classIN 45919 (RD_NS "ns-tel1.qq.com.") + ] + , additional = + [ ResourceRecord "ns-tel1.qq.com." A classIN 46520 (RD_A $ toIPv4 [121, 14, 73, 115]) + , ResourceRecord "ns-tel2.qq.com." A classIN 2890 (RD_A $ toIPv4 [222, 73, 76, 226]) + , ResourceRecord "ns-tel2.qq.com." A classIN 2890 (RD_A $ toIPv4 [183, 60, 3, 202]) + , ResourceRecord "ns-tel2.qq.com." A classIN 2890 (RD_A $ toIPv4 [218, 30, 72, 180]) + ] } diff --git a/test/RoundTripSpec.hs b/test/RoundTripSpec.hs new file mode 100644 --- /dev/null +++ b/test/RoundTripSpec.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE OverloadedStrings, CPP #-} + +module RoundTripSpec where + +import Control.Monad (replicateM) +import Data.IP (IP (..), IPv4, IPv6, toIPv4, toIPv6) +import qualified Data.ByteString.Char8 as BS +import Network.DNS.Decode +import Network.DNS.Encode +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 ((<>)) + +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative +#endif + + +spec :: Spec +spec = do + prop "IPv4" . forAll genIPv4 $ \ ip4 -> do + let str = show ip4 + read str `shouldBe` ip4 + show (read str :: IPv4) `shouldBe` str + + prop "IPv6" . forAll genIPv6 $ \ ip6 -> do + let str = show ip6 + read str `shouldBe` ip6 + show (read str :: IPv6) `shouldBe` str + + prop "TYPE" . forAll genTYPE $ \ t -> + toTYPE (fromTYPE t) `shouldBe` t + + prop "Domain" . forAll genDomain $ \ dom -> do + let bs = encodeDomain dom + decodeDomain bs `shouldBe` Right dom + fmap encodeDomain (decodeDomain bs) `shouldBe` Right bs + + prop "Mailbox" . forAll genMailbox $ \ dom -> do + let bs = encodeMailbox dom + decodeMailbox bs `shouldBe` Right dom + fmap encodeMailbox (decodeMailbox bs) `shouldBe` Right bs + + prop "DNSFlags" . forAll genDNSFlags $ \ flgs -> do + let bs = encodeDNSFlags flgs + decodeDNSFlags bs `shouldBe` Right flgs + fmap encodeDNSFlags (decodeDNSFlags bs) `shouldBe` Right bs + + prop "ResourceRecord" . forAll genResourceRecord $ \ rr -> do + let bs = encodeResourceRecord rr + decodeResourceRecord bs `shouldBe` Right rr + fmap encodeResourceRecord (decodeResourceRecord bs) `shouldBe` Right bs + + prop "DNSHeader" . forAll genDNSHeader $ \ 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 + +---------------------------------------------------------------- + +genDNSMessage :: Gen DNSMessage +genDNSMessage = + DNSMessage <$> genDNSHeader <*> listOf genQuestion <*> listOf genResourceRecord + <*> listOf genResourceRecord <*> listOf genResourceRecord + + +genQuestion :: Gen Question +genQuestion = do + typ <- genTYPE + dom <- genDomain + pure $ Question dom typ + +genTYPE :: Gen TYPE +genTYPE = frequency + [ (20, elements + [ A, AAAA, NS, TXT, MX, CNAME, SOA, PTR, SRV, DNAME, OPT, DS, RRSIG + , NSEC, DNSKEY, NSEC3, NSEC3PARAM, TLSA, CDS, CDNSKEY, CSYNC + ]) + , (1, toTYPE <$> genWord16) + ] + +genResourceRecord :: Gen ResourceRecord +genResourceRecord = frequency + [ (8, genRR) + ] + where + genRR = do + dom <- genDomain + t <- elements [A , AAAA, NS, TXT, MX, CNAME, SOA, PTR, SRV, DNAME, DS] + ResourceRecord dom t classIN <$> genWord32 <*> mkRData dom t + +mkRData :: Domain -> TYPE -> Gen RData +mkRData dom typ = + case typ of + A -> RD_A <$> genIPv4 + AAAA -> RD_AAAA <$> genIPv6 + NS -> pure $ RD_NS dom + TXT -> RD_TXT <$> genByteString + MX -> RD_MX <$> genWord16 <*> genDomain + CNAME -> pure $ RD_CNAME dom + SOA -> RD_SOA dom <$> genMailbox <*> genWord32 <*> genWord32 <*> genWord32 <*> genWord32 <*> genWord32 + PTR -> RD_PTR <$> genDomain + SRV -> RD_SRV <$> genWord16 <*> genWord16 <*> genWord16 <*> genDomain + DNAME -> RD_DNAME <$> genDomain + DS -> RD_DS <$> genWord16 <*> genWord8 <*> genWord8 <*> genByteString + TLSA -> RD_TLSA <$> genWord8 <*> genWord8 <*> genWord8 <*> genByteString + + _ -> pure . RD_TXT $ "Unhandled type " <> BS.pack (show typ) + +genIPv4 :: Gen IPv4 +genIPv4 = toIPv4 <$> replicateM 4 (fromIntegral <$> genWord8) + +genIPv6 :: Gen IPv6 +genIPv6 = toIPv6 <$> replicateM 8 (fromIntegral <$> genWord16) + +genByteString :: Gen BS.ByteString +genByteString = elements + [ "", "a", "a.b", "abc", "a.b.c" ] + +genMboxString :: Gen BS.ByteString +genMboxString = elements + [ "", "a", "a@b", "abc", "a@b.c" ] + +genDomain :: Gen Domain +genDomain = do + bs <- genByteString + pure $ bs <> "." + +genMailbox :: Gen Mailbox +genMailbox = do + bs <- genMboxString + pure $ bs <> "." + +genDNSHeader :: Gen DNSHeader +genDNSHeader = DNSHeader <$> genWord16 <*> genDNSFlags + +genDNSFlags :: Gen DNSFlags +genDNSFlags = + DNSFlags <$> genQorR <*> genOPCODE <*> genBool <*> genBool + <*> genBool <*> genBool <*> genRCODE <*> genBool + +genWord16 :: Gen Word16 +genWord16 = arbitrary + +genWord32 :: Gen Word32 +genWord32 = arbitrary + +genWord8 :: Gen Word8 +genWord8 = arbitrary + +genBool :: Gen Bool +genBool = elements [True, False] + +genQorR :: Gen QorR +genQorR = elements [minBound .. maxBound] + +genOPCODE :: Gen OPCODE +genOPCODE = elements [minBound .. maxBound] + +genRCODE :: Gen RCODE +genRCODE = elements $ map toRCODE [0..15] + +genEDNS0 :: Gen EDNS0 +genEDNS0 = do + erc <- genExtRCODE + ok <- genBool + od <- genOData + return $ defaultEDNS0 { + extRCODE = erc + , dnssecOk = ok + , options = [od] + } + +genOData :: Gen OData +genOData = oneof + [ genOD_Unknown + , OD_ClientSubnet <$> genWord8 <*> genWord8 <*> oneof [ IPv4 <$> genIPv4, IPv6 <$> genIPv6 ] + ] + where + genOD_Unknown = do + bs <- genByteString + let opc = toOptCode $ fromIntegral $ BS.length bs + pure $ UnknownOData opc bs + +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 } }) diff --git a/test2/LookupSpec.hs b/test2/LookupSpec.hs --- a/test2/LookupSpec.hs +++ b/test2/LookupSpec.hs @@ -6,13 +6,53 @@ import Test.Hspec spec :: Spec -spec = do +spec = describe "lookup" $ do - describe "lookupAAAA" $ do - it "gets IPv6 addresses" $ do - rs <- makeResolvSeed defaultResolvConf - withResolver rs $ \resolver -> do - DNS.lookupAAAA resolver "mew.org" - `shouldReturn` - Right [] + it "lookupA" $ do + rs <- makeResolvSeed defaultResolvConf + withResolver rs $ \resolver -> do + addrs <- DNS.lookupA resolver "mew.org" + -- mew.org has one or more IPv6 addresses + fmap null addrs `shouldBe` Right False + it "lookupAAAA" $ do + rs <- makeResolvSeed defaultResolvConf + withResolver rs $ \resolver -> do + -- google.com has one or more IPv6 addresses + addrs <- DNS.lookupAAAA resolver "google.com" + fmap null addrs `shouldBe` Right False + + it "lookupAAAA with emty result" $ do + rs <- makeResolvSeed defaultResolvConf + withResolver rs $ \resolver -> do + addrs <- DNS.lookupAAAA resolver "mew.org" + -- mew.org does not have any IPv6 addresses + fmap null addrs `shouldBe` Right True + + it "lookupMX" $ do + rs <- makeResolvSeed defaultResolvConf + withResolver rs $ \resolver -> do + addrs <- DNS.lookupMX resolver "mew.org" + -- mew.org has one or more MX records. + fmap null addrs `shouldBe` Right False + + it "lookupTXT" $ do + rs <- makeResolvSeed defaultResolvConf + withResolver rs $ \resolver -> do + addrs <- DNS.lookupTXT resolver "mew.org" + -- mew.org has one or more TXT records. + fmap null addrs `shouldBe` Right False + + it "lookupSOA" $ do + rs <- makeResolvSeed defaultResolvConf + withResolver rs $ \resolver -> do + addrs <- DNS.lookupTXT resolver "mew.org" + -- mew.org has a SOA record. + fmap null addrs `shouldBe` Right False + + it "lookupNS" $ do + rs <- makeResolvSeed defaultResolvConf + withResolver rs $ \resolver -> do + addrs <- DNS.lookupNS resolver "mew.org" + -- mew.org has one or more NS records. + fmap null addrs `shouldBe` Right False