dns 3.0.2 → 3.0.3

raw patch · 12 files changed

+233/−93 lines, 12 filesdep −conduitdep −conduit-extradep ~networkPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: conduit, conduit-extra

Dependency ranges changed: network

API changes (from Hackage documentation)

Files

• Changelog.md +6/−0
• Network/DNS/Decode.hs +7/−7
• Network/DNS/Decode/Internal.hs +60/−34
• Network/DNS/Encode.hs +6/−0
• Network/DNS/IO.hs +47/−18
• Network/DNS/Lookup.hs +9/−5
• Network/DNS/Memo.hs +1/−0
• Network/DNS/StateBinary.hs +24/−14
• Network/DNS/Types.hs +32/−8
• dns.cabal +3/−3
• test/DecodeSpec.hs +7/−4
• test2/IOSpec.hs +31/−0

@@ -1,3 +1,9 @@+# 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  - Supporting conduit 1.3 [#105](https://github.com/kazu-yamamoto/dns/pull/105)

@@ -20,12 +20,12 @@  -- | Decoding DNS query or response. -decode :: ByteString -> Either String DNSMessage+decode :: ByteString -> Either DNSError DNSMessage decode bs = fst <$> runSGet getResponse bs  -- | Parse many length-encoded DNS records, for example, from TCP traffic. -decodeMany :: ByteString -> Either String ([DNSMessage], ByteString)+decodeMany :: ByteString -> Either DNSError ([DNSMessage], ByteString) decodeMany bs = do     ((bss, _), leftovers) <- runSGetWithLeftovers lengthEncoded bs     msgs <- mapM decode bss@@ -38,21 +38,21 @@       getNByteString len  -- | Decoding DNS flags.-decodeDNSFlags :: ByteString -> Either String DNSFlags+decodeDNSFlags :: ByteString -> Either DNSError DNSFlags decodeDNSFlags bs = fst <$> runSGet getDNSFlags bs  -- | Decoding DNS header.-decodeDNSHeader :: ByteString -> Either String DNSHeader+decodeDNSHeader :: ByteString -> Either DNSError DNSHeader decodeDNSHeader bs = fst <$> runSGet getHeader bs  -- | Decoding domain.-decodeDomain :: ByteString -> Either String Domain+decodeDomain :: ByteString -> Either DNSError Domain decodeDomain bs = fst <$> runSGet getDomain bs  -- | Decoding mailbox.-decodeMailbox :: ByteString -> Either String Mailbox+decodeMailbox :: ByteString -> Either DNSError Mailbox decodeMailbox bs = fst <$> runSGet getMailbox bs  -- | Decoding resource record.-decodeResourceRecord :: ByteString -> Either String ResourceRecord+decodeResourceRecord :: ByteString -> Either DNSError ResourceRecord decodeResourceRecord bs = fst <$> runSGet getResourceRecord bs

@@ -33,7 +33,6 @@                   <*> getResourceRecords nsCount                   <*> getResourceRecords arCount - ----------------------------------------------------------------  getDNSFlags :: SGet DNSFlags@@ -83,8 +82,8 @@  getQuery :: SGet Question getQuery = Question <$> getDomain-                       <*> getTYPE-                       <*  ignoreClass+                    <*> getTYPE+                    <*  ignoreClass  getResourceRecords :: Int -> SGet [ResourceRecord] getResourceRecords n = replicateM n getResourceRecord@@ -174,6 +173,7 @@     decodeDval = getNByteString (len - 4) -- getRData NULL len = const RD_NULL <$> getNByteString len+-- getRData DNSKEY len = RD_DNSKEY <$> decodeKeyFlags                                 <*> decodeKeyProto                                 <*> decodeKeyAlg@@ -184,6 +184,22 @@     decodeKeyAlg    = get8     decodeKeyBytes  = getNByteString (len - 4) --+getRData NSEC3PARAM len = RD_NSEC3PARAM <$> decodeHashAlg+                                <*> decodeFlags+                                <*> decodeIterations+                                <*> decodeSalt+  where+    decodeHashAlg    = get8+    decodeFlags      = get8+    decodeIterations = get16+    decodeSalt       = do+        let n = len - 5+        slen <- get8+        guard $ fromIntegral slen == n+        if (n == 0)+        then return B.empty+        else getNByteString n+-- getRData _  len = UnknownRData <$> getNByteString len  getOData :: OptCode -> Int -> SGet OData@@ -202,44 +218,54 @@ ----------------------------------------------------------------  getDomain :: SGet Domain-getDomain = getDomain' '.'+getDomain = do+    lim <- B.length <$> getInput+    getDomain' '.' lim 0  getMailbox :: SGet Mailbox-getMailbox = getDomain' '@'+getMailbox = do+    lim <- B.length <$> getInput+    getDomain' '@' lim 0  -- | Get a domain name, using sep1 as the separate between the 1st and 2nd -- label.  Subsequent labels (and always the trailing label) are terminated -- with a ".".-getDomain' :: Char -> SGet ByteString-getDomain' sep1 = do-    pos <- getPosition-    c <- getInt8-    let n = getValue c-    -- Syntax hack to avoid using MultiWayIf-    case () of-        _ | c == 0 -> return "." -- Perhaps the root domain?-        _ | isPointer c -> do-            d <- getInt8-            let offset = n * 256 + d-            mo <- pop offset-            case mo of-                Nothing -> fail $ "getDomain: " ++ show offset-                -- A pointer may refer to another pointer.-                -- So, register this position for the domain.-                Just o -> push pos o >> return o-        -- As for now, extended labels have no use.-        -- This may change some time in the future.-        _ | isExtLabel c -> return ""-        _ -> do-            hs <- getNByteString n-            ds <- getDomain' '.'-            let dom =-                    case ds of -- avoid trailing ".."-                        "." -> hs `BS.append` "."-                        _   -> hs `BS.append` BS.singleton sep1 `BS.append` ds-            push pos dom-            return dom+getDomain' :: Char -> Int -> Int -> SGet ByteString+getDomain' sep1 lim loopcnt+  -- 127 is the logical limitation of pointers.+  | loopcnt >= 127 = fail "pointer recursion limit exceeded"+  | otherwise      = do+      pos <- getPosition+      c <- getInt8+      let n = getValue c+      getdomain pos c n   where+    getdomain pos c n+      | c == 0 = return "." -- Perhaps the root domain?+      | isPointer c = do+          d <- getInt8+          let offset = n * 256 + d+          when (offset >= lim) $ fail "pointer is too large"+          mo <- pop offset+          case mo of+              Nothing -> do+                  target <- B.drop offset <$> getInput+                  case runSGet (getDomain' sep1 lim (loopcnt + 1)) target of+                        Left (DecodeError err) -> fail err+                        Left err               -> fail $ show err+                        Right o  -> push pos (fst o) >> return (fst o)+              Just o -> push pos o >> return o+      -- As for now, extended labels have no use.+      -- This may change some time in the future.+      | isExtLabel c = return ""+      | otherwise = do+          hs <- getNByteString n+          ds <- getDomain' '.' lim (loopcnt + 1)+          let dom = case ds of -- avoid trailing ".."+                  "." -> hs `BS.append` "."+                  _   -> hs `BS.append` BS.singleton sep1 `BS.append` ds+          push pos dom+          return dom     getValue c = c .&. 0x3f     isPointer c = testBit c 7 && testBit c 6     isExtLabel c = not (testBit c 7) && testBit c 6

@@ -166,6 +166,12 @@         , put8 a         , putByteString k         ]+    (RD_NSEC3PARAM h f i s) -> mconcat+        [ put8 h+        , put8 f+        , put16 i+        , putByteStringWithLength s+        ]     UnknownRData bytes -> putByteString bytes  putOData :: OData -> SPut

@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}  module Network.DNS.IO (     -- * Receiving from socket@@ -26,51 +27,79 @@ #define GHC708 #endif -import qualified Control.Monad.State as ST+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 import Data.Char (ord)-import Data.Conduit (($$+), ($$+-), ConduitM, (.|), runConduit)-import Data.Conduit.Attoparsec (sinkParser)-import qualified Data.Conduit.Binary as CB-import Data.Conduit.Network (sourceSocket) import Data.IP (IPv4, IPv6) import Network.Socket (Socket)+import System.IO.Error + #if defined(WIN) && defined(GHC708)-import Network.Socket (send)+import Network.Socket (send, recv) import qualified Data.ByteString.Char8 as BS #else-import Network.Socket.ByteString (sendAll)+import Network.Socket.ByteString (sendAll, recv) #endif -import Network.DNS.Decode.Internal (getResponse)+import Network.DNS.Decode (decode) import Network.DNS.Encode (encode) import Network.DNS.Imports-import Network.DNS.StateBinary (PState, initialState) import Network.DNS.Types  ---------------------------------------------------------------- -sink :: ConduitM ByteString o IO (DNSMessage, PState)-sink = sinkParser $ ST.runStateT getResponse initialState- -- | Receiving DNS data from 'Socket' and parse it.  receive :: Socket -> IO DNSMessage-receive sock = fst <$> runConduit (sourceSocket sock .| sink)+receive sock = do+    let bufsiz = fromIntegral maxUdpSize+    bs <- recv sock bufsiz `E.catch` \e -> E.throwIO $ NetworkFailure e+    case decode bs of+        Left  e   -> E.throwIO e+        Right msg -> return msg  -- | Receive and parse a single virtual-circuit (TCP) query or response. --   It is up to the caller to implement any desired timeout.  receiveVC :: Socket -> IO DNSMessage receiveVC sock = do-    (src, lenbytes) <- sourceSocket sock $$+ CB.take 2-    let len = case map ord $ LBS.unpack lenbytes of-                [hi, lo] -> 256 * hi + lo-                _        -> 0-    fst <$> (src $$+- CB.isolate len .| sink)+    len <- toLen <$> recvDNS sock 2+    bs <- recvDNS sock len+    case decode bs of+        Left e    -> E.throwIO e+        Right msg -> return msg+  where+    toLen bs = case map ord $ BS.unpack bs of+        [hi, lo] -> 256 * hi + lo+        _        -> 0              -- never reached++recvDNS :: Socket -> Int -> IO ByteString+recvDNS sock len = recv1 `E.catch` \e -> E.throwIO $ NetworkFailure e+  where+    recv1 = do+        bs1 <- recvCore len+        if BS.length bs1 == len then+            return bs1+          else do+            loop bs1+    loop bs0 = do+        let left = len - BS.length bs0+        bs1 <- recvCore left+        let bs = bs0 `BS.append` bs1+        if BS.length bs == len then+            return bs+          else+            loop bs+    eofE = mkIOError eofErrorType "connection terminated" Nothing Nothing+    recvCore len0 = do+        bs <- recv sock len0+        if bs == "" then+            E.throwIO eofE+          else+            return bs  ---------------------------------------------------------------- 

@@ -309,12 +309,16 @@  ---------------------------------------------------------------- --- | Look up the \'SOA\' record for the given domain. The results include the---   domain, mailbox, serial number, refresh time, retry time, expiration---   time, and minimum TTL.+-- | Look up the \'SOA\' record for the given domain. The result 7-tuple+--   consists of the \'mname\', \'rname\', \'serial\', \'refresh\', \'retry\',+--   \'expire\' and \'minimum\' fields of the SOA record. -----   This can be useful to validate TTLs for a server or get an abuse---   contact address for a domain.+--   An \@ separator is used between the first and second labels of the+--   \'rname\' field.  Since \'rname\' is an email address, it often contains+--   periods within its first label.  Presently, the trailing period is not+--   removed from the domain part of the \'rname\', but this may change in the+--   future.  Users should be prepared to remove any trailing period before+--   using the \'rname\` as a contact email address. -- --   >>> rs <- makeResolvSeed defaultResolvConf --   >>> withResolver rs $ \resolver -> lookupSOA resolver "mew.org"

@@ -68,6 +68,7 @@ copy (RD_DS t a dt dv)    = RD_DS t a dt $ B.copy dv copy (RD_DNSKEY f p a k)  = RD_DNSKEY f p a $ B.copy k copy (RD_TLSA a b c dgst) = RD_TLSA a b c $ B.copy dgst+copy (RD_NSEC3PARAM a b c salt) = RD_NSEC3PARAM a b c $ B.copy salt copy (UnknownRData is)    = UnknownRData $ B.copy is  copyOData :: OData -> OData

@@ -24,6 +24,7 @@   , getInt32   , getNByteString   , getPosition+  , getInput   , wsPop   , wsPush   , wsPosition@@ -122,6 +123,7 @@ data PState = PState {     psDomain :: IntMap Domain   , psPosition :: Int+  , psInput :: ByteString   }  ----------------------------------------------------------------@@ -129,15 +131,18 @@ getPosition :: SGet Int getPosition = psPosition <$> ST.get +getInput :: SGet ByteString+getInput = psInput <$> ST.get+ addPosition :: Int -> SGet () addPosition n = do-    PState dom pos <- ST.get-    ST.put $ PState dom (pos + n)+    PState dom pos inp <- ST.get+    ST.put $ PState dom (pos + n) inp  push :: Int -> Domain -> SGet () push n d = do-    PState dom pos <- ST.get-    ST.put $ PState (IM.insert n d dom) pos+    PState dom pos inp <- ST.get+    ST.put $ PState (IM.insert n d dom) pos inp  pop :: Int -> SGet (Maybe Domain) pop n = IM.lookup n . psDomain <$> ST.get@@ -188,19 +193,24 @@  ---------------------------------------------------------------- -initialState :: PState-initialState = PState IM.empty 0+initialState :: ByteString -> PState+initialState inp = PState IM.empty 0 inp -runSGet :: SGet a -> ByteString -> Either String (a, PState)-runSGet parser bs = A.eitherResult $ A.parse (ST.runStateT parser initialState) bs+runSGet :: SGet a -> ByteString -> Either DNSError (a, PState)+runSGet parser inp = toResult $ A.parse (ST.runStateT parser $ initialState inp) inp+  where+    toResult :: A.Result r -> Either DNSError r+    toResult (A.Done _ r)        = Right r+    toResult (A.Fail _ _ msg)    = Left $ DecodeError msg+    toResult (A.Partial _)       = Left $ DecodeError "incomplete input" -runSGetWithLeftovers :: SGet a -> ByteString -> Either String ((a, PState), ByteString)-runSGetWithLeftovers parser bs = toResult $ A.parse (ST.runStateT parser initialState) bs+runSGetWithLeftovers :: SGet a -> ByteString -> Either DNSError ((a, PState), ByteString)+runSGetWithLeftovers parser inp = toResult $ A.parse (ST.runStateT parser $ initialState inp) inp   where-    toResult :: A.Result r -> Either String (r, ByteString)-    toResult (A.Done i r) = Right (r, i)-    toResult (A.Partial f) = toResult $ f BS.empty-    toResult (A.Fail _ _ err) = Left err+    toResult :: A.Result r -> Either DNSError (r, ByteString)+    toResult (A.Done     i r) = Right (r, i)+    toResult (A.Partial  f)   = toResult $ f BS.empty+    toResult (A.Fail _ _ err) = Left $ DecodeError err  runSPut :: SPut -> ByteString runSPut = LBS.toStrict . BB.toLazyByteString . flip ST.evalState initialWState

@@ -80,6 +80,8 @@   -- * EDNS0   , EDNS0   , defaultEDNS0+  , maxUdpSize+  , minUdpSize   -- ** Accessors   , udpSize   , extRCODE@@ -114,13 +116,14 @@ type Domain = ByteString  -- | Type for a mailbox encoded on the wire as a DNS name, but the first label--- is conceptually the user name, and sometimes has internal '.' characters--- that are not label separators.+-- is conceptually the user name, and sometimes has contains internal periods+-- that are not label separators. Therefore, in mailboxes \@ is used as the+-- separator between the first and second labels. type Mailbox = ByteString  ---------------------------------------------------------------- -#if __GLASGOW_HASKELL__ >= 800+#if __GLASGOW_HASKELL__ >= 802 -- | Types for resource records. newtype TYPE = TYPE {     -- | From type to number.@@ -352,6 +355,7 @@     -- | Network failure.   | NetworkFailure IOException     -- | Error is unknown+  | DecodeError String   | UnknownDNSError   deriving (Eq, Show, Typeable) @@ -418,7 +422,7 @@  ---------------------------------------------------------------- -#if __GLASGOW_HASKELL__ >= 800+#if __GLASGOW_HASKELL__ >= 802 -- | Response code including EDNS0's 12bit ones. newtype RCODE = RCODE {     -- | From rcode to number.@@ -646,7 +650,7 @@            | RD_DNSKEY Word16 Word8 Word8 ByteString                                  -- ^ DNSKEY (RFC4034)            --RD_NSEC3-           --RD_NSEC3PARAM+           | RD_NSEC3PARAM Word8 Word8 Word16 ByteString            | RD_TLSA Word8 Word8 Word8 ByteString                                  -- ^ TLSA (RFC6698)            --RD_CDS@@ -674,6 +678,10 @@   show (RD_DS t a dt dv) = show t ++ " " ++ show a ++ " " ++ show dt ++ " " ++ hexencode dv   show RD_NULL = "NULL"   show (RD_DNSKEY f p a k) = show f ++ " " ++ show p ++ " " ++ show a ++ " " ++ b64encode k+  show (RD_NSEC3PARAM h f i s) = show h ++ " " ++ show f ++ " " ++ show i ++ " " ++ showSalt s+    where+      showSalt ""    = "-"+      showSalt salt  = hexencode salt  hexencode :: ByteString -> String hexencode = BS.unpack . L.toStrict . L.toLazyByteString . L.byteStringHex@@ -737,7 +745,7 @@   , options  :: [OData]   } deriving (Eq, Show) -#if __GLASGOW_HASKELL__ >= 800+#if __GLASGOW_HASKELL__ >= 802 -- | Default information for EDNS0. -- -- >>> defaultEDNS0@@ -751,6 +759,22 @@ defaultEDNS0 :: EDNS0 defaultEDNS0 = EDNS0 4096 NoErr False [] +-- | Maximum UDP size. If 'udpSize' of 'EDNS0' is larger than this,+--   'fromEDNS0' uses this value instead.+--+-- >>> maxUdpSize+-- 16384+maxUdpSize :: Word16+maxUdpSize = 16384++-- | Minimum UDP size. If 'udpSize' of 'EDNS0' is smaller than this,+--   'fromEDNS0' uses this value instead.+--+-- >>> minUdpSize+-- 512+minUdpSize :: Word16+minUdpSize = 512+ -- | Generating a resource record for the additional section based on EDNS0. -- 'DNSFlags' is not generated. -- Just set the same 'RCODE' to 'DNSFlags'.@@ -759,7 +783,7 @@   where     name'  = "."     type'  = OPT-    class' = udpSize edns+    class' = maxUdpSize `min` (minUdpSize `max` udpSize edns)     ttl0'   = fromIntegral (fromRCODE (extRCODE edns) .&. 0x0ff0) `shiftL` 20     ttl'       | dnssecOk edns = ttl0' `setBit` 15@@ -779,7 +803,7 @@  ---------------------------------------------------------------- -#if __GLASGOW_HASKELL__ >= 800+#if __GLASGOW_HASKELL__ >= 802 -- | EDNS0 Option Code (RFC 6891). newtype OptCode = OptCode {     -- | From option code to number.

@@ -1,5 +1,5 @@ Name:                   dns-Version:                3.0.2+Version:                3.0.3 Author:                 Kazu Yamamoto <kazu@iij.ad.jp> Maintainer:             Kazu Yamamoto <kazu@iij.ad.jp> License:                BSD3@@ -41,8 +41,6 @@                       , base64-bytestring                       , binary                       , bytestring-                      , conduit >= 1.1-                      , conduit-extra >= 1.1                       , containers                       , cryptonite                       , iproute >= 1.3.2@@ -63,10 +61,12 @@   Ghc-Options:          -Wall   Main-Is:              Spec.hs   Other-Modules:        LookupSpec+                        IOSpec   Build-Depends:        dns                       , base                       , bytestring                       , hspec+                      , network  Test-Suite spec   Type:                 exitcode-stdio-1.0

@@ -56,13 +56,16 @@  tripleDecodeTest :: ByteString -> IO () tripleDecodeTest hexbs =-    ecase (decode $ fromHexString hexbs) fail $ \ x1 ->-        ecase (decode $ encode x1) fail $ \ x2 ->-            ecase (decode $ encode x2) fail $ \ x3 ->+    ecase (decode $ fromHexString hexbs) fail' $ \ x1 ->+        ecase (decode $ encode x1) fail' $ \ x2 ->+            ecase (decode $ encode x2) fail' $ \ x3 ->                 x3 `shouldBe` x2+  where+    fail' (DecodeError err) = fail err+    fail' _                 = error "fail'"  ecase :: Either a b -> (a -> c) -> (b -> c) -> c-ecase (Left a) f _ = f a+ecase (Left  a) f _ = f a ecase (Right b) _ g = g b  ----------------------------------------------------------------

@@ -0,0 +1,31 @@+{-# LANGUAGE OverloadedStrings #-}++module IOSpec where++import Network.DNS.IO as DNS+import Network.DNS.Types as DNS+import Network.Socket hiding (send)+import Test.Hspec++spec :: Spec+spec = describe "send/receive" $ do++    it "resolves well with UDP" $ do+        let hints = defaultHints { addrFamily = AF_INET, addrSocketType = Datagram, addrFlags = [AI_NUMERICHOST]}+        addr:_ <- getAddrInfo (Just hints) (Just "8.8.8.8") (Just "domain")+        sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)+        connect sock $ addrAddress addr+        let qry = encodeQuestions 1 [Question "www.mew.org" A] [] False+        send sock qry+        ans <- receive sock+        identifier (header ans) `shouldBe` 1++    it "resolves well with TCP" $ do+        let hints = defaultHints { addrFamily = AF_INET, addrSocketType = Stream, addrFlags = [AI_NUMERICHOST]}+        addr:_ <- getAddrInfo (Just hints) (Just "8.8.8.8") (Just "domain")+        sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)+        connect sock $ addrAddress addr+        let qry = encodeQuestions 1 [Question "www.mew.org" A] [] False+        sendVC sock qry+        ans <- receiveVC sock+        identifier (header ans) `shouldBe` 1