diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -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. diff --git a/Network/DNS.hs b/Network/DNS.hs --- a/Network/DNS.hs +++ b/Network/DNS.hs @@ -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. diff --git a/Network/DNS/LookupRaw.hs b/Network/DNS/LookupRaw.hs --- a/Network/DNS/LookupRaw.hs +++ b/Network/DNS/LookupRaw.hs @@ -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 diff --git a/Network/DNS/Transport.hs b/Network/DNS/Transport.hs --- a/Network/DNS/Transport.hs +++ b/Network/DNS/Transport.hs @@ -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 ---------------------------------------------------------------- diff --git a/dns.cabal b/dns.cabal --- a/dns.cabal +++ b/dns.cabal @@ -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 @@ -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, diff --git a/internal/Network/DNS/Decode/Parsers.hs b/internal/Network/DNS/Decode/Parsers.hs --- a/internal/Network/DNS/Decode/Parsers.hs +++ b/internal/Network/DNS/Decode/Parsers.hs @@ -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 diff --git a/internal/Network/DNS/StateBinary.hs b/internal/Network/DNS/StateBinary.hs --- a/internal/Network/DNS/StateBinary.hs +++ b/internal/Network/DNS/StateBinary.hs @@ -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) ---------------------------------------------------------------- diff --git a/internal/Network/DNS/Types/Internal.hs b/internal/Network/DNS/Types/Internal.hs --- a/internal/Network/DNS/Types/Internal.hs +++ b/internal/Network/DNS/Types/Internal.hs @@ -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: showOpaque bs = unwords ["\\#", show (BS.length bs), _b16encode bs] diff --git a/test/DecodeSpec.hs b/test/DecodeSpec.hs --- a/test/DecodeSpec.hs +++ b/test/DecodeSpec.hs @@ -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 =