CVE-2021-4249: Improper Resource Shutdown or Release (CWE-404)
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.
CWE description: The product does not release or incorrectly releases a resource before it is made available for re-use.
CVSS v3 base score: 7.5
Published: 2022-12-18T15:15Z
Repository: https://github.com/snoyberg/xml
Language: Other
Files changed: xml-conduit/src/Text/XML/Stream/Parse.hs, xml-conduit/test/unit.hs
Commit date: 2021-02-26 19:56:37 +0100
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.
Diff: diff --git a/xml-conduit/src/Text/XML/Stream/Parse.hs b/xml-conduit/src/Text/XML/Stream/Parse.hs
index 906ef0a..5870b2c 100644
--- a/xml-conduit/src/Text/XML/Stream/Parse.hs
+++ b/xml-conduit/src/Text/XML/Stream/Parse.hs
@@ -79,10 +79,11 @@ module Text.XML.Stream.Parse
     , DecodeEntities
     , DecodeIllegalCharacters
     , psDecodeEntities
     , psDecodeIllegalCharacters
     , psRetainNamespaces
+    , psEntityExpansionSizeLimit
       -- *** Entity decoding
     , decodeXmlEntities
     , decodeHtmlEntities
       -- * Event parsing
     , tag
@@ -194,11 +195,11 @@ tokenToEvent ps es n (TokenBeginElement name as isClosed _) =
         isPrefixed = kpref == Just "xmlns"
         isUnprefixed = isNothing kpref && kname == "xmlns"
 
         addNS
             | not (psRetainNamespaces ps) && (isPrefixed || isUnprefixed) = id
-            | otherwise = (((tname, map resolve val):) .)
+            | otherwise = (((tname, resolveEntities ps es val):) .)
           where
             tname
                 | isPrefixed = TName Nothing ("xmlns:" `T.append` kname)
                 | otherwise = TName kpref kname
 
@@ -210,13 +211,10 @@ tokenToEvent ps es n (TokenBeginElement name as isClosed _) =
                 l { defaultNS = if T.null $ contentsToText val
                                             then Nothing
                                             else Just $ contentsToText val }
             | otherwise = l
 
-    resolve (ContentEntity e)
-        | Just t <- lookup e es = ContentText t
-    resolve c = c
     n' = if isClosed then n else l' : n
     fixAttName (name', val) = (tnameToName True l' name', val)
     elementName = tnameToName False l' name
     begin = EventBeginElement elementName $ map fixAttName $ as' []
     end = EventEndElement elementName
@@ -225,17 +223,48 @@ tokenToEvent _ es n (TokenEndElement name) =
   where
     (l, n') =
         case n of
             []   -> (NSLevel Nothing Map.empty, [])
             x:xs -> (x, xs)
-tokenToEvent _ es n (TokenContent (ContentEntity e))
-    | Just t <- lookup e es = (es, n, [EventContent $ ContentText t])
+tokenToEvent ps es n (TokenContent (ContentEntity e))
+    = (es, n, map EventContent (resolveEntities ps es [ContentEntity e]))
 tokenToEvent _ es n (TokenContent c) = (es, n, [EventContent c])
 tokenToEvent _ es n (TokenComment c) = (es, n, [EventComment c])
 tokenToEvent _ es n (TokenDoctype t eid es') = (es ++ es', n, [EventBeginDoctype t eid, EventEndDoctype])
 tokenToEvent _ es n (TokenCDATA t) = (es, n, [EventCDATA t])
 
+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)
+
+
 tnameToName :: Bool -> NSLevel -> TName -> Name
 tnameToName _ _ (TName (Just "xml") name) =
     Name name (Just "http://www.w3.org/XML/1998/namespace") (Just "xml")
 tnameToName isAttr (NSLevel def' _) (TName Nothing name) =
     Name name (if isAttr then Nothing else def') Nothing
@@ -405,17 +434,26 @@ data ParseSettings = ParseSettings
     -- Others are passed to this function.
     --
     -- Default: @const Nothing@
     --
     -- Since 1.7.1
+    , 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
     }
 
 instance Default ParseSettings where
     def = ParseSettings
         { psDecodeEntities = decodeXmlEntities
         , psRetainNamespaces = False
         , psDecodeIllegalCharacters = const Nothing
+        , psEntityExpansionSizeLimit = 8192
         }
 
 conduitToken :: MonadThrow m => ParseSettings -> ConduitT T.Text (PositionRange, Token) m ()
 conduitToken = conduitParser . parseToken
 
@@ -553,11 +591,11 @@ parseIdent =
 
 parseContent :: ParseSettings
              -> Bool -- break on double quote
              -> Bool -- break on single quote
              -> Parser Content
-parseContent (ParseSettings decodeEntities _ decodeIllegalCharacters) breakDouble breakSingle = parseReference <|> parseTextContent where
+parseContent (ParseSettings decodeEntities _ decodeIllegalCharacters _) breakDouble breakSingle = parseReference <|> parseTextContent where
   parseReference = do
     char' '&'
     t <- parseEntityRef <|> parseHexCharRef <|> parseDecCharRef
     char' ';'
     return t
diff --git a/xml-conduit/test/unit.hs b/xml-conduit/test/unit.hs
index 570dc4e..5f23146 100644
--- a/xml-conduit/test/unit.hs
+++ b/xml-conduit/test/unit.hs
@@ -79,10 +79,14 @@ main = hspec $ do
         it "identifies unresolved entities" resolvedIdentifies
         it "decodeHtmlEntities" testHtmlEntities
         it "works for resolvable entities" resolvedAllGood
         it "merges adjacent content nodes" resolvedMergeContent
         it "understands inline entity declarations" resolvedInline
+        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
         it "doesn't break on [] in doctype comments" doctypeComment
         it "skips element declarations in doctype" doctypeElements
         it "skips processing instructions in doctype" doctypePI
     describe "pretty" $ do
         it "works" casePretty
@@ -734,10 +738,41 @@ resolvedInline = do
     Res.Document _ root _ <- return $ Res.parseLBS_ Res.def "<!DOCTYPE foo [<!ENTITY bar \"baz\">]><foo>&bar;</foo>"
     root @?= Res.Element "foo" Map.empty [Res.NodeContent "baz"]
     Res.Document _ root2 _ <- return $ Res.parseLBS_ Res.def "<!DOCTYPE foo [<!ENTITY bar \"baz\">]><foo bar='&bar;'/>"
     root2 @?= Res.Element "foo" (Map.singleton "bar" "baz") []
 
+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"
+
+
 doctypeComment :: Assertion
 doctypeComment = do
     Res.Document _ root _ <- return $ Res.parseLBS_
        Res.def "<!DOCTYPE foo [<!-- [comment] --> <!ENTITY bar \"baz\">]><foo>&bar;</foo>"
     root @?= Res.Element "foo" Map.empty [Res.NodeContent "baz"]

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"