diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,8 @@ +## 1.7.1 + +* Add `psDecodeIllegalCharacters` field in `ParseSettings` to specify how illegal characters references should be decoded +* Fix compatibility with GHC 8.4.1 [#121](https://github.com/snoyberg/xml/issues/121) + ## 1.7.0 * `psDecodeEntities` is no longer passed numeric character references (e.g., ` `, `A`) and the predefined XML entities (`&`, `<`, etc). They are now handled by the parser. Both of these construct classes only have one spec-compliant interpretation and this behaviour must always be present, so it makes no sense to force user code to re-implement the parsing logic. diff --git a/Text/XML/Stream/Parse.hs b/Text/XML/Stream/Parse.hs --- a/Text/XML/Stream/Parse.hs +++ b/Text/XML/Stream/Parse.hs @@ -102,6 +102,7 @@ , def , DecodeEntities , psDecodeEntities + , psDecodeIllegalCharacters , psRetainNamespaces -- *** Entity decoding , decodeXmlEntities @@ -157,8 +158,9 @@ , PositionRange , EventPos ) where -import Control.Applicative (Alternative (empty, (<|>)), - Applicative (..), (<$>)) +import Control.Applicative (Alternative ((<|>)), + Applicative (..), optional, + (<$>)) import qualified Control.Applicative as A import Control.Arrow ((***)) import Control.Exception (Exception (..), SomeException) @@ -308,7 +310,7 @@ -> Conduit S.ByteString m T.Text checkXMLDecl bs (Just codec) = leftover bs >> CT.decode codec checkXMLDecl bs0 Nothing = - loop [] (AT.parse (parseToken decodeXmlEntities)) bs0 + loop [] (AT.parse (parseToken def)) bs0 where loop chunks0 parser nextChunk = case parser $ decodeUtf8With lenientDecode nextChunk of @@ -387,17 +389,12 @@ parseTextPos :: MonadThrow m => ParseSettings -> Conduit T.Text m EventPos -parseTextPos de = - dropBOM - =$= tokenize - =$= toEventC de - =$= addBeginEnd - where - tokenize = conduitToken de - addBeginEnd = yield (Nothing, EventBeginDocument) >> addEnd - addEnd = await >>= maybe - (yield (Nothing, EventEndDocument)) - (\e -> yield e >> addEnd) +parseTextPos de = dropBOM =$= tokenize =$= toEventC de =$= addBeginEnd where + tokenize = conduitToken de + addBeginEnd = yield (Nothing, EventBeginDocument) >> addEnd + addEnd = await >>= maybe + (yield (Nothing, EventEndDocument)) + (\e -> yield e >> addEnd) toEventC :: Monad m => ParseSettings -> Conduit (PositionRange, Token) m EventPos toEventC ps = @@ -411,9 +408,13 @@ where (es', levels', events) = tokenToEvent ps es levels token + +type DecodeEntities = Text -> Content +type DecodeIllegalCharacters = Int -> Maybe Char + data ParseSettings = ParseSettings - { psDecodeEntities :: DecodeEntities - , psRetainNamespaces :: Bool + { psDecodeEntities :: DecodeEntities + , psRetainNamespaces :: Bool -- ^ Whether the original xmlns attributes should be retained in the parsed -- values. For more information on motivation, see: -- @@ -422,19 +423,29 @@ -- Default: False -- -- Since 1.2.1 + , psDecodeIllegalCharacters :: DecodeIllegalCharacters + -- ^ How to decode illegal character references (@&#[0-9]+;@ or @&#x[0-9a-fA-F]+;@). + -- + -- Character references within the legal ranges defined by are automatically parsed. + -- Others are passed to this function. + -- + -- Default: @const Nothing@ + -- + -- Since 1.7.1 } instance Default ParseSettings where def = ParseSettings { psDecodeEntities = decodeXmlEntities , psRetainNamespaces = False + , psDecodeIllegalCharacters = const Nothing } conduitToken :: MonadThrow m => ParseSettings -> Conduit T.Text m (PositionRange, Token) -conduitToken = conduitParser . parseToken . psDecodeEntities +conduitToken = conduitParser . parseToken -parseToken :: DecodeEntities -> Parser Token -parseToken de = (char '<' >> parseLt) <|> TokenContent <$> parseContent de False False +parseToken :: ParseSettings -> Parser Token +parseToken settings = (char '<' >> parseLt) <|> TokenContent <$> parseContent settings False False where parseLt = (char '?' >> parseInstr) <|> @@ -445,11 +456,11 @@ name <- parseIdent if name == "xml" then do - as <- A.many $ parseAttribute de + as <- A.many $ parseAttribute settings skipSpace char' '?' char' '>' - newline <|> return () + optional newline return $ TokenXMLDeclaration as else do skipSpace @@ -524,14 +535,14 @@ parseBegin = do skipSpace n <- parseName - as <- A.many $ parseAttribute de + as <- A.many $ parseAttribute settings skipSpace isClose <- (char '/' >> skipSpace >> return True) <|> return False char' '>' return $ TokenBeginElement n as isClose 0 -parseAttribute :: DecodeEntities -> Parser TAttribute -parseAttribute de = do +parseAttribute :: ParseSettings -> Parser TAttribute +parseAttribute settings = do skipSpace key <- parseName skipSpace @@ -540,8 +551,8 @@ val <- squoted <|> dquoted return (key, val) where - squoted = char '\'' *> manyTill (parseContent de False True) (char '\'') - dquoted = char '"' *> manyTill (parseContent de True False) (char '"') + squoted = char '\'' *> manyTill (parseContent settings False True) (char '\'') + dquoted = char '"' *> manyTill (parseContent settings True False) (char '"') parseName :: Parser TName parseName = @@ -567,11 +578,11 @@ valid '#' = False valid c = not $ isXMLSpace c -parseContent :: DecodeEntities +parseContent :: ParseSettings -> Bool -- break on double quote -> Bool -- break on single quote -> Parser Content -parseContent de breakDouble breakSingle = parseReference <|> parseTextContent where +parseContent (ParseSettings decodeEntities _ decodeIllegalCharacters) breakDouble breakSingle = parseReference <|> parseTextContent where parseReference = do char' '&' t <- parseEntityRef <|> parseHexCharRef <|> parseDecCharRef @@ -581,24 +592,24 @@ TName ma b <- parseName let name = maybe "" (`T.append` ":") ma `T.append` b return $ case name of - "lt" -> ContentText "<" - "gt" -> ContentText ">" - "amp" -> ContentText "&" + "lt" -> ContentText "<" + "gt" -> ContentText ">" + "amp" -> ContentText "&" "quot" -> ContentText "\"" "apos" -> ContentText "'" - _ -> de name + _ -> decodeEntities name parseHexCharRef = do void $ string "#x" n <- AT.hexadecimal - case toValidXmlChar n of + case toValidXmlChar n <|> decodeIllegalCharacters n of Nothing -> fail "Invalid character from hexadecimal character reference." Just c -> return $ ContentText $ T.singleton c parseDecCharRef = do void $ string "#" n <- AT.decimal - case toValidXmlChar n of + case toValidXmlChar n <|> decodeIllegalCharacters n of Nothing -> fail "Invalid character from decimal character reference." - Just c -> return $ ContentText $ T.singleton c + Just c -> return $ ContentText $ T.singleton c parseTextContent = ContentText <$> takeWhile1 valid valid '"' = not breakDouble valid '\'' = not breakSingle @@ -855,7 +866,7 @@ => String -- ^ Error message -> m (Maybe a) -- ^ Optional parser to be forced -> m a -force msg i = i >>= maybe (throwM $ XmlException msg Nothing) return +force msg i = i >>= maybe (throwM $ XmlException msg) return -- | A helper function which reads a file from disk using 'enumFile', detects -- character encoding using 'detectUtf', parses the XML using 'parseBytes', and @@ -873,10 +884,37 @@ -> Producer m Event parseLBS ps lbs = CL.sourceList (L.toChunks lbs) =$= parseBytes ps -data XmlException = XmlException - { xmlErrorMessage :: String - , xmlBadInput :: Maybe Event - } + +prettyEvent :: Event -> String +prettyEvent EventBeginDocument = "" +prettyEvent (EventBeginDoctype t externalID) = "" +prettyEvent EventEndDoctype = ">" +prettyEvent (EventInstruction (Instruction target data_)) = "" +prettyEvent (EventBeginElement name attributes) = "<" ++ prettyName name ++ " " ++ prettyAttributes attributes ++ ">" +prettyEvent (EventEndElement name) = "" +prettyEvent (EventContent content) = prettyContent content +prettyEvent (EventComment t) = "" +prettyEvent (EventCDATA t) = "" + +prettyAttributes :: [(Name, [Content])] -> String +prettyAttributes = intercalate " " . map (uncurry prettyAttribute) + +prettyAttribute :: Name -> [Content] -> String +prettyAttribute name content = prettyName name ++ "=\"" ++ concatMap prettyContent content ++ "\"" + +prettyExternalID :: ExternalID -> String +prettyExternalID (SystemID location) = "SYSTEM \"" ++ T.unpack location ++ "\"" +prettyExternalID (PublicID name location) = "PUBLIC \"" ++ T.unpack name ++ "\" \"" ++ T.unpack location ++ "\"" + +prettyContent :: Content -> String +prettyContent (ContentText t) = T.unpack t +prettyContent (ContentEntity t) = T.unpack t + +prettyName :: Name -> String +prettyName (Name name _namespace _prefix) = T.unpack name + +data XmlException = XmlException String | InvalidEndElement Name (Maybe Event) | InvalidEntity String (Maybe Event) | MissingAttribute String @@ -885,11 +923,10 @@ instance Exception XmlException where #if MIN_VERSION_base(4, 8, 0) - displayException (XmlException msg (Just event)) = "Error while parsing XML event " ++ show event ++ ": " ++ msg - displayException (XmlException msg _) = "Error while parsing XML: " ++ msg - displayException (InvalidEndElement name (Just event)) = "Error while parsing XML event: expected , got " ++ show event + displayException (XmlException msg) = "Error while parsing XML: " ++ msg + displayException (InvalidEndElement name (Just event)) = "Error while parsing XML event: expected , got " ++ prettyEvent event displayException (InvalidEndElement name _) = "Error while parsing XML event: expected , got nothing" - displayException (InvalidEntity msg (Just event)) = "Error while parsing XML entity " ++ show event ++ ": " ++ msg + displayException (InvalidEntity msg (Just event)) = "Error while parsing XML entity " ++ prettyEvent event ++ ": " ++ msg displayException (InvalidEntity msg _) = "Error while parsing XML entity: " ++ msg displayException (MissingAttribute msg) = "Missing required attribute: " ++ msg displayException (UnparsedAttributes attrs) = show (length attrs) ++ " remaining unparsed attributes: \n" ++ intercalate "\n" (show <$> attrs) @@ -957,7 +994,7 @@ pure = return (<*>) = ap instance Alternative AttrParser where - empty = AttrParser $ const $ Left $ toException $ XmlException "AttrParser.empty" Nothing + empty = AttrParser $ const $ Left $ toException $ XmlException "AttrParser.empty" AttrParser f <|> AttrParser g = AttrParser $ \x -> either (const $ g x) Right (f x) instance MonadThrow AttrParser where @@ -1005,24 +1042,24 @@ -- | Keep parsing elements as long as the parser returns 'Just'. many :: Monad m - => ConduitM Event o m (Maybe a) - -> ConduitM Event o m [a] + => ConduitM i o m (Maybe a) + -> ConduitM i o m [a] many i = manyIgnore i $ return Nothing -- | Like 'many' but discards the results without building an intermediate list. -- -- Since 1.5.0 many_ :: MonadThrow m - => ConduitM Event o m (Maybe a) - -> ConduitM Event o m () + => ConduitM i o m (Maybe a) + -> ConduitM i o m () many_ consumer = manyIgnoreYield (return Nothing) (void <$> consumer) -- | Keep parsing elements as long as the parser returns 'Just' -- or the ignore parser returns 'Just'. manyIgnore :: Monad m - => ConduitM Event o m (Maybe a) - -> ConduitM Event o m (Maybe b) - -> ConduitM Event o m [a] + => ConduitM i o m (Maybe a) + -> ConduitM i o m (Maybe b) + -> ConduitM i o m [a] manyIgnore i ignored = go id where go front = i >>= maybe (onFail front) (\y -> go $ front . (:) y) -- onFail is called if the main parser fails @@ -1047,9 +1084,9 @@ -- | Like 'manyIgnore', but uses 'yield' so the result list can be streamed -- to downstream conduits without waiting for 'manyIgnoreYield' to finish manyIgnoreYield :: MonadThrow m - => ConduitM Event b m (Maybe b) -- ^ Consuming parser that generates the result stream - -> ConduitM Event b m (Maybe ()) -- ^ Ignore parser that consumes elements to be ignored - -> Conduit Event m b + => ConduitM i b m (Maybe b) -- ^ Consuming parser that generates the result stream + -> ConduitM i b m (Maybe ()) -- ^ Ignore parser that consumes elements to be ignored + -> Conduit i m b manyIgnoreYield consumer ignoreParser = fix $ \loop -> consumer >>= maybe (onFail loop) (\x -> yield x >> loop) where onFail loop = ignoreParser >>= maybe (return ()) (const loop) @@ -1137,7 +1174,6 @@ takeAllTreesContent :: MonadThrow m => ConduitM Event Event m (Maybe ()) takeAllTreesContent = takeAnyTreeContent -type DecodeEntities = Text -> Content -- | Default implementation of 'DecodeEntities', which leaves the -- entity as-is. Numeric character references and the five standard diff --git a/Text/XML/Stream/Render.hs b/Text/XML/Stream/Render.hs --- a/Text/XML/Stream/Render.hs +++ b/Text/XML/Stream/Render.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} @@ -68,16 +69,16 @@ renderText rs = renderBytes rs =$= CT.decode CT.utf8 data RenderSettings = RenderSettings - { rsPretty :: Bool - , rsNamespaces :: [(Text, Text)] + { rsPretty :: Bool + , rsNamespaces :: [(Text, Text)] -- ^ Defines some top level namespace definitions to be used, in the form -- of (prefix, namespace). This has absolutely no impact on the meaning -- of your documents, but can increase readability by moving commonly -- used namespace declarations to the top level. - , rsAttrOrder :: Name -> Map.Map Name Text -> [(Name, Text)] + , rsAttrOrder :: Name -> Map.Map Name Text -> [(Name, Text)] -- ^ Specify how to turn the unordered attributes used by the "Text.XML" -- module into an ordered list. - , rsUseCDATA :: Content -> Bool + , rsUseCDATA :: Content -> Bool -- ^ Determines if for a given text content the renderer should use a -- CDATA node. -- @@ -128,7 +129,7 @@ renderBuilder :: Monad m => RenderSettings -> Conduit Event m Builder renderBuilder settings = CL.map Chunk =$= renderBuilder' yield' settings where - yield' Flush = return () + yield' Flush = return () yield' (Chunk bs) = yield bs -- | Same as 'renderBuilder' but allows you to flush XML stream to ensure that all @@ -191,7 +192,7 @@ eventToToken s useCDATA _ (EventContent c) | useCDATA c = case c of - ContentText txt -> (tokenToBuilder $ TokenCDATA txt, s) + ContentText txt -> (tokenToBuilder $ TokenCDATA txt, s) ContentEntity txt -> (tokenToBuilder $ TokenCDATA txt, s) | otherwise = (tokenToBuilder $ TokenContent c, s) eventToToken s _ _ (EventComment t) = (tokenToBuilder $ TokenComment t, s) @@ -207,7 +208,7 @@ | def' == Just ns = TName Nothing name | otherwise = case Map.lookup ns sl of - Nothing -> error "nameToTName" + Nothing -> error "nameToTName" Just pref -> TName (Just pref) name mkBeginToken :: Bool -- ^ pretty print attributes? @@ -223,7 +224,7 @@ where indent = if isPretty then 2 + 4 * length s else 0 prevsl = case s of - [] -> NSLevel Nothing Map.empty + [] -> NSLevel Nothing Map.empty sl':_ -> sl' (sl1, tname, tattrs1) = newElemStack prevsl name (sl2, tattrs2) = foldr newAttrStack (sl1, tattrs1) $ nubAttrs attrs @@ -235,7 +236,7 @@ (namespaceSL, namespaceAttrs) = unzip $ mapMaybe unused namespaces0 unused (k, v) = case lookup k' tattrs2 of - Just{} -> Nothing + Just{} -> Nothing Nothing -> Just ((v, k), (k', v')) where k' = TName (Just "xmlns") k @@ -299,7 +300,7 @@ where yield' = yield . Chunk - goC Flush = yield Flush >> prettify' level + goC Flush = yield Flush >> prettify' level goC (Chunk e) = go e go e@EventBeginDocument = do @@ -404,7 +405,12 @@ instance Monoid Attributes where mempty = Attributes mempty +#if !MIN_VERSION_base(4,11,0) (Attributes a) `mappend` (Attributes b) = Attributes (a `mappend` b) +#else +instance Semigroup Attributes where + (Attributes a) <> (Attributes b) = Attributes (a <> b) +#endif -- | Generate a single attribute. attr :: Name -- ^ Attribute's name diff --git a/Text/XML/Stream/Token.hs b/Text/XML/Stream/Token.hs --- a/Text/XML/Stream/Token.hs +++ b/Text/XML/Stream/Token.hs @@ -1,5 +1,5 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} module Text.XML.Stream.Token ( tokenToBuilder , TName (..) @@ -8,21 +8,26 @@ , NSLevel (..) ) where -import Data.XML.Types (Instruction (..), Content (..), ExternalID (..)) -import qualified Data.Text as T -import Data.Text (Text) -import Data.String (IsString (fromString)) -import Blaze.ByteString.Builder - (Builder, fromByteString, writeByteString, copyByteString) -import Blaze.ByteString.Builder.Internal.Write (fromWriteList) -import Blaze.ByteString.Builder.Char.Utf8 (writeChar, fromText) -import Data.Monoid (mconcat, mempty, mappend) -import Data.ByteString.Char8 () -import Data.Map (Map) -import qualified Blaze.ByteString.Builder.Char8 as BC8 -import qualified Data.Set as Set -import Data.List (foldl') -import Control.Arrow (first) +import Blaze.ByteString.Builder (Builder, + copyByteString, + fromByteString, + writeByteString) +import Blaze.ByteString.Builder.Char.Utf8 (fromText, writeChar) +import qualified Blaze.ByteString.Builder.Char8 as BC8 +import Blaze.ByteString.Builder.Internal.Write (fromWriteList) +import Control.Arrow (first) +import Data.ByteString.Char8 () +import Data.List (foldl') +import Data.Map (Map) +import Data.Monoid (mappend, mconcat, + mempty) +import qualified Data.Set as Set +import Data.String (IsString (fromString)) +import Data.Text (Text) +import qualified Data.Text as T +import Data.XML.Types (Content (..), + ExternalID (..), + Instruction (..)) oneSpace :: Builder oneSpace = copyByteString " " @@ -58,17 +63,17 @@ (if isEmpty then fromByteString "/>" else fromByteString ">") where attrs = nubAttrs $ map (first splitTName) attrs' - lessThan3 [] = True - lessThan3 [_] = True + lessThan3 [] = True + lessThan3 [_] = True lessThan3 [_, _] = True - lessThan3 _ = False + lessThan3 _ = False tokenToBuilder (TokenEndElement name) = mconcat [ fromByteString "" ] tokenToBuilder (TokenContent c) = contentToText c -tokenToBuilder (TokenCDATA t) = +tokenToBuilder (TokenCDATA t) = copyByteString "" @@ -151,7 +156,7 @@ data NSLevel = NSLevel { defaultNS :: Maybe Text - , prefixes :: Map Text Text + , prefixes :: Map Text Text } deriving Show @@ -171,6 +176,6 @@ | otherwise = TName (Just a) $ T.drop 1 b where (a, b) = T.break (== ':') t - + escCDATA :: Text -> Builder escCDATA s = fromText (T.replace "]]>" "]]]]>" s) diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -545,9 +545,9 @@ it "rejects leading 0X" $ go "�Xff;" @?= Nothing it "accepts lowercase hex digits" $ - go "ÿ" @?= Just spec + go "ÿ" @?= Just (spec "\xff") it "accepts uppercase hex digits" $ - go "ÿ" @?= Just spec + go "ÿ" @?= Just (spec "\xff") --Note: this must be rejected, because, according to the XML spec, a --legal EntityRef's entity matches Name, which can't start with a --hash. @@ -568,17 +568,19 @@ it "rejects illegal character #x1F" $ go "" @?= Nothing it "accepts astral plane character" $ - go "􀛿" @?= Just astralSpec + go "􀛿" @?= Just (spec "\x1006ff") + it "accepts custom character references" $ + go' customSettings " " @?= Just (spec "\xff") where - spec = Document (Prologue [] Nothing []) - (Element "foo" [] [NodeContent (ContentText "\xff")]) - [] - - astralSpec = Document (Prologue [] Nothing []) - (Element "foo" [] [NodeContent (ContentText "\x1006ff")]) + spec content = Document (Prologue [] Nothing []) + (Element "foo" [] [NodeContent (ContentText content)]) [] go = either (const Nothing) Just . D.parseLBS def + go' settings = either (const Nothing) Just . D.parseLBS settings + customSettings = def { P.psDecodeIllegalCharacters = customDecoder } + customDecoder 12 = Just '\xff' + customDecoder _ = Nothing name :: [Cu.Cursor] -> [Text] name [] = [] diff --git a/xml-conduit.cabal b/xml-conduit.cabal --- a/xml-conduit.cabal +++ b/xml-conduit.cabal @@ -1,5 +1,5 @@ name: xml-conduit -version: 1.7.0.1 +version: 1.7.1.0 license: MIT license-file: LICENSE author: Michael Snoyman , Aristid Breitkreuz