html-conduit 1.1.0.5 → 1.3.2.2
raw patch · 8 files changed
Files
- ChangeLog.md +43/−0
- LICENSE-tagstream-conduit +30/−0
- README.md +32/−0
- Text/HTML/DOM.hs +0/−144
- html-conduit.cabal +17/−10
- src/Text/HTML/DOM.hs +148/−0
- src/Text/HTML/TagStream.hs +333/−0
- test/main.hs +108/−0
+ ChangeLog.md view
@@ -0,0 +1,43 @@+# ChangeLog for `html-conduit`++## 1.3.2.2++* Fix handling of mixed case void tags [#167](https://github.com/snoyberg/xml/issues/167)++## 1.3.2.1++* Allow xml-conduit 1.9++## 1.3.2++* Fix a bug that was removing `<` symbols in script tags.++## 1.3.1++* Inline tagstream-conduit for entity decoding in attribute value bug+ fix.++## 1.3.0++* Upgrade to conduit 1.3++## 1.2.1.2++* Remove an upper bound+* Doc improvement++## 1.2.1.1++* Allow xml-conduit 1.4++## 1.2.1++* Add strict and lazy text parsing [#66](https://github.com/snoyberg/xml/pull/66)++## 1.2.0++* Drop system-filepath++## 1.1.1.2++* Fix a bug with double-unescaping of entities
+ 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
@@ -0,0 +1,32 @@+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.++Simple usage example:++```haskell+#!/usr/bin/env stack+{- stack --install-ghc --resolver lts-6.23 runghc+ --package http-conduit --package html-conduit+-}+{-# LANGUAGE OverloadedStrings #-}+import qualified Data.Text.IO as T+import Network.HTTP.Simple (httpSink)+import Text.HTML.DOM (sinkDoc)+import Text.XML.Cursor (attributeIs, content, element,+ fromDocument, ($//), (&/), (&//))++main :: IO ()+main = do+ doc <- httpSink "http://www.yesodweb.com/book" $ const sinkDoc+ let cursor = fromDocument doc+ T.putStrLn "Chapters in the Yesod book:\n"+ mapM_ T.putStrLn+ $ cursor+ $// attributeIs "class" "main-listing"+ &// element "li"+ &/ element "a"+ &/ content+```
− Text/HTML/DOM.hs
@@ -1,144 +0,0 @@-{-# LANGUAGE OverloadedStrings, CPP #-}-module Text.HTML.DOM- ( eventConduit- , sinkDoc- , readFile- , parseLBS- ) where--import Control.Monad.Trans.Resource-import Prelude hiding (readFile)-import qualified Data.ByteString as S-#if MIN_VERSION_tagstream_conduit(0,5,0)-import qualified Text.HTML.TagStream.ByteString as TS-#endif-import qualified Text.HTML.TagStream as TS-import qualified Data.XML.Types as XT-import Data.Conduit-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Conduit.List as CL-import Control.Arrow ((***), second)-import Data.Text.Encoding (decodeUtf8With)-import Data.Text.Encoding.Error (lenientDecode)-import qualified Data.Set as Set-import qualified Text.XML as X-import Text.XML.Stream.Parse (decodeHtmlEntities)-import qualified Filesystem.Path.CurrentOS as F-import Data.Conduit.Binary (sourceFile)-import qualified Data.ByteString.Lazy as L-import Control.Monad.Trans.Resource (runExceptionT_)-import Data.Functor.Identity (runIdentity)-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 => Conduit S.ByteString m XT.Event-eventConduit =- TS.tokenStream =$= go []- where- go stack = do- mx <- await- case fmap (entities . fmap' (decodeUtf8With lenientDecode)) 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)-- fmap' :: (a -> b) -> TS.Token' a -> TS.Token' b- fmap' f (TS.TagOpen x pairs b) = TS.TagOpen (f x) (map (f *** f) pairs) b- fmap' f (TS.TagClose x) = TS.TagClose (f x)- fmap' f (TS.Text x) = TS.Text (f x)- fmap' f (TS.Comment x) = TS.Comment (f x)- fmap' f (TS.Special x y) = TS.Special (f x) (f y)- fmap' f (TS.Incomplete x) = TS.Incomplete (f x)-- entities :: TS.Token' Text -> TS.Token' Text- entities (TS.TagOpen x pairs b) = TS.TagOpen x (map (second entities') pairs) b- entities (TS.Text x) = TS.Text $ entities' x- entities ts = ts-- entities' :: Text -> Text- entities' t =- case T.break (== '&') t of- (_, "") -> t- (before, t') ->- case T.break (== ';') $ T.drop 1 t' of- (_, "") -> t- (entity, rest') ->- let rest = T.drop 1 rest'- in case decodeHtmlEntities entity of- XT.ContentText entity' -> T.concat [before, entity', entities' rest]- XT.ContentEntity _ -> T.concat [before, "&", entity, entities' rest']-- 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 => Sink S.ByteString m X.Document-sinkDoc =- fmap stripDummy $ mapOutput ((,) Nothing) eventConduit =$ 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 :: F.FilePath -> IO X.Document-readFile fp = runResourceT $ sourceFile (F.encodeString fp) $$ sinkDoc--parseLBS :: L.ByteString -> X.Document-parseLBS lbs = runIdentity $ runExceptionT_ $ CL.sourceList (L.toChunks lbs) $$ sinkDoc
html-conduit.cabal view
@@ -1,7 +1,7 @@ Name: html-conduit-Version: 1.1.0.5+Version: 1.3.2.2 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,25 +9,30 @@ Maintainer: michael@snoyman.com Category: Web, Text, Conduit Build-type: Simple-Extra-source-files: test/main.hs-Cabal-version: >=1.8+Extra-source-files: test/main.hs README.md ChangeLog.md LICENSE-tagstream-conduit+Cabal-version: >=1.10 Library+ default-language: Haskell2010 Exposed-modules: Text.HTML.DOM+ other-modules: Text.HTML.TagStream+ hs-source-dirs: src Build-depends: base >= 4 && < 5 , transformers , bytestring , containers , text- , resourcet >= 0.3 && < 1.2- , conduit >= 1.0 && < 1.2- , conduit-extra- , system-filepath >= 0.4 && < 0.5- , xml-conduit >= 1.1 && < 1.3- , tagstream-conduit >= 0.4 && < 0.6+ , resourcet >= 1.2+ , conduit >= 1.3+ , xml-conduit >= 1.3 , xml-types >= 0.3 && < 0.4 + -- tagstream-conduit deps+ , attoparsec+ , conduit-extra+ test-suite test+ default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: main.hs hs-source-dirs: test@@ -38,6 +43,8 @@ , html-conduit , bytestring , containers+ , text+ , deepseq source-repository head type: git
+ src/Text/HTML/DOM.hs view
@@ -0,0 +1,148 @@+{-# 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 name = Set.member (T.toLower name) voidSet++voidSet :: Set.Set T.Text+voidSet = 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,333 @@+{-# LANGUAGE OverloadedStrings, TupleSections, ViewPatterns #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE CPP #-}+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,";"]+#if MIN_VERSION_xml_conduit(1,9,0)+ .| XML.parseText XML.def { XML.psDecodeEntities = XML.decodeHtmlEntities }+#else+ .| XML.parseText' XML.def { XML.psDecodeEntities = XML.decodeHtmlEntities }+#endif+ .| 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@@ -39,6 +44,15 @@ it "doesn't strip whitespace" $ X.parseLBS_ X.def "<foo> hello</foo>" @=? H.parseLBS "<foo> hello</foo>"+ it "split code-points" $+ X.parseLBS_ X.def "<foo> </foo>" @=?+ H.parseBSChunks ["<foo>\xc2", "\xa0</foo>"]+ it "latin1 codes" $+ X.parseText_ X.def "<foo>\232</foo>" @=?+ H.parseSTChunks ["<foo>\232</foo>"]+ it "latin1 codes strict vs lazy" $+ H.parseLT "<foo>\232</foo>" @=?+ H.parseSTChunks ["<foo>\232</foo>"] describe "HTML parsing" $ do it "XHTML" $ let html = "<html><head><title>foo</title></head><body><p>Hello World</p></body></html>"@@ -83,3 +97,97 @@ ] ] in H.parseLBS html @?= doc+ it "Mixed case br #167" $+ let html = "<html><head><title>foo</title></head><body><bR><p>Hello World</p><BR>done</body></html>"+ doc = X.Document (X.Prologue [] Nothing []) root []+ root = X.Element "html" Map.empty+ [ X.NodeElement $ X.Element "head" Map.empty+ [ X.NodeElement $ X.Element "title" Map.empty+ [X.NodeContent "foo"]+ ]+ , X.NodeElement $ X.Element "body" Map.empty+ [ X.NodeElement $ X.Element "bR" Map.empty []+ , X.NodeElement $ X.Element "p" Map.empty+ [X.NodeContent "Hello World"]+ , X.NodeElement $ X.Element "BR" Map.empty []+ , X.NodeContent "done"+ ]+ ]+ in H.parseLBS html @?= doc++ it "doesn't double unescape" $+ let html = "<p>Hello &gt; World</p>"+ doc = X.Document (X.Prologue [] Nothing []) root []+ root = X.Element "p" Map.empty+ [ 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++ describe "#128 entities cut off" $ do+ it "reported issue" $ do+ let html = "<a href=\"https://example.com?a=b&c=d\">link</a>"+ doc = X.Document (X.Prologue [] Nothing []) root []+ root = X.Element+ "a"+ (Map.singleton "href" "https://example.com?a=b&c=d")+ [X.NodeContent "link"]+ in H.parseLBS html @?= doc++ it "from test suite" $ do+ let html = "<a class=\"u-url\" href=\"https://secure.gravatar.com/avatar/947b5f3f323da0ef785b6f02d9c265d6?s=96&d=blank&r=g\">link</a>"+ doc = X.Document (X.Prologue [] Nothing []) root []+ root = X.Element+ "a"+ (Map.fromList+ [ ("href", "https://secure.gravatar.com/avatar/947b5f3f323da0ef785b6f02d9c265d6?s=96&d=blank&r=g")+ , ("class", "u-url")+ ])+ [X.NodeContent "link"]+ in H.parseLBS html @?= doc