xml-conduit 1.7.0.1 → 1.7.1.0

raw patch · 6 files changed

+152/−98 lines, 6 filesdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• ChangeLog.md +5/−0
• Text/XML/Stream/Parse.hs +92/−56
• Text/XML/Stream/Render.hs +16/−10
• Text/XML/Stream/Token.hs +27/−22
• test/main.hs +11/−9
• xml-conduit.cabal +1/−1

@@ -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.

@@ -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 <https://www.w3.org/TR/REC-xml/#NT-Char the standard> 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 = "<?xml version=\"SOME_VERSION\" encoding=\"SOME_ENCODING\""+prettyEvent EventEndDocument	 = "?>"+prettyEvent (EventBeginDoctype t externalID) = "<!DOCTYPE " ++ T.unpack t ++ " " ++ maybe mempty prettyExternalID externalID ++ ">"+prettyEvent EventEndDoctype = ">"+prettyEvent (EventInstruction (Instruction target data_)) = "<?" ++ T.unpack target ++ " " ++ T.unpack data_ ++ "?>"+prettyEvent (EventBeginElement name attributes) = "<" ++ prettyName name ++ " " ++ prettyAttributes attributes ++ ">"+prettyEvent (EventEndElement name) = "</" ++ prettyName name ++ ">"+prettyEvent (EventContent content) = prettyContent content+prettyEvent (EventComment t) = "<!-- " ++ T.unpack t ++ " -->"+prettyEvent (EventCDATA t) = "<![CDATA[" ++ T.unpack 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 </" ++ T.unpack (nameLocalName name) ++ ">, got " ++ show event+  displayException (XmlException msg) = "Error while parsing XML: " ++ msg+  displayException (InvalidEndElement name (Just event)) = "Error while parsing XML event: expected </" ++ T.unpack (nameLocalName name) ++ ">, got " ++ prettyEvent event   displayException (InvalidEndElement name _) = "Error while parsing XML event: expected </" ++ show name ++ ">, 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

@@ -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

@@ -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 "</"     , tnameToText name     , fromByteString ">"     ] tokenToBuilder (TokenContent c) = contentToText c-tokenToBuilder (TokenCDATA t) = +tokenToBuilder (TokenCDATA t) =     copyByteString "<![CDATA["     `mappend` escCDATA t     `mappend` 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 "]]>" "]]]]><![CDATA[>" s)

@@ -545,9 +545,9 @@   it "rejects leading 0X" $     go "<foo>&#x0Xff;</foo>" @?= Nothing   it "accepts lowercase hex digits" $-    go "<foo>&#xff;</foo>" @?= Just spec+    go "<foo>&#xff;</foo>" @?= Just (spec "\xff")   it "accepts uppercase hex digits" $-    go "<foo>&#xFF;</foo>" @?= Just spec+    go "<foo>&#xFF;</foo>" @?= 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 "<foo>&#x1F;</foo>" @?= Nothing   it "accepts astral plane character" $-    go "<foo>&#x1006ff;</foo>" @?= Just astralSpec+    go "<foo>&#x1006ff;</foo>" @?= Just (spec "\x1006ff")+  it "accepts custom character references" $+    go' customSettings "<foo>&#xC;</foo>" @?= 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 [] = []

@@ -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 <michael@snoyman.com>, Aristid Breitkreuz <aristidb@googlemail.com>