dns 2.0.13 → 3.0.0

raw patch · 22 files changed

+2798/−1506 lines, 22 filesdep +QuickCheckdep +asyncdep +auto-updatedep −bytestring-builderdep −network-bytestringdep −randomdep ~basedep ~bytestringdep ~iproutePVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, async, auto-update, base64-bytestring, cryptonite, psqueues, semigroups, split, time

Dependencies removed: bytestring-builder, network-bytestring, random, resourcet

Dependency ranges changed: base, bytestring, iproute, network

API changes (from Hackage documentation)

Files

• Changelog +0/−41
• Changelog.md +66/−0
• Network/DNS.hs +28/−17
• Network/DNS/Decode.hs +32/−282
• Network/DNS/Decode/Internal.hs +255/−0
• Network/DNS/Encode.hs +144/−138
• Network/DNS/IO.hs +162/−0
• Network/DNS/Internal.hs +0/−315
• Network/DNS/Lookup.hs +56/−49
• Network/DNS/LookupRaw.hs +261/−0
• Network/DNS/Memo.hs +77/−0
• Network/DNS/Resolver.hs +108/−417
• Network/DNS/StateBinary.hs +43/−18
• Network/DNS/Transport.hs +200/−0
• Network/DNS/Types.hs +810/−16
• Network/DNS/Types/Internal.hs +122/−0
• cbits/dns.c +77/−0
• dns.cabal +27/−37
• test/DecodeSpec.hs +41/−32
• test/EncodeSpec.hs +37/−136
• test/RoundTripSpec.hs +204/−0
• test2/LookupSpec.hs +48/−8

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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+      }

@@ -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-      }

@@ -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---   <http://www.haskell.org/ghc/docs/7.6.3/html/users_guide/type-class-extensions.html#overloaded-strings>---   for more information.+--   <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#overloaded-string-literals>+--   for more information. In the following examples,+--   we assuem this extension is enabled. --+--   All lookup functions eventually call 'lookupRaw'. See its 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 @@ --   <http://en.wikipedia.org/wiki/DomainKeys_Identified_Mail>. 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

@@ -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

@@ -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

@@ -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)

@@ -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

@@ -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

@@ -1,30 +1,824 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+ -- | Data types for DNS Query and Response. --   For more information, see <http://www.ietf.org/rfc/rfc1035>.  module Network.DNS.Types (-  -- * 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)

@@ -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+}

@@ -0,0 +1,77 @@+#include <winsock2.h>+#include <iphlpapi.h>+#include <string.h>+#include <windows.h>+#include <string.h>++#define MALLOC(x) HeapAlloc(GetProcessHeap(), 0, (x))+#define FREE(x) HeapFree(GetProcessHeap(), 0, (x))++// Fills `dnsAddresses` with the DNS addresses found, up to `bufferLen`.+// Returns NO_ERROR (0x0) in case the operation succeeds, otherwise a non-zero+// error code. See: https://msdn.microsoft.com/en-us/library/windows/desktop/ms681382(v=vs.85).aspx+DWORD getWindowsDefDnsServers(char* dnsAddresses, size_t bufferLen) {+    FIXED_INFO *pFixedInfo;+    ULONG ulOutBufLen;+    DWORD dwRetVal;++    if (bufferLen <= 0) return ERROR_NOT_ENOUGH_MEMORY;++    pFixedInfo = (FIXED_INFO *) MALLOC(sizeof (FIXED_INFO));+    if (pFixedInfo == NULL)+      return ERROR_NOT_ENOUGH_MEMORY;+    ulOutBufLen = sizeof (FIXED_INFO);++    // Make an initial call to GetAdaptersInfo to get the necessary size into the+    // ulOutBufLen variable+    if (GetNetworkParams(pFixedInfo, &ulOutBufLen) == ERROR_BUFFER_OVERFLOW) {+        FREE(pFixedInfo);+        pFixedInfo = (FIXED_INFO *) MALLOC(ulOutBufLen);+        if (pFixedInfo == NULL)+            return ERROR_NOT_ENOUGH_MEMORY;+    }++    dwRetVal = GetNetworkParams(pFixedInfo, &ulOutBufLen);++    if (dwRetVal == NO_ERROR) {+      int offset = 0;+      int spaceAvailable = bufferLen;+      IP_ADDR_STRING* head = &pFixedInfo->DnsServerList;+      int count = 0;++      while (head != NULL) {+        int ipLen = strlen(head->IpAddress.String);+        int copySize = ipLen + 1;++        spaceAvailable -= copySize;+	if (spaceAvailable >= 0) {+	  // Write the separator.+	  // The string is already terminated due to the call to+	  // strcpy_s, which copies the null terminator.+	  if (count != 0) dnsAddresses[offset - 1] = ',';+	  // Copy the IP address, including the null terminator.+	  strcpy_s(dnsAddresses + offset, copySize, head->IpAddress.String);+	  if (spaceAvailable == 0) break;+	} else+	  break;++        offset += copySize;+	count++;+        head = head->Next;+      }++    }++    if (pFixedInfo) FREE(pFixedInfo);+    return dwRetVal;+}++/*++// Test with 'gcc -o dnsServer -Wall -Werror -pedantic -liphlpapi -Iinclude dns.c' on a+// Windows machine.++int main(){+    printf(getWindowsDefDnsServers()->dnsAddresses);+    return 0;+}*/

@@ -1,5 +1,5 @@ Name:                   dns-Version:                2.0.13+Version:                3.0.0 Author:                 Kazu Yamamoto <kazu@iij.ad.jp> Maintainer:             Kazu Yamamoto <kazu@iij.ad.jp> 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

@@ -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

@@ -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])+        ]   }

@@ -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 } })

@@ -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