dns 4.0.1 → 4.1.0

raw patch · 20 files changed

+252/−307 lines, 20 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Changelog.md +49/−21
• Network/DNS/IO.hs +32/−7
• Network/DNS/Lookup.hs +5/−5
• Network/DNS/LookupRaw.hs +17/−2
• Network/DNS/Resolver.hs +4/−4
• Network/DNS/Transport.hs +2/−2
• Network/DNS/Utils.hs +46/−1
• dns.cabal +3/−1
• internal/Network/DNS/Decode/Internal.hs +1/−1
• internal/Network/DNS/Decode/Parsers.hs +27/−13
• internal/Network/DNS/Encode/Builders.hs +12/−6
• internal/Network/DNS/Encode/Internal.hs +1/−1
• internal/Network/DNS/Memo.hs +1/−0
• internal/Network/DNS/StateBinary.hs +3/−6
• internal/Network/DNS/Types/Internal.hs +12/−230
• test/DecodeSpec.hs +32/−4
• test/RoundTripSpec.hs +1/−1
• test2/IOSpec.hs +1/−1
• test2/LookupSpec.hs +1/−1
• test2/doctests.hs +2/−0

@@ -1,5 +1,33 @@-# 4.0.1+# ChangeLog +## 4.1.0++- Breaking change: GHC 7.x and earlier no longer supported.+  We now require support for PatternSynonyms, available since+  GHC 8.0.+- Feature: relaxed lookup-raw interface+  [#167](https://github.com/kazu-yamamoto/dns/pull/167)+- Using "53" instead of "domain".+  [#166](ttps://github.com/kazu-yamamoto/dns/pull/166)+- UDP ReceiveFrom, sendTo with SockAddr+  [#165](https://github.com/kazu-yamamoto/dns/pull/165)+- Feature: Support for RP resource record type+  [#161](https://github.com/kazu-yamamoto/dns/pull/161)+- Feature: New `splitDomain` function splits a domain name+  at the first label break, unescaping the first label to+  a raw ByteString.+- Feature: New `splitMailbox` function splits a domain name+  at the first label break, unescaping the first label to+  a raw ByteString.+  [#155](https://github.com/kazu-yamamoto/dns/pull/155)+- Bugfix: Encoding of large packets could produce invalid+  compression pointers.+  [#156](https://github.com/kazu-yamamoto/dns/pull/156)+- Bugfix: SRV record presentation form (RD_SRV show instance)+  was missing a space between the port and the target.++## 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@@ -21,7 +49,7 @@   Cabal 2.0 or later features to expose internal modules only to the test   executables. -# 4.0.0+## 4.0.0  - Breaking change: when `Domain` name ByteStrings are   parsed as a sequence of DNS labels, backslashed escapes@@ -156,26 +184,26 @@ - New OP codes: OP\_NOTIFY and OP\_UPDATE.   [#113](https://github.com/kazu-yamamoto/dns/pull/113) -# 3.0.4+## 3.0.4  - Drop unexpected UDP answers [#112](https://github.com/kazu-yamamoto/dns/pull/112) -# 3.0.3+## 3.0.3  - Implementing NSEC3PARAM [#109](https://github.com/kazu-yamamoto/dns/pull/109) - Fixing an example of DNS server. - Improving DNS decoder [#111](https://github.com/kazu-yamamoto/dns/pull/111) -# 3.0.2+## 3.0.2  - Supporting conduit 1.3 [#105](https://github.com/kazu-yamamoto/dns/pull/105) - Supporting GHC 8.4 with semigroup hack. -# 3.0.1+## 3.0.1  - Supporting GHC 7.8 again. -# 3.0.0+## 3.0.0  - The version introduces some breaking changes internally. But upper layer APIs in the `Lookup` module remain the same. - Breaking change: `Network.DNS.Types` is redesigned. `ResourceRecord` is not a sum type anymore. It holds only normal RRs. For EDNS0, a new scheme is implemented. [#63](https://github.com/kazu-yamamoto/dns/issues/63)@@ -188,52 +216,52 @@ - Some constructors such as ANY are added in the `Types` module. - Some bug fixes and code clean-up. -# 2.0.13+## 2.0.13 - Testing with AppVeyor. - Detecting a default DNS server on Windows. - Fixing sendAll on Windows [#72](https://github.com/kazu-yamamoto/dns/pull/72) -# 2.0.12+## 2.0.12 - Fixing Windows build again -# 2.0.11+## 2.0.11 - Fixing the StateBinary.get32 parser [#57](https://github.com/kazu-yamamoto/dns/pull/57) - Removing bytestring-builder dependency [#61](https://github.com/kazu-yamamoto/dns/pull/61) - Fixing Windows build [#62](https://github.com/kazu-yamamoto/dns/pull/62) -# 2.0.10+## 2.0.10 - Cleaning up the code. [#47](https://github.com/kazu-yamamoto/dns/pull/47) -# 2.0.9+## 2.0.9 - Implemented TCP fallback after a truncated UDP response. [#46](https://github.com/kazu-yamamoto/dns/pull/46) -# 2.0.8+## 2.0.8 - Better handling of encoding and decoding the "root" domain ".". [#45](https://github.com/kazu-yamamoto/dns/pull/45) -# 2.0.7+## 2.0.7 - Add length checks for A and AAAA records. [#43](https://github.com/kazu-yamamoto/dns/pull/43) -# 2.0.6+## 2.0.6 - Adding Ord instance. [#41](https://github.com/kazu-yamamoto/dns/pull/41) - Adding DNSSEC-related RRTYPEs [#40](https://github.com/kazu-yamamoto/dns/pull/40) -# 2.0.5+## 2.0.5 - Supporting DNS-SEC AD (authenticated data). [#38](https://github.com/kazu-yamamoto/dns/pull/38) - Removing the dependency to blaze-builder. -# 2.0.4+## 2.0.4 - Renaming a variable to fix preprocessor conflicts [#37](https://github.com/kazu-yamamoto/dns/pull/37) -# 2.0.3+## 2.0.3 - Handle invalid opcodes gracefully. [#36](https://github.com/kazu-yamamoto/dns/pull/36) -# 2.0.2+## 2.0.2 - Providing a new API: decodeMany. -# 2.0.1+## 2.0.1 - Updating document. -# 2.0.0+## 2.0.0 - DNSMessage is now monomorphic - RDATA is now monomorphic - Removed traversal instance for DNSMessage

@@ -1,12 +1,13 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}  module Network.DNS.IO (     -- * Receiving DNS messages     receive+  , receiveFrom   , receiveVC     -- * Sending pre-encoded messages   , send+  , sendTo   , sendVC   , sendAll     -- ** Encoding queries for transmission@@ -25,8 +26,8 @@ import Data.IP (IPv4, IPv6) import Time.System (timeCurrent) import Time.Types (Elapsed(..), Seconds(..))-import Network.Socket (Socket)-import Network.Socket.ByteString (recv)+import Network.Socket (Socket, SockAddr)+import Network.Socket.ByteString (recv, recvFrom) import qualified Network.Socket.ByteString as Socket import System.IO.Error @@ -37,10 +38,11 @@  ---------------------------------------------------------------- --- | Receive and decode a single 'DNSMessage' from a UDP 'Socket'.  Messages--- longer than 'maxUdpSize' are silently truncated, but this should not occur--- in practice, since we cap the advertised EDNS UDP buffer size limit at the--- same value.  A 'DNSError' is raised if I/O or message decoding fails.+-- | Receive and decode a single 'DNSMessage' from a UDP 'Socket', throwing away+-- the client address.  Messages longer than 'maxUdpSize' are silently+-- truncated, but this should not occur in practice, since we cap the advertised+-- EDNS UDP buffer size limit at the same value.  A 'DNSError' is raised if I/O+-- or message decoding fails. -- receive :: Socket -> IO DNSMessage receive sock = do@@ -51,6 +53,20 @@         Left  e   -> E.throwIO e         Right msg -> return msg +-- | Receive and decode a single 'DNSMessage' from a UDP 'Socket'.  Messages+-- longer than 'maxUdpSize' are silently truncated, but this should not occur+-- in practice, since we cap the advertised EDNS UDP buffer size limit at the+-- same value.  A 'DNSError' is raised if I/O or message decoding fails.+--+receiveFrom :: Socket -> IO (DNSMessage, SockAddr)+receiveFrom sock = do+    let bufsiz = fromIntegral maxUdpSize+    (bs, client) <- recvFrom sock bufsiz `E.catch` \e -> E.throwIO $ NetworkFailure e+    Elapsed (Seconds now) <- timeCurrent+    case decodeAt now bs of+        Left  e   -> E.throwIO e+        Right msg -> return (msg, client)+ -- | Receive and decode a single 'DNSMesage' from a virtual-circuit (TCP).  It -- is up to the caller to implement any desired timeout. An 'DNSError' is -- raised if I/O or message decoding fails.@@ -104,6 +120,15 @@ send :: Socket -> ByteString -> IO () send = (void .). Socket.send {-# INLINE send #-}++-- | Send an encoded 'DNSMessage' datagram over UDP to a given address.  The+-- message length is implicit in the size of the UDP datagram.  With TCP you+-- must use 'sendVC', because TCP does not have message boundaries, and each+-- message needs to be prepended with an explicit length.+--+sendTo :: Socket -> ByteString -> SockAddr -> IO ()+sendTo sock str addr = Socket.sendTo sock str addr >> return ()+{-# INLINE sendTo #-}  -- | Send a single encoded 'DNSMessage' over TCP.  An explicit length is -- prepended to the encoded buffer before transmission.  If you want to

@@ -95,7 +95,7 @@ -- --   >>> rs <- makeResolvSeed defaultResolvConf --   >>> withResolver rs $ \resolver -> lookupA resolver "www.kame.net"---   Right [203.178.141.194]+--   Right [210.155.141.200] -- lookupA :: Resolver -> Domain -> IO (Either DNSError [IPv4]) lookupA rlv dom = do@@ -116,7 +116,7 @@ -- --   >>> rs <- makeResolvSeed defaultResolvConf --   >>> withResolver rs $ \resolver -> lookupAAAA resolver "www.wide.ad.jp"---   Right [2001:200:dff:fff1:216:3eff:fe4b:651c]+--   Right [2001:200:0:180c:20c:29ff:fec9:9d61] -- lookupAAAA :: Resolver -> Domain -> IO (Either DNSError [IPv6]) lookupAAAA rlv dom = do@@ -183,7 +183,7 @@ --   >>> rs <- makeResolvSeed defaultResolvConf --   >>> ips <- withResolver rs $ \resolver -> lookupAviaMX resolver "wide.ad.jp" --   >>> fmap sort ips---   Right [133.138.10.39,203.178.136.30]+--   Right [203.178.136.30] -- --   Since there is more than one result, it is necessary to sort the --   list in order to check for equality.@@ -353,7 +353,7 @@ --   210.130.137.80, i.e., 80.137.130.210.in-addr.arpa: -- --   >>> rs <- makeResolvSeed defaultResolvConf---   >>> withResolver rs $ \resolver -> lookupPTR resolver "164.2.232.202.in-addr.arpa"+--   >>> withResolver rs $ \resolver -> lookupPTR resolver "180.2.232.202.in-addr.arpa" --   Right ["www.iij.ad.jp."] -- --   The 'lookupRDNS' function is more suited to this particular task.@@ -378,7 +378,7 @@ --   address directly: -- --   >>> rs <- makeResolvSeed defaultResolvConf---   >>> withResolver rs $ \resolver -> lookupRDNS resolver "202.232.2.164"+--   >>> withResolver rs $ \resolver -> lookupRDNS resolver "202.232.2.180" --   Right ["www.iij.ad.jp."] -- lookupRDNS :: Resolver -> Domain -> IO (Either DNSError [Domain])

@@ -7,6 +7,7 @@   -- * Lookups returning DNS Messages   , lookupRaw   , lookupRawCtl+  , lookupRawCtlRecv   -- * DNS Message procesing   , fromDNSMessage   ) where@@ -14,6 +15,7 @@ import Data.Hourglass (timeAdd, Seconds) import Prelude hiding (lookup) import Time.System (timeCurrent)+import Network.Socket (Socket)  import Network.DNS.IO import Network.DNS.Imports hiding (lookup)@@ -150,7 +152,7 @@     soas = filter (SOA `isTypeOf`) $ authority ans  insertNegative :: CacheConf -> Cache -> Key -> Entry -> TTL -> IO ()-insertNegative CacheConf{..} c k v ttl = when (ttl /= 0) $ do+insertNegative _ c k v ttl = when (ttl /= 0) $ do     ctime <- timeCurrent     let tim = ctime `timeAdd` life     insertCache k tim v c@@ -253,7 +255,20 @@              -> TYPE          -- ^ Query RRtype              -> QueryControls -- ^ Query flag and EDNS overrides              -> IO (Either DNSError DNSMessage)-lookupRawCtl rslv dom typ ctls = resolve dom typ rslv ctls receive+lookupRawCtl rslv dom typ ctls = resolve rslv dom typ ctls receive++-- | Similar to 'lookupRawCtl', but the recv action can be replaced with+-- something other than `Network.DNS.IO.receive`.+-- For example, in an environment where frequent retrieval of the current time+-- is a performance issue, you can pass the time from outside instead of+-- having `Network.DNS.IO.receive` retrieve the current time.+lookupRawCtlRecv :: Resolver                  -- ^ Resolver obtained via 'withResolver'+                 -> Domain                    -- ^ Query domain+                 -> TYPE                      -- ^ Query RRtype+                 -> QueryControls             -- ^ Query flag and EDNS overrides+                 -> (Socket -> IO DNSMessage) -- ^ Action to receive message from socket+                 -> IO (Either DNSError DNSMessage)+lookupRawCtlRecv = resolve  ---------------------------------------------------------------- 

@@ -67,12 +67,12 @@  makeAddrInfo :: HostName -> Maybe PortNumber -> IO AddrInfo makeAddrInfo addr mport = do-    let flgs = [AI_ADDRCONFIG, AI_NUMERICHOST, AI_PASSIVE]-        hints = defaultHints {-            addrFlags = if isJust mport then AI_NUMERICSERV : flgs else flgs+    let hints = defaultHints {+            addrFlags = [AI_ADDRCONFIG, AI_NUMERICHOST, AI_NUMERICSERV, AI_PASSIVE]           , addrSocketType = Datagram           }-        serv = maybe "domain" show mport+        -- 53 is the standard port number for domain name servers as assigned by IANA+        serv = maybe "53" show mport     head <$> getAddrInfo (Just hints) (Just addr) (Just serv)  ----------------------------------------------------------------

@@ -78,8 +78,8 @@ -- This function merges the query flag overrides from the resolver -- configuration with any additional overrides from the caller. ---resolve :: Domain -> TYPE -> Resolver -> Rslv0-resolve dom typ rlv qctls rcv+resolve :: Resolver -> Domain -> TYPE -> Rslv0+resolve rlv dom typ qctls rcv   | isIllegal dom = return $ Left IllegalDomain   | typ == AXFR   = return $ Left InvalidAXFRLookup   | onlyOne       = resolveOne        (head nss) (head gens) q tm retry ctls rcv

@@ -4,12 +4,15 @@     normalize   , normalizeCase   , normalizeRoot+  , splitDomain+  , splitMailbox   ) where  import qualified Data.ByteString.Char8 as BS import Data.Char (toLower) -import Network.DNS.Types.Internal (Domain)+import Network.DNS.Types.Internal (DNSError, Domain, Mailbox)+import Network.DNS.StateBinary (parseLabel)   -- | Perform both 'normalizeCase' and 'normalizeRoot' on the given@@ -130,3 +133,45 @@   | otherwise = d `BS.append` trailing_dot     where       trailing_dot = BS.pack "."++-- | Split a domain name in A-label form into its initial label and the rest of+-- the domain.  Returns an error if the initial label is malformed.  When no+-- more labels remain, the initial label will satisfy 'BS.null'.+--+-- This also decodes any escaped characters in the initial label, which may+-- therefore contain whitespace, binary data, or unescaped internal dots.  To+-- reconstruct the original domain, the initial label may sometimes require+-- correct escaping of special characters.+--+-- ==== __Examples__+--+-- >>> import Data.ByteString.Char8 as BS+-- >>> splitDomain $ BS.pack "abc\\.def.xyz"+-- Right ("abc.def","xyz")+--+-- >>> splitDomain $ BS.pack ".abc.def.xyz"+-- Left (DecodeError "invalid domain: .abc.def.xyz")+--+splitDomain :: Domain -> Either DNSError (BS.ByteString, Domain)+splitDomain = parseLabel 0x2e++-- | Split a 'Mailbox' in A-label form into its initial label 'BS.ByteString'+-- (the /localpart/ of the email address) and the remaining 'Domain' (the+-- /domainpart/ of the email address, with a possible trailing @'.'@).  Returns+-- an error if the initial label is malformed.  When no more labels remain, the+-- initial label will satisfy 'BS.null'.  The remaining labels can be obtained+-- by applying 'splitDomain' the returned domain part.+--+-- This also decodes any escaped characters in the initial label, which may+-- therefore contain whitespace, binary data, or unescaped internal dots.  To+-- reconstruct the original mailbox, the initial label may sometimes require+-- correct escaping of special characters.+--+-- ==== __Example__+--+-- >>> import Data.ByteString.Char8 as BS+-- >>> splitMailbox $ BS.pack "Joe.Admin@example.com."+-- Right ("Joe.Admin","example.com.")+--+splitMailbox :: Mailbox -> Either DNSError (BS.ByteString, Domain)+splitMailbox = parseLabel 0x40

@@ -1,5 +1,5 @@ Name:                   dns-Version:                4.0.1+Version:                4.1.0 Author:                 Kazu Yamamoto <kazu@iij.ad.jp> Maintainer:             Kazu Yamamoto <kazu@iij.ad.jp> License:                BSD3@@ -97,6 +97,7 @@                       , base                       , hspec                       , network+  Build-Tool-Depends:   hspec-discover:hspec-discover  Test-Suite spec-tests   Type:                 exitcode-stdio-1.0@@ -115,6 +116,7 @@                       , hspec                       , iproute >= 1.3.2                       , word8+  Build-Tool-Depends:   hspec-discover:hspec-discover  Test-Suite doctests   Type:                 exitcode-stdio-1.0

@@ -36,7 +36,7 @@ decodeDomain :: ByteString -> Either DNSError Domain decodeDomain bs = fst <$> runSGet getDomain bs --- | Decode a mailbox name (the SOA record /mrname/ field).  Since DNS names+-- | Decode a mailbox name (e.g. the SOA record /rname/ 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. --

@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, OverloadedStrings #-}+{-# LANGUAGE BangPatterns, LambdaCase, OverloadedStrings #-}  module Network.DNS.Decode.Parsers (     getResponse@@ -172,6 +172,10 @@     decodePriority = get16     decodeWeight   = get16     decodePort     = get16+--+getRData RP _   = RD_RP <$> getMailbox+                        <*> getDomain+-- getRData OPT len   = RD_OPT <$> getOpts len -- getRData TLSA len = RD_TLSA <$> decodeUsage@@ -451,6 +455,23 @@     let n = getValue c     getdomain pos c n   where+    -- Reprocess the same ByteString starting at the pointer+    -- target (offset).+    getPtr pos offset = do+        msg <- getInput+        let parser = skipNBytes offset >> getDomain' sep1 offset+        case runSGet parser msg of+            Left (DecodeError err) -> failSGet err+            Left err               -> fail $ show err+            Right o                -> do+                -- Cache only the presentation form decoding of domain names,+                -- mailboxes (e.g. SOA rname) are less frequently reused, and+                -- have a different presentation form, so must not share the+                -- same cache.+                when (sep1 == dot) $+                    push pos (fst o)+                return (fst o)+     getdomain pos c n       | c == 0 = return "." -- Perhaps the root domain?       | isPointer c = do@@ -458,18 +479,11 @@           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+          if sep1 /= dot+              then getPtr pos offset+              else pop offset >>= \case+                  Nothing -> getPtr pos offset+                  Just o  -> return o       -- As for now, extended labels have no use.       -- This may change some time in the future.       | isExtLabel c = return ""

@@ -15,6 +15,7 @@   ) where  import Control.Monad.State (State, modify, execState, gets)+import qualified Control.Exception as E import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS@@ -131,6 +132,7 @@     RD_PTR              ptrdname -> putDomain ptrdname     RD_MX              pref exch -> mconcat [put16 pref, putDomain exch]     RD_TXT            textstring -> putTXT textstring+    RD_RP             mbox dname -> putMailbox mbox <> putDomain dname     RD_AAAA              address -> mconcat $ map putInt8 (fromIPv6b address)     RD_SRV       pri wei prt tgt -> putSRV pri wei prt tgt     RD_DNAME               dname -> putDomain dname@@ -328,17 +330,21 @@         cur <- gets wsPosition         case mpos of             Just pos -> putPointer pos-            Nothing  -> wsPush dom cur >>+            Nothing  -> do+                        -- Pointers are limited to 14-bits!+                        when (cur <= 0x3fff) $ 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+    (hd, tl) = loop (c2w sep)+      where+        loop w = case parseLabel w dom of+            Right p | w /= 0x2e && BS.null (snd p) -> loop 0x2e+                    | otherwise -> p+            Left e -> E.throw e+     c2w = fromIntegral . fromEnum  putPointer :: Int -> SPut

@@ -28,7 +28,7 @@  -- | 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.+-- address in the @SOA@ and @RP@ records. -- encodeMailbox :: Mailbox -> ByteString encodeMailbox = runSPut . putMailbox

@@ -64,6 +64,7 @@ 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 (RD_RP mbox dname)   = RD_RP (B.copy mbox) (B.copy dname) 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

@@ -323,10 +323,7 @@ -- 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 :: Word8 -> ByteString -> Either DNSError (ByteString, ByteString) parseLabel sep dom =     if BS.any (== bslash) dom     then toResult $ A.parse (labelParser sep mempty) dom@@ -337,9 +334,9 @@     toResult _ = bottom     safeTail bs | BS.null bs = mempty                 | otherwise = BS.tail bs-    check r@(hd, tl) | not (BS.null hd) || BS.null tl = r+    check r@(hd, tl) | not (BS.null hd) || BS.null tl = Right r                      | otherwise = bottom-    bottom = E.throw $ DecodeError $ "invalid domain: " ++ S8.unpack dom+    bottom = Left $ DecodeError $ "invalid domain: " ++ S8.unpack dom  labelParser :: Word8 -> ByteString -> A.Parser ByteString labelParser sep acc = do

@@ -59,7 +59,8 @@ -- 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.+-- 'Domain' above. This is most commonly seen in the /rname/ of @SOA@ records,+-- and is also employed in the @mbox-dname@ field of @RP@ 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@@ -75,7 +76,6 @@  ---------------------------------------------------------------- -#if __GLASGOW_HASKELL__ >= 800 -- | Types for resource records. newtype TYPE = TYPE {     -- | From type to number.@@ -108,6 +108,9 @@ -- | Text strings pattern TXT :: TYPE pattern TXT        = TYPE  16+-- | Responsible Person+pattern RP :: TYPE+pattern RP         = TYPE  17 -- | IPv6 Address pattern AAAA :: TYPE pattern AAAA       = TYPE  28@@ -163,96 +166,7 @@ -- | 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"@@ -262,6 +176,7 @@     show PTR        = "PTR"     show MX         = "MX"     show TXT        = "TXT"+    show RP         = "RP"     show AAAA       = "AAAA"     show SRV        = "SRV"     show DNAME      = "DNAME"@@ -825,7 +740,6 @@  ---------------------------------------------------------------- -#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.@@ -952,113 +866,7 @@ -- 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@@ -1169,6 +977,7 @@            | RD_PTR Domain       -- ^ A domain name pointer            | RD_MX Word16 Domain -- ^ Mail exchange            | RD_TXT ByteString   -- ^ Text strings+           | RD_RP Mailbox Domain -- ^ Responsible Person (RFC1183)            | RD_AAAA IPv6        -- ^ IPv6 Address            | RD_SRV Word16 Word16 Word16 Domain                                  -- ^ Server Selection (RFC2782)@@ -1203,6 +1012,7 @@       RD_PTR               ptrdname -> showDomain ptrdname       RD_MX               pref exch -> showMX pref exch       RD_TXT             textstring -> showTXT textstring+      RD_RP              mbox dname -> showRP mbox dname       RD_AAAA               address -> show address       RD_SRV        pri wei prt tgt -> showSRV pri wei prt tgt       RD_DNAME               target -> showDomain target@@ -1221,8 +1031,8 @@       showSalt ""    = "-"       showSalt salt  = _b16encode salt       showDomain = BS.unpack-      showSOA mname mrname serial refresh retry expire minttl =-          showDomain mname ++ " " ++ showDomain mrname ++ " " +++      showSOA mname rname serial refresh retry expire minttl =+          showDomain mname ++ " " ++ showDomain rname ++ " " ++           show serial ++ " " ++ show refresh ++ " " ++           show retry ++ " " ++ show expire ++ " " ++ show minttl       showMX preference exchange =@@ -1242,9 +1052,10 @@               let (q100, r100) = divMod (fromIntegral c) 100                   (q10, r10) = divMod r100 10                in intToDigit q100 : intToDigit q10 : intToDigit r10 : s+      showRP mbox dname = showDomain mbox ++ " " ++ showDomain dname       showSRV priority weight port target =           show priority ++ " " ++ show weight ++ " " ++-          show port ++ BS.unpack target+          show port ++ " " ++ BS.unpack target       showDS keytag alg digestType digest =           show keytag ++ " " ++ show alg ++ " " ++           show digestType ++ " " ++ _b16encode digest@@ -1486,7 +1297,6 @@  ---------------------------------------------------------------- -#if __GLASGOW_HASKELL__ >= 800 -- | EDNS Option Code (RFC 6891). newtype OptCode = OptCode {     -- | From option code to number.@@ -1520,34 +1330,6 @@ -- | 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  ---------------------------------------------------------------- 

@@ -1,12 +1,9 @@-{-# LANGUAGE OverloadedStrings, CPP #-}+{-# LANGUAGE OverloadedStrings #-}  module DecodeSpec where  import Data.ByteString.Internal (ByteString(..), unsafeCreate) import qualified Data.ByteString.Char8 as BC-#if !MIN_VERSION_bytestring(0,10,0)-import qualified Data.ByteString as BS-#endif import Data.Word8 import Foreign.ForeignPtr (withForeignPtr) import Foreign.Ptr (plusPtr)@@ -42,6 +39,28 @@ --              , authority = [] --              , additional = [OptRecord {orudpsize = 4096, ordnssecok = False, orversion = 0, rdata = []}]}) +-- Message with question domain == SOA rname, testing correct decoding of+-- of the rname to presentation form when it encoded in compressed form+-- as a pointer to the question domain.+test_soa_in :: DNSMessage+test_soa_in =+    let soard = RD_SOA "ns1.example.com." "hostmaster.example.com." 0 0 0 0 0+        soarr = ResourceRecord "example.com." SOA 1 3600 soard+     in defaultResponse { question = [Question "hostmaster.example.com." A]+                        , authority = [soarr] }++-- Expected decoded presentation form of the 'test_soa' message.+test_soa_out :: DNSMessage+test_soa_out =+    let soard = RD_SOA "ns1.example.com." "hostmaster@example.com." 0 0 0 0 0+        soarr = ResourceRecord "example.com." SOA 1 3600 soard+     in defaultResponse { question = [Question "hostmaster.example.com." A]+                        , authority = [soarr] }++-- Expected compressed encoding of the 'test_soa' message+test_soa_bytes :: ByteString+test_soa_bytes = "0000858000010000000100000a686f73746d6173746572076578616d706c6503636f6d0000010001c0170006000100000e10001c036e7331c017c00c0000000000000000000000000000000000000000"+ ----------------------------------------------------------------  spec :: Spec@@ -63,6 +82,15 @@             case decode (BC.init $ encode defaultQuery) of                 Left (DecodeError {}) -> True                 _ -> error "Excess input not detected"+        it "soa mailbox presentation form" $+            case encode test_soa_in of+                enc | enc /= fromHexString test_soa_bytes+                    -> error "Unexpected test_soa encoding"+                    | otherwise -> case decode enc of+                        Left err  -> error $ "Error decoding test_soa: " ++ show err+                        Right m | m /= test_soa_out+                                  -> error $ "Wrong decode of test_soa: " ++ show m+                                | otherwise -> True  tripleDecodeTest :: ByteString -> IO () tripleDecodeTest hexbs =

@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, CPP, TransformListComp #-}+{-# LANGUAGE OverloadedStrings, TransformListComp #-}  module RoundTripSpec where 

@@ -2,7 +2,7 @@  module IOSpec where -import Network.Socket+import Network.Socket hiding (send) import Test.Hspec  import Network.DNS.IO as DNS

@@ -26,7 +26,7 @@     it "lookupAAAA with emty result" $ do         rs <- makeResolvSeed defaultResolvConf         withResolver rs $ \resolver -> do-            addrs <- DNS.lookupAAAA resolver "mew.org"+            addrs <- DNS.lookupAAAA resolver "ipv4.tlund.se"             -- mew.org does not have any IPv6 addresses             fmap null addrs `shouldBe` Right True 

@@ -17,6 +17,8 @@ modules =   [ "-XOverloadedStrings"   , "-XCPP"+  , "-XLambdaCase"+  , "-XPatternSynonyms"   , "-i","-i.","-iinternal"   , "-threaded"   , "-package=dns"