html-conduit 1.3.0 → 1.3.1
raw patch · 8 files changed
+573/−150 lines, 8 filesdep +attoparsecdep +conduit-extradep +deepseqdep −tagstream-conduit
Dependencies added: attoparsec, conduit-extra, deepseq
Dependencies removed: tagstream-conduit
Files
- ChangeLog.md +5/−0
- LICENSE-tagstream-conduit +30/−0
- README.md +2/−1
- Text/HTML/DOM.hs +0/−145
- html-conduit.cabal +11/−4
- src/Text/HTML/DOM.hs +145/−0
- src/Text/HTML/TagStream.hs +328/−0
- test/main.hs +52/−0
ChangeLog.md view
@@ -1,3 +1,8 @@+## 1.3.1++* Inline tagstream-conduit for entity decoding in attribute value bug+ fix.+ ## 1.3.0 * Upgrade to conduit 1.3
+ LICENSE-tagstream-conduit view
@@ -0,0 +1,30 @@+Copyright (c)2011, yihuang++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of yihuang nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
README.md view
@@ -1,7 +1,8 @@ This package uses tagstream-conduit for its parser. It automatically balances mismatched tags, so that there shouldn't be any parse failures. It does not handle a full HTML document rendering, such as adding missing html and head-tags.+tags. Note that, since version 1.3.1, it uses an inlined copy of+tagstream-conduit with entity decoding bugfixes applied. Simple usage example:
− Text/HTML/DOM.hs
@@ -1,145 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Text.HTML.DOM- ( eventConduit- , sinkDoc- , readFile- , parseLBS- , parseBSChunks- , eventConduitText- , sinkDocText- , parseLT- , parseSTChunks- ) where--import Control.Monad.Trans.Resource-import Prelude hiding (readFile)-import qualified Data.ByteString as S-import qualified Text.HTML.TagStream.Text as TS-import qualified Text.HTML.TagStream as TS-import qualified Data.XML.Types as XT-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import qualified Data.Conduit.List as CL-import Control.Arrow ((***))-import qualified Data.Set as Set-import qualified Text.XML as X-import Conduit-import qualified Data.ByteString.Lazy as L-import Data.Maybe (mapMaybe)---- | Converts a stream of bytes to a stream of properly balanced @Event@s.------ Note that there may be multiple (or not) root elements. @sinkDoc@ addresses--- that case.-eventConduit :: Monad m => ConduitT S.ByteString XT.Event m ()-eventConduit = decodeUtf8LenientC .| eventConduit'--eventConduitText :: Monad m => ConduitT T.Text XT.Event m ()-eventConduitText = eventConduit'--eventConduit' :: Monad m => ConduitT T.Text XT.Event m ()-eventConduit' =- TS.tokenStream .| go []- where- go stack = do- mx <- await- case mx of- Nothing -> closeStack stack-- -- Ignore processing instructions (or pseudo-instructions)- Just (TS.TagOpen local _ _) | "?" `T.isPrefixOf` local -> go stack-- Just (TS.TagOpen local attrs isClosed) -> do- let name = toName local- attrs' = map (toName *** return . XT.ContentText) attrs- yield $ XT.EventBeginElement name attrs'- if isClosed || isVoid local- then yield (XT.EventEndElement name) >> go stack- else go $ name : stack- Just (TS.TagClose name)- | toName name `elem` stack ->- let loop [] = go []- loop (n:ns) = do- yield $ XT.EventEndElement n- if n == toName name- then go ns- else loop ns- in loop stack- | otherwise -> go stack- Just (TS.Text t) -> do- yield $ XT.EventContent $ XT.ContentText t- go stack- Just (TS.Comment t) -> do- yield $ XT.EventComment t- go stack- Just TS.Special{} -> go stack- Just TS.Incomplete{} -> go stack- toName l = XT.Name l Nothing Nothing- closeStack = mapM_ (yield . XT.EventEndElement)-- isVoid = flip Set.member $ Set.fromList- [ "area"- , "base"- , "br"- , "col"- , "command"- , "embed"- , "hr"- , "img"- , "input"- , "keygen"- , "link"- , "meta"- , "param"- , "source"- , "track"- , "wbr"- ]--sinkDoc :: MonadThrow m => ConduitT S.ByteString o m X.Document-sinkDoc = sinkDoc' eventConduit--sinkDocText :: MonadThrow m => ConduitT T.Text o m X.Document-sinkDocText = sinkDoc' eventConduitText--sinkDoc'- :: MonadThrow m- => ConduitT a XT.Event m ()- -> ConduitT a o m X.Document-sinkDoc' f =- fmap stripDummy $ mapOutput ((,) Nothing) f .| addDummyWrapper .| X.fromEvents- where- addDummyWrapper = do- yield (Nothing, XT.EventBeginElement "html" [])- awaitForever yield- yield (Nothing, XT.EventEndElement "html")-- stripDummy doc@(X.Document pro (X.Element _ _ nodes) epi) =- case mapMaybe toElement nodes of- [root] -> X.Document pro root epi- _ -> doc-- toElement (X.NodeElement e) = Just e- toElement _ = Nothing--readFile :: FilePath -> IO X.Document-readFile fp = withSourceFile fp $ \src -> runConduit $ src .| sinkDoc--parseLBS :: L.ByteString -> X.Document-parseLBS = parseBSChunks . L.toChunks--parseBSChunks :: [S.ByteString] -> X.Document-parseBSChunks tss =- case runConduit $ CL.sourceList tss .| sinkDoc of- Left e -> error $ "Unexpected exception in parseBSChunks: " ++ show e- Right x -> x--parseLT :: TL.Text -> X.Document-parseLT = parseSTChunks . TL.toChunks--parseSTChunks :: [T.Text] -> X.Document-parseSTChunks tss =- case runConduit $ CL.sourceList tss .| sinkDocText of- Left e -> error $ "Unexpected exception in parseSTChunks: " ++ show e- Right x -> x-
html-conduit.cabal view
@@ -1,7 +1,7 @@ Name: html-conduit-Version: 1.3.0+Version: 1.3.1 Synopsis: Parse HTML documents using xml-conduit datatypes.-Description: This package uses tagstream-conduit for its parser. It automatically balances mismatched tags, so that there shouldn't be any parse failures. It does not handle a full HTML document rendering, such as adding missing html and head tags.+Description: This package uses tagstream-conduit for its parser. It automatically balances mismatched tags, so that there shouldn't be any parse failures. It does not handle a full HTML document rendering, such as adding missing html and head tags. Note that, since version 1.3.1, it uses an inlined copy of tagstream-conduit with entity decoding bugfixes applied. Homepage: https://github.com/snoyberg/xml License: MIT License-file: LICENSE@@ -9,11 +9,13 @@ Maintainer: michael@snoyman.com Category: Web, Text, Conduit Build-type: Simple-Extra-source-files: test/main.hs README.md ChangeLog.md+Extra-source-files: test/main.hs README.md ChangeLog.md LICENSE-tagstream-conduit Cabal-version: >=1.8 Library Exposed-modules: Text.HTML.DOM+ other-modules: Text.HTML.TagStream+ hs-source-dirs: src Build-depends: base >= 4 && < 5 , transformers , bytestring@@ -22,9 +24,12 @@ , resourcet >= 1.2 , conduit >= 1.3 , xml-conduit >= 1.3- , tagstream-conduit >= 0.5.5.3 && < 0.6 , xml-types >= 0.3 && < 0.4 + -- tagstream-conduit deps+ , attoparsec+ , conduit-extra+ test-suite test type: exitcode-stdio-1.0 main-is: main.hs@@ -36,6 +41,8 @@ , html-conduit , bytestring , containers+ , text+ , deepseq source-repository head type: git
+ src/Text/HTML/DOM.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE OverloadedStrings #-}+module Text.HTML.DOM+ ( eventConduit+ , sinkDoc+ , readFile+ , parseLBS+ , parseBSChunks+ , eventConduitText+ , sinkDocText+ , parseLT+ , parseSTChunks+ ) where++import Control.Monad.Trans.Resource+import Prelude hiding (readFile)+import qualified Data.ByteString as S+import qualified Text.HTML.TagStream as TS+import qualified Data.XML.Types as XT+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Conduit.List as CL+import Control.Arrow ((***))+import qualified Data.Set as Set+import qualified Text.XML as X+import Conduit+import qualified Data.ByteString.Lazy as L+import Data.Maybe (mapMaybe)+import qualified Data.Map.Strict as Map++-- | Converts a stream of bytes to a stream of properly balanced @Event@s.+--+-- Note that there may be multiple (or not) root elements. @sinkDoc@ addresses+-- that case.+eventConduit :: Monad m => ConduitT S.ByteString XT.Event m ()+eventConduit = decodeUtf8LenientC .| eventConduit'++eventConduitText :: Monad m => ConduitT T.Text XT.Event m ()+eventConduitText = eventConduit'++eventConduit' :: Monad m => ConduitT T.Text XT.Event m ()+eventConduit' =+ TS.tokenStream .| go []+ where+ go stack = do+ mx <- await+ case mx of+ Nothing -> closeStack stack++ -- Ignore processing instructions (or pseudo-instructions)+ Just (TS.TagOpen local _ _) | "?" `T.isPrefixOf` local -> go stack++ Just (TS.TagOpen local attrs isClosed) -> do+ let name = toName local+ attrs' = map (toName *** return . XT.ContentText) $ Map.toList attrs+ yield $ XT.EventBeginElement name attrs'+ if isClosed || isVoid local+ then yield (XT.EventEndElement name) >> go stack+ else go $ name : stack+ Just (TS.TagClose name)+ | toName name `elem` stack ->+ let loop [] = go []+ loop (n:ns) = do+ yield $ XT.EventEndElement n+ if n == toName name+ then go ns+ else loop ns+ in loop stack+ | otherwise -> go stack+ Just (TS.Text t) -> do+ yield $ XT.EventContent $ XT.ContentText t+ go stack+ Just (TS.Comment t) -> do+ yield $ XT.EventComment t+ go stack+ Just TS.Special{} -> go stack+ Just TS.Incomplete{} -> go stack+ toName l = XT.Name l Nothing Nothing+ closeStack = mapM_ (yield . XT.EventEndElement)++ isVoid = flip Set.member $ Set.fromList+ [ "area"+ , "base"+ , "br"+ , "col"+ , "command"+ , "embed"+ , "hr"+ , "img"+ , "input"+ , "keygen"+ , "link"+ , "meta"+ , "param"+ , "source"+ , "track"+ , "wbr"+ ]++sinkDoc :: MonadThrow m => ConduitT S.ByteString o m X.Document+sinkDoc = sinkDoc' eventConduit++sinkDocText :: MonadThrow m => ConduitT T.Text o m X.Document+sinkDocText = sinkDoc' eventConduitText++sinkDoc'+ :: MonadThrow m+ => ConduitT a XT.Event m ()+ -> ConduitT a o m X.Document+sinkDoc' f =+ fmap stripDummy $ mapOutput ((,) Nothing) f .| addDummyWrapper .| X.fromEvents+ where+ addDummyWrapper = do+ yield (Nothing, XT.EventBeginElement "html" [])+ awaitForever yield+ yield (Nothing, XT.EventEndElement "html")++ stripDummy doc@(X.Document pro (X.Element _ _ nodes) epi) =+ case mapMaybe toElement nodes of+ [root] -> X.Document pro root epi+ _ -> doc++ toElement (X.NodeElement e) = Just e+ toElement _ = Nothing++readFile :: FilePath -> IO X.Document+readFile fp = withSourceFile fp $ \src -> runConduit $ src .| sinkDoc++parseLBS :: L.ByteString -> X.Document+parseLBS = parseBSChunks . L.toChunks++parseBSChunks :: [S.ByteString] -> X.Document+parseBSChunks tss =+ case runConduit $ CL.sourceList tss .| sinkDoc of+ Left e -> error $ "Unexpected exception in parseBSChunks: " ++ show e+ Right x -> x++parseLT :: TL.Text -> X.Document+parseLT = parseSTChunks . TL.toChunks++parseSTChunks :: [T.Text] -> X.Document+parseSTChunks tss =+ case runConduit $ CL.sourceList tss .| sinkDocText of+ Left e -> error $ "Unexpected exception in parseSTChunks: " ++ show e+ Right x -> x+
+ src/Text/HTML/TagStream.hs view
@@ -0,0 +1,328 @@+{-# LANGUAGE OverloadedStrings, TupleSections, ViewPatterns #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RecordWildCards #-}+module Text.HTML.TagStream+ ( Token (..)+ , tokenStream+ ) where++import Control.Applicative+import Control.Monad (unless)+import Control.Monad.Trans.Resource (MonadThrow)+import Data.Char+import qualified Data.Conduit.List as CL++import Data.Attoparsec.Text+import Data.Conduit+import qualified Data.Conduit.Attoparsec as CA+import Data.Maybe (fromMaybe, isJust)+import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy as L+import qualified Data.Text.Lazy.Builder as B+import qualified Text.XML.Stream.Parse as XML+import Data.Map (Map)+import qualified Data.Map.Strict as Map+import Control.Arrow (first)++data Token+ = TagOpen Text (Map Text Text) Bool+ | TagClose Text+ | Text Text+ | Comment Text+ | Special Text Text+ | Incomplete Text+ deriving (Eq, Show)++data TagType+ = TagTypeClose+ | TagTypeSpecial+ | TagTypeNormal++{--+ - match quoted string, can fail.+ -}+quoted :: Char -> Parser Text+quoted q = T.append <$> takeTill (in2 ('\\',q))+ <*> ( char q *> pure ""+ <|> char '\\' *> atLeast 1 (quoted q) )++quotedOr :: Parser Text -> Parser Text+quotedOr p = maybeP (satisfy (in2 ('"','\''))) >>=+ maybe p quoted++{--+ - attribute value, can't fail.+ -}+attrValue :: Parser Text+attrValue = quotedOr $ takeTill ((=='>') ||. isSpace)++{--+ - attribute name, at least one char, can fail when meet tag end.+ - might match self-close tag end "/>" , make sure match `tagEnd' first.+ -}+attrName :: Parser Text+attrName = quotedOr $+ T.cons <$> satisfy (/='>')+ <*> takeTill (in3 ('/','>','=') ||. isSpace)++{--+ - tag end, return self-close or not, can fail.+ -}+tagEnd :: Parser Bool+tagEnd = char '>' *> pure False+ <|> string "/>" *> pure True++{--+ - attribute pair or tag end, can fail if tag end met.+ -}+attr :: Parser (Text, Text)+attr = (,) <$> attrName <* skipSpace+ <*> ( boolP (char '=') >>=+ cond (skipSpace *> attrValue)+ (pure "")+ )++{--+ - all attributes before tag end. can't fail.+ -}+attrs :: Parser (Map Text Text, Bool)+attrs = loop Map.empty+ where+ loop acc = skipSpace *> (Left <$> tagEnd <|> Right <$> attr) >>=+ either+ (return . (acc,))+ (\(key, value) -> loop $ Map.insert key value acc)++{--+ - comment tag without prefix.+ -}+comment :: Parser Token+comment = Comment <$> comment'+ where comment' = T.append <$> takeTill (=='-')+ <*> ( string "-->" *> return ""+ <|> atLeast 1 comment' )++{--+ - tags begine with <! , e.g. <!DOCTYPE ...>+ -}+special :: Parser Token+special = Special+ <$> ( T.cons <$> satisfy (not . ((=='-') ||. isSpace))+ <*> takeTill ((=='>') ||. isSpace)+ <* skipSpace )+ <*> takeTill (=='>') <* char '>'++{--+ - parse a tag, can fail.+ -}+tag :: Parser Token+tag = do+ t <- string "/" *> return TagTypeClose+ <|> string "!" *> return TagTypeSpecial+ <|> return TagTypeNormal+ case t of+ TagTypeClose ->+ TagClose <$> takeTill (=='>')+ <* char '>'+ TagTypeSpecial -> boolP (string "--") >>=+ cond comment special+ TagTypeNormal -> do+ name <- takeTill (in3 ('<','>','/') ||. isSpace)+ (as, close) <- attrs+ return $ TagOpen name (Map.map decodeString as) close++{--+ - record incomplete tag for streamline processing.+ -}+incomplete :: Parser Token+incomplete = Incomplete . T.cons '<' <$> takeText++{--+ - parse text node. consume at least one char, to make sure progress.+ -}+text :: Parser Token+text = Text <$> atLeast 1 (takeTill (=='<'))++decodeEntity :: MonadThrow m => Text -> m Text+decodeEntity entity =+ runConduit+ $ CL.sourceList ["&",entity,";"]+ .| XML.parseText' XML.def { XML.psDecodeEntities = XML.decodeHtmlEntities }+ .| XML.content++token :: Parser Token+token = char '<' *> (tag <|> incomplete)+ <|> text++{--+ - treat script tag specially, can't fail.+ -}+tillScriptEnd :: Token -> Parser [Token]+tillScriptEnd open =+ loop mempty+ where+ loop acc = do+ chunk <- takeTill (== '<')+ let acc' = acc <> B.fromText chunk+ finish = pure [open, Text $ L.toStrict $ B.toLazyText acc', TagClose "script"]+ hasContent = (string "/script>" *> finish) <|> loop acc'+ (char '<' *> hasContent) <|> finish++tokens :: Parser [Token]+tokens = do+ t <- token+ case t of+ TagOpen "script" _ False -> tillScriptEnd t+ Text text0 -> do+ let parseText = do+ Text text <- token+ pure text+ texts <- many parseText+ pure [Text $ decodeString $ T.concat $ text0 : texts]+ _ -> pure [t]++{--+ - Utils {{{+ -}++atLeast :: Int -> Parser Text -> Parser Text+atLeast 0 p = p+atLeast n p = T.cons <$> anyChar <*> atLeast (n-1) p++cond :: a -> a -> Bool -> a+cond a1 a2 b = if b then a1 else a2++(||.) :: Applicative f => f Bool -> f Bool -> f Bool+(||.) = liftA2 (||)++in2 :: Eq a => (a,a) -> a -> Bool+in2 (a1,a2) a = a==a1 || a==a2++in3 :: Eq a => (a,a,a) -> a -> Bool+in3 (a1,a2,a3) a = a==a1 || a==a2 || a==a3++boolP :: Parser a -> Parser Bool+boolP p = p *> pure True <|> pure False++maybeP :: Parser a -> Parser (Maybe a)+maybeP p = Just <$> p <|> return Nothing+-- }}}++-- {{{ Stream+tokenStream :: Monad m+ => ConduitT Text Token m ()+tokenStream =+ CL.filter (not . T.null) .| CA.conduitParserEither tokens .| CL.concatMap go+ where+ go (Left e) = error $ "html-conduit: parse error that should never happen occurred! " ++ show e+ go (Right (_, tokens')) = tokens'++splitAccum :: [Token] -> (Text, [Token])+splitAccum [] = (mempty, [])+splitAccum (reverse -> (Incomplete s : xs)) = (s, reverse xs)+splitAccum tokens = (mempty, tokens)++-- Entities++-- | A conduit to decode entities from a stream of tokens into a new stream of tokens.+decodeEntities :: Monad m => ConduitT Token Token m ()+decodeEntities =+ start+ where+ start = await >>= maybe (return ()) (\token' -> start' token' >> start)+ start' (Text t) = (yield t >> yieldWhileText) .| decodeEntities' .| CL.mapMaybe go+ start' (TagOpen name attrs' bool) = yield (TagOpen name (Map.map decodeString attrs') bool)+ start' token' = yield token'++ go t+ | t == "" = Nothing+ | otherwise = Just (Text t)++-- | Decode entities in a complete string.+decodeString :: Text -> Text+decodeString input =+ case makeEntityDecoder input of+ (value', remainder)+ | value' /= mempty -> value' <> decodeString remainder+ | otherwise -> input++decodeEntities' :: Monad m => ConduitT Text Text m ()+decodeEntities' =+ loop id+ where+ loop accum = do+ mchunk <- await+ let chunk = accum $ fromMaybe mempty mchunk+ (newStr, remainder) = makeEntityDecoder chunk+ yield newStr+ if isJust mchunk+ then loop (mappend remainder)+ else yield remainder++-- | Yield contiguous text tokens as strings.+yieldWhileText :: Monad m => ConduitT Token Text m ()+yieldWhileText =+ loop+ where+ loop = await >>= maybe (return ()) go+ go (Text t) = yield t >> loop+ go token' = leftover token'++-- | Decode the entities in a string type with a decoder.+makeEntityDecoder :: Text -> (Text, Text)+makeEntityDecoder = first (L.toStrict . B.toLazyText) . go+ where+ go s =+ case T.break (=='&') s of+ (_,"") -> (B.fromText s, "")+ (before,restPlusAmp@(T.drop 1 -> rest)) ->+ case T.break (not . (\c -> isNameChar c || c == '#')) rest of+ (_,"") -> (B.fromText before, restPlusAmp)+ (entity,after) -> (before1 <> before2, after')+ where+ before1 = B.fromText before+ (before2, after') =+ case mdecoded of+ Nothing -> first (("&" <> B.fromText entity) <>) (go after)+ Just (B.fromText -> decoded) ->+ case T.uncons after of+ Just (';',validAfter) -> first (decoded <>) (go validAfter)+ Just (_invalid,_rest) -> first (decoded <>) (go after)+ Nothing -> (mempty, s)+ mdecoded =+ if entity == mempty+ then Nothing+ else decodeEntity entity++-- | Is the character a valid Name starter?+isNameStart :: Char -> Bool+isNameStart c =+ c == ':' ||+ c == '_' ||+ isAsciiUpper c ||+ isAsciiLower c ||+ (c >= '\xC0' && c <= '\xD6') ||+ (c >= '\xD8' && c <= '\xF6') ||+ (c >= '\xF8' && c <= '\x2FF') ||+ (c >= '\x370' && c <= '\x37D') ||+ (c >= '\x37F' && c <= '\x1FFF') ||+ (c >= '\x200C' && c <= '\x200D') ||+ (c >= '\x2070' && c <= '\x218F') ||+ (c >= '\x2C00' && c <= '\x2FEF') ||+ (c >= '\x3001' && c <= '\xD7FF') ||+ (c >= '\xF900' && c <= '\xFDCF') ||+ (c >= '\xFDF0' && c <= '\xFFFD') ||+ (c >= '\x10000' && c <= '\xEFFFF')++-- | Is the character valid in a Name?+isNameChar :: Char -> Bool+isNameChar c =+ c == '-' ||+ c == '.' ||+ c == '\xB7' ||+ isDigit c ||+ isNameStart c ||+ (c >= '\x0300' && c <= '\x036F') ||+ (c >= '\x203F' && c <= '\x2040')
test/main.hs view
@@ -1,10 +1,15 @@ {-# LANGUAGE OverloadedStrings #-} import Test.HUnit hiding (Test) import Test.Hspec+import Test.Hspec.QuickCheck import Data.ByteString.Lazy.Char8 () import qualified Text.HTML.DOM as H import qualified Text.XML as X import qualified Data.Map as Map+import qualified Data.Text as T+import Control.Exception (evaluate)+import Control.DeepSeq (($!!))+import Control.Monad (void) main :: IO () main = hspec $ do@@ -100,3 +105,50 @@ [ X.NodeContent "Hello > World" ] in H.parseLBS html @?= doc++ it "handles entities in attributes" $+ let html = "<br title=\"Mac & Cheese\">"+ doc = X.Document (X.Prologue [] Nothing []) root []+ root = X.Element "br" (Map.singleton "title" "Mac & Cheese") []+ in H.parseLBS html @?= doc++ it "doesn't double escape entities in attributes" $+ let html = "<br title=\"Mac &amp; Cheese\">"+ doc = X.Document (X.Prologue [] Nothing []) root []+ root = X.Element "br" (Map.singleton "title" "Mac & Cheese") []+ in H.parseLBS html @?= doc++ describe "script tags" $ do+ it "ignores funny characters" $+ let html = "<script>hello > world</script>"+ doc = X.Document (X.Prologue [] Nothing []) root []+ root = X.Element "script" Map.empty [X.NodeContent "hello > world"]+ in H.parseLBS html @?= doc++ {-++ Would be nice... doesn't work with tagstream-conduit original+ code. Not even sure if the HTML5 parser spec discusses this+ case.++ it "ignores </script> inside string" $+ let html = "<script>hello \"</script>\" world</script>"+ doc = X.Document (X.Prologue [] Nothing []) root []+ root = X.Element "script" Map.empty [X.NodeContent "hello \"</script>\" world"]+ in H.parseLBS html @?= doc++ -}++ it "unterminated" $+ let html = "<script>hello > world"+ doc = X.Document (X.Prologue [] Nothing []) root []+ root = X.Element "script" Map.empty [X.NodeContent "hello > world"]+ in H.parseLBS html @?= doc++ it "entities" $+ let html = "<script>hello & world"+ doc = X.Document (X.Prologue [] Nothing []) root []+ root = X.Element "script" Map.empty [X.NodeContent "hello & world"]+ in H.parseLBS html @?= doc++ prop "parses all random input" $ \strs -> void $ evaluate $!! H.parseSTChunks $ map T.pack strs