Script 'mail_helper' called by obssrc
Hello community,
here is the log from the commit of package ghc-xml-conduit for openSUSE:Factory
checked in at 2021-04-24 23:09:00
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/ghc-xml-conduit (Old)
and /work/SRC/openSUSE:Factory/.ghc-xml-conduit.new.12324 (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-xml-conduit"
Sat Apr 24 23:09:00 2021 rev:8 rq:888039 version:1.9.1.1
Changes:
--------
--- /work/SRC/openSUSE:Factory/ghc-xml-conduit/ghc-xml-conduit.changes
2021-03-10 08:57:55.426930383 +0100
+++
/work/SRC/openSUSE:Factory/.ghc-xml-conduit.new.12324/ghc-xml-conduit.changes
2021-04-24 23:10:11.855483424 +0200
@@ -1,0 +2,10 @@
+Fri Apr 16 11:05:14 UTC 2021 - [email protected]
+
+- Update xml-conduit to version 1.9.1.1.
+ ## 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
+
+-------------------------------------------------------------------
Old:
----
xml-conduit-1.9.1.0.tar.gz
New:
----
xml-conduit-1.9.1.1.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-xml-conduit.spec ++++++
--- /var/tmp/diff_new_pack.A5xORY/_old 2021-04-24 23:10:12.263484001 +0200
+++ /var/tmp/diff_new_pack.A5xORY/_new 2021-04-24 23:10:12.267484006 +0200
@@ -19,7 +19,7 @@
%global pkg_name xml-conduit
%bcond_with tests
Name: ghc-%{pkg_name}
-Version: 1.9.1.0
+Version: 1.9.1.1
Release: 0
Summary: Pure-Haskell utilities for dealing with XML with the conduit
package
License: MIT
++++++ xml-conduit-1.9.1.0.tar.gz -> xml-conduit-1.9.1.1.tar.gz ++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/xml-conduit-1.9.1.0/ChangeLog.md
new/xml-conduit-1.9.1.1/ChangeLog.md
--- old/xml-conduit-1.9.1.0/ChangeLog.md 2001-09-09 03:46:40.000000000
+0200
+++ new/xml-conduit-1.9.1.1/ChangeLog.md 2001-09-09 03:46:40.000000000
+0200
@@ -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
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/xml-conduit-1.9.1.0/src/Text/XML/Stream/Parse.hs
new/xml-conduit-1.9.1.1/src/Text/XML/Stream/Parse.hs
--- old/xml-conduit-1.9.1.0/src/Text/XML/Stream/Parse.hs 2001-09-09
03:46:40.000000000 +0200
+++ new/xml-conduit-1.9.1.1/src/Text/XML/Stream/Parse.hs 2001-09-09
03:46:40.000000000 +0200
@@ -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
- where
- parseLt =
- (char '?' >> parseInstr) <|>
- (char '!' >> (parseComment <|> parseCdata <|> parseDoctype)) <|>
- parseBegin <|>
- (char '/' >> parseEnd)
- parseInstr = do
+parseToken settings = do
+ mbc <- peekChar
+ case mbc of
+ Just '<' -> char '<' >> parseLt
+ _ -> TokenContent <$> parseContent settings False False
+ where
+ 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.
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/xml-conduit-1.9.1.0/test/unit.hs
new/xml-conduit-1.9.1.1/test/unit.hs
--- old/xml-conduit-1.9.1.0/test/unit.hs 2001-09-09 03:46:40.000000000
+0200
+++ new/xml-conduit-1.9.1.1/test/unit.hs 2001-09-09 03:46:40.000000000
+0200
@@ -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
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/xml-conduit-1.9.1.0/xml-conduit.cabal
new/xml-conduit-1.9.1.1/xml-conduit.cabal
--- old/xml-conduit-1.9.1.0/xml-conduit.cabal 2001-09-09 03:46:40.000000000
+0200
+++ new/xml-conduit-1.9.1.1/xml-conduit.cabal 2001-09-09 03:46:40.000000000
+0200
@@ -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 <[email protected]>, Aristid Breitkreuz
<[email protected]>
@@ -59,6 +59,7 @@
, HUnit
, xml-types >= 0.3.1
, conduit
+ , conduit-extra
, blaze-markup
, resourcet
default-language: Haskell2010
