CVE-2021-4249 (Other, published 2022-12-18T15:15Z)
Description: value: A vulnerability was found in xml-conduit. It has been classified as problematic. Affected is an unknown function of the file xml-conduit/src/Text/XML/Stream/Parse.hs of the component DOCTYPE Entity Expansion Handler. The manipulation leads to infinite loop. It is possible to launch the attack remotely. Upgrading to version 1.9.1.0 is able to address this issue. The name of the patch is 4be1021791dcdee8b164d239433a2043dc0939ea. It is recommended to upgrade the affected component. The identifier of this vulnerability is VDB-216204.
Severity: nan (CVSS v3 base score: 7.5)
Weakness: CWE-404 \u2014 Improper Resource Shutdown or Release
The product does not release or incorrectly releases a resource before it is made available for re-use.
Repository: https://github.com/snoyberg/xml
Files changed:
xml-conduit/src/Text/XML/Stream/Parse.hs
xml-conduit/test/unit.hs
Commit message: Resolve entities defined in DOCTYPE recursively

Entity expansion loops are detected and avoided.

In addition, there is a limit on the length of an
entity expansion (to guard against attacks like the
billion laughs attack). This can be adjusted using
the new exported field `psEntityExpansionSizeLimit`
on ParseSettings. By default it is set at 8192.

Add tests, including a test for the billion laughs attack.

Vulnerable code:
            | otherwise = (((tname, map resolve val):) .)
    resolve (ContentEntity e)
        | Just t <- lookup e es = ContentText t
    resolve c = c
tokenToEvent _ es n (TokenContent (ContentEntity e))
    | Just t <- lookup e es = (es, n, [EventContent $ ContentText t])
parseContent (ParseSettings decodeEntities _ decodeIllegalCharacters) breakDouble breakSingle = parseReference <|> parseTextContent where

Fixed code:
    , psEntityExpansionSizeLimit
            | otherwise = (((tname, resolveEntities ps es val):) .)
tokenToEvent ps es n (TokenContent (ContentEntity e))
    = (es, n, map EventContent (resolveEntities ps es [ContentEntity e]))
resolveEntities :: ParseSettings
                -> [(Text, Text)]  -- entity table
                -> [Content]
                -> [Content]
resolveEntities ps entities = foldr go []
 where
  go c@(ContentEntity e) cs
    = case expandEntity entities e of
        Just xs -> foldr go cs xs
        Nothing ->  c : cs
  go c cs = c:cs
  expandEntity es e
    | Just t <- lookup e es =
      case AT.parseOnly (manyTill
                          (parseContent ps False False :: Parser Content)
                          AT.endOfInput) t of
        Left _      -> Nothing
        Right xs    -> let es' = filter (\(x,_) -> x /= e) es
                        in fst <$> foldr (goent es') (Just ([], 0)) xs
          -- we delete e from the entity map in resolving its contents,
          -- to avoid infinite loops in recursive expansion.
    | otherwise     = Nothing
  goent _ _ Nothing = Nothing
  goent es (ContentEntity e) (Just (cs, size))
    = expandEntity es e >>= foldr (goent es) (Just (cs, size))
  goent _ c@(ContentText t) (Just (cs, size)) =
    case size + T.length t of
      n | n > psEntityExpansionSizeLimit ps -> Nothing
        | otherwise -> Just (c:cs, size + T.length t)


    , psEntityExpansionSizeLimit :: Int
    -- ^ Maximum number of characters allowed in expanding an
    -- internal entity.  This is intended to protect against the
    -- billion laughs attack.
    --
    -- Default: @8192@
    --
    -- Since 1.9.1
        , psEntityExpansionSizeLimit = 8192
parseContent (ParseSettings decodeEntities _ decodeIllegalCharacters _) breakDouble breakSingle = parseReference <|> parseTextContent where
        it "can expand inline entities recursively" resolvedInlineRecursive
        it "doesn't explode with an inline entity loop" resolvedInlineLoop
        it "doesn't explode with the billion laughs attack" billionLaughs
        it "allows entity expansion size limit to be adjusted" thousandLaughs
resolvedInlineRecursive :: Assertion
resolvedInlineRecursive = do
    Res.Document _ root _ <- return $ Res.parseLBS_ Res.def
      "<!DOCTYPE foo [<!ENTITY bim \"baz\"><!ENTITY bar \"&bim;&#73;&amp;\">]><foo>&bar;</foo>"
    root @?= Res.Element "foo" Map.empty [Res.NodeContent "bazI&"]

resolvedInlineLoop :: Assertion
resolvedInlineLoop = do
    res <- return $ Res.parseLBS Res.def
           "<!DOCTYPE foo [<!ENTITY bim \"&bim;\">]><foo>&bim;</foo>"
    Left (toException $ Res.UnresolvedEntityException (Set.fromList ["bim"]))
      `showEq` res

billionLaughs :: Assertion
billionLaughs = do
    res <- return $ Res.parseLBS Res.def
      "<?xml version=\"1.0\"?><!DOCTYPE lolz [<!ENTITY lol \"lol\"><!ELEMENT lolz (#PCDATA)><!ENTITY lol1 \"&lol;&lol;&lol;&lol;&lol;&lol;&lol;&lol;&lol;&lol;\"><!ENTITY lol2 \"&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;\"><!ENTITY lol3 \"&lol2;&lol2;&lol2;&lol2;&lol2;&lol2;&lol2;&lol2;&lol2;&lol2;\"><!ENTITY lol4 \"&lol3;&lol3;&lol3;&lol3;&lol3;&lol3;&lol3;&lol3;&lol3;&lol3;\"><!ENTITY lol5 \"&lol4;&lol4;&lol4;&lol4;&lol4;&lol4;&lol4;&lol4;&lol4;&lol4;\"><!ENTITY lol6 \"&lol5;&lol5;&lol5;&lol5;&lol5;&lol5;&lol5;&lol5;&lol5;&lol5;\"><!ENTITY lol7 \"&lol6;&lol6;&lol6;&lol6;&lol6;&lol6;&lol6;&lol6;&lol6;&lol6;\"><!ENTITY lol8 \"&lol7;&lol7;&lol7;&lol7;&lol7;&lol7;&lol7;&lol7;&lol7;&lol7;\"><!ENTITY lol9 \"&lol8;&lol8;&lol8;&lol8;&lol8;&lol8;&lol8;&lol8;&lol8;&lol8;\">]><lolz>&lol9;</lolz>"
    Left (toException $ Res.UnresolvedEntityException (Set.fromList ["lol9"]))
      `showEq` res

thousandLaughs :: Assertion
thousandLaughs = do
    res <- return $ Res.parseLBS Res.def{ P.psEntityExpansionSizeLimit = 2999 }
      "<?xml version=\"1.0\"?><!DOCTYPE lolz [<!ENTITY lol \"lol\"><!ELEMENT lolz (#PCDATA)><!ENTITY lol1 \"&lol;&lol;&lol;&lol;&lol;&lol;&lol;&lol;&lol;&lol;\"><!ENTITY lol2 \"&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;\"><!ENTITY lol3 \"&lol2;&lol2;&lol2;&lol2;&lol2;&lol2;&lol2;&lol2;&lol2;&lol2;\">]><lolz>&lol3;</lolz>"
    Left (toException $ Res.UnresolvedEntityException (Set.fromList ["lol3"]))
      `showEq` res
    -- Raise the entity expansion limit and it should work:
    Right (Res.Document {Res.documentRoot = Res.Element{ Res.elementNodes = [Res.NodeContent t] }}) <- return $ Res.parseLBS Res.def{ P.psEntityExpansionSizeLimit = 3001 } "<?xml version=\"1.0\"?><!DOCTYPE lolz [<!ENTITY lol \"lol\"><!ELEMENT lolz (#PCDATA)><!ENTITY lol1 \"&lol;&lol;&lol;&lol;&lol;&lol;&lol;&lol;&lol;&lol;\"><!ENTITY lol2 \"&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;\"><!ENTITY lol3 \"&lol2;&lol2;&lol2;&lol2;&lol2;&lol2;&lol2;&lol2;&lol2;&lol2;\">]><lolz>&lol3;</lolz>"
    t @?= T.replicate 1000 "lol"