xml-conduit 1.9.1.1 → 1.9.1.2
raw patch · 4 files changed
+147/−23 lines, 4 filesdep ~basePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base
API changes (from Hackage documentation)
Files
- src/Text/XML/Stream/Parse.hs +64/−3
- src/Text/XML/Stream/Token.hs +31/−14
- test/unit.hs +46/−0
- xml-conduit.cabal +6/−6
src/Text/XML/Stream/Parse.hs view
@@ -147,6 +147,7 @@ import Control.Monad.Trans.Maybe (MaybeT (..)) import Control.Monad.Trans.Resource (MonadResource, MonadThrow (..), throwM)+import Data.Attoparsec.Internal (concatReverse) import Data.Attoparsec.Text (Parser, anyChar, char, manyTill, skipWhile, string, takeWhile, takeWhile1, (<?>),@@ -200,7 +201,7 @@ 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@@ -631,7 +632,7 @@ -> 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 <?> "text content") where parseReference = do char' '&' t <- parseEntityRef <|> parseHexCharRef <|> parseDecCharRef@@ -659,11 +660,71 @@ 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 <?> "text content"++ -- Turns @\r\n@ and @\r@ into @\n@. See+ -- <https://www.w3.org/TR/REC-xml/#sec-line-ends>.+ parseTextContent = do+ -- Read until the end of this piece of content+ -- OR until a carriage return. In the second case, we use+ -- handleCR to normalize \r and \r\n into \n.+ firstChunk <- takeWhile valid+ mbC <- peekChar+ case mbC of+ Just '\r' ->+ handleCR [firstChunk]+ _ ->+ exit firstChunk++ -- This is a duplication of the logic above and could be used instead.+ -- Specialising these cases to the case "full text content contains no carriage return"+ -- considerably speeds up execution when no carriage returns are in the original source.+ handleCRPeek chunks = do+ mbC <- peekChar+ case mbC of+ Just '\r' ->+ handleCR chunks+ _ ->+ exit' chunks++ handleCR chunks = do+ -- We know that the next character is a carriage return. Discard it.+ _ <- anyChar+ -- Read the next chunk.+ chunk <- takeWhile valid+ case T.uncons chunk of+ -- If it starts with newline, we're good:+ -- We've already discarded the carriage return.+ -- This is the case that replaces \r\n by \n.+ Just ('\n', _) ->+ handleCRPeek $ chunk : chunks+ -- Otherwise, we'll have to insert a newline.+ -- This is the case that replaces \r by \n.+ Just _ ->+ handleCRPeek $ chunk : "\n" : chunks+ -- If the chunk is empty, we've either hit another carriage+ -- return or the end of this piece of content. Since we've discarded+ -- a carriage return we need to insert a newline.+ Nothing ->+ handleCRPeek $ "\n" : chunks+++ -- exit and exit' fail if the emitted text content is empty.+ -- exit' uses Data.Text.concat to efficiently concatenate the collected+ -- chunks.+ exit c+ | T.null c = fail "parseTextContent"+ | otherwise = pure $ ContentText c++ exit' cs = exit $ T.concat $ reverse cs++ -- Check whether a character is valid text content (e.g. not a <)+ -- OR a carriage return. The latter is used above in parseTextContent+ -- to normalize line endings. valid '"' = not breakDouble valid '\'' = not breakSingle valid '&' = False -- amp valid '<' = False -- lt+ valid '\r' = False valid _ = True -- | Is this codepoint a valid XML character? See
src/Text/XML/Stream/Token.hs view
@@ -89,18 +89,24 @@ encodeUtf8Builder prefix <> ":" <> encodeUtf8Builder name contentToText :: Content -> Builder-contentToText (ContentText t) = encodeUtf8BuilderEscaped charUtf8XmlEscaped t+contentToText (ContentText t) = encodeUtf8BuilderEscaped (charUtf8XmlEscaped ECContent) t contentToText (ContentEntity e) = "&" <> encodeUtf8Builder e <> ";" +-- | What usage are we escaping for?+data EscapeContext = ECContent -- ^ <el>..</el>+ | ECDoubleArg -- ^ <el arg=".." />+ | ECSingleArg -- ^ <el arg='..' />+ deriving (Show, Eq)+ {-# INLINE charUtf8XmlEscaped #-}-charUtf8XmlEscaped :: E.BoundedPrim Word8-charUtf8XmlEscaped =- condB (> _gt) (E.liftFixedToBounded E.word8) $- condB (== _lt) (fixed4 (_am,(_l,(_t,_sc)))) $ -- <- condB (== _gt) (fixed4 (_am,(_g,(_t,_sc)))) $ -- >- condB (== _am) (fixed5 (_am,(_a,(_m,(_p,_sc))))) $ -- &- condB (== _dq) (fixed5 (_am,(_ha,(_3,(_4,_sc))))) $ -- "- condB (== _sq) (fixed5 (_am,(_ha,(_3,(_9,_sc))))) $ -- '+charUtf8XmlEscaped :: EscapeContext -> E.BoundedPrim Word8+charUtf8XmlEscaped ec =+ (condB (> _gt) (E.liftFixedToBounded E.word8)) $+ (condB (== _lt) (fixed4 (_am,(_l,(_t,_sc))))) $ -- <+ escapeFor ECContent (condB (== _gt) (fixed4 (_am,(_g,(_t,_sc))))) $ -- >+ (condB (== _am) (fixed5 (_am,(_a,(_m,(_p,_sc)))))) $ -- &+ escapeFor ECDoubleArg (condB (== _dq) (fixed6 (_am,(_q,(_u,(_o,(_t,_sc))))))) $ -- "+ escapeFor ECSingleArg (condB (== _sq) (fixed6 (_am,(_a,(_p,(_o,(_s,_sc))))))) $ -- ' (E.liftFixedToBounded E.word8) -- fallback for Chars smaller than '>' where _gt = 62 -- >@@ -114,11 +120,18 @@ _a = 97 -- a _m = 109 -- m _p = 112 -- p- _3 = 51 -- 3- _4 = 52 -- 4- _ha = 35 -- #, hash- _9 = 57 -- 9+ _o = 111 -- o+ _s = 115 -- s+ _q = 113 -- q+ _u = 117 -- u _sc = 59 -- ;++ {-# INLINE escapeFor #-}+ escapeFor :: EscapeContext -> (a -> a) -> a -> a+ escapeFor ec' f a+ | ec == ec' = f a+ | otherwise = a+ {-# INLINE fixed4 #-} fixed4 x = E.liftFixedToBounded $ const x >$< E.word8 >*< E.word8 >*< E.word8 >*< E.word8@@ -127,6 +140,10 @@ fixed5 x = E.liftFixedToBounded $ const x >$< E.word8 >*< E.word8 >*< E.word8 >*< E.word8 >*< E.word8 + {-# INLINE fixed6 #-}+ fixed6 x = E.liftFixedToBounded $ const x >$<+ E.word8 >*< E.word8 >*< E.word8 >*< E.word8 >*< E.word8 >*< E.word8+ type TAttribute = (TName, [Content]) foldAttrs :: Builder -- ^ before@@ -142,7 +159,7 @@ foldMap go' val <> "\"" go' (ContentText t) =- encodeUtf8BuilderEscaped charUtf8XmlEscaped t+ encodeUtf8BuilderEscaped (charUtf8XmlEscaped ECDoubleArg) t go' (ContentEntity t) = "&" <> encodeUtf8Builder t <> ";" instance IsString TName where
test/unit.hs view
@@ -53,7 +53,12 @@ it "conduit parser" testConduitParser it "can omit the XML declaration" omitXMLDeclaration it "doesn't hang on malformed entity declarations" malformedEntityDeclaration+ it "escapes <>'\"& as necessary" caseEscapesAsNecessary+ it "preserves the order of attributes" casePreservesAttrOrder context "correctly parses hexadecimal entities" hexEntityParsing+ it "normalizes line endings" crlfToLfConversion+ it "normalizes \\r at the end of a content" crlfToLfConversionCrAtEnd+ it "normalizes multiple \\rs and \\r\\ns" crlfToLfConversionCrCrCr describe "XML Cursors" $ do it "has correct parent" cursorParent it "has correct ancestor" cursorAncestor@@ -558,6 +563,29 @@ _ -> False _ -> False +caseEscapesAsNecessary :: Assertion+caseEscapesAsNecessary = do+ let doc = Res.Document (Res.Prologue [] Nothing [])+ (Res.Element "a" (Map.fromList [("attr", "'<&val>'")])+ [Res.NodeContent "'\"<&test]]>\"'"])+ []+ result = Res.renderLBS def doc+ result `shouldBe` "<?xml version=\"1.0\" encoding=\"UTF-8\"?><a attr=\"'<&val>'\">'\"<&test]]>\"'</a>"++casePreservesAttrOrder :: Assertion+casePreservesAttrOrder = do+ let doc = Document (Prologue [] Nothing [])+ (Element "doc" [] [+ NodeElement (Element "el" [("attr1", [ContentText "1"]), ("attr2", [ContentText "2"])] []),+ NodeElement (Element "el" [("attr2", [ContentText "2"]), ("attr1", [ContentText "1"])] [])+ ])+ []+ rendered = "<?xml version=\"1.0\" encoding=\"UTF-8\"?><doc><el attr1=\"1\" attr2=\"2\"/><el attr2=\"2\" attr1=\"1\"/></doc>"+ renderResult = D.renderLBS def doc+ parseResult = D.parseLBS def rendered+ renderResult `shouldBe` rendered+ parseResult `shouldSatisfy` either (const False) (doc==)+ hexEntityParsing :: Spec hexEntityParsing = do it "rejects leading 0x" $@@ -1041,3 +1069,21 @@ [] result = Res.renderLBS (def { Res.rsUseCDATA = const True }) doc result `shouldBe` "<?xml version=\"1.0\" encoding=\"UTF-8\"?><a><![CDATA[]]]]><![CDATA[>]]></a>"++crlfToLfConversion :: Assertion+crlfToLfConversion = (elementContent $ documentRoot crlfDoc) `shouldBe` crlfContent+ where+ crlfDoc = D.parseLBS_ def "<crlf>Hello,\rWorld!\r\nWe don't like your kind of line endings around here.\r\n</crlf>"+ crlfContent = [ContentText "Hello,\nWorld!\nWe don't like your kind of line endings around here.\n"]++crlfToLfConversionCrAtEnd :: Assertion+crlfToLfConversionCrAtEnd = (elementContent $ documentRoot doc) `shouldBe` content+ where+ doc = D.parseLBS_ def "<crlf>Hello, World!\r</crlf>"+ content = [ContentText "Hello, World!\n"]++crlfToLfConversionCrCrCr :: Assertion+crlfToLfConversionCrCrCr = (elementContent $ documentRoot doc) `shouldBe` content+ where+ doc = D.parseLBS_ def "<crlf>\r\r\r\n\r\r\r</crlf>"+ content = [ContentText "\n\n\n\n\n\n"]
xml-conduit.cabal view
@@ -1,7 +1,7 @@-cabal-version: >= 1.14+cabal-version: 1.14 name: xml-conduit-version: 1.9.1.1+version: 1.9.1.2 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>, Aristid Breitkreuz <aristidb@googlemail.com>@@ -17,19 +17,19 @@ tested-with: GHC >=8.0 && <8.12 custom-setup- setup-depends: base >= 4 && <5, Cabal, cabal-doctest >= 1 && <1.1+ setup-depends: base >= 4 && <5, Cabal <4, cabal-doctest >= 1.0.9 && <1.1 library- build-depends: base >= 4 && < 5+ build-depends: base >= 4.12 && < 5 , conduit >= 1.3 && < 1.4 , conduit-extra >= 1.3 && < 1.4- , resourcet >= 1.2 && < 1.3+ , resourcet >= 1.2 && < 1.4 , bytestring >= 0.10.2 , text >= 0.7 , containers >= 0.2 , xml-types >= 0.3.4 && < 0.4 , attoparsec >= 0.10- , transformers >= 0.2 && < 0.6+ , transformers >= 0.2 && < 0.7 , data-default-class , blaze-markup >= 0.5 , blaze-html >= 0.5