dns 4.0.0 → 4.0.1

raw patch · 40 files changed

+3667/−3616 lines, 40 filesdep −semigroupsdep −splitdep ~basedep ~iproutedep ~networksetup-changedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: semigroups, split

Dependency ranges changed: base, iproute, network

API changes (from Hackage documentation)

Files

• Changelog.md +23/−0
• Network/DNS.hs +2/−5
• Network/DNS/Base32Hex.hs +0/−50
• Network/DNS/Decode.hs +1/−1
• Network/DNS/Decode/Internal.hs +0/−64
• Network/DNS/Decode/Parsers.hs +0/−470
• Network/DNS/Encode.hs +1/−1
• Network/DNS/Encode/Builders.hs +0/−347
• Network/DNS/Encode/Internal.hs +0/−38
• Network/DNS/IO.hs +1/−3
• Network/DNS/Imports.hs +0/−29
• Network/DNS/Lookup.hs +19/−14
• Network/DNS/LookupRaw.hs +2/−3
• Network/DNS/Memo.hs +0/−97
• Network/DNS/Resolver.hs +2/−37
• Network/DNS/StateBinary.hs +0/−444
• Network/DNS/Transport.hs +15/−8
• Network/DNS/Types.hs +134/−1781
• Network/DNS/Types/Internal.hs +0/−136
• Network/DNS/Utils.hs +1/−1
• Setup.hs +0/−29
• cabal.project +3/−0
• dns.cabal +50/−28
• internal/Network/DNS/Base32Hex.hs +50/−0
• internal/Network/DNS/Decode/Internal.hs +64/−0
• internal/Network/DNS/Decode/Parsers.hs +486/−0
• internal/Network/DNS/Encode/Builders.hs +348/−0
• internal/Network/DNS/Encode/Internal.hs +38/−0
• internal/Network/DNS/Imports.hs +31/−0
• internal/Network/DNS/Memo.hs +99/−0
• internal/Network/DNS/Resolver/Internal.hs +52/−0
• internal/Network/DNS/StateBinary.hs +444/−0
• internal/Network/DNS/Types/Internal.hs +1618/−0
• internal/Network/DNS/Types/Resolver.hs +136/−0
• test/DecodeSpec.hs +3/−2
• test/EncodeSpec.hs +2/−2
• test/RoundTripSpec.hs +6/−12
• test2/IOSpec.hs +4/−3
• test2/LookupSpec.hs +2/−1
• test2/doctests.hs +30/−10

@@ -1,3 +1,26 @@+# 4.0.1++- Bugfix: Retry without EDNS on empty FormatErr responses. Non-EDNS resolvers+  may return a FormErr response with an empty question section. Such a response+  must be accepted as a valid signal to switch to non-EDNS queries, even though+  the response does not contain a matching question.+- Feature: New RData constructors RD_CDS and RD_CDNSKEY+- Usability: More friendly network errors, instead of reporting the error+  location as an overly verbose "addrinfo" it is now just the essential+  "tcp@address" or "udp@address".+- BCP: The EDNS UDP buffer size has been changed to the RIPE recommended+  default of 1232 bytes.  Note that this recomendation is for a default value,+  to be used when better information is not available.  Users can still+  configure larger values if their networks support larger data frames and they+  are certain there is no risk of IP fragmentation.+- CI: Linux tests now pass with GHC 8.0.2, 8.2.2, 8.4.4, 8.6.5 and 8.8.1.+  Windows tests now build and run, but pass only intermittently.  The Windows+  doctests hang most of the time, perhaps a bug or portability issue in the+  doctest code, rather than the DNS library?+- Build: Internal modules are no longer exposed outside the build, this uses+  Cabal 2.0 or later features to expose internal modules only to the test+  executables.+ # 4.0.0  - Breaking change: when `Domain` name ByteStrings are

@@ -9,8 +9,8 @@ --   Examples: -- --   >>> rs <- makeResolvSeed defaultResolvConf---   >>> withResolver rs $ \resolver -> lookupA resolver "www.mew.org"---   Right [210.130.207.72]+--   >>> withResolver rs $ \resolver -> lookupA resolver "192.0.2.1.nip.io"+--   Right [192.0.2.1] module Network.DNS (   -- * High level     module Network.DNS.Lookup@@ -53,6 +53,3 @@ import Network.DNS.Resolver import Network.DNS.Types import Network.DNS.Utils---- $setup--- >>> :set -XOverloadedStrings

@@ -1,50 +0,0 @@-module Network.DNS.Base32Hex (encode) where--import Control.Monad (when)-import qualified Data.Array.MArray as A-import qualified Data.Array.IArray as A-import qualified Data.Array.ST     as A-import qualified Data.ByteString   as B-import Data.Bits---- | Encode ByteString using the--- <https://tools.ietf.org/html/rfc4648#section-7 RFC4648 base32hex>--- encoding with no padding as specified for the--- <https://tools.ietf.org/html/rfc5155#section-3.3 RFC5155 Next Hashed Owner Name>--- field.----encode :: B.ByteString -- ^ input buffer-       -> B.ByteString -- ^ base32hex output-encode bs =-    let len = (8 * B.length bs + 4) `div` 5-        ws  = B.unpack bs-     in B.pack $ A.elems $ A.runSTUArray $ do-        a <- A.newArray (0 :: Int, len-1) 0-        go ws a 0-  where-    toHex32 w | w < 10    = 48 + w-              | otherwise = 55 + w--    load8  a i   = A.readArray  a i-    store8 a i v = A.writeArray a i v--    -- Encode a list of 8-bit words at bit offset @n@-    -- into an array 'a' of 5-bit words.-    go [] a _ = A.mapArray toHex32 a-    go (w:ws) a n = do-        -- Split 8 bits into left, middle and right parts.  The-        -- right part only gets written when the 8-bit input word-        -- splits across three different 5-bit words.-        ---        let (q, r) = n `divMod` 5-            wl =  w `shiftR` ( 3 + r)-            wm = (w `shiftL` ( 5 - r))  `shiftR` 3-            wr = (w `shiftL` (10 - r)) `shiftR` 3-        al <- case r of-              0 -> pure wl-              _ -> (wl .|.) <$> load8 a q-        store8 a q al-        store8 a (q + 1) wm-        when (r > 2) $ store8 a (q+2) wr-        go ws a $ n + 8-{-# INLINE encode #-}

@@ -28,7 +28,7 @@ import Network.DNS.Decode.Parsers import Network.DNS.Imports import Network.DNS.StateBinary-import Network.DNS.Types+import Network.DNS.Types.Internal  ---------------------------------------------------------------- 

@@ -1,64 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}--module Network.DNS.Decode.Internal (-    -- ** Internal message component decoders for tests-    decodeDNSHeader-  , decodeDNSFlags-  , decodeDomain-  , decodeMailbox-  , decodeResourceRecordAt-  , decodeResourceRecord-  ) where--import Network.DNS.Imports-import Network.DNS.StateBinary-import Network.DNS.Types-import Network.DNS.Decode.Parsers---------------------------------------------------------------------- | Decode the 'DNSFlags' field of 'DNSHeader'.  This is an internal function--- exposed only for testing.----decodeDNSFlags :: ByteString -> Either DNSError DNSFlags-decodeDNSFlags bs = fst <$> runSGet getDNSFlags bs---- | Decode the 'DNSHeader' of a message.  This is an internal function.--- exposed only for testing.----decodeDNSHeader :: ByteString -> Either DNSError DNSHeader-decodeDNSHeader bs = fst <$> runSGet getHeader bs---- | Decode a domain name.  Since DNS names may use name compression, it is not--- generally possible to decode the names separately from the enclosing DNS--- message.  This is an internal function exposed only for testing.----decodeDomain :: ByteString -> Either DNSError Domain-decodeDomain bs = fst <$> runSGet getDomain bs---- | Decode a mailbox name (the SOA record /mrname/ field).  Since DNS names--- may use name compression, it is not generally possible to decode the names--- separately from the enclosing DNS message.  This is an internal function.----decodeMailbox :: ByteString -> Either DNSError Mailbox-decodeMailbox bs = fst <$> runSGet getMailbox bs---- | Decoding resource records.---- | Decode a resource record (RR) with any DNS timestamps interpreted at the--- nominal epoch time (see 'decodeAt').  Since RRs may use name compression,--- it is not generally possible to decode resource record separately from the--- enclosing DNS message.  This is an internal function.----decodeResourceRecord :: ByteString -> Either DNSError ResourceRecord-decodeResourceRecord bs = fst <$> runSGet getResourceRecord bs---- | Decode a resource record (RR) with DNS timestamps interpreted at the--- supplied epoch time.  Since RRs may use DNS name compression, it is not--- generally possible to decode resource record separately from the enclosing--- DNS message.  This is an internal function.----decodeResourceRecordAt :: Int64      -- ^ current epoch time-                       -> ByteString -- ^ encoded resource record-                       -> Either DNSError ResourceRecord-decodeResourceRecordAt t bs = fst <$> runSGetAt t getResourceRecord bs

@@ -1,470 +0,0 @@-{-# LANGUAGE BangPatterns, OverloadedStrings #-}--module Network.DNS.Decode.Parsers (-    getResponse-  , getDNSFlags-  , getHeader-  , getResourceRecord-  , getResourceRecords-  , getDomain-  , getMailbox-  ) where--import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BS-import qualified Data.IP-import Data.IP (IP(..), toIPv4, toIPv6b, makeAddrRange)-import Data.List (partition)--import Network.DNS.Imports-import Network.DNS.StateBinary-import Network.DNS.Types---- $setup--- >>> :set -XOverloadedStrings--------------------------------------------------------------------getResponse :: SGet DNSMessage-getResponse = do-    hm <- getHeader-    qdCount <- getInt16-    anCount <- getInt16-    nsCount <- getInt16-    arCount <- getInt16-    queries <- getQueries qdCount-    answers <- getResourceRecords anCount-    authrrs <- getResourceRecords nsCount-    addnrrs <- getResourceRecords arCount-    let (opts, rest) = partition ((==) OPT. rrtype) addnrrs-        flgs         = flags hm-        rc           = fromRCODE $ rcode flgs-        (eh, erc)    = getEDNS rc opts-        hd           = hm { flags = flgs { rcode = erc } }-    pure $ DNSMessage hd eh queries answers authrrs $ ifEDNS eh rest addnrrs--  where--    -- | Get EDNS pseudo-header and the high eight bits of the extended RCODE.-    ---    getEDNS :: Word16 -> AdditionalRecords -> (EDNSheader, RCODE)-    getEDNS rc rrs = case rrs of-        [rr] | Just (edns, erc) <- optEDNS rr-               -> (EDNSheader edns, toRCODE erc)-        []     -> (NoEDNS, toRCODE rc)-        _      -> (InvalidEDNS, BadRCODE)--      where--        -- | Extract EDNS information from an OPT RR.-        ---        optEDNS :: ResourceRecord -> Maybe (EDNS, Word16)-        optEDNS (ResourceRecord "." OPT udpsiz ttl' (RD_OPT opts)) =-            let hrc      = fromIntegral rc .&. 0x0f-                erc      = shiftR (ttl' .&. 0xff000000) 20 .|. hrc-                secok    = ttl' `testBit` 15-                vers     = fromIntegral $ shiftR (ttl' .&. 0x00ff0000) 16-             in Just (EDNS vers udpsiz secok opts, fromIntegral erc)-        optEDNS _ = Nothing--------------------------------------------------------------------getDNSFlags :: SGet DNSFlags-getDNSFlags = do-    flgs <- get16-    oc <- getOpcode flgs-    return $ DNSFlags (getQorR flgs)-                      oc-                      (getAuthAnswer flgs)-                      (getTrunCation flgs)-                      (getRecDesired flgs)-                      (getRecAvailable flgs)-                      (getRcode flgs)-                      (getAuthenData flgs)-                      (getChkDisable flgs)-  where-    getQorR w = if testBit w 15 then QR_Response else QR_Query-    getOpcode w =-        case shiftR w 11 .&. 0x0f of-            n | Just opc <- toOPCODE n-              -> pure opc-              | otherwise-              -> failSGet $ "Unsupported header opcode: " ++ show n-    getAuthAnswer w = testBit w 10-    getTrunCation w = testBit w 9-    getRecDesired w = testBit w 8-    getRecAvailable w = testBit w 7-    getRcode w = toRCODE $ w .&. 0x0f-    getAuthenData w = testBit w 5-    getChkDisable w = testBit w 4--------------------------------------------------------------------getHeader :: SGet DNSHeader-getHeader =-    DNSHeader <$> decodeIdentifier <*> getDNSFlags-  where-    decodeIdentifier = get16--------------------------------------------------------------------getQueries :: Int -> SGet [Question]-getQueries n = replicateM n getQuery--getTYPE :: SGet TYPE-getTYPE = toTYPE <$> get16---- XXX: Include the class when implemented, or otherwise perhaps check the--- implicit assumption that the class is classIN.----getQuery :: SGet Question-getQuery = Question <$> getDomain-                    <*> getTYPE-                    <*  ignoreClass-  where-    ignoreClass = get16--getResourceRecords :: Int -> SGet [ResourceRecord]-getResourceRecords n = replicateM n getResourceRecord--getResourceRecord :: SGet ResourceRecord-getResourceRecord = do-    dom <- getDomain-    typ <- getTYPE-    cls <- get16-    ttl <- get32-    len <- getInt16-    dat <- fitSGet len $ getRData typ len-    return $ ResourceRecord dom typ cls ttl dat---------------------------------------------------------------------- | Helper to find position of RData end, that is, the offset of the first--- byte /after/ the current RData.----rdataEnd :: Int      -- ^ number of bytes left from current position-         -> SGet Int -- ^ end position-rdataEnd !len = (+) len <$> getPosition--getRData :: TYPE -> Int -> SGet RData-getRData NS _    = RD_NS    <$> getDomain-getRData MX _    = RD_MX    <$> get16 <*> getDomain-getRData CNAME _ = RD_CNAME <$> getDomain-getRData DNAME _ = RD_DNAME <$> getDomain-getRData TXT len = RD_TXT   <$> getTXT len-getRData A _     = RD_A . toIPv4 <$> getNBytes 4-getRData AAAA _  = RD_AAAA . toIPv6b <$> getNBytes 16-getRData SOA _   = RD_SOA  <$> getDomain-                           <*> getMailbox-                           <*> decodeSerial-                           <*> decodeRefesh-                           <*> decodeRetry-                           <*> decodeExpire-                           <*> decodeMinimum-  where-    decodeSerial  = get32-    decodeRefesh  = get32-    decodeRetry   = get32-    decodeExpire  = get32-    decodeMinimum = get32-getRData PTR _ = RD_PTR <$> getDomain-getRData SRV _ = RD_SRV <$> decodePriority-                        <*> decodeWeight-                        <*> decodePort-                        <*> getDomain-  where-    decodePriority = get16-    decodeWeight   = get16-    decodePort     = get16-getRData OPT len   = RD_OPT <$> getOpts len----getRData TLSA len = RD_TLSA <$> decodeUsage-                            <*> decodeSelector-                            <*> decodeMType-                            <*> decodeADF-  where-    decodeUsage    = get8-    decodeSelector = get8-    decodeMType    = get8-    decodeADF      = getNByteString (len - 3)----getRData DS len = RD_DS <$> decodeTag-                        <*> decodeAlg-                        <*> decodeDtyp-                        <*> decodeDval-  where-    decodeTag  = get16-    decodeAlg  = get8-    decodeDtyp = get8-    decodeDval = getNByteString (len - 4)----getRData RRSIG len = RD_RRSIG <$> decodeRRSIG-  where-    decodeRRSIG = do-        -- The signature follows a variable length zone name-        -- and occupies the rest of the RData.  Simplest to-        -- checkpoint the position at the start of the RData,-        -- and after reading the zone name, and subtract that-        -- from the RData length.-        ---        end <- rdataEnd len-        typ <- getTYPE-        alg <- get8-        cnt <- get8-        ttl <- get32-        tex <- getDnsTime-        tin <- getDnsTime-        tag <- get16-        dom <- getDomain -- XXX: Enforce no compression?-        pos <- getPosition-        val <- getNByteString $ end - pos-        return $ RDREP_RRSIG typ alg cnt ttl tex tin tag dom val-    getDnsTime   = do-        tnow <- getAtTime-        tdns <- get32-        return $! dnsTime tdns tnow----getRData NULL len = RD_NULL <$> getNByteString len-getRData NSEC len = do-    end <- rdataEnd len-    dom <- getDomain-    pos <- getPosition-    RD_NSEC dom <$> getNsecTypes (end - pos)----getRData DNSKEY len = RD_DNSKEY <$> decodeKeyFlags-                                <*> decodeKeyProto-                                <*> decodeKeyAlg-                                <*> decodeKeyBytes-  where-    decodeKeyFlags  = get16-    decodeKeyProto  = get8-    decodeKeyAlg    = get8-    decodeKeyBytes  = getNByteString (len - 4)----getRData NSEC3 len = do-    dend <- rdataEnd len-    halg <- get8-    flgs <- get8-    iter <- get16-    salt <- getInt8 >>= getNByteString-    hash <- getInt8 >>= getNByteString-    tpos <- getPosition-    RD_NSEC3 halg flgs iter salt hash <$> getNsecTypes (dend - tpos)----getRData NSEC3PARAM _ = RD_NSEC3PARAM <$> decodeHashAlg-                                      <*> decodeFlags-                                      <*> decodeIterations-                                      <*> decodeSalt-  where-    decodeHashAlg    = get8-    decodeFlags      = get8-    decodeIterations = get16-    decodeSalt       = getInt8 >>= getNByteString----getRData _  len = UnknownRData <$> getNByteString len---------------------------------------------------------------------- $------ >>> import Network.DNS.StateBinary--- >>> let Right ((t,_),l) = runSGetWithLeftovers (getTXT 8) "\3foo\3barbaz"--- >>> (t, l) == ("foobar", "baz")--- True---- | Concatenate a sequence of length-prefixed strings of text--- https://tools.ietf.org/html/rfc1035#section-3.3----getTXT :: Int -> SGet ByteString-getTXT !len = B.concat <$> sGetMany "TXT RR string" len getstring-  where-    getstring = getInt8 >>= getNByteString---- <https://tools.ietf.org/html/rfc6891#section-6.1.2>--- Parse a list of EDNS options----getOpts :: Int -> SGet [OData]-getOpts !len = sGetMany "EDNS option" len getoption-  where-    getoption = do-        code <- toOptCode <$> get16-        olen <- getInt16-        getOData code olen---- <https://tools.ietf.org/html/rfc4034#section-4.1>--- Parse a list of NSEC type bitmaps----getNsecTypes :: Int -> SGet [TYPE]-getNsecTypes !len = concat <$> sGetMany "NSEC type bitmap" len getbits-  where-    getbits = do-        window <- flip shiftL 8 <$> getInt8-        blocks <- getInt8-        when (blocks > 32) $-            failSGet $ "NSEC bitmap block too long: " ++ show blocks-        concatMap blkTypes. zip [window, window + 8..] <$> getNBytes blocks-      where-        blkTypes (bitOffset, byte) =-            [ toTYPE $ fromIntegral $ bitOffset + i |-              i <- [0..7], byte .&. bit (7-i) /= 0 ]--------------------------------------------------------------------getOData :: OptCode -> Int -> SGet OData-getOData NSID len = OD_NSID <$> getNByteString len-getOData DAU  len = OD_DAU  <$> getNoctets len-getOData DHU  len = OD_DHU  <$> getNoctets len-getOData N3U  len = OD_N3U  <$> getNoctets len-getOData ClientSubnet len = do-        family  <- get16-        srcBits <- get8-        scpBits <- get8-        addrbs  <- getNByteString (len - 4) -- 4 = 2 + 1 + 1-        ---        -- https://tools.ietf.org/html/rfc7871#section-6-        ---        -- o  ADDRESS, variable number of octets, contains either an IPv4 or-        --    IPv6 address, depending on FAMILY, which MUST be truncated to the-        --    number of bits indicated by the SOURCE PREFIX-LENGTH field,-        --    padding with 0 bits to pad to the end of the last octet needed.-        ---        -- o  A server receiving an ECS option that uses either too few or too-        --    many ADDRESS octets, or that has non-zero ADDRESS bits set beyond-        --    SOURCE PREFIX-LENGTH, SHOULD return FORMERR to reject the packet,-        --    as a signal to the software developer making the request to fix-        --    their implementation.-        ---        -- In order to avoid needless decoding errors, when the ECS encoding-        -- requirements are violated, we construct an OD_ECSgeneric OData,-        -- instread of an IP-specific OD_ClientSubnet OData, which will only-        -- be used for valid inputs.  When the family is neither IPv4(1) nor-        -- IPv6(2), or the address prefix is not correctly encoded (too long-        -- or too short), the OD_ECSgeneric data contains the verbatim input-        -- from the peer.-        ---        case BS.length addrbs == (fromIntegral srcBits + 7) `div` 8 of-            True | Just ip <- bstoip family addrbs srcBits scpBits-                -> pure $ OD_ClientSubnet srcBits scpBits ip-            _   -> pure $ OD_ECSgeneric family srcBits scpBits addrbs-  where-    prefix addr bits = Data.IP.addr $ makeAddrRange addr $ fromIntegral bits-    zeropad = (++ repeat 0). map fromIntegral. B.unpack-    checkBits fromBytes toIP srcBits scpBits bytes =-        let addr       = fromBytes bytes-            maskedAddr = prefix addr srcBits-            maxBits    = fromIntegral $ 8 * length bytes-         in if addr == maskedAddr && scpBits <= maxBits-            then Just $ toIP addr-            else Nothing-    bstoip :: Word16 -> B.ByteString -> Word8 -> Word8 -> Maybe IP-    bstoip family bs srcBits scpBits = case family of-        1 -> checkBits toIPv4  IPv4 srcBits scpBits $ take 4  $ zeropad bs-        2 -> checkBits toIPv6b IPv6 srcBits scpBits $ take 16 $ zeropad bs-        _ -> Nothing-getOData opc len = UnknownOData (fromOptCode opc) <$> getNByteString len---------------------------------------------------------------------- | Pointers MUST point back into the packet per RFC1035 Section 4.1.4.  This--- is further interpreted by the DNS community (from a discussion on the IETF--- DNSOP mailing list) to mean that they don't point back into the same domain.--- Therefore, when starting to parse a domain, the current offset is also a--- strict upper bound on the targets of any pointers that arise while processing--- the domain.  When following a pointer, the target again becomes a stict upper--- bound for any subsequent pointers.  This results in a simple loop-prevention--- algorithm, each sequence of valid pointer values is necessarily strictly--- decreasing!  The third argument to 'getDomain'' is a strict pointer upper--- bound, and is set here to the position at the start of parsing the domain--- or mailbox.------ Note: the separator passed to 'getDomain'' is required to be either \'.\' or--- \'\@\', or else 'unparseLabel' needs to be modified to handle the new value.-----getDomain :: SGet Domain-getDomain = getPosition >>= getDomain' dot--getMailbox :: SGet Mailbox-getMailbox = getPosition >>= getDomain' atsign--dot, atsign :: Word8-dot    = fromIntegral $ fromEnum '.' -- 46-atsign = fromIntegral $ fromEnum '@' -- 64---- $--- Pathological case: pointer embedded inside a label!  The pointer points--- behind the start of the domain and is then absorbed into the initial label!--- Though we don't IMHO have to support this, it is not manifestly illegal, and--- does exercise the code in an interesting way.  Ugly as this is, it also--- "works" the same in Perl's Net::DNS and reportedly in ISC's BIND.------ >>> :{--- let input = "\6\3foo\192\0\3bar\0"---     parser = skipNBytes 1 >> getDomain' dot 1---     Right (output, _) = runSGet parser input---  in output == "foo.\\003foo\\192\\000.bar."--- :}--- True------ The case below fails to point far enough back, and triggers the loop--- prevention code-path.------ >>> :{--- let input = "\6\3foo\192\1\3bar\0"---     parser = skipNBytes 1 >> getDomain' dot 1---     Left (DecodeError err) = runSGet parser input---  in err--- :}--- "invalid name compression pointer"---- | Get a domain name, using sep1 as the separator between the 1st and 2nd--- label.  Subsequent labels (and always the trailing label) are terminated--- with a ".".------ Note: the separator is required to be either \'.\' or \'\@\', or else--- 'unparseLabel' needs to be modified to handle the new value.------ Domain name compression pointers must always refer to a position that--- precedes the start of the current domain name.  The starting offsets form a--- strictly decreasing sequence, which prevents pointer loops.----getDomain' :: Word8 -> Int -> SGet ByteString-getDomain' sep1 ptrLimit = do-    pos <- getPosition-    c <- getInt8-    let n = getValue c-    getdomain pos c n-  where-    getdomain pos c n-      | c == 0 = return "." -- Perhaps the root domain?-      | isPointer c = do-          d <- getInt8-          let offset = n * 256 + d-          when (offset >= ptrLimit) $-              failSGet "invalid name compression pointer"-          mo <- pop offset-          case mo of-              Nothing -> do-                  msg <- getInput-                  -- Reprocess the same ByteString starting at the pointer-                  -- target (offset).-                  let parser = skipNBytes offset >> getDomain' sep1 offset-                  case runSGet parser msg of-                      Left (DecodeError err) -> failSGet err-                      Left err               -> fail $ show err-                      Right o  -> push pos (fst o) >> return (fst o)-              Just o -> push pos o >> return o-      -- As for now, extended labels have no use.-      -- This may change some time in the future.-      | isExtLabel c = return ""-      | otherwise = do-          hs <- unparseLabel sep1 <$> getNByteString n-          ds <- getDomain' dot ptrLimit-          let dom = case ds of -- avoid trailing ".."-                  "." -> hs <> "."-                  _   -> hs <> B.singleton sep1 <> ds-          push pos dom-          return dom-    getValue c = c .&. 0x3f-    isPointer c = testBit c 7 && testBit c 6-    isExtLabel c = not (testBit c 7) && testBit c 6

@@ -21,7 +21,7 @@  import Network.DNS.Imports import Network.DNS.StateBinary-import Network.DNS.Types+import Network.DNS.Types.Internal import Network.DNS.Encode.Builders  -- | Encode a 'DNSMessage' for transmission over UDP.  For transmission over

@@ -1,347 +0,0 @@-{-# LANGUAGE-    BangPatterns-  , RecordWildCards-  , TransformListComp-  #-}---- | DNS Message builder.-module Network.DNS.Encode.Builders (-    putDNSMessage-  , putDNSFlags-  , putHeader-  , putDomain-  , putMailbox-  , putResourceRecord-  ) where--import Control.Monad.State (State, modify, execState, gets)-import qualified Data.ByteString.Builder as BB-import qualified Data.ByteString.Char8 as BS-import qualified Data.ByteString.Lazy.Char8 as LBS-import qualified Data.IP-import Data.List (foldl')-import Data.IP (IP(..), fromIPv4, fromIPv6b, makeAddrRange)-import GHC.Exts (the, groupWith)--import Network.DNS.Imports-import Network.DNS.StateBinary-import Network.DNS.Types--------------------------------------------------------------------putDNSMessage :: DNSMessage -> SPut-putDNSMessage msg = putHeader hd-                    <> putNums-                    <> mconcat (map putQuestion qs)-                    <> mconcat (map putResourceRecord an)-                    <> mconcat (map putResourceRecord au)-                    <> mconcat (map putResourceRecord ad)-  where-    putNums = mconcat $ fmap putInt16 [ length qs-                                      , length an-                                      , length au-                                      , length ad-                                      ]-    hm = header msg-    fl = flags hm-    eh = ednsHeader msg-    qs = question msg-    an = answer msg-    au = authority msg-    hd = ifEDNS eh hm $ hm { flags = fl { rcode = rc } }-    rc = ifEDNS eh <$> id <*> nonEDNSrcode $ rcode fl-      where-        nonEDNSrcode code | fromRCODE code < 16 = code-                          | otherwise           = FormatErr-    ad = prependOpt $ additional msg-      where-        prependOpt ads = mapEDNS eh (fromEDNS ads $ fromRCODE rc) ads-          where-            fromEDNS :: AdditionalRecords -> Word16 -> EDNS -> AdditionalRecords-            fromEDNS rrs rc' edns = ResourceRecord name' type' class' ttl' rdata' : rrs-              where-                name'  = BS.singleton '.'-                type'  = OPT-                class' = maxUdpSize `min` (minUdpSize `max` ednsUdpSize edns)-                ttl0'  = fromIntegral (rc' .&. 0xff0) `shiftL` 20-                vers'  = fromIntegral (ednsVersion edns) `shiftL` 16-                ttl'-                  | ednsDnssecOk edns = ttl0' `setBit` 15 .|. vers'-                  | otherwise         = ttl0' .|. vers'-                rdata' = RD_OPT $ ednsOptions edns--putHeader :: DNSHeader -> SPut-putHeader hdr = putIdentifier (identifier hdr)-                <> putDNSFlags (flags hdr)-  where-    putIdentifier = put16--putDNSFlags :: DNSFlags -> SPut-putDNSFlags DNSFlags{..} = put16 word-  where-    set :: Word16 -> State Word16 ()-    set byte = modify (.|. byte)--    st :: State Word16 ()-    st = sequence_-              [ set (fromRCODE rcode .&. 0x0f)-              , when chkDisable          $ set (bit 4)-              , when authenData          $ set (bit 5)-              , when recAvailable        $ set (bit 7)-              , when recDesired          $ set (bit 8)-              , when trunCation          $ set (bit 9)-              , when authAnswer          $ set (bit 10)-              , set (fromOPCODE opcode `shiftL` 11)-              , when (qOrR==QR_Response) $ set (bit 15)-              ]--    word = execState st 0---- XXX: Use question class when implemented----putQuestion :: Question -> SPut-putQuestion Question{..} = putDomain qname-                           <> put16 (fromTYPE qtype)-                           <> put16 classIN--putResourceRecord :: ResourceRecord -> SPut-putResourceRecord ResourceRecord{..} = mconcat [-    putDomain rrname-  , put16 (fromTYPE rrtype)-  , put16 rrclass-  , put32 rrttl-  , putResourceRData rdata-  ]-  where-    putResourceRData :: RData -> SPut-    putResourceRData rd = do-        addPositionW 2 -- "simulate" putInt16-        rDataBuilder <- putRData rd-        let rdataLength = fromIntegral . LBS.length . BB.toLazyByteString $ rDataBuilder-        let rlenBuilder = BB.int16BE rdataLength-        return $ rlenBuilder <> rDataBuilder---putRData :: RData -> SPut-putRData rd = case rd of-    RD_A                 address -> mconcat $ map putInt8 (fromIPv4 address)-    RD_NS                nsdname -> putDomain nsdname-    RD_CNAME               cname -> putDomain cname-    RD_SOA         a b c d e f g -> putSOA a b c d e f g-    RD_NULL                bytes -> putByteString bytes-    RD_PTR              ptrdname -> putDomain ptrdname-    RD_MX              pref exch -> mconcat [put16 pref, putDomain exch]-    RD_TXT            textstring -> putTXT textstring-    RD_AAAA              address -> mconcat $ map putInt8 (fromIPv6b address)-    RD_SRV       pri wei prt tgt -> putSRV pri wei prt tgt-    RD_DNAME               dname -> putDomain dname-    RD_OPT               options -> mconcat $ fmap putOData options-    RD_DS             kt ka dt d -> putDS kt ka dt d-    RD_RRSIG               rrsig -> putRRSIG rrsig-    RD_NSEC           next types -> putDomain next <> putNsecTypes types-    RD_DNSKEY        f p alg key -> putDNSKEY f p alg key-    RD_NSEC3     a f i s h types -> putNSEC3 a f i s h types-    RD_NSEC3PARAM  a f iter salt -> putNSEC3PARAM a f iter salt-    RD_TLSA           u s m dgst -> putTLSA u s m dgst-    UnknownRData           bytes -> putByteString bytes-  where-    putSOA mn mr serial refresh retry expire minttl = mconcat-        [ putDomain mn-        , putMailbox mr-        , put32 serial-        , put32 refresh-        , put32 retry-        , put32 expire-        , put32 minttl-        ]-    -- TXT record string fragments are at most 255 bytes-    putTXT textstring =-        let (!h, !t) = BS.splitAt 255 textstring-         in putByteStringWithLength h <> if BS.null t-                then mempty-                else putTXT t-    putSRV priority weight port target = mconcat-        [ put16 priority-        , put16 weight-        , put16 port-        , putDomain target-        ]-    putDS keytag keyalg digestType digest = mconcat-        [ put16 keytag-        , put8 keyalg-        , put8 digestType-        , putByteString digest-        ]-    putRRSIG RDREP_RRSIG{..} = mconcat-        [ put16 $ fromTYPE rrsigType-        , put8 rrsigKeyAlg-        , put8 rrsigNumLabels-        , put32 rrsigTTL-        , put32 $ fromIntegral rrsigExpiration-        , put32 $ fromIntegral rrsigInception-        , put16 rrsigKeyTag-        , putDomain rrsigZone-        , putByteString rrsigValue-        ]-    putDNSKEY flags protocol alg key = mconcat-        [ put16 flags-        , put8 protocol-        , put8 alg-        , putByteString key-        ]-    putNSEC3 alg flags iterations salt hash types = mconcat-        [ put8 alg-        , put8 flags-        , put16 iterations-        , putByteStringWithLength salt-        , putByteStringWithLength hash-        , putNsecTypes types-        ]-    putNSEC3PARAM alg flags iterations salt = mconcat-        [ put8 alg-        , put8 flags-        , put16 iterations-        , putByteStringWithLength salt-        ]-    putTLSA usage selector mtype assocData = mconcat-        [ put8 usage-        , put8 selector-        , put8 mtype-        , putByteString assocData-        ]---- | Encode DNSSEC NSEC type bits-putNsecTypes :: [TYPE] -> SPut-putNsecTypes types = putTypeList $ map fromTYPE types-  where-    putTypeList :: [Word16] -> SPut-    putTypeList ts =-        mconcat [ putWindow (the top8) bot8 |-                  t <- ts,-                  let top8 = fromIntegral t `shiftR` 8,-                  let bot8 = fromIntegral t .&. 0xff,-                  then group by top8-                       using groupWith ]--    putWindow :: Int -> [Int] -> SPut-    putWindow top8 bot8s =-        let blks = maximum bot8s `shiftR` 3-         in putInt8 top8-            <> put8 (1 + fromIntegral blks)-            <> putBits 0 [ (the block, foldl' mergeBits 0 bot8) |-                           bot8 <- bot8s,-                           let block = bot8 `shiftR` 3,-                           then group by block-                                using groupWith ]-      where-        -- | Combine type bits in network bit order, i.e. bit 0 first.-        mergeBits acc b = setBit acc (7 - b.&.0x07)--    putBits :: Int -> [(Int, Word8)] -> SPut-    putBits _ [] = pure mempty-    putBits n ((block, octet) : rest) =-        putReplicate (block-n) 0-        <> put8 octet-        <> putBits (block + 1) rest---- | Encode EDNS OPTION consisting of a list of octets.-putODWords :: Word16 -> [Word8] -> SPut-putODWords code ws =-     mconcat [ put16 code-             , putInt16 $ length ws-             , mconcat $ map put8 ws-             ]---- | Encode an EDNS OPTION byte string.-putODBytes :: Word16 -> ByteString -> SPut-putODBytes code bs =-    mconcat [ put16 code-            , putInt16 $ BS.length bs-            , putByteString bs-            ]--putOData :: OData -> SPut-putOData (OD_NSID nsid) = putODBytes (fromOptCode NSID) nsid-putOData (OD_DAU as) = putODWords (fromOptCode DAU) as-putOData (OD_DHU hs) = putODWords (fromOptCode DHU) hs-putOData (OD_N3U hs) = putODWords (fromOptCode N3U) hs-putOData (OD_ClientSubnet srcBits scpBits ip) =-    -- https://tools.ietf.org/html/rfc7871#section-6-    ---    -- o  ADDRESS, variable number of octets, contains either an IPv4 or-    --    IPv6 address, depending on FAMILY, which MUST be truncated to the-    --    number of bits indicated by the SOURCE PREFIX-LENGTH field,-    --    padding with 0 bits to pad to the end of the last octet needed.-    ---    -- o  A server receiving an ECS option that uses either too few or too-    --    many ADDRESS octets, or that has non-zero ADDRESS bits set beyond-    --    SOURCE PREFIX-LENGTH, SHOULD return FORMERR to reject the packet,-    --    as a signal to the software developer making the request to fix-    --    their implementation.-    ---    let octets = fromIntegral $ (srcBits + 7) `div` 8-        prefix addr = Data.IP.addr $ makeAddrRange addr $ fromIntegral srcBits-        (family, raw) = case ip of-                        IPv4 ip4 -> (1, take octets $ fromIPv4  $ prefix ip4)-                        IPv6 ip6 -> (2, take octets $ fromIPv6b $ prefix ip6)-        dataLen = 2 + 2 + octets-     in mconcat [ put16 $ fromOptCode ClientSubnet-                , putInt16 dataLen-                , put16 family-                , put8 srcBits-                , put8 scpBits-                , mconcat $ fmap putInt8 raw-                ]-putOData (OD_ECSgeneric family srcBits scpBits addr) =-    mconcat [ put16 $ fromOptCode ClientSubnet-            , putInt16 $ 4 + BS.length addr-            , put16 family-            , put8 srcBits-            , put8 scpBits-            , putByteString addr-            ]-putOData (UnknownOData code bs) = putODBytes code bs---- In the case of the TXT record, we need to put the string length--- fixme : What happens with the length > 256 ?-putByteStringWithLength :: BS.ByteString -> SPut-putByteStringWithLength bs = putInt8 (fromIntegral $ BS.length bs) -- put the length of the given string-                          <> putByteString bs--------------------------------------------------------------------rootDomain :: Domain-rootDomain = BS.pack "."--putDomain :: Domain -> SPut-putDomain = putDomain' '.'--putMailbox :: Mailbox -> SPut-putMailbox = putDomain' '@'--putDomain' :: Char -> ByteString -> SPut-putDomain' sep dom-    | BS.null dom || dom == rootDomain = put8 0-    | otherwise = do-        mpos <- wsPop dom-        cur <- gets wsPosition-        case mpos of-            Just pos -> putPointer pos-            Nothing  -> wsPush dom cur >>-                        mconcat [ putPartialDomain hd-                                , putDomain' '.' tl-                                ]-  where-    -- Try with the preferred separator if present, else fall back to '.'.-    (hd, tl) =-        let p = parseLabel (c2w sep) dom-         in if sep /= '.' && BS.null (snd p)-            then parseLabel (c2w '.') dom-            else p-    c2w = fromIntegral . fromEnum--putPointer :: Int -> SPut-putPointer pos = putInt16 (pos .|. 0xc000)--putPartialDomain :: Domain -> SPut-putPartialDomain = putByteStringWithLength

@@ -1,38 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}---- | Internal DNS message component encoders for the test-suite.-module Network.DNS.Encode.Internal (-    encodeDNSHeader-  , encodeDNSFlags-  , encodeDomain-  , encodeMailbox-  , encodeResourceRecord-  ) where--import Network.DNS.Encode.Builders-import Network.DNS.Imports-import Network.DNS.StateBinary-import Network.DNS.Types---- | Encode DNS flags.-encodeDNSFlags :: DNSFlags -> ByteString-encodeDNSFlags = runSPut . putDNSFlags---- | Encode DNS header.-encodeDNSHeader :: DNSHeader -> ByteString-encodeDNSHeader = runSPut . putHeader---- | Encode a domain.-encodeDomain :: Domain -> ByteString-encodeDomain = runSPut . putDomain---- | Encode a mailbox name.  The first label is separated from the remaining--- labels by an @'\@'@ rather than a @.@.  This is used for the contact--- address in the @SOA@ record.----encodeMailbox :: Mailbox -> ByteString-encodeMailbox = runSPut . putMailbox---- | Encode a ResourceRecord.-encodeResourceRecord :: ResourceRecord -> ByteString-encodeResourceRecord rr = runSPut $ putResourceRecord rr

@@ -18,7 +18,6 @@   ) where  import qualified Control.Exception as E-import Control.Monad (void) import qualified Data.ByteString as B import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Char8 as BS@@ -31,11 +30,10 @@ import qualified Network.Socket.ByteString as Socket import System.IO.Error - import Network.DNS.Decode (decodeAt) import Network.DNS.Encode (encode) import Network.DNS.Imports-import Network.DNS.Types+import Network.DNS.Types.Internal  ---------------------------------------------------------------- 

@@ -1,29 +0,0 @@-module Network.DNS.Imports (-    ByteString-  , Int64-  , NonEmpty(..)-  , module Control.Applicative-  , module Control.Monad-  , module Data.Bits-  , module Data.List-  , module Data.Maybe-  , module Data.Monoid-  , module Data.Ord-  , module Data.Typeable-  , module Data.Word-  , module Numeric-  ) where--import Control.Applicative-import Control.Monad-import Data.Bits-import Data.ByteString (ByteString)-import Data.Int (Int64)-import Data.List-import Data.List.NonEmpty (NonEmpty(..))-import Data.Maybe-import Data.Monoid-import Data.Ord-import Data.Typeable-import Data.Word-import Numeric

@@ -78,10 +78,7 @@ import Network.DNS.Imports import Network.DNS.LookupRaw as DNS import Network.DNS.Resolver as DNS-import Network.DNS.Types---- $setup--- >>> :set -XOverloadedStrings+import Network.DNS.Types.Internal  ---------------------------------------------------------------- @@ -90,11 +87,11 @@ --   A straightforward example: -- --   >>> rs <- makeResolvSeed defaultResolvConf---   >>> withResolver rs $ \resolver -> lookupA resolver "www.mew.org"---   Right [210.130.207.72]+--   >>> withResolver rs $ \resolver -> lookupA resolver "192.0.2.1.nip.io"+--   Right [192.0.2.1] -- --   This function will also follow a CNAME and resolve its target if---   one exists for the queries hostname:+--   one exists for the queried hostname: -- --   >>> rs <- makeResolvSeed defaultResolvConf --   >>> withResolver rs $ \resolver -> lookupA resolver "www.kame.net"@@ -139,15 +136,15 @@ --   constitute an MX record: a hostname , and an integer priority. We --   therefore return each record as a @('Domain', Int)@. -----   In this first example, we look up the MX for the domain---   \"example.com\". It has no MX (to prevent a deluge of spam from---   examples posted on the internet). But remember, \"no results\" is---   still a successful result.+--   In this first example, we look up the MX for the domain \"example.com\".+--   It has an RFC7505 NULL MX (to prevent a deluge of spam from examples+--   posted on the internet). -- --   >>> rs <- makeResolvSeed defaultResolvConf --   >>> withResolver rs $ \resolver -> lookupMX resolver "example.com"---   Right []+--   Right [(".",0)] --+-- --   The domain \"mew.org\" does however have a single MX: -- --   >>> rs <- makeResolvSeed defaultResolvConf@@ -157,6 +154,13 @@ --   Also note that all hostnames are returned with a trailing dot to --   indicate the DNS root. --+--   However the MX host itself has no need for an MX record, so its MX RRset+--   is empty.  But, \"no results\" is still a successful result.+--+--   >>> rs <- makeResolvSeed defaultResolvConf+--   >>> withResolver rs $ \resolver -> lookupMX resolver "mail.mew.org"+--   Right []+-- lookupMX :: Resolver -> Domain -> IO (Either DNSError [(Domain,Int)]) lookupMX rlv dom = do   erds <- DNS.lookup rlv dom MX@@ -323,8 +327,9 @@ --   using the \'rname\` as a contact email address. -- --   >>> rs <- makeResolvSeed defaultResolvConf---   >>> withResolver rs $ \resolver -> lookupSOA resolver "mew.org"---   Right [("ns1.mew.org.","kazu@mew.org.",201406240,3600,300,3600000,3600)]+--   >>> soa <- withResolver rs $ \resolver -> lookupSOA resolver "mew.org"+--   >>> map (\ (mn, rn, _, _, _, _, _) -> (mn, rn)) <$> soa+--   Right [("ns1.mew.org.","kazu@mew.org.")] -- lookupSOA :: Resolver -> Domain -> IO (Either DNSError [(Domain,Mailbox,Word32,Word32,Word32,Word32,Word32)]) lookupSOA rlv dom = do

@@ -12,18 +12,17 @@   ) where  import Data.Hourglass (timeAdd, Seconds)-import Time.System (timeCurrent) import Prelude hiding (lookup)+import Time.System (timeCurrent)  import Network.DNS.IO import Network.DNS.Imports hiding (lookup) import Network.DNS.Memo import Network.DNS.Transport-import Network.DNS.Types import Network.DNS.Types.Internal+import Network.DNS.Types.Resolver  -- $setup--- >>> :set -XOverloadedStrings -- >>> import Network.DNS.Resolver  ----------------------------------------------------------------

@@ -1,97 +0,0 @@-{-# LANGUAGE RecordWildCards #-}--module Network.DNS.Memo where--import qualified Control.Reaper as R-import qualified Data.ByteString as B-import Data.Hourglass (Elapsed)-import Data.OrdPSQ (OrdPSQ)-import qualified Data.OrdPSQ as PSQ-import Time.System (timeCurrent)--import Network.DNS.Imports-import Network.DNS.Types--data Section = Answer | Authority deriving (Eq, Ord, Show)--type Key = (ByteString-           ,TYPE)-type Prio = Elapsed--type Entry = Either DNSError [RData]--type DB = OrdPSQ Key Prio Entry--type Cache = R.Reaper DB (Key,Prio,Entry)--newCache :: Int -> IO Cache-newCache delay = R.mkReaper R.defaultReaperSettings {-    R.reaperEmpty  = PSQ.empty-  , R.reaperCons   = \(k, tim, v) psq -> PSQ.insert k tim v psq-  , R.reaperAction = prune-  , R.reaperDelay  = delay * 1000000-  , R.reaperNull   = PSQ.null-  }--lookupCache :: Key -> Cache -> IO (Maybe (Prio, Entry))-lookupCache key reaper = PSQ.lookup key <$> R.reaperRead reaper--insertCache :: Key -> Prio -> Entry -> Cache -> IO ()-insertCache (dom,typ) tim ent0 reaper = R.reaperAdd reaper (key,tim,ent)-  where-    key = (B.copy dom,typ)-    ent = case ent0 of-      l@(Left _)  -> l-      (Right rds) -> Right $ map copy rds---- Theoretically speaking, atMostView itself is good enough for pruning.--- But auto-update assumes a list based db which does not provide atMost--- functions. So, we need to do this redundant way.-prune :: DB -> IO (DB -> DB)-prune oldpsq = do-    tim <- timeCurrent-    let (_, pruned) = PSQ.atMostView tim oldpsq-    return $ \newpsq -> foldl' ins pruned $ PSQ.toList newpsq-  where-    ins psq (k,p,v) = PSQ.insert k p v psq--copy :: RData -> RData-copy r@(RD_A _)           = r-copy (RD_NS dom)          = RD_NS $ B.copy dom-copy (RD_CNAME dom)       = RD_CNAME $ B.copy dom-copy (RD_SOA mn mr a b c d e) = RD_SOA (B.copy mn) (B.copy mr) a b c d e-copy (RD_PTR dom)         = RD_PTR $ B.copy dom-copy (RD_NULL bytes)      = RD_NULL $ B.copy bytes-copy (RD_MX prf dom)      = RD_MX prf $ B.copy dom-copy (RD_TXT txt)         = RD_TXT $ B.copy txt-copy 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_NSEC dom ts)     = RD_NSEC (B.copy dom) ts-copy (RD_DNSKEY f p a k)  = RD_DNSKEY f p a $ B.copy k-copy (RD_TLSA a b c dgst) = RD_TLSA a b c $ B.copy dgst-copy (RD_NSEC3 a b c s h t) = RD_NSEC3 a b c (B.copy s) (B.copy h) t-copy (RD_NSEC3PARAM a b c salt) = RD_NSEC3PARAM a b c $ B.copy salt-copy (RD_RRSIG sig)       = RD_RRSIG $ copysig sig-  where-    copysig s@RDREP_RRSIG{..} =-        s { rrsigZone = B.copy rrsigZone-          , rrsigValue = B.copy rrsigValue }-copy (UnknownRData is)    = UnknownRData $ B.copy is--copyOData :: OData -> OData-copyOData (OD_ECSgeneric family srcBits scpBits bs) =-    OD_ECSgeneric family srcBits scpBits $ B.copy bs-copyOData (OD_NSID nsid) = OD_NSID $ B.copy nsid-copyOData (UnknownOData c b)        = UnknownOData c $ B.copy b---- No copying required for the rest, but avoiding a wildcard pattern match--- so that if more option types are added in the future, the compiler will--- complain about a partial function.----copyOData o@OD_ClientSubnet {} = o-copyOData o@OD_DAU {} = o-copyOData o@OD_DHU {} = o-copyOData o@OD_N3U {} = o

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-} @@ -30,12 +29,6 @@   , withResolvers   ) where -#if !defined(mingw32_HOST_OS)-#define POSIX-#else-#define WIN-#endif- import Control.Exception as E import qualified Crypto.Random as C import qualified Data.ByteString as BS@@ -45,19 +38,12 @@ import Network.Socket (AddrInfoFlag(..), AddrInfo(..), PortNumber, HostName, SocketType(Datagram), getAddrInfo, defaultHints) import Prelude -#if defined(WIN)-import qualified Data.List.Split as Split-import Foreign.C.String-import Foreign.Marshal.Alloc (allocaBytes)-#else-import Data.Char (isSpace)-#endif- import Network.DNS.Imports import Network.DNS.Memo+import Network.DNS.Resolver.Internal import Network.DNS.Transport-import Network.DNS.Types import Network.DNS.Types.Internal+import Network.DNS.Types.Resolver  ---------------------------------------------------------------- @@ -78,27 +64,6 @@         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

@@ -1,444 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}-module Network.DNS.StateBinary (-    PState(..)-  , initialState-  , SPut-  , runSPut-  , put8-  , put16-  , put32-  , putInt8-  , putInt16-  , putInt32-  , putByteString-  , putReplicate-  , SGet-  , failSGet-  , fitSGet-  , runSGet-  , runSGetAt-  , runSGetWithLeftovers-  , runSGetWithLeftoversAt-  , get8-  , get16-  , get32-  , getInt8-  , getInt16-  , getInt32-  , getNByteString-  , sGetMany-  , getPosition-  , getInput-  , getAtTime-  , wsPop-  , wsPush-  , wsPosition-  , addPositionW-  , push-  , pop-  , getNBytes-  , getNoctets-  , skipNBytes-  , parseLabel-  , unparseLabel-  ) where--import qualified Control.Exception as E-import Control.Monad.State.Strict (State, StateT)-import qualified Control.Monad.State.Strict as ST-import qualified Data.Attoparsec.ByteString as A-import qualified Data.Attoparsec.Types as T-import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as S8-import Data.ByteString.Builder (Builder)-import qualified Data.ByteString.Builder as BB-import qualified Data.ByteString.Lazy as LB-import qualified Data.ByteString.Lazy.Char8 as LBS-import Data.IntMap (IntMap)-import qualified Data.IntMap as IM-import Data.Map (Map)-import qualified Data.Map as M-import Data.Semigroup as Sem--import Network.DNS.Imports-import Network.DNS.Types--------------------------------------------------------------------type SPut = State WState Builder--data WState = WState {-    wsDomain :: Map Domain Int-  , wsPosition :: Int-}--initialWState :: WState-initialWState = WState M.empty 0--instance Sem.Semigroup SPut where-    p1 <> p2 = (Sem.<>) <$> p1 <*> p2--instance Monoid SPut where-    mempty = return mempty-#if !(MIN_VERSION_base(4,11,0))-    mappend = (Sem.<>)-#endif--put8 :: Word8 -> SPut-put8 = fixedSized 1 BB.word8--put16 :: Word16 -> SPut-put16 = fixedSized 2 BB.word16BE--put32 :: Word32 -> SPut-put32 = fixedSized 4 BB.word32BE--putInt8 :: Int -> SPut-putInt8 = fixedSized 1 (BB.int8 . fromIntegral)--putInt16 :: Int -> SPut-putInt16 = fixedSized 2 (BB.int16BE . fromIntegral)--putInt32 :: Int -> SPut-putInt32 = fixedSized 4 (BB.int32BE . fromIntegral)--putByteString :: ByteString -> SPut-putByteString = writeSized BS.length BB.byteString--putReplicate :: Int -> Word8 -> SPut-putReplicate n w =-    fixedSized n BB.lazyByteString $ LB.replicate (fromIntegral n) w--addPositionW :: Int -> State WState ()-addPositionW n = do-    (WState m cur) <- ST.get-    ST.put $ WState m (cur+n)--fixedSized :: Int -> (a -> Builder) -> a -> SPut-fixedSized n f a = do addPositionW n-                      return (f a)--writeSized :: (a -> Int) -> (a -> Builder) -> a -> SPut-writeSized n f a = do addPositionW (n a)-                      return (f a)--wsPop :: Domain -> State WState (Maybe Int)-wsPop dom = do-    doms <- ST.gets wsDomain-    return $ M.lookup dom doms--wsPush :: Domain -> Int -> State WState ()-wsPush dom pos = do-    (WState m cur) <- ST.get-    ST.put $ WState (M.insert dom pos m) cur--------------------------------------------------------------------type SGet = StateT PState (T.Parser ByteString)--data PState = PState {-    psDomain :: IntMap Domain-  , psPosition :: Int-  , psInput :: ByteString-  , psAtTime  :: Int64-  }--------------------------------------------------------------------getPosition :: SGet Int-getPosition = ST.gets psPosition--getInput :: SGet ByteString-getInput = ST.gets psInput--getAtTime :: SGet Int64-getAtTime = ST.gets psAtTime--addPosition :: Int -> SGet ()-addPosition n | n < 0 = failSGet "internal error: negative position increment"-              | otherwise = do-    PState dom pos inp t <- ST.get-    let !pos' = pos + n-    when (pos' > BS.length inp) $-        failSGet "malformed or truncated input"-    ST.put $ PState dom pos' inp t--push :: Int -> Domain -> SGet ()-push n d = do-    PState dom pos inp t <- ST.get-    ST.put $ PState (IM.insert n d dom) pos inp t--pop :: Int -> SGet (Maybe Domain)-pop n = ST.gets (IM.lookup n . psDomain)--------------------------------------------------------------------get8 :: SGet Word8-get8  = ST.lift A.anyWord8 <* addPosition 1--get16 :: SGet Word16-get16 = ST.lift getWord16be <* addPosition 2-  where-    word8' = fromIntegral <$> A.anyWord8-    getWord16be = do-        a <- word8'-        b <- word8'-        return $ a * 0x100 + b--get32 :: SGet Word32-get32 = ST.lift getWord32be <* addPosition 4-  where-    word8' = fromIntegral <$> A.anyWord8-    getWord32be = do-        a <- word8'-        b <- word8'-        c <- word8'-        d <- word8'-        return $ a * 0x1000000 + b * 0x10000 + c * 0x100 + d--getInt8 :: SGet Int-getInt8 = fromIntegral <$> get8--getInt16 :: SGet Int-getInt16 = fromIntegral <$> get16--getInt32 :: SGet Int-getInt32 = fromIntegral <$> get32--------------------------------------------------------------------overrun :: SGet a-overrun = failSGet "malformed or truncated input"--getNBytes :: Int -> SGet [Int]-getNBytes n | n < 0     = overrun-            | otherwise = toInts <$> getNByteString n-  where-    toInts = map fromIntegral . BS.unpack--getNoctets :: Int -> SGet [Word8]-getNoctets n | n < 0     = overrun-             | otherwise = BS.unpack <$> getNByteString n--skipNBytes :: Int -> SGet ()-skipNBytes n | n < 0     = overrun-             | otherwise = ST.lift (A.take n) >> addPosition n--getNByteString :: Int -> SGet ByteString-getNByteString n | n < 0     = overrun-                 | otherwise = ST.lift (A.take n) <* addPosition n--fitSGet :: Int -> SGet a -> SGet a-fitSGet len parser | len < 0   = overrun-                   | otherwise = do-    pos0 <- getPosition-    ret <- parser-    pos' <- getPosition-    if pos' == pos0 + len-    then return $! ret-    else if pos' > pos0 + len-    then failSGet "element size exceeds declared size"-    else failSGet "element shorter than declared size"---- | Parse a list of elements that takes up exactly a given number of bytes.--- In order to avoid infinite loops, if an element parser succeeds without--- moving the buffer offset forward, an error will be returned.----sGetMany :: String -- ^ element type for error messages-         -> Int    -- ^ input buffer length-         -> SGet a -- ^ element parser-         -> SGet [a]-sGetMany elemname len parser | len < 0   = overrun-                             | otherwise = go len []-  where-    go n xs-        | n < 0     = failSGet $ elemname ++ " longer than declared size"-        | n == 0    = pure $ reverse xs-        | otherwise = do-            pos0 <- getPosition-            x    <- parser-            pos1 <- getPosition-            if pos1 <= pos0-            then failSGet $ "internal error: in-place success for " ++ elemname-            else go (n + pos0 - pos1) (x : xs)---------------------------------------------------------------------- | To get a broad range of correct RRSIG inception and expiration times--- without over or underflow, we choose a time half way between midnight PDT--- 2010-07-15 (the day the root zone was signed) and 2^32 seconds later on--- 2146-08-21.  Since 'decode' and 'runSGet' are pure, we can't peek at the--- current time while parsing.  Outside this date range the output is off by--- some non-zero multiple 2\^32 seconds.----dnsTimeMid :: Int64-dnsTimeMid = 3426660848--initialState :: Int64 -> ByteString -> PState-initialState t inp = PState IM.empty 0 inp t---- Construct our own error message, without the unhelpful AttoParsec--- \"Failed reading: \" prefix.----failSGet :: String -> SGet a-failSGet msg = ST.lift (fail "" A.<?> msg)--runSGetAt :: Int64 -> SGet a -> ByteString -> Either DNSError (a, PState)-runSGetAt t parser inp =-    toResult $ A.parse (ST.runStateT parser $ initialState t inp) inp-  where-    toResult :: A.Result r -> Either DNSError r-    toResult (A.Done _ r)        = Right r-    toResult (A.Fail _ ctx msg)  = Left $ DecodeError $ head $ ctx ++ [msg]-    toResult (A.Partial _)       = Left $ DecodeError "incomplete input"--runSGet :: SGet a -> ByteString -> Either DNSError (a, PState)-runSGet = runSGetAt dnsTimeMid--runSGetWithLeftoversAt :: Int64      -- ^ Reference time for DNS clock arithmetic-                       -> SGet a     -- ^ Parser-                       -> ByteString -- ^ Encoded message-                       -> Either DNSError ((a, PState), ByteString)-runSGetWithLeftoversAt t parser inp =-    toResult $ A.parse (ST.runStateT parser $ initialState t inp) inp-  where-    toResult :: A.Result r -> Either DNSError (r, ByteString)-    toResult (A.Done     i r) = Right (r, i)-    toResult (A.Partial  f)   = toResult $ f BS.empty-    toResult (A.Fail _ ctx e) = Left $ DecodeError $ head $ ctx ++ [e]--runSGetWithLeftovers :: SGet a -> ByteString -> Either DNSError ((a, PState), ByteString)-runSGetWithLeftovers = runSGetWithLeftoversAt dnsTimeMid--runSPut :: SPut -> ByteString-runSPut = LBS.toStrict . BB.toLazyByteString . flip ST.evalState initialWState---------------------------------------------------------------------- | Decode a domain name in A-label form to a leading label and a tail with--- the remaining labels, unescaping backlashed chars and decimal triples along--- the way. Any  U-label conversion belongs at the layer above this code.------ This function is pure, but is not total, it throws an error when presented--- with malformed input----parseLabel :: Word8 -> ByteString -> (ByteString, ByteString)-parseLabel sep dom =-    if BS.any (== bslash) dom-    then toResult $ A.parse (labelParser sep mempty) dom-    else check $ safeTail <$> BS.break (== sep) dom-  where-    toResult (A.Partial c)  = toResult (c mempty)-    toResult (A.Done tl hd) = check (hd, tl)-    toResult _ = bottom-    safeTail bs | BS.null bs = mempty-                | otherwise = BS.tail bs-    check r@(hd, tl) | not (BS.null hd) || BS.null tl = r-                     | otherwise = bottom-    bottom = E.throw $ DecodeError $ "invalid domain: " ++ S8.unpack dom--labelParser :: Word8 -> ByteString -> A.Parser ByteString-labelParser sep acc = do-    acc' <- mappend acc <$> A.option mempty simple-    labelEnd sep acc' <|> (escaped >>= labelParser sep . BS.snoc acc')-  where-    simple = fst <$> A.match skipUnescaped-      where-        skipUnescaped = A.skipMany1 $ A.satisfy notSepOrBslash-        notSepOrBslash w = w /= sep && w /= bslash--    escaped = do-        A.skip (== bslash)-        either decodeDec pure =<< A.eitherP digit A.anyWord8-      where-        digit = fromIntegral <$> A.satisfyWith (\n -> n - zero) (<=9)-        decodeDec d =-            safeWord8 =<< trigraph d <$> digit <*> digit-          where-            trigraph :: Word -> Word -> Word -> Word-            trigraph x y z = 100 * x + 10 * y + z--            safeWord8 :: Word -> A.Parser Word8-            safeWord8 n | n > 255 = mzero-                        | otherwise = pure $ fromIntegral n--labelEnd :: Word8 -> ByteString -> A.Parser ByteString-labelEnd sep acc =-    A.satisfy (== sep) *> pure acc <|>-    A.endOfInput       *> pure acc---------------------------------------------------------------------- | Convert a wire-form label to presentation-form by escaping--- the separator, special and non-printing characters.  For simple--- labels with no bytes that require escaping we get back the input--- bytestring asis with no copying or re-construction.------ Note: the separator is required to be either \'.\' or \'\@\', but this--- constraint is the caller's responsibility and is not checked here.----unparseLabel :: Word8 -> ByteString -> ByteString-unparseLabel sep label =-    if BS.all (isPlain sep) label-    then label-    else toResult $ A.parse (labelUnparser sep mempty) label-  where-    toResult (A.Partial c) = toResult (c mempty)-    toResult (A.Done _ r) = r-    toResult _ = E.throw UnknownDNSError -- can't happen--labelUnparser :: Word8 -> ByteString -> A.Parser ByteString-labelUnparser sep acc = do-    acc' <- mappend acc <$> A.option mempty asis-    A.endOfInput *> pure acc' <|> (esc >>= labelUnparser sep . mappend acc')-  where-    -- Non-printables are escaped as decimal trigraphs, while printable-    -- specials just get a backslash prefix.-    esc = do-        w <- A.anyWord8-        if w <= 32 || w >= 127-        then let (q100, r100) = w `divMod` 100-                 (q10, r10) = r100 `divMod` 10-              in pure $ BS.pack [ bslash, zero + q100, zero + q10, zero + r10 ]-        else pure $ BS.pack [ bslash, w ]--    -- Runs of plain bytes are recognized as a single chunk, which is then-    -- returned as-is.-    asis = fmap fst $ A.match $ A.skipMany1 $ A.satisfy $ isPlain sep---- | In the presentation form of DNS labels, these characters are escaped by--- prepending a backlash. (They have special meaning in zone files). Whitespace--- and other non-printable or non-ascii characters are encoded via "\DDD"--- decimal escapes. The separator character is also quoted in each label. Note--- that '@' is quoted even when not the separator.-escSpecials :: ByteString-escSpecials = "\"$();@\\"---- | Is the given byte the separator or one of the specials?-isSpecial :: Word8 -> Word8 -> Bool-isSpecial sep w = w == sep || BS.elemIndex w escSpecials /= Nothing---- | Is the given byte a plain byte that reqires no escaping. The tests are--- ordered to succeed or fail quickly in the most common cases. The test--- ranges assume the expected numeric values of the named special characters.--- Note: the separator is assumed to be either '.' or '@' and so not matched by--- any of the first three fast-path 'True' cases.-isPlain :: Word8 -> Word8 -> Bool-isPlain sep w | w >= 127                 = False -- <DEL> + non-ASCII-              | w > bslash               = True  -- ']'..'_'..'a'..'z'..'~'-              | w >= zero && w < semi    = True  -- '0'..'9'..':'-              | w > atsign && w < bslash = True  -- 'A'..'Z'..'['-              | w <= 32                  = False -- non-printables-              | isSpecial sep w          = False -- one of the specials-              | otherwise                = True  -- plain punctuation---- | Some numeric byte constants.-zero, semi, atsign, bslash :: Word8-zero = fromIntegral $ fromEnum '0'    -- 48-semi = fromIntegral $ fromEnum ';'    -- 59-atsign = fromIntegral $ fromEnum '@'  -- 64-bslash = fromIntegral $ fromEnum '\\' -- 92

@@ -16,18 +16,24 @@  import Network.DNS.IO import Network.DNS.Imports-import Network.DNS.Types import Network.DNS.Types.Internal+import Network.DNS.Types.Resolver  -- | Check response for a matching identifier and question.  If we ever do -- pipelined TCP, we'll need to handle out of order responses.  See: -- https://tools.ietf.org/html/rfc7766#section-7+-- checkResp :: Question -> Identifier -> DNSMessage -> Bool checkResp q seqno = isNothing . checkRespM q seqno +-- When the response 'RCODE' is 'FormatErr', the server did not understand our+-- query packet, and so is not expected to return a matching question.+-- checkRespM :: Question -> Identifier -> DNSMessage -> Maybe DNSError checkRespM q seqno resp   | identifier (header resp) /= seqno = Just SequenceNumberMismatch+  | FormatErr <- rcode $ flags $ header resp+  , []        <- question resp        = Nothing   | [q] /= question resp              = Just QuestionMismatch   | otherwise                         = Nothing @@ -133,9 +139,10 @@ ----------------------------------------------------------------  ioErrorToDNSError :: AddrInfo -> String -> IOError -> IO DNSMessage-ioErrorToDNSError ai tag ioe = throwIO $ NetworkFailure aioe+ioErrorToDNSError ai protoName ioe = throwIO $ NetworkFailure aioe   where-    aioe = annotateIOError ioe (show ai) Nothing $ Just tag+    loc = protoName ++ "@" ++ show (addrAddress ai)+    aioe = annotateIOError ioe loc Nothing Nothing  ---------------------------------------------------------------- @@ -149,7 +156,7 @@ udpLookup :: Identifier -> UdpRslv udpLookup ident retry rcv ai q tm ctls = do     let qry = encodeQuestion ident q ctls-    E.handle (ioErrorToDNSError ai "UDP") $+    E.handle (ioErrorToDNSError ai "udp") $       bracket (udpOpen ai) close (loop qry ctls 0 RetryLimitExceeded)   where     loop qry lctls cnt err sock@@ -178,9 +185,9 @@     -- instead we'll time out if no matching answer arrives.     --     getAns sock = do-        mres <- rcv sock-        if checkResp q ident mres-        then return mres+        resp <- rcv sock+        if checkResp q ident resp+        then return resp         else getAns sock  ----------------------------------------------------------------@@ -197,7 +204,7 @@ -- This throws DNSError only. tcpLookup :: IO Identifier -> TcpRslv tcpLookup gen ai q tm ctls =-    E.handle (ioErrorToDNSError ai "TCP") $ do+    E.handle (ioErrorToDNSError ai "tcp") $ do         res <- bracket (tcpOpen addr) close (perform ctls)         let rc = rcode $ flags $ header res             eh = ednsHeader res

@@ -1,1781 +1,134 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE CPP #-}---- | Data types for DNS Query and Response.---   For more information, see <http://www.ietf.org/rfc/rfc1035>.--module Network.DNS.Types (-  -- * Resource Records-    ResourceRecord (..)-  , Answers-  , AuthorityRecords-  , AdditionalRecords-  -- ** Types-  , Domain-  , CLASS-  , classIN-  , TTL-  -- ** Resource Record Types-  , TYPE (-    A-  , NS-  , CNAME-  , SOA-  , NULL-  , PTR-  , MX-  , TXT-  , AAAA-  , SRV-  , DNAME-  , OPT-  , DS-  , RRSIG-  , NSEC-  , DNSKEY-  , NSEC3-  , NSEC3PARAM-  , TLSA-  , CDS-  , CDNSKEY-  , CSYNC-  , AXFR-  , ANY-  , CAA-  )-  , fromTYPE-  , toTYPE-  -- ** Resource Data-  , RData (..)-  , RD_RRSIG(..)-  , dnsTime-  -- * DNS Message-  , DNSMessage (..)-  -- ** Query-  , makeQuery-  , makeEmptyQuery-  , defaultQuery-  -- ** Query Controls-  , QueryControls-  , rdFlag-  , adFlag-  , cdFlag-  , doFlag-  , ednsEnabled-  , ednsSetVersion-  , ednsSetUdpSize-  , ednsSetOptions-  -- *** Flag and OData control operations-  , FlagOp(..)-  , ODataOp(..)-  -- ** Response-  , defaultResponse-  , makeResponse-  -- ** DNS Header-  , DNSHeader (..)-  , Identifier-  -- *** DNS flags-  , DNSFlags (..)-  , QorR (..)-  , defaultDNSFlags-  -- *** OPCODE and RCODE-  , OPCODE (..)-  , fromOPCODE-  , toOPCODE-  , RCODE (-    NoErr-  , FormatErr-  , ServFail-  , NameErr-  , NotImpl-  , Refused-  , YXDomain-  , YXRRSet-  , NXRRSet-  , NotAuth-  , NotZone-  , BadVers-  , BadKey-  , BadTime-  , BadMode-  , BadName-  , BadAlg-  , BadTrunc-  , BadCookie-  , BadRCODE-  )-  , fromRCODE-  , toRCODE-  -- ** EDNS Pseudo-Header-  , EDNSheader(..)-  , ifEDNS-  , mapEDNS-  -- *** EDNS record-  , EDNS(..)-  , defaultEDNS-  , maxUdpSize-  , minUdpSize-  -- *** EDNS options-  , OData (..)-  , OptCode (-    ClientSubnet-  , DAU-  , DHU-  , N3U-  , NSID-  )-  , fromOptCode-  , toOptCode-  -- ** DNS Body-  , Question (..)-  -- * DNS Error-  , DNSError (..)-  -- * Other types-  , Mailbox-  ) where--import Control.Exception (Exception, IOException)-import Control.Applicative ((<|>))-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BS-import Data.Char (intToDigit)-import Data.Function (on)-import qualified Data.Hourglass as H-import Data.IP (IP(..), IPv4, IPv6)-import qualified Data.List as List-import           Data.Maybe (fromMaybe)-import qualified Data.Semigroup as Sem--import qualified Data.ByteString.Base16 as B16-import qualified Network.DNS.Base32Hex as B32-import qualified Data.ByteString.Base64 as B64--import Network.DNS.Imports---- $setup--- >>> :set -XOverloadedStrings--- >>> import Network.DNS---------------------------------------------------------------------- | This type holds the /presentation form/ of fully-qualified DNS domain--- names encoded as ASCII A-labels, with \'.\' separators between labels.--- Non-printing characters are escaped as @\\DDD@ (a backslash, followed by--- three decimal digits). The special characters: @ \", \$, (, ), ;, \@,@ and--- @\\@ are escaped by prepending a backslash.  The trailing \'.\' is optional--- on input, but is recommended, and is always added when decoding from--- /wire form/.------ The encoding of domain names to /wire form/, e.g. for transmission in a--- query, requires the input encodings to be valid, otherwise a 'DecodeError'--- may be thrown. Domain names received in wire form in DNS messages are--- escaped to this presentation form as part of decoding the 'DNSMessage'.------ This form is ASCII-only. Any conversion between A-label 'ByteString's,--- and U-label 'Text' happens at whatever layer maps user input to DNS--- names, or presents /friendly/ DNS names to the user.  Not all users--- can read all scripts, and applications that default to U-label form--- should ideally give the user a choice to see the A-label form.--- Examples:------ @--- www.example.org.           -- Ordinary DNS name.--- \_25.\_tcp.mx1.example.net.  -- TLSA RR initial labels have \_ prefixes.--- \\001.exotic.example.       -- First label is Ctrl-A!--- just\\.one\\.label.example.  -- First label is \"just.one.label\"--- @----type Domain = ByteString---- | Type for a mailbox encoded on the wire as a DNS name, but the first label--- is conceptually the local part of an email address, and may contain internal--- periods that are not label separators. Therefore, in mailboxes \@ is used as--- the separator between the first and second labels, and any \'.\' characters--- in the first label are not escaped.  The encoding is otherwise the same as--- 'Domain' above. This is most commonly seen in the /mrname/ of @SOA@ records.--- On input, if there is no unescaped \@ character in the 'Mailbox', it is--- reparsed with \'.\' as the first label separator. Thus the traditional--- format with all labels separated by dots is also accepted, but decoding from--- wire form always uses \@ between the first label and the domain-part of the--- address.  Examples:------ @--- hostmaster\@example.org.  -- First label is simply @hostmaster@--- john.smith\@examle.com.   -- First label is @john.smith@--- @----type Mailbox = ByteString--------------------------------------------------------------------#if __GLASGOW_HASKELL__ >= 800--- | Types for resource records.-newtype TYPE = TYPE {-    -- | From type to number.-    fromTYPE :: Word16-  } deriving (Eq, Ord)---- https://www.iana.org/assignments/dns-parameters/dns-parameters.xhtml#dns-parameters-4---- | IPv4 address-pattern A :: TYPE-pattern A          = TYPE   1--- | An authoritative name serve-pattern NS :: TYPE-pattern NS         = TYPE   2--- | The canonical name for an alias-pattern CNAME :: TYPE-pattern CNAME      = TYPE   5--- | Marks the start of a zone of authority-pattern SOA :: TYPE-pattern SOA        = TYPE   6--- | A null RR (EXPERIMENTAL)-pattern NULL :: TYPE-pattern NULL       = TYPE  10--- | A domain name pointer-pattern PTR :: TYPE-pattern PTR        = TYPE  12--- | Mail exchange-pattern MX :: TYPE-pattern MX         = TYPE  15--- | Text strings-pattern TXT :: TYPE-pattern TXT        = TYPE  16--- | IPv6 Address-pattern AAAA :: TYPE-pattern AAAA       = TYPE  28--- | Server Selection (RFC2782)-pattern SRV :: TYPE-pattern SRV        = TYPE  33--- | DNAME (RFC6672)-pattern DNAME :: TYPE-pattern DNAME      = TYPE  39 -- RFC 6672--- | OPT (RFC6891)-pattern OPT :: TYPE-pattern OPT        = TYPE  41 -- RFC 6891--- | Delegation Signer (RFC4034)-pattern DS :: TYPE-pattern DS         = TYPE  43 -- RFC 4034--- | RRSIG (RFC4034)-pattern RRSIG :: TYPE-pattern RRSIG      = TYPE  46 -- RFC 4034--- | NSEC (RFC4034)-pattern NSEC :: TYPE-pattern NSEC       = TYPE  47 -- RFC 4034--- | DNSKEY (RFC4034)-pattern DNSKEY :: TYPE-pattern DNSKEY     = TYPE  48 -- RFC 4034--- | NSEC3 (RFC5155)-pattern NSEC3 :: TYPE-pattern NSEC3      = TYPE  50 -- RFC 5155--- | NSEC3PARAM (RFC5155)-pattern NSEC3PARAM :: TYPE-pattern NSEC3PARAM = TYPE  51 -- RFC 5155--- | TLSA (RFC6698)-pattern TLSA :: TYPE-pattern TLSA       = TYPE  52 -- RFC 6698--- | Child DS (RFC7344)-pattern CDS :: TYPE-pattern CDS        = TYPE  59 -- RFC 7344--- | DNSKEY(s) the Child wants reflected in DS (RFC7344)-pattern CDNSKEY :: TYPE-pattern CDNSKEY    = TYPE  60 -- RFC 7344--- | Child-To-Parent Synchronization (RFC7477)-pattern CSYNC :: TYPE-pattern CSYNC      = TYPE  62 -- RFC 7477--- | Zone transfer (RFC5936)-pattern AXFR :: TYPE-pattern AXFR       = TYPE 252 -- RFC 5936--- | A request for all records the server/cache has available-pattern ANY :: TYPE-pattern ANY        = TYPE 255--- | Certification Authority Authorization (RFC6844)-pattern CAA :: TYPE-pattern CAA        = TYPE 257 -- RFC 6844---- | From number to type.-toTYPE :: Word16 -> TYPE-toTYPE = TYPE-#else--- | Types for resource records.-data TYPE = A          -- ^ IPv4 address-          | NS         -- ^ An authoritative name serve-          | CNAME      -- ^ The canonical name for an alias-          | SOA        -- ^ Marks the start of a zone of authority-          | NULL       -- ^ A null RR (EXPERIMENTAL)-          | PTR        -- ^ A domain name pointer-          | MX         -- ^ Mail exchange-          | TXT        -- ^ Text strings-          | AAAA       -- ^ IPv6 Address-          | SRV        -- ^ Server Selection (RFC2782)-          | DNAME      -- ^ DNAME (RFC6672)-          | OPT        -- ^ OPT (RFC6891)-          | DS         -- ^ Delegation Signer (RFC4034)-          | RRSIG      -- ^ RRSIG (RFC4034)-          | NSEC       -- ^ NSEC (RFC4034)-          | DNSKEY     -- ^ DNSKEY (RFC4034)-          | NSEC3      -- ^ NSEC3 (RFC5155)-          | NSEC3PARAM -- ^ NSEC3PARAM (RFC5155)-          | TLSA       -- ^ TLSA (RFC6698)-          | CDS        -- ^ Child DS (RFC7344)-          | CDNSKEY    -- ^ DNSKEY(s) the Child wants reflected in DS (RFC7344)-          | CSYNC      -- ^ Child-To-Parent Synchronization (RFC7477)-          | AXFR       -- ^ Zone transfer (RFC5936)-          | ANY        -- ^ A request for all records the server/cache-                       --   has available-          | CAA        -- ^ Certification Authority Authorization (RFC6844)-          | UnknownTYPE Word16  -- ^ Unknown type-          deriving (Eq, Ord, Read)---- | From type to number.-fromTYPE :: TYPE -> Word16-fromTYPE A          =  1-fromTYPE NS         =  2-fromTYPE CNAME      =  5-fromTYPE SOA        =  6-fromTYPE NULL       = 10-fromTYPE PTR        = 12-fromTYPE MX         = 15-fromTYPE TXT        = 16-fromTYPE AAAA       = 28-fromTYPE SRV        = 33-fromTYPE DNAME      = 39-fromTYPE OPT        = 41-fromTYPE DS         = 43-fromTYPE RRSIG      = 46-fromTYPE NSEC       = 47-fromTYPE DNSKEY     = 48-fromTYPE NSEC3      = 50-fromTYPE NSEC3PARAM = 51-fromTYPE TLSA       = 52-fromTYPE CDS        = 59-fromTYPE CDNSKEY    = 60-fromTYPE CSYNC      = 62-fromTYPE AXFR       = 252-fromTYPE ANY        = 255-fromTYPE CAA        = 257-fromTYPE (UnknownTYPE x) = x---- | From number to type.-toTYPE :: Word16 -> TYPE-toTYPE  1 = A-toTYPE  2 = NS-toTYPE  5 = CNAME-toTYPE  6 = SOA-toTYPE 10 = NULL-toTYPE 12 = PTR-toTYPE 15 = MX-toTYPE 16 = TXT-toTYPE 28 = AAAA-toTYPE 33 = SRV-toTYPE 39 = DNAME-toTYPE 41 = OPT-toTYPE 43 = DS-toTYPE 46 = RRSIG-toTYPE 47 = NSEC-toTYPE 48 = DNSKEY-toTYPE 50 = NSEC3-toTYPE 51 = NSEC3PARAM-toTYPE 52 = TLSA-toTYPE 59 = CDS-toTYPE 60 = CDNSKEY-toTYPE 62 = CSYNC-toTYPE 252 = AXFR-toTYPE 255 = ANY-toTYPE 257 = CAA-toTYPE x   = UnknownTYPE x-#endif--instance Show TYPE where-    show A          = "A"-    show NS         = "NS"-    show CNAME      = "CNAME"-    show SOA        = "SOA"-    show NULL       = "NULL"-    show PTR        = "PTR"-    show MX         = "MX"-    show TXT        = "TXT"-    show AAAA       = "AAAA"-    show SRV        = "SRV"-    show DNAME      = "DNAME"-    show OPT        = "OPT"-    show DS         = "DS"-    show RRSIG      = "RRSIG"-    show NSEC       = "NSEC"-    show DNSKEY     = "DNSKEY"-    show NSEC3      = "NSEC3"-    show NSEC3PARAM = "NSEC3PARAM"-    show TLSA       = "TLSA"-    show CDS        = "CDS"-    show CDNSKEY    = "CDNSKEY"-    show CSYNC      = "CSYNC"-    show AXFR       = "AXFR"-    show ANY        = "ANY"-    show CAA        = "CAA"-    show x          = "TYPE" ++ show (fromTYPE x)---------------------------------------------------------------------- | An enumeration of all possible DNS errors that can occur.-data DNSError =-    -- | The sequence number of the answer doesn't match our query. This-    --   could indicate foul play.-    SequenceNumberMismatch-    -- | The question section of the response doesn't match our query. This-    --   could indicate foul play.-  | QuestionMismatch-    -- | A zone tranfer, i.e., a request of type AXFR, was attempted with the-    -- "lookup" interface. Zone transfer is different enough from "normal"-    -- requests that it requires a different interface.-  | InvalidAXFRLookup-    -- | The number of retries for the request was exceeded.-  | RetryLimitExceeded-    -- | TCP fallback request timed out.-  | TimeoutExpired-    -- | The answer has the correct sequence number, but returned an-    --   unexpected RDATA format.-  | UnexpectedRDATA-    -- | The domain for query is illegal.-  | IllegalDomain-    -- | The name server was unable to interpret the query.-  | FormatError-    -- | The name server was unable to process this query due to a-    --   problem with the name server.-  | ServerFailure-    -- | This code signifies that the domain name referenced in the-    --   query does not exist.-  | NameError-    -- | The name server does not support the requested kind of query.-  | NotImplemented-    -- | The name server refuses to perform the specified operation for-    --   policy reasons.  For example, a name-    --   server may not wish to provide the-    --   information to the particular requester,-    --   or a name server may not wish to perform-    --   a particular operation (e.g., zone transfer) for particular data.-  | OperationRefused-    -- | The server does not support the OPT RR version or content-  | BadOptRecord-    -- | Configuration is wrong.-  | BadConfiguration-    -- | Network failure.-  | NetworkFailure IOException-    -- | Error is unknown-  | DecodeError String-  | UnknownDNSError-  deriving (Eq, Show, Typeable)--instance Exception DNSError----- | Data type representing the optional EDNS pseudo-header of a 'DNSMessage'--- When a single well-formed @OPT@ 'ResourceRecord' was present in the--- message's additional section, it is decoded to an 'EDNS' record and and--- stored in the message 'ednsHeader' field.  The corresponding @OPT RR@ is--- then removed from the additional section.------ When the constructor is 'NoEDNS', no @EDNS OPT@ record was present in the--- message additional section.  When 'InvalidEDNS', the message holds either a--- malformed OPT record or more than one OPT record, which can still be found--- in (have not been removed from) the message additional section.------ The EDNS OPT record augments the message error status with an 8-bit field--- that forms 12-bit extended RCODE when combined with the 4-bit RCODE from the--- unextended DNS header.  In EDNS messages it is essential to not use just the--- bare 4-bit 'RCODE' from the original DNS header.  Therefore, in order to--- avoid potential misinterpretation of the response 'RCODE', when the OPT--- record is decoded, the upper eight bits of the error status are--- automatically combined with the 'rcode' of the message header, so that there--- is only one place in which to find the full 12-bit result.  Therefore, the--- decoded 'EDNS' pseudo-header, does not hold any error status bits.------ The reverse process occurs when encoding messages.  The low four bits of the--- message header 'rcode' are encoded into the wire-form DNS header, while the--- upper eight bits are encoded as part of the OPT record.  In DNS responses with--- an 'rcode' larger than 15, EDNS extensions SHOULD be enabled by providing a--- value for 'ednsHeader' with a constructor of 'EDNSheader'.  If EDNS is not--- enabled in such a message, in order to avoid truncation of 'RCODE' values--- that don't fit in the non-extended DNS header, the encoded wire-form 'RCODE'--- is set to 'FormatErr'.------ When encoding messages for transmission, the 'ednsHeader' is used to--- generate the additional OPT record.  Do not add explicit @OPT@ records--- to the aditional section, configure EDNS via the 'EDNSheader' instead.------ >>> let getopts eh = mapEDNS eh ednsOptions []--- >>> let optsin     = [OD_ClientSubnet 24 0 $ read "192.0.2.1"]--- >>> let masked     = [OD_ClientSubnet 24 0 $ read "192.0.2.0"]--- >>> let message    = makeEmptyQuery $ ednsSetOptions $ ODataSet optsin--- >>> let optsout    = getopts. ednsHeader <$> (decode $ encode message)--- >>> optsout       == Right masked--- True----data EDNSheader = EDNSheader EDNS -- ^ A valid EDNS message-                | NoEDNS          -- ^ A valid non-EDNS message-                | InvalidEDNS     -- ^ Multiple or bad additional @OPT@ RRs-    deriving (Eq, Show)----- | Return the second argument for EDNS messages, otherwise the third.-ifEDNS :: EDNSheader -- ^ EDNS pseudo-header-       -> a          -- ^ Value to return for EDNS messages-       -> a          -- ^ Value to return for non-EDNS messages-       -> a-ifEDNS (EDNSheader _) a _ = a-ifEDNS             _  _ b = b-{-# INLINE ifEDNS #-}----- | Return the output of a function applied to the EDNS pseudo-header if EDNS---   is enabled, otherwise return a default value.-mapEDNS :: EDNSheader  -- ^ EDNS pseudo-header-        -> (EDNS -> a) -- ^ Function to apply to 'EDNS' value-        -> a           -- ^ Default result for non-EDNS messages-        -> a-mapEDNS (EDNSheader eh) f _ = f eh-mapEDNS               _ _ a = a-{-# INLINE mapEDNS #-}----- | DNS message format for queries and replies.----data DNSMessage = DNSMessage {-    header     :: !DNSHeader        -- ^ Header with extended 'RCODE'-  , ednsHeader :: EDNSheader        -- ^ EDNS pseudo-header-  , question   :: [Question]        -- ^ The question for the name server-  , answer     :: Answers           -- ^ RRs answering the question-  , authority  :: AuthorityRecords  -- ^ RRs pointing toward an authority-  , additional :: AdditionalRecords -- ^ RRs holding additional information-  } deriving (Eq, Show)---- | An identifier assigned by the program that---   generates any kind of query.-type Identifier = Word16---- | Raw data format for the header of DNS Query and Response.-data DNSHeader = DNSHeader {-    identifier :: !Identifier -- ^ Query or reply identifier.-  , flags      :: !DNSFlags   -- ^ Flags, OPCODE, and RCODE-  } deriving (Eq, Show)---- | Raw data format for the flags of DNS Query and Response.-data DNSFlags = DNSFlags {-    qOrR         :: !QorR  -- ^ Query or response.-  , opcode       :: !OPCODE -- ^ Kind of query.-  , authAnswer   :: !Bool  -- ^ AA (Authoritative Answer) bit - this bit is valid in responses,-                           -- and specifies that the responding name server is an-                           -- authority for the domain name in question section.-  , trunCation   :: !Bool  -- ^ TC (Truncated Response) bit - specifies that this message was truncated-                           -- due to length greater than that permitted on the-                           -- transmission channel.-  , recDesired   :: !Bool  -- ^ RD (Recursion Desired) bit - this bit may be set in a query and-                           -- is copied into the response.  If RD is set, it directs-                           -- the name server to pursue the query recursively.-                           -- Recursive query support is optional.-  , recAvailable :: !Bool  -- ^ RA (Recursion Available) bit - this be is set or cleared in a-                           -- response, and denotes whether recursive query support is-                           -- available in the name server.--  , rcode        :: !RCODE -- ^ The full 12-bit extended RCODE when EDNS is in use.-                           -- Should always be zero in well-formed requests.-                           -- When decoding replies, the high eight bits from-                           -- any EDNS response are combined with the 4-bit-                           -- RCODE from the DNS header.  When encoding-                           -- replies, if no EDNS OPT record is provided, RCODE-                           -- values > 15 are mapped to 'FormatErr'.-  , authenData   :: !Bool  -- ^ AD (Authenticated Data) bit - (RFC4035, Section 3.2.3).-  , chkDisable   :: !Bool  -- ^ CD (Checking Disabled) bit - (RFC4035, Section 3.2.2).-  } deriving (Eq, Show)----- | Default 'DNSFlags' record suitable for making recursive queries.  By default--- the RD bit is set, and the AD and CD bits are cleared.----defaultDNSFlags :: DNSFlags-defaultDNSFlags = DNSFlags-         { qOrR         = QR_Query-         , opcode       = OP_STD-         , authAnswer   = False-         , trunCation   = False-         , recDesired   = True-         , recAvailable = False-         , authenData   = False-         , chkDisable   = False-         , rcode        = NoErr-         }---------------------------------------------------------------------- | Boolean flag operations. These form a 'Monoid'.  When combined via--- `mappend`, as with function composition, the left-most value has--- the last say.------ >>> mempty :: FlagOp--- FlagKeep--- >>> FlagSet <> mempty--- FlagSet--- >>> FlagClear <> FlagSet <> mempty--- FlagClear--- >>> FlagReset <> FlagClear <> FlagSet <> mempty--- FlagReset-data FlagOp = FlagSet   -- ^ Set the flag to 1-            | FlagClear -- ^ Clear the flag to 0-            | FlagReset -- ^ Reset the flag to its default value-            | FlagKeep  -- ^ Leave the flag unchanged-            deriving (Eq, Show)---- | Apply the given 'FlagOp' to a default boolean value to produce the final--- setting.----applyFlag :: FlagOp -> Bool -> Bool-applyFlag FlagSet   _ = True-applyFlag FlagClear _ = False-applyFlag _         v = v---- $--- Test associativity of the semigroup operation:------ >>> let ops = [FlagSet, FlagClear, FlagReset, FlagKeep]--- >>> foldl (&&) True [(a<>b)<>c == a<>(b<>c) | a <- ops, b <- ops, c <- ops]--- True----instance Sem.Semigroup FlagOp where-    FlagKeep <> op = op-    op       <> _  = op--instance Monoid FlagOp where-    mempty = FlagKeep-#if !(MIN_VERSION_base(4,11,0))-    -- this is redundant starting with base-4.11 / GHC 8.4-    -- if you want to avoid CPP, you can define `mappend = (<>)` unconditionally-    mappend = (Sem.<>)-#endif---- | We don't show options left at their default value.----skipDefault :: String-skipDefault = ""---- | Show non-default flag values----showFlag :: String -> FlagOp -> String-showFlag nm FlagSet   = nm ++ ":1"-showFlag nm FlagClear = nm ++ ":0"-showFlag _  FlagReset = skipDefault-showFlag _  FlagKeep  = skipDefault---- | Combine a list of options for display, skipping default values----showOpts :: [String] -> String-showOpts os = List.intercalate "," $ List.filter (/= skipDefault) os---------------------------------------------------------------------- | Control over query-related DNS header flags. As with function composition,--- the left-most value has the last say.----data HeaderControls = HeaderControls-    { rdBit :: !FlagOp-    , adBit :: !FlagOp-    , cdBit :: !FlagOp-    }-    deriving (Eq)--instance Sem.Semigroup HeaderControls where-    (HeaderControls rd1 ad1 cd1) <> (HeaderControls rd2 ad2 cd2) =-        HeaderControls (rd1 <> rd2) (ad1 <> ad2) (cd1 <> cd2)--instance Monoid HeaderControls where-    mempty = HeaderControls FlagKeep FlagKeep FlagKeep-#if !(MIN_VERSION_base(4,11,0))-    -- this is redundant starting with base-4.11 / GHC 8.4-    -- if you want to avoid CPP, you can define `mappend = (<>)` unconditionally-    mappend = (Sem.<>)-#endif--instance Show HeaderControls where-    show (HeaderControls rd ad cd) =-        showOpts-             [ showFlag "rd" rd-             , showFlag "ad" ad-             , showFlag "cd" cd ]---- | Apply all the query flag overrides to 'defaultDNSFlags', returning the--- resulting 'DNSFlags' suitable for making queries with the requested flag--- settings.  This is only needed if you're creating your own 'DNSMessage',--- the 'Network.DNS.LookupRaw.lookupRawCtl' function takes a 'QueryControls'--- argument and handles this conversion internally.------ Default overrides can be specified in the resolver configuration by setting--- the 'Network.DNS.resolvQueryControls' field of the--- 'Network.DNS.Resolver.ResolvConf' argument to--- 'Network.DNS.Resolver.makeResolvSeed'.  These then apply to lookups via--- resolvers based on the resulting configuration, with the exception of--- 'Network.DNS.LookupRaw.lookupRawCtl' which takes an additional--- 'QueryControls' argument to augment the default overrides.----queryDNSFlags :: HeaderControls -> DNSFlags-queryDNSFlags (HeaderControls rd ad cd) = d {-      recDesired = applyFlag rd $ recDesired d-    , authenData = applyFlag ad $ authenData d-    , chkDisable = applyFlag cd $ chkDisable d-    }-  where-    d = defaultDNSFlags---------------------------------------------------------------------- | The default EDNS Option list is empty.  We define two operations, one to--- prepend a list of options, and another to set a specific list of options.----data ODataOp = ODataAdd [OData] -- ^ Add the specified options to the list.-             | ODataSet [OData] -- ^ Set the option list as specified.-             deriving (Eq)---- | Since any given option code can appear at most once in the list, we--- de-duplicate by the OPTION CODE when combining lists.----odataDedup :: ODataOp -> [OData]-odataDedup op =-    List.nubBy ((==) `on` odataToOptCode) $-        case op of-            ODataAdd os -> os-            ODataSet os -> os---- $--- Test associativity of the OData semigroup operation:------ >>> let ip1 = IPv4 $ read "127.0.0.0"--- >>> let ip2 = IPv4 $ read "192.0.2.0"--- >>> let cs1 = OD_ClientSubnet 8 0 ip1--- >>> let cs2 = OD_ClientSubnet 24 0 ip2--- >>> let cs3 = OD_ECSgeneric 0 24 0 "foo"--- >>> let dau1 = OD_DAU [3,5,7,8]--- >>> let dau2 = OD_DAU [13,14]--- >>> let dhu1 = OD_DHU [1,2]--- >>> let dhu2 = OD_DHU [3,4]--- >>> let nsid = OD_NSID ""--- >>> let ops1 = [ODataAdd [dau1, dau2, cs1], ODataAdd [dau2, cs2, dhu1]]--- >>> let ops2 = [ODataSet [], ODataSet [dhu2, cs3], ODataSet [nsid]]--- >>> let ops = ops1 ++ ops2--- >>> foldl (&&) True [(a<>b)<>c == a<>(b<>c) | a <- ops, b <- ops, c <- ops]--- True--instance Sem.Semigroup ODataOp where-    ODataAdd as <> ODataAdd bs = ODataAdd $ as ++ bs-    ODataAdd as <> ODataSet bs = ODataSet $ as ++ bs-    ODataSet as <> _ = ODataSet as--instance Monoid ODataOp where-    mempty = ODataAdd []-#if !(MIN_VERSION_base(4,11,0))-    -- this is redundant starting with base-4.11 / GHC 8.4-    -- if you want to avoid CPP, you can define `mappend = (<>)` unconditionally-    mappend = (Sem.<>)-#endif---------------------------------------------------------------------- | EDNS query controls.  When EDNS is disabled via @ednsEnabled FlagClear@,--- all the other EDNS-related overrides have no effect.------ >>> ednsHeader $ makeEmptyQuery $ ednsEnabled FlagClear <> doFlag FlagSet--- NoEDNS-data EdnsControls = EdnsControls-    { extEn :: !FlagOp         -- ^ Enabled-    , extVn :: !(Maybe Word8)  -- ^ Version-    , extSz :: !(Maybe Word16) -- ^ UDP Size-    , extDO :: !FlagOp         -- ^ DNSSEC OK (DO) bit-    , extOd :: !ODataOp        -- ^ EDNS option list tweaks-    }-    deriving (Eq)---- | Apply all the query flag overrides to 'defaultDNSFlags', returning the--instance Sem.Semigroup EdnsControls where-    (EdnsControls en1 vn1 sz1 do1 od1) <> (EdnsControls en2 vn2 sz2 do2 od2) =-        EdnsControls (en1 <> en2) (vn1 <|> vn2) (sz1 <|> sz2)-                    (do1 <> do2) (od1 <> od2)--instance Monoid EdnsControls where-    mempty = EdnsControls FlagKeep Nothing Nothing FlagKeep mempty-#if !(MIN_VERSION_base(4,11,0))-    -- this is redundant starting with base-4.11 / GHC 8.4-    -- if you want to avoid CPP, you can define `mappend = (<>)` unconditionally-    mappend = (Sem.<>)-#endif--instance Show EdnsControls where-    show (EdnsControls en vn sz d0 od) =-        showOpts-            [ showFlag "edns.enabled" en-            , showWord "edns.version" vn-            , showWord "edns.udpsize" sz-            , showFlag "edns.dobit"   d0-            , showOdOp "edns.options" $ map (show. odataToOptCode)-                                      $ odataDedup od ]-      where-        showWord :: Show a => String -> Maybe a -> String-        showWord nm w = maybe skipDefault (\s -> nm ++ ":" ++ show s) w--        showOdOp :: String -> [String] -> String-        showOdOp nm os = case os of-            [] -> ""-            _  -> nm ++ ":[" ++ List.intercalate "," os ++ "]"---- | Construct a list of 0 or 1 EDNS OPT RRs based on EdnsControls setting.----queryEdns :: EdnsControls -> EDNSheader-queryEdns (EdnsControls en vn sz d0 od) =-    let d  = defaultEDNS-     in if en == FlagClear-        then NoEDNS-        else EDNSheader $ d { ednsVersion = fromMaybe (ednsVersion d) vn-                            , ednsUdpSize = fromMaybe (ednsUdpSize d) sz-                            , ednsDnssecOk = applyFlag d0 (ednsDnssecOk d)-                            , ednsOptions  = odataDedup od-                            }---------------------------------------------------------------------- | Query controls form a 'Monoid', as with function composition, the--- left-most value has the last say.  The 'Monoid' is generated by two sets of--- combinators, one that controls query-related DNS header flags, and another--- that controls EDNS features.------ The header flag controls are: 'rdFlag', 'adFlag' and 'cdFlag'.------ The EDNS feature controls are: 'doFlag', 'ednsEnabled', 'ednsSetVersion',--- 'ednsSetUdpSize' and 'ednsSetOptions'.  When EDNS is disabled, all the other--- EDNS-related controls have no effect.------ __Example:__ Disable DNSSEC checking on the server, and request signatures and--- NSEC records, perhaps for your own independent validation.  The UDP buffer--- size is set large, for use with a local loopback nameserver on the same host.------ >>> :{--- mconcat [ adFlag FlagClear---         , cdFlag FlagSet---         , doFlag FlagSet---         , ednsSetUdpSize (Just 8192) -- IPv4 loopback server?---         ]--- :}--- ad:0,cd:1,edns.udpsize:8192,edns.dobit:1------ __Example:__ Use EDNS version 1 (yet to be specified), request nameserver--- ids from the server, and indicate a client subnet of "192.0.2.1/24".------ >>> :set -XOverloadedStrings--- >>> let emptyNSID = ""--- >>> let mask = 24--- >>> let ipaddr = read "192.0.2.1"--- >>> :{--- mconcat [ ednsSetVersion (Just 1)---         , ednsSetOptions (ODataAdd [OD_NSID emptyNSID])---         , ednsSetOptions (ODataAdd [OD_ClientSubnet mask 0 ipaddr])---         ]--- :}--- edns.version:1,edns.options:[NSID,ClientSubnet]--data QueryControls = QueryControls-    { qctlHeader :: !HeaderControls-    , qctlEdns   :: !EdnsControls-    }-    deriving (Eq)--instance Sem.Semigroup QueryControls where-    (QueryControls fl1 ex1) <> (QueryControls fl2 ex2) =-        QueryControls (fl1 <> fl2) (ex1 <> ex2)--instance Monoid QueryControls where-    mempty = QueryControls mempty mempty-#if !(MIN_VERSION_base(4,11,0))-    -- this is redundant starting with base-4.11 / GHC 8.4-    -- if you want to avoid CPP, you can define `mappend = (<>)` unconditionally-    mappend = (Sem.<>)-#endif--instance Show QueryControls where-    show (QueryControls fl ex) = showOpts [ show fl, show ex ]---------------------------------------------------------------------- | Generator of 'QueryControls' that adjusts the RD bit.------ >>> rdFlag FlagClear--- rd:0-rdFlag :: FlagOp -> QueryControls-rdFlag rd = mempty { qctlHeader = mempty { rdBit = rd } }---- | Generator of 'QueryControls' that adjusts the AD bit.------ >>> adFlag FlagSet--- ad:1-adFlag :: FlagOp -> QueryControls-adFlag ad = mempty { qctlHeader = mempty { adBit = ad } }---- | Generator of 'QueryControls' that adjusts the CD bit.------ >>> cdFlag FlagSet--- cd:1-cdFlag :: FlagOp -> QueryControls-cdFlag cd = mempty { qctlHeader = mempty { cdBit = cd } }---- | Generator of 'QueryControls' that enables or disables EDNS support.---   When EDNS is disabled, the rest of the 'EDNS' controls are ignored.------ >>> ednsHeader $ makeEmptyQuery $ ednsEnabled FlagClear <> doFlag FlagSet--- NoEDNS-ednsEnabled :: FlagOp -> QueryControls-ednsEnabled en = mempty { qctlEdns = mempty { extEn = en } }---- | Generator of 'QueryControls' that adjusts the 'EDNS' version.--- A value of 'Nothing' makes no changes, while 'Just' @v@ sets--- the EDNS version to @v@.------ >>> ednsSetVersion (Just 1)--- edns.version:1-ednsSetVersion :: Maybe Word8 -> QueryControls-ednsSetVersion vn = mempty { qctlEdns = mempty { extVn = vn } }---- | Generator of 'QueryControls' that adjusts the 'EDNS' UDP buffer size.--- A value of 'Nothing' makes no changes, while 'Just' @n@ sets the EDNS UDP--- buffer size to @n@.------ >>> ednsSetUdpSize (Just 2048)--- edns.udpsize:2048-ednsSetUdpSize :: Maybe Word16 -> QueryControls-ednsSetUdpSize sz = mempty { qctlEdns = mempty { extSz = sz } }---- | Generator of 'QueryControls' that adjusts the 'EDNS' DnssecOk (DO) bit.------ >>> doFlag FlagSet--- edns.dobit:1-doFlag :: FlagOp -> QueryControls-doFlag d0 = mempty { qctlEdns = mempty { extDO = d0 } }---- | Generator of 'QueryControls' that adjusts the list of 'EDNS' options.------ >>> :set -XOverloadedStrings--- >>> ednsSetOptions (ODataAdd [OD_NSID ""])--- edns.options:[NSID]-ednsSetOptions :: ODataOp -> QueryControls-ednsSetOptions od = mempty { qctlEdns = mempty { extOd = od } }---------------------------------------------------------------------- | Query or response.-data QorR = QR_Query    -- ^ Query.-          | QR_Response -- ^ Response.-          deriving (Eq, Show, Enum, Bounded)---- | Kind of query.-data OPCODE-  = OP_STD -- ^ A standard query.-  | OP_INV -- ^ An inverse query (inverse queries are deprecated).-  | OP_SSR -- ^ A server status request.-  | OP_NOTIFY -- ^ A zone change notification (RFC1996)-  | OP_UPDATE -- ^ An update request (RFC2136)-  deriving (Eq, Show, Enum, Bounded)---- | Convert a 16-bit DNS OPCODE number to its internal representation----toOPCODE :: Word16 -> Maybe OPCODE-toOPCODE i = case i of-  0 -> Just OP_STD-  1 -> Just OP_INV-  2 -> Just OP_SSR-  -- OPCODE 3 is unassigned-  4 -> Just OP_NOTIFY-  5 -> Just OP_UPDATE-  _ -> Nothing---- | Convert the internal representation of a DNS OPCODE to its 16-bit numeric--- value.----fromOPCODE :: OPCODE -> Word16-fromOPCODE OP_STD    = 0-fromOPCODE OP_INV    = 1-fromOPCODE OP_SSR    = 2-fromOPCODE OP_NOTIFY = 4-fromOPCODE OP_UPDATE = 5--------------------------------------------------------------------#if __GLASGOW_HASKELL__ >= 800--- | EDNS extended 12-bit response code.  Non-EDNS messages use only the low 4--- bits.  With EDNS this stores the combined error code from the DNS header and--- and the EDNS psuedo-header. See 'EDNSheader' for more detail.-newtype RCODE = RCODE {-    -- | Convert an 'RCODE' to its numeric value.-    fromRCODE :: Word16-  } deriving (Eq)---- | Provide an Enum instance for backwards compatibility-instance Enum RCODE where-    fromEnum = fromIntegral . fromRCODE-    toEnum = RCODE . fromIntegral---- | No error condition.-pattern NoErr     :: RCODE-pattern NoErr      = RCODE  0--- | Format error - The name server was---   unable to interpret the query.-pattern FormatErr :: RCODE-pattern FormatErr  = RCODE  1--- | Server failure - The name server was---   unable to process this query due to a---   problem with the name server.-pattern ServFail  :: RCODE-pattern ServFail   = RCODE  2--- | Name Error - Meaningful only for---   responses from an authoritative name---   server, this code signifies that the---   domain name referenced in the query does---   not exist.-pattern NameErr   :: RCODE-pattern NameErr    = RCODE  3--- | Not Implemented - The name server does---   not support the requested kind of query.-pattern NotImpl   :: RCODE-pattern NotImpl    = RCODE  4--- | Refused - The name server refuses to---   perform the specified operation for---   policy reasons.  For example, a name---   server may not wish to provide the---   information to the particular requester,---   or a name server may not wish to perform---   a particular operation (e.g., zone---   transfer) for particular data.-pattern Refused   :: RCODE-pattern Refused    = RCODE  5--- | YXDomain - Dynamic update response, a pre-requisite domain that should not--- exist, does exist.-pattern YXDomain :: RCODE-pattern YXDomain  = RCODE 6--- | YXRRSet - Dynamic update response, a pre-requisite RRSet that should not--- exist, does exist.-pattern YXRRSet  :: RCODE-pattern YXRRSet   = RCODE 7--- | NXRRSet - Dynamic update response, a pre-requisite RRSet that should--- exist, does not exist.-pattern NXRRSet  :: RCODE-pattern NXRRSet   = RCODE 8--- | NotAuth - Dynamic update response, the server is not authoritative for the--- zone named in the Zone Section.-pattern NotAuth  :: RCODE-pattern NotAuth   = RCODE 9--- | NotZone - Dynamic update response, a name used in the Prerequisite or--- Update Section is not within the zone denoted by the Zone Section.-pattern NotZone  :: RCODE-pattern NotZone   = RCODE 10--- | Bad OPT Version (BADVERS, RFC 6891).-pattern BadVers   :: RCODE-pattern BadVers    = RCODE 16--- | Key not recognized [RFC2845]-pattern BadKey    :: RCODE-pattern BadKey     = RCODE 17--- | Signature out of time window [RFC2845]-pattern BadTime   :: RCODE-pattern BadTime    = RCODE 18--- | Bad TKEY Mode [RFC2930]-pattern BadMode   :: RCODE-pattern BadMode    = RCODE 19--- | Duplicate key name [RFC2930]-pattern BadName   :: RCODE-pattern BadName    = RCODE 20--- | Algorithm not supported [RFC2930]-pattern BadAlg    :: RCODE-pattern BadAlg     = RCODE 21--- | Bad Truncation [RFC4635]-pattern BadTrunc  :: RCODE-pattern BadTrunc   = RCODE 22--- | Bad/missing Server Cookie [RFC7873]-pattern BadCookie :: RCODE-pattern BadCookie  = RCODE 23--- | Malformed (peer) EDNS message, no RCODE available.  This is not an RCODE--- that can be sent by a peer.  It lies outside the 12-bit range expressible--- via EDNS.  The low 12-bits are chosen to coincide with 'FormatErr'.  When--- an EDNS message is malformed, and we're unable to extract the extended RCODE,--- the header 'rcode' is set to 'BadRCODE'.-pattern BadRCODE  :: RCODE-pattern BadRCODE   = RCODE 0x1001---- | Use https://tools.ietf.org/html/rfc2929#section-2.3 names for DNS RCODEs-instance Show RCODE where-    show NoErr     = "NoError"-    show FormatErr = "FormErr"-    show ServFail  = "ServFail"-    show NameErr   = "NXDomain"-    show NotImpl   = "NotImp"-    show Refused   = "Refused"-    show YXDomain  = "YXDomain"-    show YXRRSet   = "YXRRSet"-    show NotAuth   = "NotAuth"-    show NotZone   = "NotZone"-    show BadVers   = "BadVers"-    show BadKey    = "BadKey"-    show BadTime   = "BadTime"-    show BadMode   = "BadMode"-    show BadName   = "BadName"-    show BadAlg    = "BadAlg"-    show BadTrunc  = "BadTrunc"-    show BadCookie = "BadCookie"-    show x         = "RCODE " ++ (show $ fromRCODE x)---- | Convert a numeric value to a corresponding 'RCODE'.  The behaviour is--- undefined for values outside the range @[0 .. 0xFFF]@ since the EDNS--- extended RCODE is a 12-bit value.  Values in the range @[0xF01 .. 0xFFF]@--- are reserved for private use.-toRCODE :: Word16 -> RCODE-toRCODE = RCODE-#else--- | EDNS extended 12-bit response code.  Non-EDNS messages use only the low 4--- bits.  With EDNS this stores the combined error code from the DNS header and--- and the EDNS psuedo-header. See 'EDNSheader' for more detail.-data RCODE-  = NoErr     -- ^ No error condition.-  | FormatErr -- ^ Format error - The name server was-              --   unable to interpret the query.-  | ServFail  -- ^ Server failure - The name server was-              --   unable to process this query due to a-              --   problem with the name server.-  | NameErr   -- ^ Name Error - Meaningful only for-              --   responses from an authoritative name-              --   server, this code signifies that the-              --   domain name referenced in the query does-              --   not exist.-  | NotImpl   -- ^ Not Implemented - The name server does-              --   not support the requested kind of query.-  | Refused   -- ^ Refused - The name server refuses to-              --   perform the specified operation for-              --   policy reasons.  For example, a name-              --   server may not wish to provide the-              --   information to the particular requester,-              --   or a name server may not wish to perform-              --   a particular operation (e.g., zone-              --   transfer) for particular data.-  | YXDomain  -- ^ Dynamic update response, a pre-requisite-              --   domain that should not exist, does exist.-  | YXRRSet   -- ^ Dynamic update response, a pre-requisite-              --   RRSet that should not exist, does exist.-  | NXRRSet   -- ^ Dynamic update response, a pre-requisite-              --   RRSet that should exist, does not exist.-  | NotAuth   -- ^ Dynamic update response, the server is not-              --   authoritative for the zone named in the Zone Section.-  | NotZone   -- ^ Dynamic update response, a name used in the-              --   Prerequisite or Update Section is not within the zone-              --   denoted by the Zone Section.-  | BadVers   -- ^ Bad OPT Version (RFC 6891)-  | BadKey    -- ^ Key not recognized [RFC2845]-  | BadTime   -- ^ Signature out of time window [RFC2845]-  | BadMode   -- ^ Bad TKEY Mode [RFC2930]-  | BadName   -- ^ Duplicate key name [RFC2930]-  | BadAlg    -- ^ Algorithm not supported [RFC2930]-  | BadTrunc  -- ^ Bad Truncation [RFC4635]-  | BadCookie -- ^ Bad/missing Server Cookie [RFC7873]-  | BadRCODE  -- ^ Malformed (peer) EDNS message, no RCODE available.  This is-              -- not an RCODE that can be sent by a peer.  It lies outside the-              -- 12-bit range expressible via EDNS.  The low bits are chosen to-              -- coincide with 'FormatErr'.  When an EDNS message is malformed,-              -- and we're unable to extract the extended RCODE, the header-              -- 'rcode' is set to 'BadRCODE'.-  | UnknownRCODE Word16-  deriving (Eq, Ord, Show)---- | Convert an 'RCODE' to its numeric value.-fromRCODE :: RCODE -> Word16-fromRCODE NoErr     =  0-fromRCODE FormatErr =  1-fromRCODE ServFail  =  2-fromRCODE NameErr   =  3-fromRCODE NotImpl   =  4-fromRCODE Refused   =  5-fromRCODE YXDomain  =  6-fromRCODE YXRRSet   =  7-fromRCODE NXRRSet   =  8-fromRCODE NotAuth   =  9-fromRCODE NotZone   = 10-fromRCODE BadVers   = 16-fromRCODE BadKey    = 17-fromRCODE BadTime   = 18-fromRCODE BadMode   = 19-fromRCODE BadName   = 20-fromRCODE BadAlg    = 21-fromRCODE BadTrunc  = 22-fromRCODE BadCookie = 23-fromRCODE BadRCODE  = 0x1001-fromRCODE (UnknownRCODE x) = x---- | Convert a numeric value to a corresponding 'RCODE'.  The behaviour--- is undefined for values outside the range @[0 .. 0xFFF]@ since the--- EDNS extended RCODE is a 12-bit value.  Values in the range--- @[0xF01 .. 0xFFF]@ are reserved for private use.----toRCODE :: Word16 -> RCODE-toRCODE  0 = NoErr-toRCODE  1 = FormatErr-toRCODE  2 = ServFail-toRCODE  3 = NameErr-toRCODE  4 = NotImpl-toRCODE  5 = Refused-toRCODE  6 = YXDomain-toRCODE  7 = YXRRSet-toRCODE  8 = NXRRSet-toRCODE  9 = NotAuth-toRCODE 10 = NotZone-toRCODE 16 = BadVers-toRCODE 17 = BadKey-toRCODE 18 = BadTime-toRCODE 19 = BadMode-toRCODE 20 = BadName-toRCODE 21 = BadAlg-toRCODE 22 = BadTrunc-toRCODE 23 = BadCookie-toRCODE 0x1001 = BadRCODE-toRCODE  x = UnknownRCODE x-#endif---------------------------------------------------------------------- XXX: The Question really should also include the CLASS------ | Raw data format for DNS questions.-data Question = Question {-    qname  :: Domain -- ^ A domain name-  , qtype  :: TYPE   -- ^ The type of the query-  } deriving (Eq, Show)---------------------------------------------------------------------- | Resource record class.-type CLASS = Word16---- | Resource record class for the Internet.-classIN :: CLASS-classIN = 1---- | Time to live in second.-type TTL = Word32---- | Raw data format for resource records.-data ResourceRecord = ResourceRecord {-    rrname  :: !Domain -- ^ Name-  , rrtype  :: !TYPE   -- ^ Resource record type-  , rrclass :: !CLASS  -- ^ Resource record class-  , rrttl   :: !TTL    -- ^ Time to live-  , rdata   :: !RData  -- ^ Resource data-  } deriving (Eq,Show)---------------------------------------------------------------------- | Given a 32-bit circle-arithmetic DNS time, and the current absolute epoch--- time, return the epoch time corresponding to the DNS timestamp.----dnsTime :: Word32 -- ^ DNS circle-arithmetic timestamp-        -> Int64  -- ^ current epoch time-        -> Int64  -- ^ absolute DNS timestamp-dnsTime tdns tnow =-    let delta = tdns - fromIntegral tnow-     in if delta > 0x7FFFFFFF -- tdns is in the past?-           then tnow - (0x100000000 - fromIntegral delta)-           else tnow + fromIntegral delta---- | Convert epoch time to a YYYYMMDDHHMMSS string:------ >>> :{--- let testVector =---         [ ( "19230704085602", -1467299038)---         , ( "19331017210945", -1142563815)---         , ( "19480919012827", -671668293 )---         , ( "19631210171455", -191227505 )---         , ( "20060819001740", 1155946660 )---         , ( "20180723061122", 1532326282 )---         , ( "20281019005024", 1855529424 )---         , ( "20751108024632", 3340406792 )---         , ( "21240926071415", 4883008455 )---         , ( "21270331070215", 4962150135 )---         , ( "21371220015305", 5300560385 )---         , ( "21680118121052", 6249787852 )---         , ( "21811012210032", 6683202032 )---         , ( "22060719093224", 7464648744 )---         , ( "22100427121648", 7583717808 )---         , ( "22530821173957", 8950757997 )---         , ( "23010804210243", 10463979763)---         , ( "23441111161706", 11829514626)---         , ( "23750511175551", 12791843751)---         , ( "23860427060801", 13137746881) ]---  in (==) <$> map (showTime.snd) <*> map fst $ testVector--- :}--- True-----showTime :: Int64 -> String-showTime t = H.timePrint fmt $ H.Elapsed $ H.Seconds t-  where-    fmt = [ H.Format_Year4, H.Format_Month2, H.Format_Day2-          , H.Format_Hour,  H.Format_Minute, H.Format_Second ]---- | RRSIG representation.------ As noted in--- <https://tools.ietf.org/html/rfc4034#section-3.1.5 Section 3.1.5 of RFC 4034>--- the RRsig inception and expiration times use serial number arithmetic.  As a--- result these timestamps /are not/ pure values, their meaning is--- time-dependent!  They depend on the present time and are both at most--- approximately +\/-68 years from the present.  This ambiguity is not a--- problem because cached RRSIG records should only persist a few days,--- signature lifetimes should be *much* shorter than 68 years, and key rotation--- should result any misconstrued 136-year-old signatures fail to validate.--- This also means that the interpretation of a time that is exactly half-way--- around the clock at @now +\/-0x80000000@ is not important, the signature--- should never be valid.------ The upshot for us is that we need to convert these *impure* relative values--- to pure absolute values at the moment they are received from from the network--- (or read from files, ... in some impure I/O context), and convert them back to--- 32-bit values when encoding.  Therefore, the constructor takes absolute--- 64-bit representations of the inception and expiration times.------ The 'dnsTime' function performs the requisite conversion.----data RD_RRSIG = RDREP_RRSIG-    { rrsigType       :: !TYPE       -- ^ RRtype of RRset signed-    , rrsigKeyAlg     :: !Word8      -- ^ DNSKEY algorithm-    , rrsigNumLabels  :: !Word8      -- ^ Number of labels signed-    , rrsigTTL        :: !Word32     -- ^ Maximum origin TTL-    , rrsigExpiration :: !Int64      -- ^ Time last valid-    , rrsigInception  :: !Int64      -- ^ Time first valid-    , rrsigKeyTag     :: !Word16     -- ^ Signing key tag-    , rrsigZone       :: !Domain     -- ^ Signing domain-    , rrsigValue      :: !ByteString -- ^ Opaque signature-    }-    deriving (Eq, Ord)--instance Show RD_RRSIG where-    show RDREP_RRSIG{..} = unwords-        [ show rrsigType-        , show rrsigKeyAlg-        , show rrsigNumLabels-        , show rrsigTTL-        , showTime rrsigExpiration-        , showTime rrsigInception-        , show rrsigKeyTag-        , BS.unpack rrsigZone-        , b64encode rrsigValue-        ]---- | Raw data format for each type.-data RData = RD_A IPv4           -- ^ IPv4 address-           | RD_NS Domain        -- ^ An authoritative name serve-           | RD_CNAME Domain     -- ^ The canonical name for an alias-           | RD_SOA Domain Mailbox Word32 Word32 Word32 Word32 Word32-                                 -- ^ Marks the start of a zone of authority-           | RD_NULL ByteString  -- ^ NULL RR (EXPERIMENTAL, RFC1035).-           | RD_PTR Domain       -- ^ A domain name pointer-           | RD_MX Word16 Domain -- ^ Mail exchange-           | RD_TXT ByteString   -- ^ Text strings-           | RD_AAAA IPv6        -- ^ IPv6 Address-           | RD_SRV Word16 Word16 Word16 Domain-                                 -- ^ Server Selection (RFC2782)-           | RD_DNAME Domain     -- ^ DNAME (RFC6672)-           | RD_OPT [OData]      -- ^ OPT (RFC6891)-           | RD_DS Word16 Word8 Word8 ByteString -- ^ Delegation Signer (RFC4034)-           | RD_RRSIG RD_RRSIG   -- ^ DNSSEC signature-           | RD_NSEC Domain [TYPE] -- ^ DNSSEC denial of existence NSEC record-           | RD_DNSKEY Word16 Word8 Word8 ByteString-                                 -- ^ DNSKEY (RFC4034)-           | RD_NSEC3 Word8 Word8 Word16 ByteString ByteString [TYPE]-                                 -- ^ DNSSEC hashed denial of existence (RFC5155)-           | RD_NSEC3PARAM Word8 Word8 Word16 ByteString-                                 -- ^ NSEC3 zone parameters (RFC5155)-           | RD_TLSA Word8 Word8 Word8 ByteString-                                 -- ^ TLSA (RFC6698)-           --RD_CDS-           --RD_CDNSKEY-           --RD_CSYNC-           | UnknownRData ByteString   -- ^ Unknown resource data-    deriving (Eq, Ord)--instance Show RData where-  show rd = case rd of-      RD_A                  address -> show address-      RD_NS                 nsdname -> showDomain nsdname-      RD_CNAME                cname -> showDomain cname-      RD_SOA          a b c d e f g -> showSOA a b c d e f g-      RD_NULL                 bytes -> showOpaque bytes-      RD_PTR               ptrdname -> showDomain ptrdname-      RD_MX               pref exch -> showMX pref exch-      RD_TXT             textstring -> showTXT textstring-      RD_AAAA               address -> show address-      RD_SRV        pri wei prt tgt -> showSRV pri wei prt tgt-      RD_DNAME               target -> showDomain target-      RD_OPT                options -> show options-      RD_DS          tag alg dalg d -> showDS tag alg dalg d-      RD_RRSIG                rrsig -> show rrsig-      RD_NSEC            next types -> showNSEC next types-      RD_DNSKEY             f p a k -> showDNSKEY f p a k-      RD_NSEC3      a f i s h types -> showNSEC3 a f i s h types-      RD_NSEC3PARAM         a f i s -> showNSEC3PARAM a f i s-      RD_TLSA               u s m d -> showTLSA u s m d-      UnknownRData            bytes -> showOpaque bytes-    where-      showSalt ""    = "-"-      showSalt salt  = b16encode salt-      showDomain = BS.unpack-      showSOA mname mrname serial refresh retry expire minttl =-          showDomain mname ++ " " ++ showDomain mrname ++ " " ++-          show serial ++ " " ++ show refresh ++ " " ++-          show retry ++ " " ++ show expire ++ " " ++ show minttl-      showMX preference exchange =-          show preference ++ " " ++ showDomain exchange-      showTXT bs = '"' : B.foldr dnsesc ['"'] bs-        where-          c2w = fromIntegral . fromEnum-          w2c = toEnum . fromIntegral-          doubleQuote = c2w '"'-          backSlash   = c2w '\\'-          dnsesc c s-              | c == doubleQuote   = '\\' : w2c c : s-              | c == backSlash     = '\\' : w2c c : s-              | c >= 32 && c < 127 =        w2c c : s-              | otherwise          = '\\' : ddd c   s-          ddd c s =-              let (q100, r100) = divMod (fromIntegral c) 100-                  (q10, r10) = divMod r100 10-               in intToDigit q100 : intToDigit q10 : intToDigit r10 : s-      showSRV priority weight port target =-          show priority ++ " " ++ show weight ++ " " ++-          show port ++ BS.unpack target-      showDS keytag alg digestType digest =-          show keytag ++ " " ++ show alg ++ " " ++-          show digestType ++ " " ++ b16encode digest-      showNSEC next types =-          unwords $ showDomain next : map show types-      showDNSKEY flags protocol alg key =-          show flags ++ " " ++ show protocol ++ " " ++-          show alg ++ " " ++ b64encode key-      -- | <https://tools.ietf.org/html/rfc5155#section-3.2>-      showNSEC3 hashalg flags iterations salt nexthash types =-          unwords $ show hashalg : show flags : show iterations :-                    showSalt salt : b32encode nexthash : map show types-      showNSEC3PARAM hashAlg flags iterations salt =-          show hashAlg ++ " " ++ show flags ++ " " ++-          show iterations ++ " " ++ showSalt salt-      showTLSA usage selector mtype digest =-          show usage ++ " " ++ show selector ++ " " ++-          show mtype ++ " " ++ b16encode digest-      -- | Opaque RData: <https://tools.ietf.org/html/rfc3597#section-5>-      showOpaque bs = unwords ["\\#", show (BS.length bs), b16encode bs]--b16encode, b32encode, b64encode :: ByteString -> String-b16encode = BS.unpack. B16.encode-b32encode = BS.unpack. B32.encode-b64encode = BS.unpack. B64.encode---- | Type alias for resource records in the answer section.-type Answers = [ResourceRecord]---- | Type alias for resource records in the answer section.-type AuthorityRecords = [ResourceRecord]---- | Type for resource records in the additional section.-type AdditionalRecords = [ResourceRecord]---------------------------------------------------------------------- | A 'DNSMessage' template for queries with default settings for--- the message 'DNSHeader' and 'EDNSheader'.  This is the initial--- query message state, before customization via 'QueryControls'.----defaultQuery :: DNSMessage-defaultQuery = DNSMessage {-    header = DNSHeader {-       identifier = 0-     , flags = defaultDNSFlags-     }-  , ednsHeader = EDNSheader defaultEDNS-  , question   = []-  , answer     = []-  , authority  = []-  , additional = []-  }---- | Default response.  When responding to EDNS queries, the response must--- either be an EDNS response, or else FormatErr must be returned.  The default--- response message has EDNS disabled ('ednsHeader' set to 'NoEDNS'), it should--- be updated as appropriate.------ Do not explicitly add OPT RRs to the additional section, instead let the--- encoder compute and add the OPT record based on the EDNS pseudo-header.------ The 'RCODE' in the 'DNSHeader' should be set to the appropriate 12-bit--- extended value, which will be split between the primary header and EDNS OPT--- record during message encoding (low 4 bits in DNS header, high 8 bits in--- EDNS OPT record).  See 'EDNSheader' for more details.----defaultResponse :: DNSMessage-defaultResponse = DNSMessage {-    header = DNSHeader {-       identifier = 0-     , flags = defaultDNSFlags {-              qOrR = QR_Response-            , authAnswer = True-            , recAvailable = True-            , authenData = False-       }-     }-  , ednsHeader = NoEDNS-  , question   = []-  , answer     = []-  , authority  = []-  , additional = []-  }---- | A query template with 'QueryControls' overrides applied,--- with just the 'Question' and query 'Identifier' remaining--- to be filled in.----makeEmptyQuery :: QueryControls -- ^ Flag and EDNS overrides-               -> DNSMessage-makeEmptyQuery ctls = defaultQuery {-      header = header'-    , ednsHeader = queryEdns ehctls-    }-  where-    hctls = qctlHeader ctls-    ehctls = qctlEdns ctls-    header' = (header defaultQuery) { flags = queryDNSFlags hctls }---- | Construct a complete query 'DNSMessage', by combining the 'defaultQuery'--- template with the specified 'Identifier', and 'Question'.  The--- 'QueryControls' can be 'mempty' to leave all header and EDNS settings at--- their default values, or some combination of overrides.  A default set of--- overrides can be enabled via the 'Network.DNS.Resolver.resolvQueryControls'--- field of 'Network.DNS.Resolver.ResolvConf'.  Per-query overrides are--- possible by using 'Network.DNS.LookupRaw.loookupRawCtl'.----makeQuery :: Identifier        -- ^ Crypto random request id-          -> Question          -- ^ Question name and type-          -> QueryControls     -- ^ Custom RD\/AD\/CD flags and EDNS settings-          -> DNSMessage-makeQuery idt q ctls = empqry {-      header = (header empqry) { identifier = idt }-    , question = [q]-    }-  where-    empqry = makeEmptyQuery ctls---- | Construct a query response 'DNSMessage'.-makeResponse :: Identifier-             -> Question-             -> Answers-             -> DNSMessage-makeResponse idt q as = defaultResponse {-      header = header' { identifier = idt }-    , question = [q]-    , answer   = as-    }-  where-    header' = header defaultResponse--------------------------------------------------------------------- EDNS (RFC 6891, EDNS(0))--------------------------------------------------------------------- | EDNS information defined in RFC 6891.-data EDNS = EDNS {-    -- | EDNS version, presently only version 0 is defined.-    ednsVersion :: !Word8-    -- | Supported UDP payload size.-  , ednsUdpSize  :: !Word16-    -- | Request DNSSEC replies (with RRSIG and NSEC records as as appropriate)-    -- from the server.  Generally, not needed (except for diagnostic purposes)-    -- unless the signatures will be validated.  Just setting the 'AD' bit in-    -- the query and checking it in the response is sufficient (but often-    -- subject to man-in-the-middle forgery) if all that's wanted is whether-    -- the server validated the response.-  , ednsDnssecOk :: !Bool-    -- | EDNS options (e.g. 'OD_NSID', 'OD_ClientSubnet', ...)-  , ednsOptions  :: ![OData]-  } deriving (Eq, Show)---- | The default EDNS pseudo-header for queries.  The UDP buffer size is set to---   1216 bytes, which should result in replies that fit into the 1280 byte---   IPv6 minimum MTU.  Since IPv6 only supports fragmentation at the source,---   and even then not all gateways forward IPv6 pre-fragmented IPv6 packets,---   it is best to keep DNS packet sizes below this limit when using IPv6---   nameservers.  A larger value may be practical when using IPv4 exclusively.------ @--- defaultEDNS = EDNS---     { ednsVersion = 0      -- The default EDNS version is 0---     , ednsUdpSize = 1216   -- IPv6-safe UDP MTU---     , ednsDnssecOk = False -- We don't do DNSSEC validation---     , ednsOptions = []     -- No EDNS options by default---     }--- @----defaultEDNS :: EDNS-defaultEDNS = EDNS-    { ednsVersion = 0      -- The default EDNS version is 0-    , ednsUdpSize = 1216   -- IPv6-safe UDP MTU-    , ednsDnssecOk = False -- We don't do DNSSEC validation-    , ednsOptions = []     -- No EDNS options by default-    }---- | Maximum UDP size that can be advertised.  If the 'ednsUdpSize' of 'EDNS'---   is larger, then this value is sent instead.  This value is likely to work---   only for local nameservers on the loopback network.  Servers may enforce---   a smaller limit.------ >>> maxUdpSize--- 16384-maxUdpSize :: Word16-maxUdpSize = 16384---- | Minimum UDP size to advertise. If 'ednsUdpSize' of 'EDNS' is smaller,---   then this value is sent instead.------ >>> minUdpSize--- 512-minUdpSize :: Word16-minUdpSize = 512--------------------------------------------------------------------#if __GLASGOW_HASKELL__ >= 800--- | EDNS Option Code (RFC 6891).-newtype OptCode = OptCode {-    -- | From option code to number.-    fromOptCode :: Word16-  } deriving (Eq,Ord)---- | NSID (RFC5001, section 2.3)-pattern NSID :: OptCode-pattern NSID = OptCode 3---- | DNSSEC algorithm support (RFC6974, section 3)-pattern DAU :: OptCode-pattern DAU = OptCode 5-pattern DHU :: OptCode-pattern DHU = OptCode 6-pattern N3U :: OptCode-pattern N3U = OptCode 7---- | Client subnet (RFC7871)-pattern ClientSubnet :: OptCode-pattern ClientSubnet = OptCode 8--instance Show OptCode where-    show NSID         = "NSID"-    show DAU          = "DAU"-    show DHU          = "DHU"-    show N3U          = "N3U"-    show ClientSubnet = "ClientSubnet"-    show x            = "OptCode" ++ (show $ fromOptCode x)---- | From number to option code.-toOptCode :: Word16 -> OptCode-toOptCode = OptCode-#else--- | Option Code (RFC 6891).-data OptCode = NSID                  -- ^ Name Server Identifier (RFC5001)-             | DAU                   -- ^ DNSSEC Algorithm understood (RFC6975)-             | DHU                   -- ^ DNSSEC Hash Understood (RFC6975)-             | N3U                   -- ^ NSEC3 Hash Understood (RFC6975)-             | ClientSubnet          -- ^ Client subnet (RFC7871)-             | UnknownOptCode Word16 -- ^ Unknown option code-    deriving (Eq, Ord, Show)---- | From option code to number.-fromOptCode :: OptCode -> Word16-fromOptCode NSID         = 3-fromOptCode DAU          = 5-fromOptCode DHU          = 6-fromOptCode N3U          = 7-fromOptCode ClientSubnet = 8-fromOptCode (UnknownOptCode x) = x---- | From number to option code.-toOptCode :: Word16 -> OptCode-toOptCode 3 = NSID-toOptCode 5 = DAU-toOptCode 6 = DHU-toOptCode 7 = N3U-toOptCode 8 = ClientSubnet-toOptCode x = UnknownOptCode x-#endif---------------------------------------------------------------------- | RData formats for a few EDNS options, and an opaque catcall-data OData =-      -- | Name Server Identifier (RFC5001).  Bidirectional, empty from client.-      -- (opaque octet-string).  May contain binary data, which MUST be empty-      -- in queries.-      OD_NSID ByteString-      -- | DNSSEC Algorithm Understood (RFC6975).  Client to server.-      -- (array of 8-bit numbers). Lists supported DNSKEY algorithms.-    | OD_DAU [Word8]-      -- | DS Hash Understood (RFC6975).  Client to server.-      -- (array of 8-bit numbers). Lists supported DS hash algorithms.-    | OD_DHU [Word8]-      -- | NSEC3 Hash Understood (RFC6975).  Client to server.-      -- (array of 8-bit numbers). Lists supported NSEC3 hash algorithms.-    | OD_N3U [Word8]-      -- | Client subnet (RFC7871).  Bidirectional.-      -- (source bits, scope bits, address).-      -- The address is masked and truncated when encoding queries.  The-      -- address is zero-padded when decoding.  Invalid input encodings-      -- result in an 'OD_ECSgeneric' value instead.-      ---    | OD_ClientSubnet Word8 Word8 IP-      -- | Unsupported or malformed IP client subnet option.  Bidirectional.-      -- (address family, source bits, scope bits, opaque address).-    | OD_ECSgeneric Word16 Word8 Word8 ByteString-      -- | Generic EDNS option.-      -- (numeric 'OptCode', opaque content)-    | UnknownOData Word16 ByteString-    deriving (Eq,Ord)----- | Recover the (often implicit) 'OptCode' from a value of the 'OData' sum--- type.-odataToOptCode :: OData -> OptCode-odataToOptCode OD_NSID {}            = NSID-odataToOptCode OD_DAU {}             = DAU-odataToOptCode OD_DHU {}             = DHU-odataToOptCode OD_N3U {}             = N3U-odataToOptCode OD_ClientSubnet {}    = ClientSubnet-odataToOptCode OD_ECSgeneric {}      = ClientSubnet-odataToOptCode (UnknownOData code _) = toOptCode code--instance Show OData where-    show (OD_NSID nsid) = showNSID nsid-    show (OD_DAU as)    = showAlgList "DAU" as-    show (OD_DHU hs)    = showAlgList "DHU" hs-    show (OD_N3U hs)    = showAlgList "N3U" hs-    show (OD_ClientSubnet b1 b2 ip@(IPv4 _)) = showECS 1 b1 b2 $ show ip-    show (OD_ClientSubnet b1 b2 ip@(IPv6 _)) = showECS 2 b1 b2 $ show ip-    show (OD_ECSgeneric fam b1 b2 a) = showECS fam b1 b2 $ b16encode a-    show (UnknownOData code bs) = showUnknown code bs--showAlgList :: String -> [Word8] -> String-showAlgList nm ws = nm ++ " " ++ List.intercalate "," (map show ws)--showNSID :: ByteString -> String-showNSID nsid = "NSID" ++ " " ++ b16encode nsid ++ ";" ++ printable nsid-  where-    printable = BS.unpack. BS.map (\c -> if c < ' ' || c > '~' then '?' else c)--showECS :: Word16 -> Word8 -> Word8 -> String -> String-showECS family srcBits scpBits address =-    show family ++ " " ++ show srcBits-                ++ " " ++ show scpBits ++ " " ++ address--showUnknown :: Word16 -> ByteString -> String-showUnknown code bs = "UnknownOData " ++ show code ++ " " ++ b16encode bs+-- | Data types for DNS Query and Response.+--   For more information, see <http://www.ietf.org/rfc/rfc1035>.++module Network.DNS.Types (+  -- * Resource Records+    ResourceRecord (..)+  , Answers+  , AuthorityRecords+  , AdditionalRecords+  -- ** Types+  , Domain+  , CLASS+  , classIN+  , TTL+  -- ** Resource Record Types+  , TYPE (+    A+  , NS+  , CNAME+  , SOA+  , NULL+  , PTR+  , MX+  , TXT+  , AAAA+  , SRV+  , DNAME+  , OPT+  , DS+  , RRSIG+  , NSEC+  , DNSKEY+  , NSEC3+  , NSEC3PARAM+  , TLSA+  , CDS+  , CDNSKEY+  , CSYNC+  , AXFR+  , ANY+  , CAA+  )+  , fromTYPE+  , toTYPE+  -- ** Resource Data+  , RData (..)+  , RD_RRSIG(..)+  , dnsTime+  -- * DNS Message+  , DNSMessage (..)+  -- ** Query+  , makeQuery+  , makeEmptyQuery+  , defaultQuery+  -- ** Query Controls+  , QueryControls+  , rdFlag+  , adFlag+  , cdFlag+  , doFlag+  , ednsEnabled+  , ednsSetVersion+  , ednsSetUdpSize+  , ednsSetOptions+  -- *** Flag and OData control operations+  , FlagOp(..)+  , ODataOp(..)+  -- ** Response+  , defaultResponse+  , makeResponse+  -- ** DNS Header+  , DNSHeader (..)+  , Identifier+  -- *** DNS flags+  , DNSFlags (..)+  , QorR (..)+  , defaultDNSFlags+  -- *** OPCODE and RCODE+  , OPCODE (..)+  , fromOPCODE+  , toOPCODE+  , RCODE (+    NoErr+  , FormatErr+  , ServFail+  , NameErr+  , NotImpl+  , Refused+  , YXDomain+  , YXRRSet+  , NXRRSet+  , NotAuth+  , NotZone+  , BadVers+  , BadKey+  , BadTime+  , BadMode+  , BadName+  , BadAlg+  , BadTrunc+  , BadCookie+  , BadRCODE+  )+  , fromRCODE+  , toRCODE+  -- ** EDNS Pseudo-Header+  , EDNSheader(..)+  , ifEDNS+  , mapEDNS+  -- *** EDNS record+  , EDNS(..)+  , defaultEDNS+  , maxUdpSize+  , minUdpSize+  -- *** EDNS options+  , OData (..)+  , OptCode (+    ClientSubnet+  , DAU+  , DHU+  , N3U+  , NSID+  )+  , fromOptCode+  , toOptCode+  -- ** DNS Body+  , Question (..)+  -- * DNS Error+  , DNSError (..)+  -- * Other types+  , Mailbox+    ) where++import Network.DNS.Types.Internal

@@ -1,136 +0,0 @@-module Network.DNS.Types.Internal where--import Network.Socket (AddrInfo(..), PortNumber, HostName)--import Network.DNS.Imports-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 EDNS:------  >>> let conf = defaultResolvConf { resolvQueryControls = ednsEnabled FlagClear }------  An example to enable query result caching:------  >>> let conf = defaultResolvConf { resolvCache = Just defaultCacheConf }------ An example to disable requesting recursive service.------  >>> let conf = defaultResolvConf { resolvQueryControls = rdFlag FlagClear }------ An example to set the AD bit in all queries by default.------  >>> let conf = defaultResolvConf { resolvQueryControls = adFlag FlagSet }------ An example to set the both the AD and CD bits in all queries by default.------  >>> let conf = defaultResolvConf { resolvQueryControls = adFlag FlagSet <> cdFlag FlagSet }------ An example with an EDNS buffer size of 1216 bytes, which is more robust with--- IPv6, and the DO bit set to request DNSSEC responses.------  >>> let conf = defaultResolvConf { resolvQueryControls = ednsSetUdpSize (Just 1216) <> doFlag FlagSet }----data ResolvConf = ResolvConf {-   -- | Server information.-    resolvInfo       :: FileOrNumericHost-   -- | Timeout in micro seconds.-  , resolvTimeout    :: Int-   -- | The number of retries including the first try.-  , resolvRetry      :: Int-   -- | Concurrent queries if multiple DNS servers are specified.-  , resolvConcurrent :: Bool-   -- | Cache configuration.-  , resolvCache      :: Maybe CacheConf-   -- | Overrides for the default flags used for queries via resolvers that use-   -- this configuration.-  , resolvQueryControls :: QueryControls-} deriving Show---- | Return a default 'ResolvConf':------ * 'resolvInfo' is 'RCFilePath' \"\/etc\/resolv.conf\".--- * 'resolvTimeout' is 3,000,000 micro seconds.--- * 'resolvRetry' is 3.--- * 'resolvConcurrent' is False.--- * 'resolvCache' is Nothing.--- * 'resolvQueryControls' is an empty set of overrides.-defaultResolvConf :: ResolvConf-defaultResolvConf = ResolvConf {-    resolvInfo       = RCFilePath "/etc/resolv.conf"-  , resolvTimeout    = 3 * 1000 * 1000-  , resolvRetry      = 3-  , resolvConcurrent = False-  , resolvCache      = Nothing-  , resolvQueryControls = mempty-}---------------------------------------------------------------------- | Intermediate abstract data type for resolvers.---   IP address information of DNS servers is generated---   according to 'resolvInfo' internally.---   This value can be safely reused for 'withResolver'.------   The naming is confusing for historical reasons.-data ResolvSeed = ResolvSeed {-    resolvconf  :: ResolvConf-  , nameservers :: NonEmpty AddrInfo-}---------------------------------------------------------------------- | Abstract data type of DNS Resolver.---   This includes newly seeded identifier generators for all---   specified DNS servers and a cache database.-data Resolver = Resolver {-    resolvseed :: ResolvSeed-  , genIds     :: NonEmpty (IO Word16)-  , cache      :: Maybe Cache-}

@@ -9,7 +9,7 @@ import qualified Data.ByteString.Char8 as BS import Data.Char (toLower) -import Network.DNS.Types (Domain)+import Network.DNS.Types.Internal (Domain)   -- | Perform both 'normalizeCase' and 'normalizeRoot' on the given

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

@@ -0,0 +1,3 @@+packages: .+optimization: True+write-ghc-environment-files: always

@@ -1,5 +1,5 @@ Name:                   dns-Version:                4.0.0+Version:                4.0.1 Author:                 Kazu Yamamoto <kazu@iij.ad.jp> Maintainer:             Kazu Yamamoto <kazu@iij.ad.jp> License:                BSD3@@ -9,18 +9,50 @@   A thread-safe DNS library for both clients and servers written   in pure Haskell. Category:               Network-Cabal-Version:          >= 1.10-Build-Type:             Custom+Cabal-Version:          2.0+Build-Type:             Simple Extra-Source-Files:     Changelog.md+                        cabal.project                         cbits/dns.c-Tested-With:            GHC == 7.10.3-                      , GHC == 8.0.2+Tested-With:            GHC == 8.0.2                       , GHC == 8.2.2                       , GHC == 8.4.4                       , GHC == 8.6.5+                      , GHC == 8.8.1 -Custom-Setup-  Setup-Depends:        base, Cabal, cabal-doctest >=1.0.6 && <1.1+Library dns-internal+  Default-Language:     Haskell2010+  GHC-Options:          -Wall+  Hs-Source-Dirs:       internal+  Exposed-Modules:      Network.DNS.Imports+                        Network.DNS.Types.Internal+                        Network.DNS.Types.Resolver+                        Network.DNS.Resolver.Internal+                        Network.DNS.Decode.Parsers+                        Network.DNS.Decode.Internal+                        Network.DNS.Encode.Builders+                        Network.DNS.Encode.Internal+                        Network.DNS.StateBinary+                        Network.DNS.Memo+                        Network.DNS.Base32Hex+  Build-Depends:        base+                      , array+                      , async+                      , attoparsec+                      , auto-update+                      , base16-bytestring+                      , base64-bytestring+                      , bytestring+                      , containers+                      , cryptonite+                      , hourglass+                      , iproute+                      , mtl+                      , network+                      , psqueues+  if os(windows)+    C-Sources:        cbits/dns.c+    Extra-Libraries:  iphlpapi  Library   Default-Language:     Haskell2010@@ -32,21 +64,11 @@                         Network.DNS.Utils                         Network.DNS.Types                         Network.DNS.Decode-                        Network.DNS.Decode.Internal                         Network.DNS.Encode-                        Network.DNS.Encode.Internal                         Network.DNS.IO-  Other-Modules:        Network.DNS.Base32Hex-                        Network.DNS.Decode.Parsers-                        Network.DNS.Encode.Builders-                        Network.DNS.Imports-                        Network.DNS.Memo-                        Network.DNS.StateBinary-                        Network.DNS.Transport-                        Network.DNS.Types.Internal-  if impl(ghc < 8)-    Build-Depends:      semigroups-  Build-Depends:        base >= 4 && < 5+  Other-Modules:        Network.DNS.Transport+  Build-Depends:        dns-internal+                      , base >= 4 && < 5                       , array                       , async                       , attoparsec@@ -61,12 +83,8 @@                       , mtl                       , network >= 2.3                       , psqueues-  if os(windows)-    Build-Depends:    split-    C-Sources:        cbits/dns.c-    Extra-Libraries:  iphlpapi -Test-Suite network+Test-Suite network-tests   Type:                 exitcode-stdio-1.0   Default-Language:     Haskell2010   Hs-Source-Dirs:       test2@@ -75,11 +93,12 @@   Other-Modules:        LookupSpec                         IOSpec   Build-Depends:        dns+                      , dns-internal                       , base                       , hspec                       , network -Test-Suite spec+Test-Suite spec-tests   Type:                 exitcode-stdio-1.0   Default-Language:     Haskell2010   Hs-Source-Dirs:       test@@ -89,19 +108,22 @@                         DecodeSpec                         RoundTripSpec   Build-Depends:        dns+                      , dns-internal                       , QuickCheck >= 2.9                       , base                       , bytestring                       , hspec-                      , iproute >= 1.2.4+                      , iproute >= 1.3.2                       , word8  Test-Suite doctests   Type:                 exitcode-stdio-1.0   Default-Language:     Haskell2010   Hs-Source-Dirs:       test2-  Ghc-Options:          -Wall+  Ghc-Options:          -Wall -threaded   Main-Is:              doctests.hs+  Other-Modules:        Paths_dns+  Autogen-Modules:      Paths_dns   Build-Depends:        base                       , doctest 

@@ -0,0 +1,50 @@+module Network.DNS.Base32Hex (encode) where++import qualified Data.Array.MArray as A+import qualified Data.Array.IArray as A+import qualified Data.Array.ST     as A+import qualified Data.ByteString   as B++import Network.DNS.Imports++-- | Encode ByteString using the+-- <https://tools.ietf.org/html/rfc4648#section-7 RFC4648 base32hex>+-- encoding with no padding as specified for the+-- <https://tools.ietf.org/html/rfc5155#section-3.3 RFC5155 Next Hashed Owner Name>+-- field.+--+encode :: B.ByteString -- ^ input buffer+       -> B.ByteString -- ^ base32hex output+encode bs =+    let len = (8 * B.length bs + 4) `div` 5+        ws  = B.unpack bs+     in B.pack $ A.elems $ A.runSTUArray $ do+        a <- A.newArray (0 :: Int, len-1) 0+        go ws a 0+  where+    toHex32 w | w < 10    = 48 + w+              | otherwise = 55 + w++    load8  a i   = A.readArray  a i+    store8 a i v = A.writeArray a i v++    -- Encode a list of 8-bit words at bit offset @n@+    -- into an array 'a' of 5-bit words.+    go [] a _ = A.mapArray toHex32 a+    go (w:ws) a n = do+        -- Split 8 bits into left, middle and right parts.  The+        -- right part only gets written when the 8-bit input word+        -- splits across three different 5-bit words.+        --+        let (q, r) = n `divMod` 5+            wl =  w `shiftR` ( 3 + r)+            wm = (w `shiftL` ( 5 - r))  `shiftR` 3+            wr = (w `shiftL` (10 - r)) `shiftR` 3+        al <- case r of+              0 -> pure wl+              _ -> (wl .|.) <$> load8 a q+        store8 a q al+        store8 a (q + 1) wm+        when (r > 2) $ store8 a (q+2) wr+        go ws a $ n + 8+{-# INLINE encode #-}

@@ -0,0 +1,64 @@+{-# OPTIONS_HADDOCK hide #-}++module Network.DNS.Decode.Internal (+    -- ** Internal message component decoders for tests+    decodeDNSHeader+  , decodeDNSFlags+  , decodeDomain+  , decodeMailbox+  , decodeResourceRecordAt+  , decodeResourceRecord+  ) where++import Network.DNS.Decode.Parsers+import Network.DNS.Imports+import Network.DNS.StateBinary+import Network.DNS.Types.Internal++----------------------------------------------------------------++-- | Decode the 'DNSFlags' field of 'DNSHeader'.  This is an internal function+-- exposed only for testing.+--+decodeDNSFlags :: ByteString -> Either DNSError DNSFlags+decodeDNSFlags bs = fst <$> runSGet getDNSFlags bs++-- | Decode the 'DNSHeader' of a message.  This is an internal function.+-- exposed only for testing.+--+decodeDNSHeader :: ByteString -> Either DNSError DNSHeader+decodeDNSHeader bs = fst <$> runSGet getHeader bs++-- | Decode a domain name.  Since DNS names may use name compression, it is not+-- generally possible to decode the names separately from the enclosing DNS+-- message.  This is an internal function exposed only for testing.+--+decodeDomain :: ByteString -> Either DNSError Domain+decodeDomain bs = fst <$> runSGet getDomain bs++-- | Decode a mailbox name (the SOA record /mrname/ field).  Since DNS names+-- may use name compression, it is not generally possible to decode the names+-- separately from the enclosing DNS message.  This is an internal function.+--+decodeMailbox :: ByteString -> Either DNSError Mailbox+decodeMailbox bs = fst <$> runSGet getMailbox bs++-- | Decoding resource records.++-- | Decode a resource record (RR) with any DNS timestamps interpreted at the+-- nominal epoch time (see 'decodeAt').  Since RRs may use name compression,+-- it is not generally possible to decode resource record separately from the+-- enclosing DNS message.  This is an internal function.+--+decodeResourceRecord :: ByteString -> Either DNSError ResourceRecord+decodeResourceRecord bs = fst <$> runSGet getResourceRecord bs++-- | Decode a resource record (RR) with DNS timestamps interpreted at the+-- supplied epoch time.  Since RRs may use DNS name compression, it is not+-- generally possible to decode resource record separately from the enclosing+-- DNS message.  This is an internal function.+--+decodeResourceRecordAt :: Int64      -- ^ current epoch time+                       -> ByteString -- ^ encoded resource record+                       -> Either DNSError ResourceRecord+decodeResourceRecordAt t bs = fst <$> runSGetAt t getResourceRecord bs

@@ -0,0 +1,486 @@+{-# LANGUAGE BangPatterns, OverloadedStrings #-}++module Network.DNS.Decode.Parsers (+    getResponse+  , getDNSFlags+  , getHeader+  , getResourceRecord+  , getResourceRecords+  , getDomain+  , getMailbox+  ) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BS+import qualified Data.IP+import Data.IP (IP(..), toIPv4, toIPv6b, makeAddrRange)++import Network.DNS.Imports+import Network.DNS.StateBinary+import Network.DNS.Types.Internal++----------------------------------------------------------------++getResponse :: SGet DNSMessage+getResponse = do+    hm <- getHeader+    qdCount <- getInt16+    anCount <- getInt16+    nsCount <- getInt16+    arCount <- getInt16+    queries <- getQueries qdCount+    answers <- getResourceRecords anCount+    authrrs <- getResourceRecords nsCount+    addnrrs <- getResourceRecords arCount+    let (opts, rest) = partition ((==) OPT. rrtype) addnrrs+        flgs         = flags hm+        rc           = fromRCODE $ rcode flgs+        (eh, erc)    = getEDNS rc opts+        hd           = hm { flags = flgs { rcode = erc } }+    pure $ DNSMessage hd eh queries answers authrrs $ ifEDNS eh rest addnrrs++  where++    -- | Get EDNS pseudo-header and the high eight bits of the extended RCODE.+    --+    getEDNS :: Word16 -> AdditionalRecords -> (EDNSheader, RCODE)+    getEDNS rc rrs = case rrs of+        [rr] | Just (edns, erc) <- optEDNS rr+               -> (EDNSheader edns, toRCODE erc)+        []     -> (NoEDNS, toRCODE rc)+        _      -> (InvalidEDNS, BadRCODE)++      where++        -- | Extract EDNS information from an OPT RR.+        --+        optEDNS :: ResourceRecord -> Maybe (EDNS, Word16)+        optEDNS (ResourceRecord "." OPT udpsiz ttl' (RD_OPT opts)) =+            let hrc      = fromIntegral rc .&. 0x0f+                erc      = shiftR (ttl' .&. 0xff000000) 20 .|. hrc+                secok    = ttl' `testBit` 15+                vers     = fromIntegral $ shiftR (ttl' .&. 0x00ff0000) 16+             in Just (EDNS vers udpsiz secok opts, fromIntegral erc)+        optEDNS _ = Nothing++----------------------------------------------------------------++getDNSFlags :: SGet DNSFlags+getDNSFlags = do+    flgs <- get16+    oc <- getOpcode flgs+    return $ DNSFlags (getQorR flgs)+                      oc+                      (getAuthAnswer flgs)+                      (getTrunCation flgs)+                      (getRecDesired flgs)+                      (getRecAvailable flgs)+                      (getRcode flgs)+                      (getAuthenData flgs)+                      (getChkDisable flgs)+  where+    getQorR w = if testBit w 15 then QR_Response else QR_Query+    getOpcode w =+        case shiftR w 11 .&. 0x0f of+            n | Just opc <- toOPCODE n+              -> pure opc+              | otherwise+              -> failSGet $ "Unsupported header opcode: " ++ show n+    getAuthAnswer w = testBit w 10+    getTrunCation w = testBit w 9+    getRecDesired w = testBit w 8+    getRecAvailable w = testBit w 7+    getRcode w = toRCODE $ w .&. 0x0f+    getAuthenData w = testBit w 5+    getChkDisable w = testBit w 4++----------------------------------------------------------------++getHeader :: SGet DNSHeader+getHeader =+    DNSHeader <$> decodeIdentifier <*> getDNSFlags+  where+    decodeIdentifier = get16++----------------------------------------------------------------++getQueries :: Int -> SGet [Question]+getQueries n = replicateM n getQuery++getTYPE :: SGet TYPE+getTYPE = toTYPE <$> get16++-- XXX: Include the class when implemented, or otherwise perhaps check the+-- implicit assumption that the class is classIN.+--+getQuery :: SGet Question+getQuery = Question <$> getDomain+                    <*> getTYPE+                    <*  ignoreClass+  where+    ignoreClass = get16++getResourceRecords :: Int -> SGet [ResourceRecord]+getResourceRecords n = replicateM n getResourceRecord++getResourceRecord :: SGet ResourceRecord+getResourceRecord = do+    dom <- getDomain+    typ <- getTYPE+    cls <- get16+    ttl <- get32+    len <- getInt16+    dat <- fitSGet len $ getRData typ len+    return $ ResourceRecord dom typ cls ttl dat++----------------------------------------------------------------++-- | Helper to find position of RData end, that is, the offset of the first+-- byte /after/ the current RData.+--+rdataEnd :: Int      -- ^ number of bytes left from current position+         -> SGet Int -- ^ end position+rdataEnd !len = (+) len <$> getPosition++getRData :: TYPE -> Int -> SGet RData+getRData NS _    = RD_NS    <$> getDomain+getRData MX _    = RD_MX    <$> get16 <*> getDomain+getRData CNAME _ = RD_CNAME <$> getDomain+getRData DNAME _ = RD_DNAME <$> getDomain+getRData TXT len = RD_TXT   <$> getTXT len+getRData A _     = RD_A . toIPv4 <$> getNBytes 4+getRData AAAA _  = RD_AAAA . toIPv6b <$> getNBytes 16+getRData SOA _   = RD_SOA  <$> getDomain+                           <*> getMailbox+                           <*> decodeSerial+                           <*> decodeRefesh+                           <*> decodeRetry+                           <*> decodeExpire+                           <*> decodeMinimum+  where+    decodeSerial  = get32+    decodeRefesh  = get32+    decodeRetry   = get32+    decodeExpire  = get32+    decodeMinimum = get32+getRData PTR _ = RD_PTR <$> getDomain+getRData SRV _ = RD_SRV <$> decodePriority+                        <*> decodeWeight+                        <*> decodePort+                        <*> getDomain+  where+    decodePriority = get16+    decodeWeight   = get16+    decodePort     = get16+getRData OPT len   = RD_OPT <$> getOpts len+--+getRData TLSA len = RD_TLSA <$> decodeUsage+                            <*> decodeSelector+                            <*> decodeMType+                            <*> decodeADF+  where+    decodeUsage    = get8+    decodeSelector = get8+    decodeMType    = get8+    decodeADF      = getNByteString (len - 3)+--+getRData DS len = RD_DS <$> decodeTag+                        <*> decodeAlg+                        <*> decodeDtyp+                        <*> decodeDval+  where+    decodeTag  = get16+    decodeAlg  = get8+    decodeDtyp = get8+    decodeDval = getNByteString (len - 4)+--+getRData CDS len = RD_CDS <$> decodeTag+                          <*> decodeAlg+                          <*> decodeDtyp+                          <*> decodeDval+  where+    decodeTag  = get16+    decodeAlg  = get8+    decodeDtyp = get8+    decodeDval = getNByteString (len - 4)+--+getRData RRSIG len = RD_RRSIG <$> decodeRRSIG+  where+    decodeRRSIG = do+        -- The signature follows a variable length zone name+        -- and occupies the rest of the RData.  Simplest to+        -- checkpoint the position at the start of the RData,+        -- and after reading the zone name, and subtract that+        -- from the RData length.+        --+        end <- rdataEnd len+        typ <- getTYPE+        alg <- get8+        cnt <- get8+        ttl <- get32+        tex <- getDnsTime+        tin <- getDnsTime+        tag <- get16+        dom <- getDomain -- XXX: Enforce no compression?+        pos <- getPosition+        val <- getNByteString $ end - pos+        return $ RDREP_RRSIG typ alg cnt ttl tex tin tag dom val+    getDnsTime   = do+        tnow <- getAtTime+        tdns <- get32+        return $! dnsTime tdns tnow+--+getRData NULL len = RD_NULL <$> getNByteString len+getRData NSEC len = do+    end <- rdataEnd len+    dom <- getDomain+    pos <- getPosition+    RD_NSEC dom <$> getNsecTypes (end - pos)+--+getRData DNSKEY len = RD_DNSKEY <$> decodeKeyFlags+                                <*> decodeKeyProto+                                <*> decodeKeyAlg+                                <*> decodeKeyBytes+  where+    decodeKeyFlags  = get16+    decodeKeyProto  = get8+    decodeKeyAlg    = get8+    decodeKeyBytes  = getNByteString (len - 4)+--+getRData CDNSKEY len = RD_CDNSKEY <$> decodeKeyFlags+                                  <*> decodeKeyProto+                                  <*> decodeKeyAlg+                                  <*> decodeKeyBytes+  where+    decodeKeyFlags  = get16+    decodeKeyProto  = get8+    decodeKeyAlg    = get8+    decodeKeyBytes  = getNByteString (len - 4)+--+getRData NSEC3 len = do+    dend <- rdataEnd len+    halg <- get8+    flgs <- get8+    iter <- get16+    salt <- getInt8 >>= getNByteString+    hash <- getInt8 >>= getNByteString+    tpos <- getPosition+    RD_NSEC3 halg flgs iter salt hash <$> getNsecTypes (dend - tpos)+--+getRData NSEC3PARAM _ = RD_NSEC3PARAM <$> decodeHashAlg+                                      <*> decodeFlags+                                      <*> decodeIterations+                                      <*> decodeSalt+  where+    decodeHashAlg    = get8+    decodeFlags      = get8+    decodeIterations = get16+    decodeSalt       = getInt8 >>= getNByteString+--+getRData _  len = UnknownRData <$> getNByteString len++----------------------------------------------------------------++-- $+--+-- >>> import Network.DNS.StateBinary+-- >>> let Right ((t,_),l) = runSGetWithLeftovers (getTXT 8) "\3foo\3barbaz"+-- >>> (t, l) == ("foobar", "baz")+-- True++-- | Concatenate a sequence of length-prefixed strings of text+-- https://tools.ietf.org/html/rfc1035#section-3.3+--+getTXT :: Int -> SGet ByteString+getTXT !len = B.concat <$> sGetMany "TXT RR string" len getstring+  where+    getstring = getInt8 >>= getNByteString++-- <https://tools.ietf.org/html/rfc6891#section-6.1.2>+-- Parse a list of EDNS options+--+getOpts :: Int -> SGet [OData]+getOpts !len = sGetMany "EDNS option" len getoption+  where+    getoption = do+        code <- toOptCode <$> get16+        olen <- getInt16+        getOData code olen++-- <https://tools.ietf.org/html/rfc4034#section-4.1>+-- Parse a list of NSEC type bitmaps+--+getNsecTypes :: Int -> SGet [TYPE]+getNsecTypes !len = concat <$> sGetMany "NSEC type bitmap" len getbits+  where+    getbits = do+        window <- flip shiftL 8 <$> getInt8+        blocks <- getInt8+        when (blocks > 32) $+            failSGet $ "NSEC bitmap block too long: " ++ show blocks+        concatMap blkTypes. zip [window, window + 8..] <$> getNBytes blocks+      where+        blkTypes (bitOffset, byte) =+            [ toTYPE $ fromIntegral $ bitOffset + i |+              i <- [0..7], byte .&. bit (7-i) /= 0 ]++----------------------------------------------------------------++getOData :: OptCode -> Int -> SGet OData+getOData NSID len = OD_NSID <$> getNByteString len+getOData DAU  len = OD_DAU  <$> getNoctets len+getOData DHU  len = OD_DHU  <$> getNoctets len+getOData N3U  len = OD_N3U  <$> getNoctets len+getOData ClientSubnet len = do+        family  <- get16+        srcBits <- get8+        scpBits <- get8+        addrbs  <- getNByteString (len - 4) -- 4 = 2 + 1 + 1+        --+        -- https://tools.ietf.org/html/rfc7871#section-6+        --+        -- o  ADDRESS, variable number of octets, contains either an IPv4 or+        --    IPv6 address, depending on FAMILY, which MUST be truncated to the+        --    number of bits indicated by the SOURCE PREFIX-LENGTH field,+        --    padding with 0 bits to pad to the end of the last octet needed.+        --+        -- o  A server receiving an ECS option that uses either too few or too+        --    many ADDRESS octets, or that has non-zero ADDRESS bits set beyond+        --    SOURCE PREFIX-LENGTH, SHOULD return FORMERR to reject the packet,+        --    as a signal to the software developer making the request to fix+        --    their implementation.+        --+        -- In order to avoid needless decoding errors, when the ECS encoding+        -- requirements are violated, we construct an OD_ECSgeneric OData,+        -- instread of an IP-specific OD_ClientSubnet OData, which will only+        -- be used for valid inputs.  When the family is neither IPv4(1) nor+        -- IPv6(2), or the address prefix is not correctly encoded (too long+        -- or too short), the OD_ECSgeneric data contains the verbatim input+        -- from the peer.+        --+        case BS.length addrbs == (fromIntegral srcBits + 7) `div` 8 of+            True | Just ip <- bstoip family addrbs srcBits scpBits+                -> pure $ OD_ClientSubnet srcBits scpBits ip+            _   -> pure $ OD_ECSgeneric family srcBits scpBits addrbs+  where+    prefix addr bits = Data.IP.addr $ makeAddrRange addr $ fromIntegral bits+    zeropad = (++ repeat 0). map fromIntegral. B.unpack+    checkBits fromBytes toIP srcBits scpBits bytes =+        let addr       = fromBytes bytes+            maskedAddr = prefix addr srcBits+            maxBits    = fromIntegral $ 8 * length bytes+         in if addr == maskedAddr && scpBits <= maxBits+            then Just $ toIP addr+            else Nothing+    bstoip :: Word16 -> B.ByteString -> Word8 -> Word8 -> Maybe IP+    bstoip family bs srcBits scpBits = case family of+        1 -> checkBits toIPv4  IPv4 srcBits scpBits $ take 4  $ zeropad bs+        2 -> checkBits toIPv6b IPv6 srcBits scpBits $ take 16 $ zeropad bs+        _ -> Nothing+getOData opc len = UnknownOData (fromOptCode opc) <$> getNByteString len++----------------------------------------------------------------++-- | Pointers MUST point back into the packet per RFC1035 Section 4.1.4.  This+-- is further interpreted by the DNS community (from a discussion on the IETF+-- DNSOP mailing list) to mean that they don't point back into the same domain.+-- Therefore, when starting to parse a domain, the current offset is also a+-- strict upper bound on the targets of any pointers that arise while processing+-- the domain.  When following a pointer, the target again becomes a stict upper+-- bound for any subsequent pointers.  This results in a simple loop-prevention+-- algorithm, each sequence of valid pointer values is necessarily strictly+-- decreasing!  The third argument to 'getDomain'' is a strict pointer upper+-- bound, and is set here to the position at the start of parsing the domain+-- or mailbox.+--+-- Note: the separator passed to 'getDomain'' is required to be either \'.\' or+-- \'\@\', or else 'unparseLabel' needs to be modified to handle the new value.+--++getDomain :: SGet Domain+getDomain = getPosition >>= getDomain' dot++getMailbox :: SGet Mailbox+getMailbox = getPosition >>= getDomain' atsign++dot, atsign :: Word8+dot    = fromIntegral $ fromEnum '.' -- 46+atsign = fromIntegral $ fromEnum '@' -- 64++-- $+-- Pathological case: pointer embedded inside a label!  The pointer points+-- behind the start of the domain and is then absorbed into the initial label!+-- Though we don't IMHO have to support this, it is not manifestly illegal, and+-- does exercise the code in an interesting way.  Ugly as this is, it also+-- "works" the same in Perl's Net::DNS and reportedly in ISC's BIND.+--+-- >>> :{+-- let input = "\6\3foo\192\0\3bar\0"+--     parser = skipNBytes 1 >> getDomain' dot 1+--     Right (output, _) = runSGet parser input+--  in output == "foo.\\003foo\\192\\000.bar."+-- :}+-- True+--+-- The case below fails to point far enough back, and triggers the loop+-- prevention code-path.+--+-- >>> :{+-- let input = "\6\3foo\192\1\3bar\0"+--     parser = skipNBytes 1 >> getDomain' dot 1+--     Left (DecodeError err) = runSGet parser input+--  in err+-- :}+-- "invalid name compression pointer"++-- | Get a domain name, using sep1 as the separator between the 1st and 2nd+-- label.  Subsequent labels (and always the trailing label) are terminated+-- with a ".".+--+-- Note: the separator is required to be either \'.\' or \'\@\', or else+-- 'unparseLabel' needs to be modified to handle the new value.+--+-- Domain name compression pointers must always refer to a position that+-- precedes the start of the current domain name.  The starting offsets form a+-- strictly decreasing sequence, which prevents pointer loops.+--+getDomain' :: Word8 -> Int -> SGet ByteString+getDomain' sep1 ptrLimit = do+    pos <- getPosition+    c <- getInt8+    let n = getValue c+    getdomain pos c n+  where+    getdomain pos c n+      | c == 0 = return "." -- Perhaps the root domain?+      | isPointer c = do+          d <- getInt8+          let offset = n * 256 + d+          when (offset >= ptrLimit) $+              failSGet "invalid name compression pointer"+          mo <- pop offset+          case mo of+              Nothing -> do+                  msg <- getInput+                  -- Reprocess the same ByteString starting at the pointer+                  -- target (offset).+                  let parser = skipNBytes offset >> getDomain' sep1 offset+                  case runSGet parser msg of+                      Left (DecodeError err) -> failSGet err+                      Left err               -> fail $ show err+                      Right o  -> push pos (fst o) >> return (fst o)+              Just o -> push pos o >> return o+      -- As for now, extended labels have no use.+      -- This may change some time in the future.+      | isExtLabel c = return ""+      | otherwise = do+          hs <- unparseLabel sep1 <$> getNByteString n+          ds <- getDomain' dot ptrLimit+          let dom = case ds of -- avoid trailing ".."+                  "." -> hs <> "."+                  _   -> hs <> B.singleton sep1 <> ds+          push pos dom+          return dom+    getValue c = c .&. 0x3f+    isPointer c = testBit c 7 && testBit c 6+    isExtLabel c = not (testBit c 7) && testBit c 6

@@ -0,0 +1,348 @@+{-# LANGUAGE+    BangPatterns+  , RecordWildCards+  , TransformListComp+  #-}++-- | DNS Message builder.+module Network.DNS.Encode.Builders (+    putDNSMessage+  , putDNSFlags+  , putHeader+  , putDomain+  , putMailbox+  , putResourceRecord+  ) where++import Control.Monad.State (State, modify, execState, gets)+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy.Char8 as LBS+import qualified Data.IP+import Data.IP (IP(..), fromIPv4, fromIPv6b, makeAddrRange)+import GHC.Exts (the, groupWith)++import Network.DNS.Imports+import Network.DNS.StateBinary+import Network.DNS.Types.Internal++----------------------------------------------------------------++putDNSMessage :: DNSMessage -> SPut+putDNSMessage msg = putHeader hd+                    <> putNums+                    <> mconcat (map putQuestion qs)+                    <> mconcat (map putResourceRecord an)+                    <> mconcat (map putResourceRecord au)+                    <> mconcat (map putResourceRecord ad)+  where+    putNums = mconcat $ fmap putInt16 [ length qs+                                      , length an+                                      , length au+                                      , length ad+                                      ]+    hm = header msg+    fl = flags hm+    eh = ednsHeader msg+    qs = question msg+    an = answer msg+    au = authority msg+    hd = ifEDNS eh hm $ hm { flags = fl { rcode = rc } }+    rc = ifEDNS eh <$> id <*> nonEDNSrcode $ rcode fl+      where+        nonEDNSrcode code | fromRCODE code < 16 = code+                          | otherwise           = FormatErr+    ad = prependOpt $ additional msg+      where+        prependOpt ads = mapEDNS eh (fromEDNS ads $ fromRCODE rc) ads+          where+            fromEDNS :: AdditionalRecords -> Word16 -> EDNS -> AdditionalRecords+            fromEDNS rrs rc' edns = ResourceRecord name' type' class' ttl' rdata' : rrs+              where+                name'  = BS.singleton '.'+                type'  = OPT+                class' = maxUdpSize `min` (minUdpSize `max` ednsUdpSize edns)+                ttl0'  = fromIntegral (rc' .&. 0xff0) `shiftL` 20+                vers'  = fromIntegral (ednsVersion edns) `shiftL` 16+                ttl'+                  | ednsDnssecOk edns = ttl0' `setBit` 15 .|. vers'+                  | otherwise         = ttl0' .|. vers'+                rdata' = RD_OPT $ ednsOptions edns++putHeader :: DNSHeader -> SPut+putHeader hdr = putIdentifier (identifier hdr)+                <> putDNSFlags (flags hdr)+  where+    putIdentifier = put16++putDNSFlags :: DNSFlags -> SPut+putDNSFlags DNSFlags{..} = put16 word+  where+    set :: Word16 -> State Word16 ()+    set byte = modify (.|. byte)++    st :: State Word16 ()+    st = sequence_+              [ set (fromRCODE rcode .&. 0x0f)+              , when chkDisable          $ set (bit 4)+              , when authenData          $ set (bit 5)+              , when recAvailable        $ set (bit 7)+              , when recDesired          $ set (bit 8)+              , when trunCation          $ set (bit 9)+              , when authAnswer          $ set (bit 10)+              , set (fromOPCODE opcode `shiftL` 11)+              , when (qOrR==QR_Response) $ set (bit 15)+              ]++    word = execState st 0++-- XXX: Use question class when implemented+--+putQuestion :: Question -> SPut+putQuestion Question{..} = putDomain qname+                           <> put16 (fromTYPE qtype)+                           <> put16 classIN++putResourceRecord :: ResourceRecord -> SPut+putResourceRecord ResourceRecord{..} = mconcat [+    putDomain rrname+  , put16 (fromTYPE rrtype)+  , put16 rrclass+  , put32 rrttl+  , putResourceRData rdata+  ]+  where+    putResourceRData :: RData -> SPut+    putResourceRData rd = do+        addPositionW 2 -- "simulate" putInt16+        rDataBuilder <- putRData rd+        let rdataLength = fromIntegral . LBS.length . BB.toLazyByteString $ rDataBuilder+        let rlenBuilder = BB.int16BE rdataLength+        return $ rlenBuilder <> rDataBuilder+++putRData :: RData -> SPut+putRData rd = case rd of+    RD_A                 address -> mconcat $ map putInt8 (fromIPv4 address)+    RD_NS                nsdname -> putDomain nsdname+    RD_CNAME               cname -> putDomain cname+    RD_SOA         a b c d e f g -> putSOA a b c d e f g+    RD_NULL                bytes -> putByteString bytes+    RD_PTR              ptrdname -> putDomain ptrdname+    RD_MX              pref exch -> mconcat [put16 pref, putDomain exch]+    RD_TXT            textstring -> putTXT textstring+    RD_AAAA              address -> mconcat $ map putInt8 (fromIPv6b address)+    RD_SRV       pri wei prt tgt -> putSRV pri wei prt tgt+    RD_DNAME               dname -> putDomain dname+    RD_OPT               options -> mconcat $ fmap putOData options+    RD_DS             kt ka dt d -> putDS kt ka dt d+    RD_CDS            kt ka dt d -> putDS kt ka dt d+    RD_RRSIG               rrsig -> putRRSIG rrsig+    RD_NSEC           next types -> putDomain next <> putNsecTypes types+    RD_DNSKEY        f p alg key -> putDNSKEY f p alg key+    RD_CDNSKEY       f p alg key -> putDNSKEY f p alg key+    RD_NSEC3     a f i s h types -> putNSEC3 a f i s h types+    RD_NSEC3PARAM  a f iter salt -> putNSEC3PARAM a f iter salt+    RD_TLSA           u s m dgst -> putTLSA u s m dgst+    UnknownRData           bytes -> putByteString bytes+  where+    putSOA mn mr serial refresh retry expire minttl = mconcat+        [ putDomain mn+        , putMailbox mr+        , put32 serial+        , put32 refresh+        , put32 retry+        , put32 expire+        , put32 minttl+        ]+    -- TXT record string fragments are at most 255 bytes+    putTXT textstring =+        let (!h, !t) = BS.splitAt 255 textstring+         in putByteStringWithLength h <> if BS.null t+                then mempty+                else putTXT t+    putSRV priority weight port target = mconcat+        [ put16 priority+        , put16 weight+        , put16 port+        , putDomain target+        ]+    putDS keytag keyalg digestType digest = mconcat+        [ put16 keytag+        , put8 keyalg+        , put8 digestType+        , putByteString digest+        ]+    putRRSIG RDREP_RRSIG{..} = mconcat+        [ put16 $ fromTYPE rrsigType+        , put8 rrsigKeyAlg+        , put8 rrsigNumLabels+        , put32 rrsigTTL+        , put32 $ fromIntegral rrsigExpiration+        , put32 $ fromIntegral rrsigInception+        , put16 rrsigKeyTag+        , putDomain rrsigZone+        , putByteString rrsigValue+        ]+    putDNSKEY flags protocol alg key = mconcat+        [ put16 flags+        , put8 protocol+        , put8 alg+        , putByteString key+        ]+    putNSEC3 alg flags iterations salt hash types = mconcat+        [ put8 alg+        , put8 flags+        , put16 iterations+        , putByteStringWithLength salt+        , putByteStringWithLength hash+        , putNsecTypes types+        ]+    putNSEC3PARAM alg flags iterations salt = mconcat+        [ put8 alg+        , put8 flags+        , put16 iterations+        , putByteStringWithLength salt+        ]+    putTLSA usage selector mtype assocData = mconcat+        [ put8 usage+        , put8 selector+        , put8 mtype+        , putByteString assocData+        ]++-- | Encode DNSSEC NSEC type bits+putNsecTypes :: [TYPE] -> SPut+putNsecTypes types = putTypeList $ map fromTYPE types+  where+    putTypeList :: [Word16] -> SPut+    putTypeList ts =+        mconcat [ putWindow (the top8) bot8 |+                  t <- ts,+                  let top8 = fromIntegral t `shiftR` 8,+                  let bot8 = fromIntegral t .&. 0xff,+                  then group by top8+                       using groupWith ]++    putWindow :: Int -> [Int] -> SPut+    putWindow top8 bot8s =+        let blks = maximum bot8s `shiftR` 3+         in putInt8 top8+            <> put8 (1 + fromIntegral blks)+            <> putBits 0 [ (the block, foldl' mergeBits 0 bot8) |+                           bot8 <- bot8s,+                           let block = bot8 `shiftR` 3,+                           then group by block+                                using groupWith ]+      where+        -- | Combine type bits in network bit order, i.e. bit 0 first.+        mergeBits acc b = setBit acc (7 - b.&.0x07)++    putBits :: Int -> [(Int, Word8)] -> SPut+    putBits _ [] = pure mempty+    putBits n ((block, octet) : rest) =+        putReplicate (block-n) 0+        <> put8 octet+        <> putBits (block + 1) rest++-- | Encode EDNS OPTION consisting of a list of octets.+putODWords :: Word16 -> [Word8] -> SPut+putODWords code ws =+     mconcat [ put16 code+             , putInt16 $ length ws+             , mconcat $ map put8 ws+             ]++-- | Encode an EDNS OPTION byte string.+putODBytes :: Word16 -> ByteString -> SPut+putODBytes code bs =+    mconcat [ put16 code+            , putInt16 $ BS.length bs+            , putByteString bs+            ]++putOData :: OData -> SPut+putOData (OD_NSID nsid) = putODBytes (fromOptCode NSID) nsid+putOData (OD_DAU as) = putODWords (fromOptCode DAU) as+putOData (OD_DHU hs) = putODWords (fromOptCode DHU) hs+putOData (OD_N3U hs) = putODWords (fromOptCode N3U) hs+putOData (OD_ClientSubnet srcBits scpBits ip) =+    -- https://tools.ietf.org/html/rfc7871#section-6+    --+    -- o  ADDRESS, variable number of octets, contains either an IPv4 or+    --    IPv6 address, depending on FAMILY, which MUST be truncated to the+    --    number of bits indicated by the SOURCE PREFIX-LENGTH field,+    --    padding with 0 bits to pad to the end of the last octet needed.+    --+    -- o  A server receiving an ECS option that uses either too few or too+    --    many ADDRESS octets, or that has non-zero ADDRESS bits set beyond+    --    SOURCE PREFIX-LENGTH, SHOULD return FORMERR to reject the packet,+    --    as a signal to the software developer making the request to fix+    --    their implementation.+    --+    let octets = fromIntegral $ (srcBits + 7) `div` 8+        prefix addr = Data.IP.addr $ makeAddrRange addr $ fromIntegral srcBits+        (family, raw) = case ip of+                        IPv4 ip4 -> (1, take octets $ fromIPv4  $ prefix ip4)+                        IPv6 ip6 -> (2, take octets $ fromIPv6b $ prefix ip6)+        dataLen = 2 + 2 + octets+     in mconcat [ put16 $ fromOptCode ClientSubnet+                , putInt16 dataLen+                , put16 family+                , put8 srcBits+                , put8 scpBits+                , mconcat $ fmap putInt8 raw+                ]+putOData (OD_ECSgeneric family srcBits scpBits addr) =+    mconcat [ put16 $ fromOptCode ClientSubnet+            , putInt16 $ 4 + BS.length addr+            , put16 family+            , put8 srcBits+            , put8 scpBits+            , putByteString addr+            ]+putOData (UnknownOData code bs) = putODBytes code bs++-- In the case of the TXT record, we need to put the string length+-- fixme : What happens with the length > 256 ?+putByteStringWithLength :: BS.ByteString -> SPut+putByteStringWithLength bs = putInt8 (fromIntegral $ BS.length bs) -- put the length of the given string+                          <> putByteString bs++----------------------------------------------------------------++rootDomain :: Domain+rootDomain = BS.pack "."++putDomain :: Domain -> SPut+putDomain = putDomain' '.'++putMailbox :: Mailbox -> SPut+putMailbox = putDomain' '@'++putDomain' :: Char -> ByteString -> SPut+putDomain' sep dom+    | BS.null dom || dom == rootDomain = put8 0+    | otherwise = do+        mpos <- wsPop dom+        cur <- gets wsPosition+        case mpos of+            Just pos -> putPointer pos+            Nothing  -> wsPush dom cur >>+                        mconcat [ putPartialDomain hd+                                , putDomain' '.' tl+                                ]+  where+    -- Try with the preferred separator if present, else fall back to '.'.+    (hd, tl) =+        let p = parseLabel (c2w sep) dom+         in if sep /= '.' && BS.null (snd p)+            then parseLabel (c2w '.') dom+            else p+    c2w = fromIntegral . fromEnum++putPointer :: Int -> SPut+putPointer pos = putInt16 (pos .|. 0xc000)++putPartialDomain :: Domain -> SPut+putPartialDomain = putByteStringWithLength

@@ -0,0 +1,38 @@+{-# OPTIONS_HADDOCK hide #-}++-- | Internal DNS message component encoders for the test-suite.+module Network.DNS.Encode.Internal (+    encodeDNSHeader+  , encodeDNSFlags+  , encodeDomain+  , encodeMailbox+  , encodeResourceRecord+  ) where++import Network.DNS.Encode.Builders+import Network.DNS.Imports+import Network.DNS.StateBinary+import Network.DNS.Types.Internal++-- | Encode DNS flags.+encodeDNSFlags :: DNSFlags -> ByteString+encodeDNSFlags = runSPut . putDNSFlags++-- | Encode DNS header.+encodeDNSHeader :: DNSHeader -> ByteString+encodeDNSHeader = runSPut . putHeader++-- | Encode a domain.+encodeDomain :: Domain -> ByteString+encodeDomain = runSPut . putDomain++-- | Encode a mailbox name.  The first label is separated from the remaining+-- labels by an @'\@'@ rather than a @.@.  This is used for the contact+-- address in the @SOA@ record.+--+encodeMailbox :: Mailbox -> ByteString+encodeMailbox = runSPut . putMailbox++-- | Encode a ResourceRecord.+encodeResourceRecord :: ResourceRecord -> ByteString+encodeResourceRecord rr = runSPut $ putResourceRecord rr

@@ -0,0 +1,31 @@+module Network.DNS.Imports (+    ByteString+  , Int64+  , NonEmpty(..)+  , module Control.Applicative+  , module Control.Monad+  , module Data.Bits+  , module Data.Function+  , module Data.List+  , module Data.Maybe+  , module Data.Monoid+  , module Data.Ord+  , module Data.Typeable+  , module Data.Word+  , module Numeric+  ) where++import Control.Applicative+import Control.Monad+import Data.Bits+import Data.ByteString (ByteString)+import Data.Function+import Data.Int (Int64)+import Data.List+import Data.List.NonEmpty (NonEmpty(..))+import Data.Maybe+import Data.Monoid+import Data.Ord+import Data.Typeable+import Data.Word+import Numeric

@@ -0,0 +1,99 @@+{-# LANGUAGE RecordWildCards #-}++module Network.DNS.Memo where++import qualified Control.Reaper as R+import qualified Data.ByteString as B+import Data.Hourglass (Elapsed)+import Data.OrdPSQ (OrdPSQ)+import qualified Data.OrdPSQ as PSQ+import Time.System (timeCurrent)++import Network.DNS.Imports+import Network.DNS.Types.Internal++data Section = Answer | Authority deriving (Eq, Ord, Show)++type Key = (ByteString+           ,TYPE)+type Prio = Elapsed++type Entry = Either DNSError [RData]++type DB = OrdPSQ Key Prio Entry++type Cache = R.Reaper DB (Key,Prio,Entry)++newCache :: Int -> IO Cache+newCache delay = R.mkReaper R.defaultReaperSettings {+    R.reaperEmpty  = PSQ.empty+  , R.reaperCons   = \(k, tim, v) psq -> PSQ.insert k tim v psq+  , R.reaperAction = prune+  , R.reaperDelay  = delay * 1000000+  , R.reaperNull   = PSQ.null+  }++lookupCache :: Key -> Cache -> IO (Maybe (Prio, Entry))+lookupCache key reaper = PSQ.lookup key <$> R.reaperRead reaper++insertCache :: Key -> Prio -> Entry -> Cache -> IO ()+insertCache (dom,typ) tim ent0 reaper = R.reaperAdd reaper (key,tim,ent)+  where+    key = (B.copy dom,typ)+    ent = case ent0 of+      l@(Left _)  -> l+      (Right rds) -> Right $ map copy rds++-- Theoretically speaking, atMostView itself is good enough for pruning.+-- But auto-update assumes a list based db which does not provide atMost+-- functions. So, we need to do this redundant way.+prune :: DB -> IO (DB -> DB)+prune oldpsq = do+    tim <- timeCurrent+    let (_, pruned) = PSQ.atMostView tim oldpsq+    return $ \newpsq -> foldl' ins pruned $ PSQ.toList newpsq+  where+    ins psq (k,p,v) = PSQ.insert k p v psq++copy :: RData -> RData+copy r@(RD_A _)           = r+copy (RD_NS dom)          = RD_NS $ B.copy dom+copy (RD_CNAME dom)       = RD_CNAME $ B.copy dom+copy (RD_SOA mn mr a b c d e) = RD_SOA (B.copy mn) (B.copy mr) a b c d e+copy (RD_PTR dom)         = RD_PTR $ B.copy dom+copy (RD_NULL bytes)      = RD_NULL $ B.copy bytes+copy (RD_MX prf dom)      = RD_MX prf $ B.copy dom+copy (RD_TXT txt)         = RD_TXT $ B.copy txt+copy r@(RD_AAAA _)        = r+copy (RD_SRV a b c dom)   = RD_SRV a b c $ B.copy dom+copy (RD_DNAME dom)       = RD_DNAME $ B.copy dom+copy (RD_OPT od)          = RD_OPT $ map copyOData od+copy (RD_DS t a dt dv)    = RD_DS t a dt $ B.copy dv+copy (RD_CDS t a dt dv)   = RD_CDS t a dt $ B.copy dv+copy (RD_NSEC dom ts)     = RD_NSEC (B.copy dom) ts+copy (RD_DNSKEY f p a k)  = RD_DNSKEY f p a $ B.copy k+copy (RD_CDNSKEY f p a k) = RD_CDNSKEY f p a $ B.copy k+copy (RD_TLSA a b c dgst) = RD_TLSA a b c $ B.copy dgst+copy (RD_NSEC3 a b c s h t) = RD_NSEC3 a b c (B.copy s) (B.copy h) t+copy (RD_NSEC3PARAM a b c salt) = RD_NSEC3PARAM a b c $ B.copy salt+copy (RD_RRSIG sig)       = RD_RRSIG $ copysig sig+  where+    copysig s@RDREP_RRSIG{..} =+        s { rrsigZone = B.copy rrsigZone+          , rrsigValue = B.copy rrsigValue }+copy (UnknownRData is)    = UnknownRData $ B.copy is++copyOData :: OData -> OData+copyOData (OD_ECSgeneric family srcBits scpBits bs) =+    OD_ECSgeneric family srcBits scpBits $ B.copy bs+copyOData (OD_NSID nsid) = OD_NSID $ B.copy nsid+copyOData (UnknownOData c b)        = UnknownOData c $ B.copy b++-- No copying required for the rest, but avoiding a wildcard pattern match+-- so that if more option types are added in the future, the compiler will+-- complain about a partial function.+--+copyOData o@OD_ClientSubnet {} = o+copyOData o@OD_DAU {} = o+copyOData o@OD_DHU {} = o+copyOData o@OD_N3U {} = o

@@ -0,0 +1,52 @@+{-# LANGUAGE CPP #-}++module Network.DNS.Resolver.Internal (+      getDefaultDnsServers+    ) where++import Network.DNS.Imports++#if !defined(mingw32_HOST_OS)+#define POSIX+#else+#define WIN+#endif++#if defined(WIN)+import Foreign.C.String+import Foreign.Marshal.Alloc (allocaBytes)+#else+import Data.Char (isSpace)+#endif++getDefaultDnsServers :: FilePath -> IO [String]++#if defined(WIN)++foreign import ccall "getWindowsDefDnsServers" getWindowsDefDnsServers :: CString -> Int -> IO Word32++getDefaultDnsServers _ = do+  allocaBytes 256 $ \cString -> do+     res <- getWindowsDefDnsServers cString 256+     case res of+       0 -> split ',' <$> peekCString cString+       _ -> return [] -- TODO: Do proper error handling here.+  where+    split :: Char -> String -> [String]+    split c cs =+        let (h, t) = dropWhile (== c) <$> break (== c) cs+         in if null t+            then if null h then [] else [h]+            else if null h+            then split c t+            else h : split c t++#else++getDefaultDnsServers file = toAddresses <$> readFile file+  where+    toAddresses :: String -> [String]+    toAddresses cs = map extract (filter ("nameserver" `isPrefixOf`) (lines cs))+    extract = reverse . dropWhile isSpace . reverse . dropWhile isSpace . drop 11++#endif

@@ -0,0 +1,444 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+module Network.DNS.StateBinary (+    PState(..)+  , initialState+  , SPut+  , runSPut+  , put8+  , put16+  , put32+  , putInt8+  , putInt16+  , putInt32+  , putByteString+  , putReplicate+  , SGet+  , failSGet+  , fitSGet+  , runSGet+  , runSGetAt+  , runSGetWithLeftovers+  , runSGetWithLeftoversAt+  , get8+  , get16+  , get32+  , getInt8+  , getInt16+  , getInt32+  , getNByteString+  , sGetMany+  , getPosition+  , getInput+  , getAtTime+  , wsPop+  , wsPush+  , wsPosition+  , addPositionW+  , push+  , pop+  , getNBytes+  , getNoctets+  , skipNBytes+  , parseLabel+  , unparseLabel+  ) where++import qualified Control.Exception as E+import Control.Monad.State.Strict (State, StateT)+import qualified Control.Monad.State.Strict as ST+import qualified Data.Attoparsec.ByteString as A+import qualified Data.Attoparsec.Types as T+import qualified Data.ByteString as BS+import Data.ByteString.Builder (Builder)+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.Lazy as LB+import qualified Data.ByteString.Lazy.Char8 as LBS+import Data.IntMap (IntMap)+import qualified Data.IntMap as IM+import Data.Map (Map)+import qualified Data.Map as M+import Data.Semigroup as Sem++import Network.DNS.Imports+import Network.DNS.Types.Internal++----------------------------------------------------------------++type SPut = State WState Builder++data WState = WState {+    wsDomain :: Map Domain Int+  , wsPosition :: Int+}++initialWState :: WState+initialWState = WState M.empty 0++instance Sem.Semigroup SPut where+    p1 <> p2 = (Sem.<>) <$> p1 <*> p2++instance Monoid SPut where+    mempty = return mempty+#if !(MIN_VERSION_base(4,11,0))+    mappend = (Sem.<>)+#endif++put8 :: Word8 -> SPut+put8 = fixedSized 1 BB.word8++put16 :: Word16 -> SPut+put16 = fixedSized 2 BB.word16BE++put32 :: Word32 -> SPut+put32 = fixedSized 4 BB.word32BE++putInt8 :: Int -> SPut+putInt8 = fixedSized 1 (BB.int8 . fromIntegral)++putInt16 :: Int -> SPut+putInt16 = fixedSized 2 (BB.int16BE . fromIntegral)++putInt32 :: Int -> SPut+putInt32 = fixedSized 4 (BB.int32BE . fromIntegral)++putByteString :: ByteString -> SPut+putByteString = writeSized BS.length BB.byteString++putReplicate :: Int -> Word8 -> SPut+putReplicate n w =+    fixedSized n BB.lazyByteString $ LB.replicate (fromIntegral n) w++addPositionW :: Int -> State WState ()+addPositionW n = do+    (WState m cur) <- ST.get+    ST.put $ WState m (cur+n)++fixedSized :: Int -> (a -> Builder) -> a -> SPut+fixedSized n f a = do addPositionW n+                      return (f a)++writeSized :: (a -> Int) -> (a -> Builder) -> a -> SPut+writeSized n f a = do addPositionW (n a)+                      return (f a)++wsPop :: Domain -> State WState (Maybe Int)+wsPop dom = do+    doms <- ST.gets wsDomain+    return $ M.lookup dom doms++wsPush :: Domain -> Int -> State WState ()+wsPush dom pos = do+    (WState m cur) <- ST.get+    ST.put $ WState (M.insert dom pos m) cur++----------------------------------------------------------------++type SGet = StateT PState (T.Parser ByteString)++data PState = PState {+    psDomain :: IntMap Domain+  , psPosition :: Int+  , psInput :: ByteString+  , psAtTime  :: Int64+  }++----------------------------------------------------------------++getPosition :: SGet Int+getPosition = ST.gets psPosition++getInput :: SGet ByteString+getInput = ST.gets psInput++getAtTime :: SGet Int64+getAtTime = ST.gets psAtTime++addPosition :: Int -> SGet ()+addPosition n | n < 0 = failSGet "internal error: negative position increment"+              | otherwise = do+    PState dom pos inp t <- ST.get+    let !pos' = pos + n+    when (pos' > BS.length inp) $+        failSGet "malformed or truncated input"+    ST.put $ PState dom pos' inp t++push :: Int -> Domain -> SGet ()+push n d = do+    PState dom pos inp t <- ST.get+    ST.put $ PState (IM.insert n d dom) pos inp t++pop :: Int -> SGet (Maybe Domain)+pop n = ST.gets (IM.lookup n . psDomain)++----------------------------------------------------------------++get8 :: SGet Word8+get8  = ST.lift A.anyWord8 <* addPosition 1++get16 :: SGet Word16+get16 = ST.lift getWord16be <* addPosition 2+  where+    word8' = fromIntegral <$> A.anyWord8+    getWord16be = do+        a <- word8'+        b <- word8'+        return $ a * 0x100 + b++get32 :: SGet Word32+get32 = ST.lift getWord32be <* addPosition 4+  where+    word8' = fromIntegral <$> A.anyWord8+    getWord32be = do+        a <- word8'+        b <- word8'+        c <- word8'+        d <- word8'+        return $ a * 0x1000000 + b * 0x10000 + c * 0x100 + d++getInt8 :: SGet Int+getInt8 = fromIntegral <$> get8++getInt16 :: SGet Int+getInt16 = fromIntegral <$> get16++getInt32 :: SGet Int+getInt32 = fromIntegral <$> get32++----------------------------------------------------------------++overrun :: SGet a+overrun = failSGet "malformed or truncated input"++getNBytes :: Int -> SGet [Int]+getNBytes n | n < 0     = overrun+            | otherwise = toInts <$> getNByteString n+  where+    toInts = map fromIntegral . BS.unpack++getNoctets :: Int -> SGet [Word8]+getNoctets n | n < 0     = overrun+             | otherwise = BS.unpack <$> getNByteString n++skipNBytes :: Int -> SGet ()+skipNBytes n | n < 0     = overrun+             | otherwise = ST.lift (A.take n) >> addPosition n++getNByteString :: Int -> SGet ByteString+getNByteString n | n < 0     = overrun+                 | otherwise = ST.lift (A.take n) <* addPosition n++fitSGet :: Int -> SGet a -> SGet a+fitSGet len parser | len < 0   = overrun+                   | otherwise = do+    pos0 <- getPosition+    ret <- parser+    pos' <- getPosition+    if pos' == pos0 + len+    then return $! ret+    else if pos' > pos0 + len+    then failSGet "element size exceeds declared size"+    else failSGet "element shorter than declared size"++-- | Parse a list of elements that takes up exactly a given number of bytes.+-- In order to avoid infinite loops, if an element parser succeeds without+-- moving the buffer offset forward, an error will be returned.+--+sGetMany :: String -- ^ element type for error messages+         -> Int    -- ^ input buffer length+         -> SGet a -- ^ element parser+         -> SGet [a]+sGetMany elemname len parser | len < 0   = overrun+                             | otherwise = go len []+  where+    go n xs+        | n < 0     = failSGet $ elemname ++ " longer than declared size"+        | n == 0    = pure $ reverse xs+        | otherwise = do+            pos0 <- getPosition+            x    <- parser+            pos1 <- getPosition+            if pos1 <= pos0+            then failSGet $ "internal error: in-place success for " ++ elemname+            else go (n + pos0 - pos1) (x : xs)++----------------------------------------------------------------++-- | To get a broad range of correct RRSIG inception and expiration times+-- without over or underflow, we choose a time half way between midnight PDT+-- 2010-07-15 (the day the root zone was signed) and 2^32 seconds later on+-- 2146-08-21.  Since 'decode' and 'runSGet' are pure, we can't peek at the+-- current time while parsing.  Outside this date range the output is off by+-- some non-zero multiple 2\^32 seconds.+--+dnsTimeMid :: Int64+dnsTimeMid = 3426660848++initialState :: Int64 -> ByteString -> PState+initialState t inp = PState IM.empty 0 inp t++-- Construct our own error message, without the unhelpful AttoParsec+-- \"Failed reading: \" prefix.+--+failSGet :: String -> SGet a+failSGet msg = ST.lift (fail "" A.<?> msg)++runSGetAt :: Int64 -> SGet a -> ByteString -> Either DNSError (a, PState)+runSGetAt t parser inp =+    toResult $ A.parse (ST.runStateT parser $ initialState t inp) inp+  where+    toResult :: A.Result r -> Either DNSError r+    toResult (A.Done _ r)        = Right r+    toResult (A.Fail _ ctx msg)  = Left $ DecodeError $ head $ ctx ++ [msg]+    toResult (A.Partial _)       = Left $ DecodeError "incomplete input"++runSGet :: SGet a -> ByteString -> Either DNSError (a, PState)+runSGet = runSGetAt dnsTimeMid++runSGetWithLeftoversAt :: Int64      -- ^ Reference time for DNS clock arithmetic+                       -> SGet a     -- ^ Parser+                       -> ByteString -- ^ Encoded message+                       -> Either DNSError ((a, PState), ByteString)+runSGetWithLeftoversAt t parser inp =+    toResult $ A.parse (ST.runStateT parser $ initialState t inp) inp+  where+    toResult :: A.Result r -> Either DNSError (r, ByteString)+    toResult (A.Done     i r) = Right (r, i)+    toResult (A.Partial  f)   = toResult $ f BS.empty+    toResult (A.Fail _ ctx e) = Left $ DecodeError $ head $ ctx ++ [e]++runSGetWithLeftovers :: SGet a -> ByteString -> Either DNSError ((a, PState), ByteString)+runSGetWithLeftovers = runSGetWithLeftoversAt dnsTimeMid++runSPut :: SPut -> ByteString+runSPut = LBS.toStrict . BB.toLazyByteString . flip ST.evalState initialWState++----------------------------------------------------------------++-- | Decode a domain name in A-label form to a leading label and a tail with+-- the remaining labels, unescaping backlashed chars and decimal triples along+-- the way. Any  U-label conversion belongs at the layer above this code.+--+-- This function is pure, but is not total, it throws an error when presented+-- with malformed input+--+parseLabel :: Word8 -> ByteString -> (ByteString, ByteString)+parseLabel sep dom =+    if BS.any (== bslash) dom+    then toResult $ A.parse (labelParser sep mempty) dom+    else check $ safeTail <$> BS.break (== sep) dom+  where+    toResult (A.Partial c)  = toResult (c mempty)+    toResult (A.Done tl hd) = check (hd, tl)+    toResult _ = bottom+    safeTail bs | BS.null bs = mempty+                | otherwise = BS.tail bs+    check r@(hd, tl) | not (BS.null hd) || BS.null tl = r+                     | otherwise = bottom+    bottom = E.throw $ DecodeError $ "invalid domain: " ++ S8.unpack dom++labelParser :: Word8 -> ByteString -> A.Parser ByteString+labelParser sep acc = do+    acc' <- mappend acc <$> A.option mempty simple+    labelEnd sep acc' <|> (escaped >>= labelParser sep . BS.snoc acc')+  where+    simple = fst <$> A.match skipUnescaped+      where+        skipUnescaped = A.skipMany1 $ A.satisfy notSepOrBslash+        notSepOrBslash w = w /= sep && w /= bslash++    escaped = do+        A.skip (== bslash)+        either decodeDec pure =<< A.eitherP digit A.anyWord8+      where+        digit = fromIntegral <$> A.satisfyWith (\n -> n - zero) (<=9)+        decodeDec d =+            safeWord8 =<< trigraph d <$> digit <*> digit+          where+            trigraph :: Word -> Word -> Word -> Word+            trigraph x y z = 100 * x + 10 * y + z++            safeWord8 :: Word -> A.Parser Word8+            safeWord8 n | n > 255 = mzero+                        | otherwise = pure $ fromIntegral n++labelEnd :: Word8 -> ByteString -> A.Parser ByteString+labelEnd sep acc =+    A.satisfy (== sep) *> pure acc <|>+    A.endOfInput       *> pure acc++----------------------------------------------------------------++-- | Convert a wire-form label to presentation-form by escaping+-- the separator, special and non-printing characters.  For simple+-- labels with no bytes that require escaping we get back the input+-- bytestring asis with no copying or re-construction.+--+-- Note: the separator is required to be either \'.\' or \'\@\', but this+-- constraint is the caller's responsibility and is not checked here.+--+unparseLabel :: Word8 -> ByteString -> ByteString+unparseLabel sep label =+    if BS.all (isPlain sep) label+    then label+    else toResult $ A.parse (labelUnparser sep mempty) label+  where+    toResult (A.Partial c) = toResult (c mempty)+    toResult (A.Done _ r) = r+    toResult _ = E.throw UnknownDNSError -- can't happen++labelUnparser :: Word8 -> ByteString -> A.Parser ByteString+labelUnparser sep acc = do+    acc' <- mappend acc <$> A.option mempty asis+    A.endOfInput *> pure acc' <|> (esc >>= labelUnparser sep . mappend acc')+  where+    -- Non-printables are escaped as decimal trigraphs, while printable+    -- specials just get a backslash prefix.+    esc = do+        w <- A.anyWord8+        if w <= 32 || w >= 127+        then let (q100, r100) = w `divMod` 100+                 (q10, r10) = r100 `divMod` 10+              in pure $ BS.pack [ bslash, zero + q100, zero + q10, zero + r10 ]+        else pure $ BS.pack [ bslash, w ]++    -- Runs of plain bytes are recognized as a single chunk, which is then+    -- returned as-is.+    asis = fmap fst $ A.match $ A.skipMany1 $ A.satisfy $ isPlain sep++-- | In the presentation form of DNS labels, these characters are escaped by+-- prepending a backlash. (They have special meaning in zone files). Whitespace+-- and other non-printable or non-ascii characters are encoded via "\DDD"+-- decimal escapes. The separator character is also quoted in each label. Note+-- that '@' is quoted even when not the separator.+escSpecials :: ByteString+escSpecials = "\"$();@\\"++-- | Is the given byte the separator or one of the specials?+isSpecial :: Word8 -> Word8 -> Bool+isSpecial sep w = w == sep || BS.elemIndex w escSpecials /= Nothing++-- | Is the given byte a plain byte that reqires no escaping. The tests are+-- ordered to succeed or fail quickly in the most common cases. The test+-- ranges assume the expected numeric values of the named special characters.+-- Note: the separator is assumed to be either '.' or '@' and so not matched by+-- any of the first three fast-path 'True' cases.+isPlain :: Word8 -> Word8 -> Bool+isPlain sep w | w >= 127                 = False -- <DEL> + non-ASCII+              | w > bslash               = True  -- ']'..'_'..'a'..'z'..'~'+              | w >= zero && w < semi    = True  -- '0'..'9'..':'+              | w > atsign && w < bslash = True  -- 'A'..'Z'..'['+              | w <= 32                  = False -- non-printables+              | isSpecial sep w          = False -- one of the specials+              | otherwise                = True  -- plain punctuation++-- | Some numeric byte constants.+zero, semi, atsign, bslash :: Word8+zero = fromIntegral $ fromEnum '0'    -- 48+semi = fromIntegral $ fromEnum ';'    -- 59+atsign = fromIntegral $ fromEnum '@'  -- 64+bslash = fromIntegral $ fromEnum '\\' -- 92

@@ -0,0 +1,1618 @@+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE CPP #-}++module Network.DNS.Types.Internal where++import Control.Exception (Exception, IOException)+import qualified Data.ByteString as B+import qualified Data.ByteString.Base16 as B16+import qualified Data.ByteString.Base64 as B64+import qualified Data.ByteString.Char8 as BS+import Data.Char (intToDigit)+import qualified Data.Hourglass as H+import Data.IP (IP(..), IPv4, IPv6)+import qualified Data.Semigroup as Sem++import qualified Network.DNS.Base32Hex as B32+import Network.DNS.Imports++-- $setup+-- >>> import Network.DNS++----------------------------------------------------------------++-- | This type holds the /presentation form/ of fully-qualified DNS domain+-- names encoded as ASCII A-labels, with \'.\' separators between labels.+-- Non-printing characters are escaped as @\\DDD@ (a backslash, followed by+-- three decimal digits). The special characters: @ \", \$, (, ), ;, \@,@ and+-- @\\@ are escaped by prepending a backslash.  The trailing \'.\' is optional+-- on input, but is recommended, and is always added when decoding from+-- /wire form/.+--+-- The encoding of domain names to /wire form/, e.g. for transmission in a+-- query, requires the input encodings to be valid, otherwise a 'DecodeError'+-- may be thrown. Domain names received in wire form in DNS messages are+-- escaped to this presentation form as part of decoding the 'DNSMessage'.+--+-- This form is ASCII-only. Any conversion between A-label 'ByteString's,+-- and U-label 'Text' happens at whatever layer maps user input to DNS+-- names, or presents /friendly/ DNS names to the user.  Not all users+-- can read all scripts, and applications that default to U-label form+-- should ideally give the user a choice to see the A-label form.+-- Examples:+--+-- @+-- www.example.org.           -- Ordinary DNS name.+-- \_25.\_tcp.mx1.example.net.  -- TLSA RR initial labels have \_ prefixes.+-- \\001.exotic.example.       -- First label is Ctrl-A!+-- just\\.one\\.label.example.  -- First label is \"just.one.label\"+-- @+--+type Domain = ByteString++-- | Type for a mailbox encoded on the wire as a DNS name, but the first label+-- is conceptually the local part of an email address, and may contain internal+-- periods that are not label separators. Therefore, in mailboxes \@ is used as+-- the separator between the first and second labels, and any \'.\' characters+-- in the first label are not escaped.  The encoding is otherwise the same as+-- 'Domain' above. This is most commonly seen in the /mrname/ of @SOA@ records.+-- On input, if there is no unescaped \@ character in the 'Mailbox', it is+-- reparsed with \'.\' as the first label separator. Thus the traditional+-- format with all labels separated by dots is also accepted, but decoding from+-- wire form always uses \@ between the first label and the domain-part of the+-- address.  Examples:+--+-- @+-- hostmaster\@example.org.  -- First label is simply @hostmaster@+-- john.smith\@examle.com.   -- First label is @john.smith@+-- @+--+type Mailbox = ByteString++----------------------------------------------------------------++#if __GLASGOW_HASKELL__ >= 800+-- | Types for resource records.+newtype TYPE = TYPE {+    -- | From type to number.+    fromTYPE :: Word16+  } deriving (Eq, Ord)++-- https://www.iana.org/assignments/dns-parameters/dns-parameters.xhtml#dns-parameters-4++-- | IPv4 address+pattern A :: TYPE+pattern A          = TYPE   1+-- | An authoritative name serve+pattern NS :: TYPE+pattern NS         = TYPE   2+-- | The canonical name for an alias+pattern CNAME :: TYPE+pattern CNAME      = TYPE   5+-- | Marks the start of a zone of authority+pattern SOA :: TYPE+pattern SOA        = TYPE   6+-- | A null RR (EXPERIMENTAL)+pattern NULL :: TYPE+pattern NULL       = TYPE  10+-- | A domain name pointer+pattern PTR :: TYPE+pattern PTR        = TYPE  12+-- | Mail exchange+pattern MX :: TYPE+pattern MX         = TYPE  15+-- | Text strings+pattern TXT :: TYPE+pattern TXT        = TYPE  16+-- | IPv6 Address+pattern AAAA :: TYPE+pattern AAAA       = TYPE  28+-- | Server Selection (RFC2782)+pattern SRV :: TYPE+pattern SRV        = TYPE  33+-- | DNAME (RFC6672)+pattern DNAME :: TYPE+pattern DNAME      = TYPE  39 -- RFC 6672+-- | OPT (RFC6891)+pattern OPT :: TYPE+pattern OPT        = TYPE  41 -- RFC 6891+-- | Delegation Signer (RFC4034)+pattern DS :: TYPE+pattern DS         = TYPE  43 -- RFC 4034+-- | RRSIG (RFC4034)+pattern RRSIG :: TYPE+pattern RRSIG      = TYPE  46 -- RFC 4034+-- | NSEC (RFC4034)+pattern NSEC :: TYPE+pattern NSEC       = TYPE  47 -- RFC 4034+-- | DNSKEY (RFC4034)+pattern DNSKEY :: TYPE+pattern DNSKEY     = TYPE  48 -- RFC 4034+-- | NSEC3 (RFC5155)+pattern NSEC3 :: TYPE+pattern NSEC3      = TYPE  50 -- RFC 5155+-- | NSEC3PARAM (RFC5155)+pattern NSEC3PARAM :: TYPE+pattern NSEC3PARAM = TYPE  51 -- RFC 5155+-- | TLSA (RFC6698)+pattern TLSA :: TYPE+pattern TLSA       = TYPE  52 -- RFC 6698+-- | Child DS (RFC7344)+pattern CDS :: TYPE+pattern CDS        = TYPE  59 -- RFC 7344+-- | DNSKEY(s) the Child wants reflected in DS (RFC7344)+pattern CDNSKEY :: TYPE+pattern CDNSKEY    = TYPE  60 -- RFC 7344+-- | Child-To-Parent Synchronization (RFC7477)+pattern CSYNC :: TYPE+pattern CSYNC      = TYPE  62 -- RFC 7477+-- | Zone transfer (RFC5936)+pattern AXFR :: TYPE+pattern AXFR       = TYPE 252 -- RFC 5936+-- | A request for all records the server/cache has available+pattern ANY :: TYPE+pattern ANY        = TYPE 255+-- | Certification Authority Authorization (RFC6844)+pattern CAA :: TYPE+pattern CAA        = TYPE 257 -- RFC 6844++-- | From number to type.+toTYPE :: Word16 -> TYPE+toTYPE = TYPE+#else+-- | Types for resource records.+data TYPE = A          -- ^ IPv4 address+          | NS         -- ^ An authoritative name serve+          | CNAME      -- ^ The canonical name for an alias+          | SOA        -- ^ Marks the start of a zone of authority+          | NULL       -- ^ A null RR (EXPERIMENTAL)+          | PTR        -- ^ A domain name pointer+          | MX         -- ^ Mail exchange+          | TXT        -- ^ Text strings+          | AAAA       -- ^ IPv6 Address+          | SRV        -- ^ Server Selection (RFC2782)+          | DNAME      -- ^ DNAME (RFC6672)+          | OPT        -- ^ OPT (RFC6891)+          | DS         -- ^ Delegation Signer (RFC4034)+          | RRSIG      -- ^ RRSIG (RFC4034)+          | NSEC       -- ^ NSEC (RFC4034)+          | DNSKEY     -- ^ DNSKEY (RFC4034)+          | NSEC3      -- ^ NSEC3 (RFC5155)+          | NSEC3PARAM -- ^ NSEC3PARAM (RFC5155)+          | TLSA       -- ^ TLSA (RFC6698)+          | CDS        -- ^ Child DS (RFC7344)+          | CDNSKEY    -- ^ DNSKEY(s) the Child wants reflected in DS (RFC7344)+          | CSYNC      -- ^ Child-To-Parent Synchronization (RFC7477)+          | AXFR       -- ^ Zone transfer (RFC5936)+          | ANY        -- ^ A request for all records the server/cache+                       --   has available+          | CAA        -- ^ Certification Authority Authorization (RFC6844)+          | UnknownTYPE Word16  -- ^ Unknown type+          deriving (Eq, Ord, Read)++-- | From type to number.+fromTYPE :: TYPE -> Word16+fromTYPE A          =  1+fromTYPE NS         =  2+fromTYPE CNAME      =  5+fromTYPE SOA        =  6+fromTYPE NULL       = 10+fromTYPE PTR        = 12+fromTYPE MX         = 15+fromTYPE TXT        = 16+fromTYPE AAAA       = 28+fromTYPE SRV        = 33+fromTYPE DNAME      = 39+fromTYPE OPT        = 41+fromTYPE DS         = 43+fromTYPE RRSIG      = 46+fromTYPE NSEC       = 47+fromTYPE DNSKEY     = 48+fromTYPE NSEC3      = 50+fromTYPE NSEC3PARAM = 51+fromTYPE TLSA       = 52+fromTYPE CDS        = 59+fromTYPE CDNSKEY    = 60+fromTYPE CSYNC      = 62+fromTYPE AXFR       = 252+fromTYPE ANY        = 255+fromTYPE CAA        = 257+fromTYPE (UnknownTYPE x) = x++-- | From number to type.+toTYPE :: Word16 -> TYPE+toTYPE  1 = A+toTYPE  2 = NS+toTYPE  5 = CNAME+toTYPE  6 = SOA+toTYPE 10 = NULL+toTYPE 12 = PTR+toTYPE 15 = MX+toTYPE 16 = TXT+toTYPE 28 = AAAA+toTYPE 33 = SRV+toTYPE 39 = DNAME+toTYPE 41 = OPT+toTYPE 43 = DS+toTYPE 46 = RRSIG+toTYPE 47 = NSEC+toTYPE 48 = DNSKEY+toTYPE 50 = NSEC3+toTYPE 51 = NSEC3PARAM+toTYPE 52 = TLSA+toTYPE 59 = CDS+toTYPE 60 = CDNSKEY+toTYPE 62 = CSYNC+toTYPE 252 = AXFR+toTYPE 255 = ANY+toTYPE 257 = CAA+toTYPE x   = UnknownTYPE x+#endif++instance Show TYPE where+    show A          = "A"+    show NS         = "NS"+    show CNAME      = "CNAME"+    show SOA        = "SOA"+    show NULL       = "NULL"+    show PTR        = "PTR"+    show MX         = "MX"+    show TXT        = "TXT"+    show AAAA       = "AAAA"+    show SRV        = "SRV"+    show DNAME      = "DNAME"+    show OPT        = "OPT"+    show DS         = "DS"+    show RRSIG      = "RRSIG"+    show NSEC       = "NSEC"+    show DNSKEY     = "DNSKEY"+    show NSEC3      = "NSEC3"+    show NSEC3PARAM = "NSEC3PARAM"+    show TLSA       = "TLSA"+    show CDS        = "CDS"+    show CDNSKEY    = "CDNSKEY"+    show CSYNC      = "CSYNC"+    show AXFR       = "AXFR"+    show ANY        = "ANY"+    show CAA        = "CAA"+    show x          = "TYPE" ++ show (fromTYPE x)++----------------------------------------------------------------++-- | An enumeration of all possible DNS errors that can occur.+data DNSError =+    -- | The sequence number of the answer doesn't match our query. This+    --   could indicate foul play.+    SequenceNumberMismatch+    -- | The question section of the response doesn't match our query. This+    --   could indicate foul play.+  | QuestionMismatch+    -- | A zone tranfer, i.e., a request of type AXFR, was attempted with the+    -- "lookup" interface. Zone transfer is different enough from "normal"+    -- requests that it requires a different interface.+  | InvalidAXFRLookup+    -- | The number of retries for the request was exceeded.+  | RetryLimitExceeded+    -- | TCP fallback request timed out.+  | TimeoutExpired+    -- | The answer has the correct sequence number, but returned an+    --   unexpected RDATA format.+  | UnexpectedRDATA+    -- | The domain for query is illegal.+  | IllegalDomain+    -- | The name server was unable to interpret the query.+  | FormatError+    -- | The name server was unable to process this query due to a+    --   problem with the name server.+  | ServerFailure+    -- | This code signifies that the domain name referenced in the+    --   query does not exist.+  | NameError+    -- | The name server does not support the requested kind of query.+  | NotImplemented+    -- | The name server refuses to perform the specified operation for+    --   policy reasons.  For example, a name+    --   server may not wish to provide the+    --   information to the particular requester,+    --   or a name server may not wish to perform+    --   a particular operation (e.g., zone transfer) for particular data.+  | OperationRefused+    -- | The server does not support the OPT RR version or content+  | BadOptRecord+    -- | Configuration is wrong.+  | BadConfiguration+    -- | Network failure.+  | NetworkFailure IOException+    -- | Error is unknown+  | DecodeError String+  | UnknownDNSError+  deriving (Eq, Show, Typeable)++instance Exception DNSError+++-- | Data type representing the optional EDNS pseudo-header of a 'DNSMessage'+-- When a single well-formed @OPT@ 'ResourceRecord' was present in the+-- message's additional section, it is decoded to an 'EDNS' record and and+-- stored in the message 'ednsHeader' field.  The corresponding @OPT RR@ is+-- then removed from the additional section.+--+-- When the constructor is 'NoEDNS', no @EDNS OPT@ record was present in the+-- message additional section.  When 'InvalidEDNS', the message holds either a+-- malformed OPT record or more than one OPT record, which can still be found+-- in (have not been removed from) the message additional section.+--+-- The EDNS OPT record augments the message error status with an 8-bit field+-- that forms 12-bit extended RCODE when combined with the 4-bit RCODE from the+-- unextended DNS header.  In EDNS messages it is essential to not use just the+-- bare 4-bit 'RCODE' from the original DNS header.  Therefore, in order to+-- avoid potential misinterpretation of the response 'RCODE', when the OPT+-- record is decoded, the upper eight bits of the error status are+-- automatically combined with the 'rcode' of the message header, so that there+-- is only one place in which to find the full 12-bit result.  Therefore, the+-- decoded 'EDNS' pseudo-header, does not hold any error status bits.+--+-- The reverse process occurs when encoding messages.  The low four bits of the+-- message header 'rcode' are encoded into the wire-form DNS header, while the+-- upper eight bits are encoded as part of the OPT record.  In DNS responses with+-- an 'rcode' larger than 15, EDNS extensions SHOULD be enabled by providing a+-- value for 'ednsHeader' with a constructor of 'EDNSheader'.  If EDNS is not+-- enabled in such a message, in order to avoid truncation of 'RCODE' values+-- that don't fit in the non-extended DNS header, the encoded wire-form 'RCODE'+-- is set to 'FormatErr'.+--+-- When encoding messages for transmission, the 'ednsHeader' is used to+-- generate the additional OPT record.  Do not add explicit @OPT@ records+-- to the aditional section, configure EDNS via the 'EDNSheader' instead.+--+-- >>> let getopts eh = mapEDNS eh ednsOptions []+-- >>> let optsin     = [OD_ClientSubnet 24 0 $ read "192.0.2.1"]+-- >>> let masked     = [OD_ClientSubnet 24 0 $ read "192.0.2.0"]+-- >>> let message    = makeEmptyQuery $ ednsSetOptions $ ODataSet optsin+-- >>> let optsout    = getopts. ednsHeader <$> (decode $ encode message)+-- >>> optsout       == Right masked+-- True+--+data EDNSheader = EDNSheader EDNS -- ^ A valid EDNS message+                | NoEDNS          -- ^ A valid non-EDNS message+                | InvalidEDNS     -- ^ Multiple or bad additional @OPT@ RRs+    deriving (Eq, Show)+++-- | Return the second argument for EDNS messages, otherwise the third.+ifEDNS :: EDNSheader -- ^ EDNS pseudo-header+       -> a          -- ^ Value to return for EDNS messages+       -> a          -- ^ Value to return for non-EDNS messages+       -> a+ifEDNS (EDNSheader _) a _ = a+ifEDNS             _  _ b = b+{-# INLINE ifEDNS #-}+++-- | Return the output of a function applied to the EDNS pseudo-header if EDNS+--   is enabled, otherwise return a default value.+mapEDNS :: EDNSheader  -- ^ EDNS pseudo-header+        -> (EDNS -> a) -- ^ Function to apply to 'EDNS' value+        -> a           -- ^ Default result for non-EDNS messages+        -> a+mapEDNS (EDNSheader eh) f _ = f eh+mapEDNS               _ _ a = a+{-# INLINE mapEDNS #-}+++-- | DNS message format for queries and replies.+--+data DNSMessage = DNSMessage {+    header     :: !DNSHeader        -- ^ Header with extended 'RCODE'+  , ednsHeader :: EDNSheader        -- ^ EDNS pseudo-header+  , question   :: [Question]        -- ^ The question for the name server+  , answer     :: Answers           -- ^ RRs answering the question+  , authority  :: AuthorityRecords  -- ^ RRs pointing toward an authority+  , additional :: AdditionalRecords -- ^ RRs holding additional information+  } deriving (Eq, Show)++-- | An identifier assigned by the program that+--   generates any kind of query.+type Identifier = Word16++-- | Raw data format for the header of DNS Query and Response.+data DNSHeader = DNSHeader {+    identifier :: !Identifier -- ^ Query or reply identifier.+  , flags      :: !DNSFlags   -- ^ Flags, OPCODE, and RCODE+  } deriving (Eq, Show)++-- | Raw data format for the flags of DNS Query and Response.+data DNSFlags = DNSFlags {+    qOrR         :: !QorR  -- ^ Query or response.+  , opcode       :: !OPCODE -- ^ Kind of query.+  , authAnswer   :: !Bool  -- ^ AA (Authoritative Answer) bit - this bit is valid in responses,+                           -- and specifies that the responding name server is an+                           -- authority for the domain name in question section.+  , trunCation   :: !Bool  -- ^ TC (Truncated Response) bit - specifies that this message was truncated+                           -- due to length greater than that permitted on the+                           -- transmission channel.+  , recDesired   :: !Bool  -- ^ RD (Recursion Desired) bit - this bit may be set in a query and+                           -- is copied into the response.  If RD is set, it directs+                           -- the name server to pursue the query recursively.+                           -- Recursive query support is optional.+  , recAvailable :: !Bool  -- ^ RA (Recursion Available) bit - this be is set or cleared in a+                           -- response, and denotes whether recursive query support is+                           -- available in the name server.++  , rcode        :: !RCODE -- ^ The full 12-bit extended RCODE when EDNS is in use.+                           -- Should always be zero in well-formed requests.+                           -- When decoding replies, the high eight bits from+                           -- any EDNS response are combined with the 4-bit+                           -- RCODE from the DNS header.  When encoding+                           -- replies, if no EDNS OPT record is provided, RCODE+                           -- values > 15 are mapped to 'FormatErr'.+  , authenData   :: !Bool  -- ^ AD (Authenticated Data) bit - (RFC4035, Section 3.2.3).+  , chkDisable   :: !Bool  -- ^ CD (Checking Disabled) bit - (RFC4035, Section 3.2.2).+  } deriving (Eq, Show)+++-- | Default 'DNSFlags' record suitable for making recursive queries.  By default+-- the RD bit is set, and the AD and CD bits are cleared.+--+defaultDNSFlags :: DNSFlags+defaultDNSFlags = DNSFlags+         { qOrR         = QR_Query+         , opcode       = OP_STD+         , authAnswer   = False+         , trunCation   = False+         , recDesired   = True+         , recAvailable = False+         , authenData   = False+         , chkDisable   = False+         , rcode        = NoErr+         }++----------------------------------------------------------------++-- | Boolean flag operations. These form a 'Monoid'.  When combined via+-- `mappend`, as with function composition, the left-most value has+-- the last say.+--+-- >>> mempty :: FlagOp+-- FlagKeep+-- >>> FlagSet <> mempty+-- FlagSet+-- >>> FlagClear <> FlagSet <> mempty+-- FlagClear+-- >>> FlagReset <> FlagClear <> FlagSet <> mempty+-- FlagReset+data FlagOp = FlagSet   -- ^ Set the flag to 1+            | FlagClear -- ^ Clear the flag to 0+            | FlagReset -- ^ Reset the flag to its default value+            | FlagKeep  -- ^ Leave the flag unchanged+            deriving (Eq, Show)++-- $+-- Test associativity of the semigroup operation:+--+-- >>> let ops = [FlagSet, FlagClear, FlagReset, FlagKeep]+-- >>> foldl (&&) True [(a<>b)<>c == a<>(b<>c) | a <- ops, b <- ops, c <- ops]+-- True+--+instance Sem.Semigroup FlagOp where+    FlagKeep <> op = op+    op       <> _  = op++instance Monoid FlagOp where+    mempty = FlagKeep+#if !(MIN_VERSION_base(4,11,0))+    -- this is redundant starting with base-4.11 / GHC 8.4+    -- if you want to avoid CPP, you can define `mappend = (<>)` unconditionally+    mappend = (Sem.<>)+#endif++-- | We don't show options left at their default value.+--+_skipDefault :: String+_skipDefault = ""++-- | Show non-default flag values+--+_showFlag :: String -> FlagOp -> String+_showFlag nm FlagSet   = nm ++ ":1"+_showFlag nm FlagClear = nm ++ ":0"+_showFlag _  FlagReset = _skipDefault+_showFlag _  FlagKeep  = _skipDefault++-- | Combine a list of options for display, skipping default values+--+_showOpts :: [String] -> String+_showOpts os = intercalate "," $ filter (/= _skipDefault) os++----------------------------------------------------------------++-- | Control over query-related DNS header flags. As with function composition,+-- the left-most value has the last say.+--+data HeaderControls = HeaderControls+    { rdBit :: !FlagOp+    , adBit :: !FlagOp+    , cdBit :: !FlagOp+    }+    deriving (Eq)++instance Sem.Semigroup HeaderControls where+    (HeaderControls rd1 ad1 cd1) <> (HeaderControls rd2 ad2 cd2) =+        HeaderControls (rd1 <> rd2) (ad1 <> ad2) (cd1 <> cd2)++instance Monoid HeaderControls where+    mempty = HeaderControls FlagKeep FlagKeep FlagKeep+#if !(MIN_VERSION_base(4,11,0))+    -- this is redundant starting with base-4.11 / GHC 8.4+    -- if you want to avoid CPP, you can define `mappend = (<>)` unconditionally+    mappend = (Sem.<>)+#endif++instance Show HeaderControls where+    show (HeaderControls rd ad cd) =+        _showOpts+             [ _showFlag "rd" rd+             , _showFlag "ad" ad+             , _showFlag "cd" cd ]++----------------------------------------------------------------++-- | The default EDNS Option list is empty.  We define two operations, one to+-- prepend a list of options, and another to set a specific list of options.+--+data ODataOp = ODataAdd [OData] -- ^ Add the specified options to the list.+             | ODataSet [OData] -- ^ Set the option list as specified.+             deriving (Eq)++-- | Since any given option code can appear at most once in the list, we+-- de-duplicate by the OPTION CODE when combining lists.+--+_odataDedup :: ODataOp -> [OData]+_odataDedup op =+    nubBy ((==) `on` _odataToOptCode) $+        case op of+            ODataAdd os -> os+            ODataSet os -> os++-- $+-- Test associativity of the OData semigroup operation:+--+-- >>> let ip1 = IPv4 $ read "127.0.0.0"+-- >>> let ip2 = IPv4 $ read "192.0.2.0"+-- >>> let cs1 = OD_ClientSubnet 8 0 ip1+-- >>> let cs2 = OD_ClientSubnet 24 0 ip2+-- >>> let cs3 = OD_ECSgeneric 0 24 0 "foo"+-- >>> let dau1 = OD_DAU [3,5,7,8]+-- >>> let dau2 = OD_DAU [13,14]+-- >>> let dhu1 = OD_DHU [1,2]+-- >>> let dhu2 = OD_DHU [3,4]+-- >>> let nsid = OD_NSID ""+-- >>> let ops1 = [ODataAdd [dau1, dau2, cs1], ODataAdd [dau2, cs2, dhu1]]+-- >>> let ops2 = [ODataSet [], ODataSet [dhu2, cs3], ODataSet [nsid]]+-- >>> let ops = ops1 ++ ops2+-- >>> foldl (&&) True [(a<>b)<>c == a<>(b<>c) | a <- ops, b <- ops, c <- ops]+-- True++instance Sem.Semigroup ODataOp where+    ODataAdd as <> ODataAdd bs = ODataAdd $ as ++ bs+    ODataAdd as <> ODataSet bs = ODataSet $ as ++ bs+    ODataSet as <> _ = ODataSet as++instance Monoid ODataOp where+    mempty = ODataAdd []+#if !(MIN_VERSION_base(4,11,0))+    -- this is redundant starting with base-4.11 / GHC 8.4+    -- if you want to avoid CPP, you can define `mappend = (<>)` unconditionally+    mappend = (Sem.<>)+#endif++----------------------------------------------------------------++-- | EDNS query controls.  When EDNS is disabled via @ednsEnabled FlagClear@,+-- all the other EDNS-related overrides have no effect.+--+-- >>> ednsHeader $ makeEmptyQuery $ ednsEnabled FlagClear <> doFlag FlagSet+-- NoEDNS+data EdnsControls = EdnsControls+    { extEn :: !FlagOp         -- ^ Enabled+    , extVn :: !(Maybe Word8)  -- ^ Version+    , extSz :: !(Maybe Word16) -- ^ UDP Size+    , extDO :: !FlagOp         -- ^ DNSSEC OK (DO) bit+    , extOd :: !ODataOp        -- ^ EDNS option list tweaks+    }+    deriving (Eq)++-- | Apply all the query flag overrides to 'defaultDNSFlags', returning the++instance Sem.Semigroup EdnsControls where+    (EdnsControls en1 vn1 sz1 do1 od1) <> (EdnsControls en2 vn2 sz2 do2 od2) =+        EdnsControls (en1 <> en2) (vn1 <|> vn2) (sz1 <|> sz2)+                    (do1 <> do2) (od1 <> od2)++instance Monoid EdnsControls where+    mempty = EdnsControls FlagKeep Nothing Nothing FlagKeep mempty+#if !(MIN_VERSION_base(4,11,0))+    -- this is redundant starting with base-4.11 / GHC 8.4+    -- if you want to avoid CPP, you can define `mappend = (<>)` unconditionally+    mappend = (Sem.<>)+#endif++instance Show EdnsControls where+    show (EdnsControls en vn sz d0 od) =+        _showOpts+            [ _showFlag "edns.enabled" en+            , _showWord "edns.version" vn+            , _showWord "edns.udpsize" sz+            , _showFlag "edns.dobit"   d0+            , _showOdOp "edns.options" $ map (show. _odataToOptCode)+                                       $ _odataDedup od ]+      where+        _showWord :: Show a => String -> Maybe a -> String+        _showWord nm w = maybe _skipDefault (\s -> nm ++ ":" ++ show s) w++        _showOdOp :: String -> [String] -> String+        _showOdOp nm os = case os of+            [] -> ""+            _  -> nm ++ ":[" ++ intercalate "," os ++ "]"++----------------------------------------------------------------++-- | Query controls form a 'Monoid', as with function composition, the+-- left-most value has the last say.  The 'Monoid' is generated by two sets of+-- combinators, one that controls query-related DNS header flags, and another+-- that controls EDNS features.+--+-- The header flag controls are: 'rdFlag', 'adFlag' and 'cdFlag'.+--+-- The EDNS feature controls are: 'doFlag', 'ednsEnabled', 'ednsSetVersion',+-- 'ednsSetUdpSize' and 'ednsSetOptions'.  When EDNS is disabled, all the other+-- EDNS-related controls have no effect.+--+-- __Example:__ Disable DNSSEC checking on the server, and request signatures and+-- NSEC records, perhaps for your own independent validation.  The UDP buffer+-- size is set large, for use with a local loopback nameserver on the same host.+--+-- >>> :{+-- mconcat [ adFlag FlagClear+--         , cdFlag FlagSet+--         , doFlag FlagSet+--         , ednsSetUdpSize (Just 8192) -- IPv4 loopback server?+--         ]+-- :}+-- ad:0,cd:1,edns.udpsize:8192,edns.dobit:1+--+-- __Example:__ Use EDNS version 1 (yet to be specified), request nameserver+-- ids from the server, and indicate a client subnet of "192.0.2.1/24".+--+-- >>> :set -XOverloadedStrings+-- >>> let emptyNSID = ""+-- >>> let mask = 24+-- >>> let ipaddr = read "192.0.2.1"+-- >>> :{+-- mconcat [ ednsSetVersion (Just 1)+--         , ednsSetOptions (ODataAdd [OD_NSID emptyNSID])+--         , ednsSetOptions (ODataAdd [OD_ClientSubnet mask 0 ipaddr])+--         ]+-- :}+-- edns.version:1,edns.options:[NSID,ClientSubnet]++data QueryControls = QueryControls+    { qctlHeader :: !HeaderControls+    , qctlEdns   :: !EdnsControls+    }+    deriving (Eq)++instance Sem.Semigroup QueryControls where+    (QueryControls fl1 ex1) <> (QueryControls fl2 ex2) =+        QueryControls (fl1 <> fl2) (ex1 <> ex2)++instance Monoid QueryControls where+    mempty = QueryControls mempty mempty+#if !(MIN_VERSION_base(4,11,0))+    -- this is redundant starting with base-4.11 / GHC 8.4+    -- if you want to avoid CPP, you can define `mappend = (<>)` unconditionally+    mappend = (Sem.<>)+#endif++instance Show QueryControls where+    show (QueryControls fl ex) = _showOpts [ show fl, show ex ]++----------------------------------------------------------------++-- | Generator of 'QueryControls' that adjusts the RD bit.+--+-- >>> rdFlag FlagClear+-- rd:0+rdFlag :: FlagOp -> QueryControls+rdFlag rd = mempty { qctlHeader = mempty { rdBit = rd } }++-- | Generator of 'QueryControls' that adjusts the AD bit.+--+-- >>> adFlag FlagSet+-- ad:1+adFlag :: FlagOp -> QueryControls+adFlag ad = mempty { qctlHeader = mempty { adBit = ad } }++-- | Generator of 'QueryControls' that adjusts the CD bit.+--+-- >>> cdFlag FlagSet+-- cd:1+cdFlag :: FlagOp -> QueryControls+cdFlag cd = mempty { qctlHeader = mempty { cdBit = cd } }++-- | Generator of 'QueryControls' that enables or disables EDNS support.+--   When EDNS is disabled, the rest of the 'EDNS' controls are ignored.+--+-- >>> ednsHeader $ makeEmptyQuery $ ednsEnabled FlagClear <> doFlag FlagSet+-- NoEDNS+ednsEnabled :: FlagOp -> QueryControls+ednsEnabled en = mempty { qctlEdns = mempty { extEn = en } }++-- | Generator of 'QueryControls' that adjusts the 'EDNS' version.+-- A value of 'Nothing' makes no changes, while 'Just' @v@ sets+-- the EDNS version to @v@.+--+-- >>> ednsSetVersion (Just 1)+-- edns.version:1+ednsSetVersion :: Maybe Word8 -> QueryControls+ednsSetVersion vn = mempty { qctlEdns = mempty { extVn = vn } }++-- | Generator of 'QueryControls' that adjusts the 'EDNS' UDP buffer size.+-- A value of 'Nothing' makes no changes, while 'Just' @n@ sets the EDNS UDP+-- buffer size to @n@.+--+-- >>> ednsSetUdpSize (Just 2048)+-- edns.udpsize:2048+ednsSetUdpSize :: Maybe Word16 -> QueryControls+ednsSetUdpSize sz = mempty { qctlEdns = mempty { extSz = sz } }++-- | Generator of 'QueryControls' that adjusts the 'EDNS' DnssecOk (DO) bit.+--+-- >>> doFlag FlagSet+-- edns.dobit:1+doFlag :: FlagOp -> QueryControls+doFlag d0 = mempty { qctlEdns = mempty { extDO = d0 } }++-- | Generator of 'QueryControls' that adjusts the list of 'EDNS' options.+--+-- >>> :set -XOverloadedStrings+-- >>> ednsSetOptions (ODataAdd [OD_NSID ""])+-- edns.options:[NSID]+ednsSetOptions :: ODataOp -> QueryControls+ednsSetOptions od = mempty { qctlEdns = mempty { extOd = od } }++----------------------------------------------------------------++-- | Query or response.+data QorR = QR_Query    -- ^ Query.+          | QR_Response -- ^ Response.+          deriving (Eq, Show, Enum, Bounded)++-- | Kind of query.+data OPCODE+  = OP_STD -- ^ A standard query.+  | OP_INV -- ^ An inverse query (inverse queries are deprecated).+  | OP_SSR -- ^ A server status request.+  | OP_NOTIFY -- ^ A zone change notification (RFC1996)+  | OP_UPDATE -- ^ An update request (RFC2136)+  deriving (Eq, Show, Enum, Bounded)++-- | Convert a 16-bit DNS OPCODE number to its internal representation+--+toOPCODE :: Word16 -> Maybe OPCODE+toOPCODE i = case i of+  0 -> Just OP_STD+  1 -> Just OP_INV+  2 -> Just OP_SSR+  -- OPCODE 3 is unassigned+  4 -> Just OP_NOTIFY+  5 -> Just OP_UPDATE+  _ -> Nothing++-- | Convert the internal representation of a DNS OPCODE to its 16-bit numeric+-- value.+--+fromOPCODE :: OPCODE -> Word16+fromOPCODE OP_STD    = 0+fromOPCODE OP_INV    = 1+fromOPCODE OP_SSR    = 2+fromOPCODE OP_NOTIFY = 4+fromOPCODE OP_UPDATE = 5++----------------------------------------------------------------++#if __GLASGOW_HASKELL__ >= 800+-- | EDNS extended 12-bit response code.  Non-EDNS messages use only the low 4+-- bits.  With EDNS this stores the combined error code from the DNS header and+-- and the EDNS psuedo-header. See 'EDNSheader' for more detail.+newtype RCODE = RCODE {+    -- | Convert an 'RCODE' to its numeric value.+    fromRCODE :: Word16+  } deriving (Eq)++-- | Provide an Enum instance for backwards compatibility+instance Enum RCODE where+    fromEnum = fromIntegral . fromRCODE+    toEnum = RCODE . fromIntegral++-- | No error condition.+pattern NoErr     :: RCODE+pattern NoErr      = RCODE  0+-- | Format error - The name server was+--   unable to interpret the query.+pattern FormatErr :: RCODE+pattern FormatErr  = RCODE  1+-- | Server failure - The name server was+--   unable to process this query due to a+--   problem with the name server.+pattern ServFail  :: RCODE+pattern ServFail   = RCODE  2+-- | Name Error - Meaningful only for+--   responses from an authoritative name+--   server, this code signifies that the+--   domain name referenced in the query does+--   not exist.+pattern NameErr   :: RCODE+pattern NameErr    = RCODE  3+-- | Not Implemented - The name server does+--   not support the requested kind of query.+pattern NotImpl   :: RCODE+pattern NotImpl    = RCODE  4+-- | Refused - The name server refuses to+--   perform the specified operation for+--   policy reasons.  For example, a name+--   server may not wish to provide the+--   information to the particular requester,+--   or a name server may not wish to perform+--   a particular operation (e.g., zone+--   transfer) for particular data.+pattern Refused   :: RCODE+pattern Refused    = RCODE  5+-- | YXDomain - Dynamic update response, a pre-requisite domain that should not+-- exist, does exist.+pattern YXDomain :: RCODE+pattern YXDomain  = RCODE 6+-- | YXRRSet - Dynamic update response, a pre-requisite RRSet that should not+-- exist, does exist.+pattern YXRRSet  :: RCODE+pattern YXRRSet   = RCODE 7+-- | NXRRSet - Dynamic update response, a pre-requisite RRSet that should+-- exist, does not exist.+pattern NXRRSet  :: RCODE+pattern NXRRSet   = RCODE 8+-- | NotAuth - Dynamic update response, the server is not authoritative for the+-- zone named in the Zone Section.+pattern NotAuth  :: RCODE+pattern NotAuth   = RCODE 9+-- | NotZone - Dynamic update response, a name used in the Prerequisite or+-- Update Section is not within the zone denoted by the Zone Section.+pattern NotZone  :: RCODE+pattern NotZone   = RCODE 10+-- | Bad OPT Version (BADVERS, RFC 6891).+pattern BadVers   :: RCODE+pattern BadVers    = RCODE 16+-- | Key not recognized [RFC2845]+pattern BadKey    :: RCODE+pattern BadKey     = RCODE 17+-- | Signature out of time window [RFC2845]+pattern BadTime   :: RCODE+pattern BadTime    = RCODE 18+-- | Bad TKEY Mode [RFC2930]+pattern BadMode   :: RCODE+pattern BadMode    = RCODE 19+-- | Duplicate key name [RFC2930]+pattern BadName   :: RCODE+pattern BadName    = RCODE 20+-- | Algorithm not supported [RFC2930]+pattern BadAlg    :: RCODE+pattern BadAlg     = RCODE 21+-- | Bad Truncation [RFC4635]+pattern BadTrunc  :: RCODE+pattern BadTrunc   = RCODE 22+-- | Bad/missing Server Cookie [RFC7873]+pattern BadCookie :: RCODE+pattern BadCookie  = RCODE 23+-- | Malformed (peer) EDNS message, no RCODE available.  This is not an RCODE+-- that can be sent by a peer.  It lies outside the 12-bit range expressible+-- via EDNS.  The low 12-bits are chosen to coincide with 'FormatErr'.  When+-- an EDNS message is malformed, and we're unable to extract the extended RCODE,+-- the header 'rcode' is set to 'BadRCODE'.+pattern BadRCODE  :: RCODE+pattern BadRCODE   = RCODE 0x1001++-- | Use https://tools.ietf.org/html/rfc2929#section-2.3 names for DNS RCODEs+instance Show RCODE where+    show NoErr     = "NoError"+    show FormatErr = "FormErr"+    show ServFail  = "ServFail"+    show NameErr   = "NXDomain"+    show NotImpl   = "NotImp"+    show Refused   = "Refused"+    show YXDomain  = "YXDomain"+    show YXRRSet   = "YXRRSet"+    show NotAuth   = "NotAuth"+    show NotZone   = "NotZone"+    show BadVers   = "BadVers"+    show BadKey    = "BadKey"+    show BadTime   = "BadTime"+    show BadMode   = "BadMode"+    show BadName   = "BadName"+    show BadAlg    = "BadAlg"+    show BadTrunc  = "BadTrunc"+    show BadCookie = "BadCookie"+    show x         = "RCODE " ++ (show $ fromRCODE x)++-- | Convert a numeric value to a corresponding 'RCODE'.  The behaviour is+-- undefined for values outside the range @[0 .. 0xFFF]@ since the EDNS+-- extended RCODE is a 12-bit value.  Values in the range @[0xF01 .. 0xFFF]@+-- are reserved for private use.+toRCODE :: Word16 -> RCODE+toRCODE = RCODE+#else+-- | EDNS extended 12-bit response code.  Non-EDNS messages use only the low 4+-- bits.  With EDNS this stores the combined error code from the DNS header and+-- and the EDNS psuedo-header. See 'EDNSheader' for more detail.+data RCODE+  = NoErr     -- ^ No error condition.+  | FormatErr -- ^ Format error - The name server was+              --   unable to interpret the query.+  | ServFail  -- ^ Server failure - The name server was+              --   unable to process this query due to a+              --   problem with the name server.+  | NameErr   -- ^ Name Error - Meaningful only for+              --   responses from an authoritative name+              --   server, this code signifies that the+              --   domain name referenced in the query does+              --   not exist.+  | NotImpl   -- ^ Not Implemented - The name server does+              --   not support the requested kind of query.+  | Refused   -- ^ Refused - The name server refuses to+              --   perform the specified operation for+              --   policy reasons.  For example, a name+              --   server may not wish to provide the+              --   information to the particular requester,+              --   or a name server may not wish to perform+              --   a particular operation (e.g., zone+              --   transfer) for particular data.+  | YXDomain  -- ^ Dynamic update response, a pre-requisite+              --   domain that should not exist, does exist.+  | YXRRSet   -- ^ Dynamic update response, a pre-requisite+              --   RRSet that should not exist, does exist.+  | NXRRSet   -- ^ Dynamic update response, a pre-requisite+              --   RRSet that should exist, does not exist.+  | NotAuth   -- ^ Dynamic update response, the server is not+              --   authoritative for the zone named in the Zone Section.+  | NotZone   -- ^ Dynamic update response, a name used in the+              --   Prerequisite or Update Section is not within the zone+              --   denoted by the Zone Section.+  | BadVers   -- ^ Bad OPT Version (RFC 6891)+  | BadKey    -- ^ Key not recognized [RFC2845]+  | BadTime   -- ^ Signature out of time window [RFC2845]+  | BadMode   -- ^ Bad TKEY Mode [RFC2930]+  | BadName   -- ^ Duplicate key name [RFC2930]+  | BadAlg    -- ^ Algorithm not supported [RFC2930]+  | BadTrunc  -- ^ Bad Truncation [RFC4635]+  | BadCookie -- ^ Bad/missing Server Cookie [RFC7873]+  | BadRCODE  -- ^ Malformed (peer) EDNS message, no RCODE available.  This is+              -- not an RCODE that can be sent by a peer.  It lies outside the+              -- 12-bit range expressible via EDNS.  The low bits are chosen to+              -- coincide with 'FormatErr'.  When an EDNS message is malformed,+              -- and we're unable to extract the extended RCODE, the header+              -- 'rcode' is set to 'BadRCODE'.+  | UnknownRCODE Word16+  deriving (Eq, Ord, Show)++-- | Convert an 'RCODE' to its numeric value.+fromRCODE :: RCODE -> Word16+fromRCODE NoErr     =  0+fromRCODE FormatErr =  1+fromRCODE ServFail  =  2+fromRCODE NameErr   =  3+fromRCODE NotImpl   =  4+fromRCODE Refused   =  5+fromRCODE YXDomain  =  6+fromRCODE YXRRSet   =  7+fromRCODE NXRRSet   =  8+fromRCODE NotAuth   =  9+fromRCODE NotZone   = 10+fromRCODE BadVers   = 16+fromRCODE BadKey    = 17+fromRCODE BadTime   = 18+fromRCODE BadMode   = 19+fromRCODE BadName   = 20+fromRCODE BadAlg    = 21+fromRCODE BadTrunc  = 22+fromRCODE BadCookie = 23+fromRCODE BadRCODE  = 0x1001+fromRCODE (UnknownRCODE x) = x++-- | Convert a numeric value to a corresponding 'RCODE'.  The behaviour+-- is undefined for values outside the range @[0 .. 0xFFF]@ since the+-- EDNS extended RCODE is a 12-bit value.  Values in the range+-- @[0xF01 .. 0xFFF]@ are reserved for private use.+--+toRCODE :: Word16 -> RCODE+toRCODE  0 = NoErr+toRCODE  1 = FormatErr+toRCODE  2 = ServFail+toRCODE  3 = NameErr+toRCODE  4 = NotImpl+toRCODE  5 = Refused+toRCODE  6 = YXDomain+toRCODE  7 = YXRRSet+toRCODE  8 = NXRRSet+toRCODE  9 = NotAuth+toRCODE 10 = NotZone+toRCODE 16 = BadVers+toRCODE 17 = BadKey+toRCODE 18 = BadTime+toRCODE 19 = BadMode+toRCODE 20 = BadName+toRCODE 21 = BadAlg+toRCODE 22 = BadTrunc+toRCODE 23 = BadCookie+toRCODE 0x1001 = BadRCODE+toRCODE  x = UnknownRCODE x+#endif++----------------------------------------------------------------++-- XXX: The Question really should also include the CLASS+--+-- | Raw data format for DNS questions.+data Question = Question {+    qname  :: Domain -- ^ A domain name+  , qtype  :: TYPE   -- ^ The type of the query+  } deriving (Eq, Show)++----------------------------------------------------------------++-- | Resource record class.+type CLASS = Word16++-- | Resource record class for the Internet.+classIN :: CLASS+classIN = 1++-- | Time to live in second.+type TTL = Word32++-- | Raw data format for resource records.+data ResourceRecord = ResourceRecord {+    rrname  :: !Domain -- ^ Name+  , rrtype  :: !TYPE   -- ^ Resource record type+  , rrclass :: !CLASS  -- ^ Resource record class+  , rrttl   :: !TTL    -- ^ Time to live+  , rdata   :: !RData  -- ^ Resource data+  } deriving (Eq,Show)++----------------------------------------------------------------++-- | Given a 32-bit circle-arithmetic DNS time, and the current absolute epoch+-- time, return the epoch time corresponding to the DNS timestamp.+--+dnsTime :: Word32 -- ^ DNS circle-arithmetic timestamp+        -> Int64  -- ^ current epoch time+        -> Int64  -- ^ absolute DNS timestamp+dnsTime tdns tnow =+    let delta = tdns - fromIntegral tnow+     in if delta > 0x7FFFFFFF -- tdns is in the past?+           then tnow - (0x100000000 - fromIntegral delta)+           else tnow + fromIntegral delta++-- | RRSIG representation.+--+-- As noted in+-- <https://tools.ietf.org/html/rfc4034#section-3.1.5 Section 3.1.5 of RFC 4034>+-- the RRsig inception and expiration times use serial number arithmetic.  As a+-- result these timestamps /are not/ pure values, their meaning is+-- time-dependent!  They depend on the present time and are both at most+-- approximately +\/-68 years from the present.  This ambiguity is not a+-- problem because cached RRSIG records should only persist a few days,+-- signature lifetimes should be *much* shorter than 68 years, and key rotation+-- should result any misconstrued 136-year-old signatures fail to validate.+-- This also means that the interpretation of a time that is exactly half-way+-- around the clock at @now +\/-0x80000000@ is not important, the signature+-- should never be valid.+--+-- The upshot for us is that we need to convert these *impure* relative values+-- to pure absolute values at the moment they are received from from the network+-- (or read from files, ... in some impure I/O context), and convert them back to+-- 32-bit values when encoding.  Therefore, the constructor takes absolute+-- 64-bit representations of the inception and expiration times.+--+-- The 'dnsTime' function performs the requisite conversion.+--+data RD_RRSIG = RDREP_RRSIG+    { rrsigType       :: !TYPE       -- ^ RRtype of RRset signed+    , rrsigKeyAlg     :: !Word8      -- ^ DNSKEY algorithm+    , rrsigNumLabels  :: !Word8      -- ^ Number of labels signed+    , rrsigTTL        :: !Word32     -- ^ Maximum origin TTL+    , rrsigExpiration :: !Int64      -- ^ Time last valid+    , rrsigInception  :: !Int64      -- ^ Time first valid+    , rrsigKeyTag     :: !Word16     -- ^ Signing key tag+    , rrsigZone       :: !Domain     -- ^ Signing domain+    , rrsigValue      :: !ByteString -- ^ Opaque signature+    }+    deriving (Eq, Ord)++instance Show RD_RRSIG where+    show RDREP_RRSIG{..} = unwords+        [ show rrsigType+        , show rrsigKeyAlg+        , show rrsigNumLabels+        , show rrsigTTL+        , showTime rrsigExpiration+        , showTime rrsigInception+        , show rrsigKeyTag+        , BS.unpack rrsigZone+        , _b64encode rrsigValue+        ]+      where+        showTime :: Int64 -> String+        showTime t = H.timePrint fmt $ H.Elapsed $ H.Seconds t+          where+            fmt = [ H.Format_Year4, H.Format_Month2, H.Format_Day2+                  , H.Format_Hour,  H.Format_Minute, H.Format_Second ]++-- | Raw data format for each type.+data RData = RD_A IPv4           -- ^ IPv4 address+           | RD_NS Domain        -- ^ An authoritative name serve+           | RD_CNAME Domain     -- ^ The canonical name for an alias+           | RD_SOA Domain Mailbox Word32 Word32 Word32 Word32 Word32+                                 -- ^ Marks the start of a zone of authority+           | RD_NULL ByteString  -- ^ NULL RR (EXPERIMENTAL, RFC1035).+           | RD_PTR Domain       -- ^ A domain name pointer+           | RD_MX Word16 Domain -- ^ Mail exchange+           | RD_TXT ByteString   -- ^ Text strings+           | RD_AAAA IPv6        -- ^ IPv6 Address+           | RD_SRV Word16 Word16 Word16 Domain+                                 -- ^ Server Selection (RFC2782)+           | RD_DNAME Domain     -- ^ DNAME (RFC6672)+           | RD_OPT [OData]      -- ^ OPT (RFC6891)+           | RD_DS Word16 Word8 Word8 ByteString -- ^ Delegation Signer (RFC4034)+           | RD_RRSIG RD_RRSIG   -- ^ DNSSEC signature+           | RD_NSEC Domain [TYPE] -- ^ DNSSEC denial of existence NSEC record+           | RD_DNSKEY Word16 Word8 Word8 ByteString+                                 -- ^ DNSKEY (RFC4034)+           | RD_NSEC3 Word8 Word8 Word16 ByteString ByteString [TYPE]+                                 -- ^ DNSSEC hashed denial of existence (RFC5155)+           | RD_NSEC3PARAM Word8 Word8 Word16 ByteString+                                 -- ^ NSEC3 zone parameters (RFC5155)+           | RD_TLSA Word8 Word8 Word8 ByteString+                                 -- ^ TLSA (RFC6698)+           | RD_CDS Word16 Word8 Word8 ByteString+                                 -- ^ Child DS (RFC7344)+           | RD_CDNSKEY Word16 Word8 Word8 ByteString+                                 -- ^ Child DNSKEY (RFC7344)+           --RD_CSYNC+           | UnknownRData ByteString   -- ^ Unknown resource data+    deriving (Eq, Ord)++instance Show RData where+  show rd = case rd of+      RD_A                  address -> show address+      RD_NS                 nsdname -> showDomain nsdname+      RD_CNAME                cname -> showDomain cname+      RD_SOA          a b c d e f g -> showSOA a b c d e f g+      RD_NULL                 bytes -> showOpaque bytes+      RD_PTR               ptrdname -> showDomain ptrdname+      RD_MX               pref exch -> showMX pref exch+      RD_TXT             textstring -> showTXT textstring+      RD_AAAA               address -> show address+      RD_SRV        pri wei prt tgt -> showSRV pri wei prt tgt+      RD_DNAME               target -> showDomain target+      RD_OPT                options -> show options+      RD_DS          tag alg dalg d -> showDS tag alg dalg d+      RD_RRSIG                rrsig -> show rrsig+      RD_NSEC            next types -> showNSEC next types+      RD_DNSKEY             f p a k -> showDNSKEY f p a k+      RD_NSEC3      a f i s h types -> showNSEC3 a f i s h types+      RD_NSEC3PARAM         a f i s -> showNSEC3PARAM a f i s+      RD_TLSA               u s m d -> showTLSA u s m d+      RD_CDS         tag alg dalg d -> showDS tag alg dalg d+      RD_CDNSKEY            f p a k -> showDNSKEY f p a k+      UnknownRData            bytes -> showOpaque bytes+    where+      showSalt ""    = "-"+      showSalt salt  = _b16encode salt+      showDomain = BS.unpack+      showSOA mname mrname serial refresh retry expire minttl =+          showDomain mname ++ " " ++ showDomain mrname ++ " " +++          show serial ++ " " ++ show refresh ++ " " +++          show retry ++ " " ++ show expire ++ " " ++ show minttl+      showMX preference exchange =+          show preference ++ " " ++ showDomain exchange+      showTXT bs = '"' : B.foldr dnsesc ['"'] bs+        where+          c2w = fromIntegral . fromEnum+          w2c = toEnum . fromIntegral+          doubleQuote = c2w '"'+          backSlash   = c2w '\\'+          dnsesc c s+              | c == doubleQuote   = '\\' : w2c c : s+              | c == backSlash     = '\\' : w2c c : s+              | c >= 32 && c < 127 =        w2c c : s+              | otherwise          = '\\' : ddd c   s+          ddd c s =+              let (q100, r100) = divMod (fromIntegral c) 100+                  (q10, r10) = divMod r100 10+               in intToDigit q100 : intToDigit q10 : intToDigit r10 : s+      showSRV priority weight port target =+          show priority ++ " " ++ show weight ++ " " +++          show port ++ BS.unpack target+      showDS keytag alg digestType digest =+          show keytag ++ " " ++ show alg ++ " " +++          show digestType ++ " " ++ _b16encode digest+      showNSEC next types =+          unwords $ showDomain next : map show types+      showDNSKEY flags protocol alg key =+          show flags ++ " " ++ show protocol ++ " " +++          show alg ++ " " ++ _b64encode key+      -- | <https://tools.ietf.org/html/rfc5155#section-3.2>+      showNSEC3 hashalg flags iterations salt nexthash types =+          unwords $ show hashalg : show flags : show iterations :+                    showSalt salt : _b32encode nexthash : map show types+      showNSEC3PARAM hashAlg flags iterations salt =+          show hashAlg ++ " " ++ show flags ++ " " +++          show iterations ++ " " ++ showSalt salt+      showTLSA usage selector mtype digest =+          show usage ++ " " ++ show selector ++ " " +++          show mtype ++ " " ++ _b16encode digest+      -- | Opaque RData: <https://tools.ietf.org/html/rfc3597#section-5>+      showOpaque bs = unwords ["\\#", show (BS.length bs), _b16encode bs]++_b16encode, _b32encode, _b64encode :: ByteString -> String+_b16encode = BS.unpack. B16.encode+_b32encode = BS.unpack. B32.encode+_b64encode = BS.unpack. B64.encode++-- | Type alias for resource records in the answer section.+type Answers = [ResourceRecord]++-- | Type alias for resource records in the answer section.+type AuthorityRecords = [ResourceRecord]++-- | Type for resource records in the additional section.+type AdditionalRecords = [ResourceRecord]++----------------------------------------------------------------++-- | A 'DNSMessage' template for queries with default settings for+-- the message 'DNSHeader' and 'EDNSheader'.  This is the initial+-- query message state, before customization via 'QueryControls'.+--+defaultQuery :: DNSMessage+defaultQuery = DNSMessage {+    header = DNSHeader {+       identifier = 0+     , flags = defaultDNSFlags+     }+  , ednsHeader = EDNSheader defaultEDNS+  , question   = []+  , answer     = []+  , authority  = []+  , additional = []+  }++-- | Default response.  When responding to EDNS queries, the response must+-- either be an EDNS response, or else FormatErr must be returned.  The default+-- response message has EDNS disabled ('ednsHeader' set to 'NoEDNS'), it should+-- be updated as appropriate.+--+-- Do not explicitly add OPT RRs to the additional section, instead let the+-- encoder compute and add the OPT record based on the EDNS pseudo-header.+--+-- The 'RCODE' in the 'DNSHeader' should be set to the appropriate 12-bit+-- extended value, which will be split between the primary header and EDNS OPT+-- record during message encoding (low 4 bits in DNS header, high 8 bits in+-- EDNS OPT record).  See 'EDNSheader' for more details.+--+defaultResponse :: DNSMessage+defaultResponse = DNSMessage {+    header = DNSHeader {+       identifier = 0+     , flags = defaultDNSFlags {+              qOrR = QR_Response+            , authAnswer = True+            , recAvailable = True+            , authenData = False+       }+     }+  , ednsHeader = NoEDNS+  , question   = []+  , answer     = []+  , authority  = []+  , additional = []+  }++-- | A query template with 'QueryControls' overrides applied,+-- with just the 'Question' and query 'Identifier' remaining+-- to be filled in.+--+makeEmptyQuery :: QueryControls -- ^ Flag and EDNS overrides+               -> DNSMessage+makeEmptyQuery ctls = defaultQuery {+      header = header'+    , ednsHeader = queryEdns ehctls+    }+  where+    hctls = qctlHeader ctls+    ehctls = qctlEdns ctls+    header' = (header defaultQuery) { flags = queryDNSFlags hctls }++    -- | Apply the given 'FlagOp' to a default boolean value to produce the final+    -- setting.+    --+    applyFlag :: FlagOp -> Bool -> Bool+    applyFlag FlagSet   _ = True+    applyFlag FlagClear _ = False+    applyFlag _         v = v++    -- | Construct a list of 0 or 1 EDNS OPT RRs based on EdnsControls setting.+    --+    queryEdns :: EdnsControls -> EDNSheader+    queryEdns (EdnsControls en vn sz d0 od) =+        let d  = defaultEDNS+         in if en == FlagClear+            then NoEDNS+            else EDNSheader $ d { ednsVersion = fromMaybe (ednsVersion d) vn+                                , ednsUdpSize = fromMaybe (ednsUdpSize d) sz+                                , ednsDnssecOk = applyFlag d0 (ednsDnssecOk d)+                                , ednsOptions  = _odataDedup od+                                }++    -- | Apply all the query flag overrides to 'defaultDNSFlags', returning the+    -- resulting 'DNSFlags' suitable for making queries with the requested flag+    -- settings.  This is only needed if you're creating your own 'DNSMessage',+    -- the 'Network.DNS.LookupRaw.lookupRawCtl' function takes a 'QueryControls'+    -- argument and handles this conversion internally.+    --+    -- Default overrides can be specified in the resolver configuration by setting+    -- the 'Network.DNS.resolvQueryControls' field of the+    -- 'Network.DNS.Resolver.ResolvConf' argument to+    -- 'Network.DNS.Resolver.makeResolvSeed'.  These then apply to lookups via+    -- resolvers based on the resulting configuration, with the exception of+    -- 'Network.DNS.LookupRaw.lookupRawCtl' which takes an additional+    -- 'QueryControls' argument to augment the default overrides.+    --+    queryDNSFlags :: HeaderControls -> DNSFlags+    queryDNSFlags (HeaderControls rd ad cd) = d {+          recDesired = applyFlag rd $ recDesired d+        , authenData = applyFlag ad $ authenData d+        , chkDisable = applyFlag cd $ chkDisable d+        }+      where+        d = defaultDNSFlags++-- | Construct a complete query 'DNSMessage', by combining the 'defaultQuery'+-- template with the specified 'Identifier', and 'Question'.  The+-- 'QueryControls' can be 'mempty' to leave all header and EDNS settings at+-- their default values, or some combination of overrides.  A default set of+-- overrides can be enabled via the 'Network.DNS.Resolver.resolvQueryControls'+-- field of 'Network.DNS.Resolver.ResolvConf'.  Per-query overrides are+-- possible by using 'Network.DNS.LookupRaw.loookupRawCtl'.+--+makeQuery :: Identifier        -- ^ Crypto random request id+          -> Question          -- ^ Question name and type+          -> QueryControls     -- ^ Custom RD\/AD\/CD flags and EDNS settings+          -> DNSMessage+makeQuery idt q ctls = empqry {+      header = (header empqry) { identifier = idt }+    , question = [q]+    }+  where+    empqry = makeEmptyQuery ctls++-- | Construct a query response 'DNSMessage'.+makeResponse :: Identifier+             -> Question+             -> Answers+             -> DNSMessage+makeResponse idt q as = defaultResponse {+      header = header' { identifier = idt }+    , question = [q]+    , answer   = as+    }+  where+    header' = header defaultResponse++----------------------------------------------------------------+-- EDNS (RFC 6891, EDNS(0))+----------------------------------------------------------------++-- | EDNS information defined in RFC 6891.+data EDNS = EDNS {+    -- | EDNS version, presently only version 0 is defined.+    ednsVersion :: !Word8+    -- | Supported UDP payload size.+  , ednsUdpSize  :: !Word16+    -- | Request DNSSEC replies (with RRSIG and NSEC records as as appropriate)+    -- from the server.  Generally, not needed (except for diagnostic purposes)+    -- unless the signatures will be validated.  Just setting the 'AD' bit in+    -- the query and checking it in the response is sufficient (but often+    -- subject to man-in-the-middle forgery) if all that's wanted is whether+    -- the server validated the response.+  , ednsDnssecOk :: !Bool+    -- | EDNS options (e.g. 'OD_NSID', 'OD_ClientSubnet', ...)+  , ednsOptions  :: ![OData]+  } deriving (Eq, Show)++-- | The default EDNS pseudo-header for queries.  The UDP buffer size is set to+--   1216 bytes, which should result in replies that fit into the 1280 byte+--   IPv6 minimum MTU.  Since IPv6 only supports fragmentation at the source,+--   and even then not all gateways forward IPv6 pre-fragmented IPv6 packets,+--   it is best to keep DNS packet sizes below this limit when using IPv6+--   nameservers.  A larger value may be practical when using IPv4 exclusively.+--+-- @+-- defaultEDNS = EDNS+--     { ednsVersion = 0      -- The default EDNS version is 0+--     , ednsUdpSize = 1232   -- IPv6-safe UDP MTU (RIPE recommendation)+--     , ednsDnssecOk = False -- We don't do DNSSEC validation+--     , ednsOptions = []     -- No EDNS options by default+--     }+-- @+--+defaultEDNS :: EDNS+defaultEDNS = EDNS+    { ednsVersion = 0      -- The default EDNS version is 0+    , ednsUdpSize = 1232   -- IPv6-safe UDP MTU+    , ednsDnssecOk = False -- We don't do DNSSEC validation+    , ednsOptions = []     -- No EDNS options by default+    }++-- | Maximum UDP size that can be advertised.  If the 'ednsUdpSize' of 'EDNS'+--   is larger, then this value is sent instead.  This value is likely to work+--   only for local nameservers on the loopback network.  Servers may enforce+--   a smaller limit.+--+-- >>> maxUdpSize+-- 16384+maxUdpSize :: Word16+maxUdpSize = 16384++-- | Minimum UDP size to advertise. If 'ednsUdpSize' of 'EDNS' is smaller,+--   then this value is sent instead.+--+-- >>> minUdpSize+-- 512+minUdpSize :: Word16+minUdpSize = 512++----------------------------------------------------------------++#if __GLASGOW_HASKELL__ >= 800+-- | EDNS Option Code (RFC 6891).+newtype OptCode = OptCode {+    -- | From option code to number.+    fromOptCode :: Word16+  } deriving (Eq,Ord)++-- | NSID (RFC5001, section 2.3)+pattern NSID :: OptCode+pattern NSID = OptCode 3++-- | DNSSEC algorithm support (RFC6974, section 3)+pattern DAU :: OptCode+pattern DAU = OptCode 5+pattern DHU :: OptCode+pattern DHU = OptCode 6+pattern N3U :: OptCode+pattern N3U = OptCode 7++-- | Client subnet (RFC7871)+pattern ClientSubnet :: OptCode+pattern ClientSubnet = OptCode 8++instance Show OptCode where+    show NSID         = "NSID"+    show DAU          = "DAU"+    show DHU          = "DHU"+    show N3U          = "N3U"+    show ClientSubnet = "ClientSubnet"+    show x            = "OptCode" ++ (show $ fromOptCode x)++-- | From number to option code.+toOptCode :: Word16 -> OptCode+toOptCode = OptCode+#else+-- | Option Code (RFC 6891).+data OptCode = NSID                  -- ^ Name Server Identifier (RFC5001)+             | DAU                   -- ^ DNSSEC Algorithm understood (RFC6975)+             | DHU                   -- ^ DNSSEC Hash Understood (RFC6975)+             | N3U                   -- ^ NSEC3 Hash Understood (RFC6975)+             | ClientSubnet          -- ^ Client subnet (RFC7871)+             | UnknownOptCode Word16 -- ^ Unknown option code+    deriving (Eq, Ord, Show)++-- | From option code to number.+fromOptCode :: OptCode -> Word16+fromOptCode NSID         = 3+fromOptCode DAU          = 5+fromOptCode DHU          = 6+fromOptCode N3U          = 7+fromOptCode ClientSubnet = 8+fromOptCode (UnknownOptCode x) = x++-- | From number to option code.+toOptCode :: Word16 -> OptCode+toOptCode 3 = NSID+toOptCode 5 = DAU+toOptCode 6 = DHU+toOptCode 7 = N3U+toOptCode 8 = ClientSubnet+toOptCode x = UnknownOptCode x+#endif++----------------------------------------------------------------++-- | RData formats for a few EDNS options, and an opaque catchall+data OData =+      -- | Name Server Identifier (RFC5001).  Bidirectional, empty from client.+      -- (opaque octet-string).  May contain binary data, which MUST be empty+      -- in queries.+      OD_NSID ByteString+      -- | DNSSEC Algorithm Understood (RFC6975).  Client to server.+      -- (array of 8-bit numbers). Lists supported DNSKEY algorithms.+    | OD_DAU [Word8]+      -- | DS Hash Understood (RFC6975).  Client to server.+      -- (array of 8-bit numbers). Lists supported DS hash algorithms.+    | OD_DHU [Word8]+      -- | NSEC3 Hash Understood (RFC6975).  Client to server.+      -- (array of 8-bit numbers). Lists supported NSEC3 hash algorithms.+    | OD_N3U [Word8]+      -- | Client subnet (RFC7871).  Bidirectional.+      -- (source bits, scope bits, address).+      -- The address is masked and truncated when encoding queries.  The+      -- address is zero-padded when decoding.  Invalid input encodings+      -- result in an 'OD_ECSgeneric' value instead.+      --+    | OD_ClientSubnet Word8 Word8 IP+      -- | Unsupported or malformed IP client subnet option.  Bidirectional.+      -- (address family, source bits, scope bits, opaque address).+    | OD_ECSgeneric Word16 Word8 Word8 ByteString+      -- | Generic EDNS option.+      -- (numeric 'OptCode', opaque content)+    | UnknownOData Word16 ByteString+    deriving (Eq,Ord)+++-- | Recover the (often implicit) 'OptCode' from a value of the 'OData' sum+-- type.+_odataToOptCode :: OData -> OptCode+_odataToOptCode OD_NSID {}            = NSID+_odataToOptCode OD_DAU {}             = DAU+_odataToOptCode OD_DHU {}             = DHU+_odataToOptCode OD_N3U {}             = N3U+_odataToOptCode OD_ClientSubnet {}    = ClientSubnet+_odataToOptCode OD_ECSgeneric {}      = ClientSubnet+_odataToOptCode (UnknownOData code _) = toOptCode code++instance Show OData where+    show (OD_NSID nsid) = _showNSID nsid+    show (OD_DAU as)    = _showAlgList "DAU" as+    show (OD_DHU hs)    = _showAlgList "DHU" hs+    show (OD_N3U hs)    = _showAlgList "N3U" hs+    show (OD_ClientSubnet b1 b2 ip@(IPv4 _)) = _showECS 1 b1 b2 $ show ip+    show (OD_ClientSubnet b1 b2 ip@(IPv6 _)) = _showECS 2 b1 b2 $ show ip+    show (OD_ECSgeneric fam b1 b2 a) = _showECS fam b1 b2 $ _b16encode a+    show (UnknownOData code bs) =+        "UnknownOData " ++ show code ++ " " ++ _b16encode bs++_showAlgList :: String -> [Word8] -> String+_showAlgList nm ws = nm ++ " " ++ intercalate "," (map show ws)++_showNSID :: ByteString -> String+_showNSID nsid = "NSID" ++ " " ++ _b16encode nsid ++ ";" ++ printable nsid+  where+    printable = BS.unpack. BS.map (\c -> if c < ' ' || c > '~' then '?' else c)++_showECS :: Word16 -> Word8 -> Word8 -> String -> String+_showECS family srcBits scpBits address =+    show family ++ " " ++ show srcBits+                ++ " " ++ show scpBits ++ " " ++ address

@@ -0,0 +1,136 @@+module Network.DNS.Types.Resolver where++import Network.Socket (AddrInfo(..), PortNumber, HostName)++import Network.DNS.Imports+import Network.DNS.Memo+import Network.DNS.Types.Internal++----------------------------------------------------------------++-- | The type to specify a cache server.+data FileOrNumericHost = RCFilePath FilePath -- ^ A path for \"resolv.conf\"+                                             -- where one or more IP addresses+                                             -- of DNS servers should be found+                                             -- on Unix.+                                             -- Default DNS servers are+                                             -- automatically detected+                                             -- on Windows regardless of+                                             -- the value of the file name.+                       | RCHostName HostName -- ^ A numeric IP address. /Warning/: host names are invalid.+                       | RCHostNames [HostName] -- ^ Numeric IP addresses. /Warning/: host names are invalid.+                       | RCHostPort HostName PortNumber -- ^ A numeric IP address and port number. /Warning/: host names are invalid.+                       deriving Show++----------------------------------------------------------------++-- | Cache configuration for responses.+data CacheConf = CacheConf {+    -- | If RR's TTL is higher than this value, this value is used instead.+    maximumTTL  :: TTL+    -- | Cache pruning interval in seconds.+  , pruningDelay  :: Int+  } deriving Show++-- | Default cache configuration.+--+-- >>> defaultCacheConf+-- CacheConf {maximumTTL = 300, pruningDelay = 10}+defaultCacheConf :: CacheConf+defaultCacheConf = CacheConf 300 10++----------------------------------------------------------------++-- | Type for resolver configuration.+--  Use 'defaultResolvConf' to create a new value.+--+--  An example to use Google's public DNS cache instead of resolv.conf:+--+--  >>> let conf = defaultResolvConf { resolvInfo = RCHostName "8.8.8.8" }+--+--  An example to use multiple Google's public DNS cache concurrently:+--+--  >>> let conf = defaultResolvConf { resolvInfo = RCHostNames ["8.8.8.8","8.8.4.4"], resolvConcurrent = True }+--+--  An example to disable EDNS:+--+--  >>> let conf = defaultResolvConf { resolvQueryControls = ednsEnabled FlagClear }+--+--  An example to enable query result caching:+--+--  >>> let conf = defaultResolvConf { resolvCache = Just defaultCacheConf }+--+-- An example to disable requesting recursive service.+--+--  >>> let conf = defaultResolvConf { resolvQueryControls = rdFlag FlagClear }+--+-- An example to set the AD bit in all queries by default.+--+--  >>> let conf = defaultResolvConf { resolvQueryControls = adFlag FlagSet }+--+-- An example to set the both the AD and CD bits in all queries by default.+--+--  >>> let conf = defaultResolvConf { resolvQueryControls = adFlag FlagSet <> cdFlag FlagSet }+--+-- An example with an EDNS buffer size of 1216 bytes, which is more robust with+-- IPv6, and the DO bit set to request DNSSEC responses.+--+--  >>> let conf = defaultResolvConf { resolvQueryControls = ednsSetUdpSize (Just 1216) <> doFlag FlagSet }+--+data ResolvConf = ResolvConf {+   -- | Server information.+    resolvInfo       :: FileOrNumericHost+   -- | Timeout in micro seconds.+  , resolvTimeout    :: Int+   -- | The number of retries including the first try.+  , resolvRetry      :: Int+   -- | Concurrent queries if multiple DNS servers are specified.+  , resolvConcurrent :: Bool+   -- | Cache configuration.+  , resolvCache      :: Maybe CacheConf+   -- | Overrides for the default flags used for queries via resolvers that use+   -- this configuration.+  , resolvQueryControls :: QueryControls+} deriving Show++-- | Return a default 'ResolvConf':+--+-- * 'resolvInfo' is 'RCFilePath' \"\/etc\/resolv.conf\".+-- * 'resolvTimeout' is 3,000,000 micro seconds.+-- * 'resolvRetry' is 3.+-- * 'resolvConcurrent' is False.+-- * 'resolvCache' is Nothing.+-- * 'resolvQueryControls' is an empty set of overrides.+defaultResolvConf :: ResolvConf+defaultResolvConf = ResolvConf {+    resolvInfo       = RCFilePath "/etc/resolv.conf"+  , resolvTimeout    = 3 * 1000 * 1000+  , resolvRetry      = 3+  , resolvConcurrent = False+  , resolvCache      = Nothing+  , resolvQueryControls = mempty+}++----------------------------------------------------------------++-- | Intermediate abstract data type for resolvers.+--   IP address information of DNS servers is generated+--   according to 'resolvInfo' internally.+--   This value can be safely reused for 'withResolver'.+--+--   The naming is confusing for historical reasons.+data ResolvSeed = ResolvSeed {+    resolvconf  :: ResolvConf+  , nameservers :: NonEmpty AddrInfo+}++----------------------------------------------------------------++-- | Abstract data type of DNS Resolver.+--   This includes newly seeded identifier generators for all+--   specified DNS servers and a cache database.+data Resolver = Resolver {+    resolvseed :: ResolvSeed+  , genIds     :: NonEmpty (IO Word16)+  , cache      :: Maybe Cache+}

@@ -7,13 +7,14 @@ #if !MIN_VERSION_bytestring(0,10,0) import qualified Data.ByteString as BS #endif-import Data.Monoid ((<>)) import Data.Word8 import Foreign.ForeignPtr (withForeignPtr) import Foreign.Ptr (plusPtr) import Foreign.Storable (peek, poke, peekByteOff)-import Network.DNS import Test.Hspec++import Network.DNS+import Network.DNS.Imports  ---------------------------------------------------------------- 

@@ -3,9 +3,9 @@ module EncodeSpec where  import Data.IP-import Network.DNS-import Network.DNS.Types (defaultQuery, Question(..)) import Test.Hspec++import Network.DNS  spec :: Spec spec = do

@@ -2,27 +2,21 @@  module RoundTripSpec where -import Control.Monad (replicateM) import qualified Data.IP import Data.IP (Addr, IP(..), IPv4, IPv6, toIPv4, toIPv6, makeAddrRange) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BS-import Network.DNS.Decode-import Network.DNS.Decode.Internal-import Network.DNS.Encode-import Network.DNS.Encode.Internal-import Network.DNS.Types import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck (Gen, arbitrary, elements, forAll, frequency, listOf, oneof)-import Data.Word (Word8, Word16, Word32)-import Data.Monoid ((<>)) import GHC.Exts (the, groupWith) -#if __GLASGOW_HASKELL__ < 709-import Control.Applicative-#endif-+import Network.DNS.Decode+import Network.DNS.Decode.Internal+import Network.DNS.Encode+import Network.DNS.Encode.Internal+import Network.DNS.Imports+import Network.DNS.Types  spec :: Spec spec = do

@@ -2,11 +2,12 @@  module IOSpec where -import Data.Monoid ((<>))+import Network.Socket+import Test.Hspec+ import Network.DNS.IO as DNS+import Network.DNS.Imports import Network.DNS.Types as DNS-import Network.Socket hiding (send)-import Test.Hspec  spec :: Spec spec = describe "send/receive" $ do

@@ -2,8 +2,9 @@  module LookupSpec where -import Network.DNS as DNS import Test.Hspec++import Network.DNS as DNS  spec :: Spec spec = describe "lookup" $ do

@@ -1,14 +1,34 @@+{-# LANGUAGE CPP #-}++-- | Run doctests only on non-Windows systems with GHC 8.4 or later.+--+-- The Windows doctests now compile and run, but either succeed quickly or+-- randomly hang (before AppVeyor kills them after an hour).  So we disable+-- these for now.  This can be tested again at some point in the future.+-- module Main where -import Build_doctests (flags, pkgs, module_sources)-import Test.DocTest (doctest)+#if !defined(mingw32_HOST_OS) && MIN_TOOL_VERSION_ghc(8,4,0)+import Test.DocTest+import System.Environment +-- | Expose precompiled library modules.+modules :: [String]+modules =+  [ "-XOverloadedStrings"+  , "-XCPP"+  , "-i","-i.","-iinternal"+  , "-threaded"+  , "-package=dns"+  , "Network/DNS.hs"+  ]+ main :: IO ()-main = do-    putStrLn $ unwords $ "\ndoctest args: " : args-    doctest args-  where-    args = [ "-XCPP" ] ++-           flags ++-           pkgs ++-           module_sources+main = getArgs >>= doctest . (++ modules)++#else++main :: IO ()+main = return ()++#endif