xml-conduit 1.9.1.0 → 1.9.1.1
raw patch · 4 files changed
+142/−65 lines, 4 filesdep ~conduit-extradep ~resourcetdep ~transformersPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: conduit-extra, resourcet, transformers
API changes (from Hackage documentation)
Files
- ChangeLog.md +6/−0
- src/Text/XML/Stream/Parse.hs +100/−62
- test/unit.hs +34/−2
- xml-conduit.cabal +2/−1
ChangeLog.md view
@@ -1,3 +1,9 @@+## 1.9.1.1++* Entity declarations with tags inside are now correctly handled+* Parser now fails gracefully on malformed entity declarations+* Parameter entity declarations are now ignored+ ## 1.9.1 * `]` characters inside doctype are now correctly handled
src/Text/XML/Stream/Parse.hs view
@@ -149,17 +149,20 @@ throwM) import Data.Attoparsec.Text (Parser, anyChar, char, manyTill, skipWhile, string, takeWhile,- takeWhile1, try)+ takeWhile1, (<?>),+ notInClass, skipMany, skipMany1,+ satisfy, peekChar) import qualified Data.Attoparsec.Text as AT import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Builder as Builder import Data.Char (isSpace) import Data.Conduit.Attoparsec (PositionRange, conduitParser) import qualified Data.Conduit.Text as CT import Data.Default.Class (Default (..)) import Data.List (foldl', intercalate) import qualified Data.Map as Map-import Data.Maybe (fromMaybe, isNothing)+import Data.Maybe (fromMaybe, isNothing, mapMaybe) import Data.String (IsString (..)) import Data.Text (Text, pack) import qualified Data.Text as T@@ -197,8 +200,15 @@ addNS | not (psRetainNamespaces ps) && (isPrefixed || isUnprefixed) = id- | otherwise = (((tname, resolveEntities ps es val):) .)+ | otherwise = (((tname, resolveEntities' ps es val):) .) where+ resolveEntities' ps' es' xs =+ mapMaybe extractTokenContent+ (resolveEntities ps' es'+ (map TokenContent xs))+ extractTokenContent (TokenContent c) = Just c+ extractTokenContent _ = Nothing+ tname | isPrefixed = TName Nothing ("xmlns:" `T.append` kname) | otherwise = TName kpref kname@@ -225,8 +235,15 @@ case n of [] -> (NSLevel Nothing Map.empty, []) x:xs -> (x, xs)-tokenToEvent ps es n (TokenContent (ContentEntity e))- = (es, n, map EventContent (resolveEntities ps es [ContentEntity e]))+tokenToEvent ps es n tok@(TokenContent c@(ContentEntity e))+ = case lookup e es of+ Just _ -> (es, n, concatMap toEvents newtoks)+ Nothing -> (es, n, [EventContent c])+ where+ toEvents t =+ let (_, _, events) = tokenToEvent ps [] n t+ in events+ newtoks = resolveEntities ps es [tok] 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])@@ -234,33 +251,36 @@ resolveEntities :: ParseSettings -> EntityTable- -> [Content]- -> [Content]+ -> [Token]+ -> [Token] resolveEntities ps entities = foldr go [] where- go c@(ContentEntity e) cs+ go tok@(TokenContent (ContentEntity e)) toks = case expandEntity entities e of- Just xs -> foldr go cs xs- Nothing -> c : cs- go c cs = c:cs+ Just xs -> foldr go toks xs+ Nothing -> tok : toks+ go tok toks = tok : toks expandEntity es e | Just t <- lookup e es = case AT.parseOnly (manyTill- (parseContent ps False False :: Parser Content)+ (parseToken ps :: Parser Token) AT.endOfInput) t of Left _ -> Nothing- Right xs -> let es' = filter (\(x,_) -> x /= e) es+ Right xs -> -- recursively expand+ 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))+ goent es (TokenContent (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+ goent _ tok (Just (toks, size)) =+ let toksize = fromIntegral $+ L.length (Builder.toLazyByteString (tokenToBuilder tok))+ in case size + toksize of n | n > psEntityExpansionSizeLimit ps -> Nothing- | otherwise -> Just (c:cs, size + T.length t)+ | otherwise -> Just (tok:toks, n) tnameToName :: Bool -> NSLevel -> TName -> Name@@ -458,14 +478,21 @@ conduitToken = conduitParser . parseToken parseToken :: ParseSettings -> Parser Token-parseToken settings = (char '<' >> parseLt) <|> TokenContent <$> parseContent settings False False+parseToken settings = do+ mbc <- peekChar+ case mbc of+ Just '<' -> char '<' >> parseLt+ _ -> TokenContent <$> parseContent settings False False where- parseLt =- (char '?' >> parseInstr) <|>- (char '!' >> (parseComment <|> parseCdata <|> parseDoctype)) <|>- parseBegin <|>- (char '/' >> parseEnd)- parseInstr = do+ parseLt = do+ mbc <- peekChar+ case mbc of+ Just '?' -> char' '?' >> parseInstr+ Just '!' -> char' '!' >>+ (parseComment <|> parseCdata <|> parseDoctype)+ Just '/' -> char' '/' >> parseEnd+ _ -> parseBegin+ parseInstr = (do name <- parseIdent if name == "xml" then do@@ -477,18 +504,19 @@ return $ TokenXMLDeclaration as else do skipSpace- x <- T.pack <$> manyTill anyChar (try $ string "?>")- return $ TokenInstruction $ Instruction name x- parseComment = do+ x <- T.pack <$> manyTill anyChar (string "?>")+ return $ TokenInstruction $ Instruction name x)+ <?> "instruction"+ parseComment = (do char' '-' char' '-'- c <- T.pack <$> manyTill anyChar (string "-->") -- FIXME use takeWhile instead- return $ TokenComment c- parseCdata = do+ c <- T.pack <$> manyTill anyChar (string "-->")+ return $ TokenComment c) <?> "comment"+ parseCdata = (do _ <- string "[CDATA["- t <- T.pack <$> manyTill anyChar (string "]]>") -- FIXME use takeWhile instead- return $ TokenCDATA t- parseDoctype = do+ t <- T.pack <$> manyTill anyChar (string "]]>")+ return $ TokenCDATA t) <?> "CDATA"+ parseDoctype = (do _ <- string "DOCTYPE" skipSpace name <- parseName@@ -501,80 +529,90 @@ fmap Just parseSystemID <|> return Nothing skipSpace- ents <- (do- char' '['- ents <- parseEntities id- skipSpace- return ents) <|> return []+ mbc <- peekChar+ ents <- case mbc of+ Just '[' ->+ do char' '['+ ents <- parseDeclarations id+ skipSpace+ return ents+ _ -> return [] char' '>' newline <|> return ()- return $ TokenDoctype i eid ents- parseEntities front =- (char ']' >> return (front [])) <|>- (parseEntity >>= \e -> parseEntities (front . (e:))) <|>+ return $ TokenDoctype i eid ents) <?> "DOCTYPE"+ parseDeclarations front = -- we ignore everything but ENTITY+ (char' ']' >> return (front [])) <|>+ (parseEntity >>= \f -> parseDeclarations (front . f)) <|> (string "<!--" >> manyTill anyChar (string "-->") >>- parseEntities front) <|>+ parseDeclarations front) <|> -- this clause handles directives like <!ELEMENT -- and processing instructions:- (char '<' >> AT.skipWhile (/= '>') >> char '>'- >> parseEntities front) <|>- (skipWhile (\t -> t /= ']' && t /= '<') >> parseEntities front)- parseEntity = try $ do+ (do char' '<'+ skipMany+ (void (takeWhile1 (notInClass "]<>'\"")) <|> void quotedText)+ char' '>'+ parseDeclarations front) <|>+ (skipMany1 (satisfy (notInClass "]<>")) >>+ parseDeclarations front)+ parseEntity = (do _ <- string "<!ENTITY" skipSpace+ isParameterEntity <- AT.option False (True <$ (char' '%' *> skipSpace)) i <- parseIdent t <- quotedText skipSpace char' '>'- return (i, t)+ return $+ if isParameterEntity+ then id+ else ((i, t):)) <?> "entity" parsePublicID = PublicID <$> (string "PUBLIC" *> quotedText) <*> quotedText parseSystemID = SystemID <$> (string "SYSTEM" *> quotedText)- quotedText = do+ quotedText = (do skipSpace- between '"' <|> between '\''+ between '"' <|> between '\'') <?> "quoted text" between c = do char' c x <- takeWhile (/=c) char' c return x- parseEnd = do+ parseEnd = (do skipSpace n <- parseName skipSpace char' '>'- return $ TokenEndElement n- parseBegin = do+ return $ TokenEndElement n) <?> "close tag"+ parseBegin = (do skipSpace n <- parseName as <- A.many $ parseAttribute settings skipSpace isClose <- (char '/' >> skipSpace >> return True) <|> return False char' '>'- return $ TokenBeginElement n as isClose 0+ return $ TokenBeginElement n as isClose 0) <?> "open tag" parseAttribute :: ParseSettings -> Parser TAttribute-parseAttribute settings = do+parseAttribute settings = (do skipSpace key <- parseName skipSpace char' '=' skipSpace val <- squoted <|> dquoted- return (key, val)+ return (key, val)) <?> "attribute" where squoted = char '\'' *> manyTill (parseContent settings False True) (char '\'') dquoted = char '"' *> manyTill (parseContent settings True False) (char '"') parseName :: Parser TName parseName =- name <$> parseIdent <*> A.optional (char ':' >> parseIdent)+ (name <$> parseIdent <*> A.optional (char ':' >> parseIdent)) <?> "name" where name i1 Nothing = TName Nothing i1 name i1 (Just i2) = TName (Just i1) i2 parseIdent :: Parser Text-parseIdent =- takeWhile1 valid+parseIdent = takeWhile1 valid <?> "identifier" where valid '&' = False valid '<' = False@@ -621,7 +659,7 @@ case toValidXmlChar n <|> decodeIllegalCharacters n of Nothing -> fail "Invalid character from decimal character reference." Just c -> return $ ContentText $ T.singleton c- parseTextContent = ContentText <$> takeWhile1 valid+ parseTextContent = ContentText <$> takeWhile1 valid <?> "text content" valid '"' = not breakDouble valid '\'' = not breakSingle valid '&' = False -- amp@@ -1117,10 +1155,10 @@ => ConduitT Event o m (Maybe a) -> ConduitT Event o m (Maybe b) -> ConduitT Event o m [a]-manyIgnore i ignored = go id where+manyIgnore i ignored' = go id where go front = i >>= maybe (onFail front) (\y -> go $ front . (:) y) -- onFail is called if the main parser fails- onFail front = ignored >>= maybe (return $ front []) (const $ go front)+ onFail front = ignored' >>= maybe (return $ front []) (const $ go front) -- | Like @many@, but any tags and content the consumer doesn't match on -- are silently ignored.
test/unit.hs view
@@ -1,7 +1,8 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} -import Control.Exception (Exception, toException)+import Control.Exception (Exception, toException,+ fromException) import Control.Monad.IO.Class (liftIO) import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L@@ -23,7 +24,9 @@ (&.//), (&/), (&//)) import qualified Control.Monad.Trans.Resource as C-import Data.Conduit ((.|), runConduit, runConduitRes, ConduitT)+import Data.Conduit ((.|), runConduit,+ runConduitRes, ConduitT)+import Data.Conduit.Attoparsec (ParseError(..)) import qualified Data.Conduit as C import qualified Data.Conduit.List as CL import qualified Data.Map as Map@@ -49,6 +52,7 @@ it "displays comments" testRenderComments it "conduit parser" testConduitParser it "can omit the XML declaration" omitXMLDeclaration+ it "doesn't hang on malformed entity declarations" malformedEntityDeclaration context "correctly parses hexadecimal entities" hexEntityParsing describe "XML Cursors" $ do it "has correct parent" cursorParent@@ -81,10 +85,12 @@ it "works for resolvable entities" resolvedAllGood it "merges adjacent content nodes" resolvedMergeContent it "understands inline entity declarations" resolvedInline+ it "understands complex inline with markup" resolvedInlineComplex 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 "ignores parameter entity declarations" parameterEntity it "doesn't break on [] in doctype comments" doctypeComment it "skips element declarations in doctype" doctypeElements it "skips processing instructions in doctype" doctypePI@@ -543,6 +549,15 @@ [] spec = "<foo>bar</foo>" +malformedEntityDeclaration :: Assertion+malformedEntityDeclaration = do -- missing > after bim+ assertBool "raises ParseError" $+ case Res.parseLBS Res.def "<!DOCTYPE foo [<!ENTITY bim \"Hello\"]><foo></foo>" of+ Left e -> case fromException e of+ Just (ParseError ["DOCTYPE"] _ _) -> True+ _ -> False+ _ -> False+ hexEntityParsing :: Spec hexEntityParsing = do it "rejects leading 0x" $@@ -740,6 +755,14 @@ Res.Document _ root2 _ <- return $ Res.parseLBS_ Res.def "<!DOCTYPE foo [<!ENTITY bar \"baz\">]><foo bar='&bar;'/>" root2 @?= Res.Element "foo" (Map.singleton "bar" "baz") [] +resolvedInlineComplex :: Assertion+resolvedInlineComplex = do+ Res.Document _ root _ <- return $ Res.parseLBS_ Res.def "<!DOCTYPE foo [<!ENTITY bar \"<p>baz &bim;</p>\"><!ENTITY bim \"Hello\">]><foo>&bar;</foo>"+ root @?= Res.Element "foo" Map.empty [Res.NodeElement (Res.Element "p" Map.empty [Res.NodeContent "baz Hello"])]+ Res.Document _ root2 _ <- return $ Res.parseLBS_ Res.def "<!DOCTYPE foo [<!ENTITY bar \"<p>baz</p>\">]><foo class=\"&bar;\"/>"+ root2 @?= Res.Element "foo" (Map.fromList [("class","baz")]) []++ resolvedInlineRecursive :: Assertion resolvedInlineRecursive = do Res.Document _ root _ <- return $ Res.parseLBS_ Res.def@@ -752,6 +775,10 @@ "<!DOCTYPE foo [<!ENTITY bim \"&bim;\">]><foo>&bim;</foo>" Left (toException $ Res.UnresolvedEntityException (Set.fromList ["bim"])) `showEq` res+ res2 <- return $ Res.parseLBS Res.def+ "<!DOCTYPE foo [<!ENTITY bim \"&bim;\">]><foo class=\"&bim;\"/>"+ Left (toException $ Res.UnresolvedEntityException (Set.fromList ["bim"]))+ `showEq` res2 billionLaughs :: Assertion billionLaughs = do@@ -770,6 +797,11 @@ 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" +parameterEntity :: Assertion+parameterEntity = do+ let res = Res.parseLBS Res.def "<!DOCTYPE foo [<!ENTITY % bim \"Hello\">]><foo>&bim;</foo>"+ Left (toException $ Res.UnresolvedEntityException (Set.fromList ["bim"]))+ `showEq` res doctypeComment :: Assertion doctypeComment = do
xml-conduit.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.14 name: xml-conduit-version: 1.9.1.0+version: 1.9.1.1 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>, Aristid Breitkreuz <aristidb@googlemail.com>@@ -59,6 +59,7 @@ , HUnit , xml-types >= 0.3.1 , conduit+ , conduit-extra , blaze-markup , resourcet default-language: Haskell2010