dns 4.2.0 → 4.2.1
raw patch · 9 files changed
+73/−25 lines, 9 filesdep ~basePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base
API changes (from Hackage documentation)
Files
- Changelog.md +11/−0
- Network/DNS.hs +1/−1
- Network/DNS/LookupRaw.hs +2/−2
- Network/DNS/Transport.hs +8/−4
- dns.cabal +4/−4
- internal/Network/DNS/Decode/Parsers.hs +29/−10
- internal/Network/DNS/StateBinary.hs +3/−3
- internal/Network/DNS/Types/Internal.hs +1/−1
- test/DecodeSpec.hs +14/−0
Changelog.md view
@@ -1,5 +1,16 @@ # ChangeLog +## 4.2.1++- Security: decoding a domain name could consume a lot of CPU time and+ memory with a crafted message (very long names or many compression+ pointers). Now names longer than 255 octets and names that follow+ more than 127 compression pointers are rejected.+- Security: an undecodable UDP reply (possibly spoofed) aborted the+ lookup. Now it is dropped and the resolver keeps waiting.+- The TTL of negative cache entries is now capped by `maximumTTL`.+- Mailboxes are no longer stored in the domain name cache of the decoder.+ ## 4.2.0 - Switching cryptonite to crypton.
Network/DNS.hs view
@@ -40,7 +40,7 @@ -- | Encoding a query or response. , module Network.DNS.Decode- -- | Decoding a qurey or response.+ -- | Decoding a query or response. , module Network.DNS.IO -- | Sending and receiving.
Network/DNS/LookupRaw.hs view
@@ -152,13 +152,13 @@ soas = filter (SOA `isTypeOf`) $ authority ans insertNegative :: CacheConf -> Cache -> Key -> Entry -> TTL -> IO ()-insertNegative _ c k v ttl = when (ttl /= 0) $ do+insertNegative CacheConf{..} c k v ttl = when (ttl /= 0) $ do ctime <- timeCurrent let tim = ctime `timeAdd` life insertCache k tim v c where life :: Seconds- life = fromIntegral ttl+ life = fromIntegral (maximumTTL `min` ttl) isTypeOf :: TYPE -> ResourceRecord -> Bool isTypeOf t ResourceRecord{..} = rrtype == t
Network/DNS/Transport.hs view
@@ -183,12 +183,16 @@ -- to wait for the right answer, without resending the question. -- Note, this eliminates sequence mismatch as a UDP error condition, -- instead we'll time out if no matching answer arrives.+ -- Undecodable datagrams (possibly spoofed) are dropped likewise. -- getAns sock = do- resp <- rcv sock- if checkResp q ident resp- then return resp- else getAns sock+ eresp <- E.try $ rcv sock+ case eresp of+ Left (DecodeError _) -> getAns sock+ Left e -> E.throwIO e+ Right resp+ | checkResp q ident resp -> return resp+ | otherwise -> getAns sock ----------------------------------------------------------------
dns.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.0 name: dns-version: 4.2.0+version: 4.2.1 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto <kazu@iij.ad.jp>@@ -75,7 +75,7 @@ default-language: Haskell2010 ghc-options: -Wall build-depends:- base,+ base >=4 && <5, array, async, attoparsec,@@ -110,7 +110,7 @@ build-depends: dns, dns-internal,- base,+ base >=4 && <5, hspec, network @@ -130,7 +130,7 @@ dns, dns-internal, QuickCheck >=2.9,- base,+ base >=4 && <5, bytestring, case-insensitive, hspec,
internal/Network/DNS/Decode/Parsers.hs view
@@ -457,7 +457,20 @@ -- strictly decreasing sequence, which prevents pointer loops. -- getDomain' :: Word8 -> Int -> SGet ByteString-getDomain' sep1 ptrLimit = do+getDomain' sep1 ptrLimit = fst <$> getDomainW sep1 ptrLimit 0++-- | RFC 1035 limits the wire length of a domain name to 255 octets.+maxDomainLength :: Int+maxDomainLength = 255++-- | Upper bound of compression pointers followed for a single name.+maxPointerHops :: Int+maxPointerHops = 127++-- | Like 'getDomain'' but also returns the wire length of the name.+-- The third argument is the number of pointers already followed.+getDomainW :: Word8 -> Int -> Int -> SGet (ByteString, Int)+getDomainW sep1 ptrLimit hops = do pos <- getPosition c <- getInt8 let n = getValue c@@ -467,26 +480,28 @@ -- target (offset). getPtr pos offset = do msg <- getInput- let parser = skipNBytes offset >> getDomain' sep1 offset+ let parser = skipNBytes offset >> getDomainW sep1 offset (hops + 1) case runSGet parser msg of Left (DecodeError err) -> failSGet err Left err -> fail $ show err- Right o -> do+ 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)+ push pos o+ return o getdomain pos c n- | c == 0 = return "." -- Perhaps the root domain?+ | c == 0 = return (".", 1) -- Perhaps the root domain? | isPointer c = do d <- getInt8 let offset = n * 256 + d when (offset >= ptrLimit) $ failSGet "invalid name compression pointer"+ when (hops >= maxPointerHops) $+ failSGet "too many name compression pointers" if sep1 /= dot then getPtr pos offset else pop offset >>= \case@@ -494,15 +509,19 @@ Just o -> return o -- As for now, extended labels have no use. -- This may change some time in the future.- | isExtLabel c = return ""+ | isExtLabel c = return ("", 1) | otherwise = do hs <- unparseLabel sep1 <$> getNByteString n- ds <- getDomain' dot ptrLimit+ (ds, len) <- getDomainW dot ptrLimit hops+ let len' = n + 1 + len+ when (len' > maxDomainLength) $+ failSGet "domain name too long" let dom = case ds of -- avoid trailing ".." "." -> hs <> "." _ -> hs <> B.singleton sep1 <> ds- push pos dom- return dom+ when (sep1 == dot) $+ push pos (dom, len')+ return (dom, len') getValue c = c .&. 0x3f isPointer c = testBit c 7 && testBit c 6 isExtLabel c = not (testBit c 7) && testBit c 6
internal/Network/DNS/StateBinary.hs view
@@ -141,7 +141,7 @@ type SGet = StateT PState (T.Parser ByteString) data PState = PState {- psDomain :: IntMap Domain+ psDomain :: IntMap (Domain, Int) -- ^ with its wire length , psPosition :: Int , psInput :: ByteString , psAtTime :: Int64@@ -167,12 +167,12 @@ failSGet "malformed or truncated input" ST.put $ PState dom pos' inp t -push :: Int -> Domain -> SGet ()+push :: Int -> (Domain, Int) -> 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 :: Int -> SGet (Maybe (Domain, Int)) pop n = ST.gets (IM.lookup n . psDomain) ----------------------------------------------------------------
internal/Network/DNS/Types/Internal.hs view
@@ -1080,7 +1080,7 @@ show usage ++ " " ++ show selector ++ " " ++ show mtype ++ " " ++ _b16encode digest showCAA flags tag value =- show flags ++ " " ++ BS.unpack (CI.original tag) ++ " " ++ show value+ show flags ++ " " ++ BS.unpack (CI.original tag) ++ " " ++ showTXT value -- | Opaque RData: <https://tools.ietf.org/html/rfc3597#section-5> showOpaque bs = unwords ["\\#", show (BS.length bs), _b16encode bs]
test/DecodeSpec.hs view
@@ -82,6 +82,14 @@ case decode (BC.init $ encode defaultQuery) of Left (DecodeError {}) -> True _ -> error "Excess input not detected"+ it "accepts a name of 255 octets" $+ case decode (queryWithLabels 127) of+ Right _ -> True+ Left err -> error $ "Unexpected error: " ++ show err+ it "rejects a name longer than 255 octets" $+ case decode (queryWithLabels 128) of+ Left (DecodeError {}) -> True+ _ -> error "Too long name not detected" it "soa mailbox presentation form" $ case encode test_soa_in of enc | enc /= fromHexString test_soa_bytes@@ -91,6 +99,12 @@ Right m | m /= test_soa_out -> error $ "Wrong decode of test_soa: " ++ show m | otherwise -> True++-- A query whose qname consists of n one-octet labels.+queryWithLabels :: Int -> ByteString+queryWithLabels n =+ BC.pack $ "\0\0\1\0\0\1\0\0\0\0\0\0"+ ++ concat (replicate n "\1a") ++ "\0" ++ "\0\1\0\1" tripleDecodeTest :: ByteString -> IO () tripleDecodeTest hexbs =