diff --git a/FilterUrl.hs b/FilterUrl.hs --- a/FilterUrl.hs +++ b/FilterUrl.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} import Control.Applicative import System.Environment (getArgs) -import System.IO (openBinaryFile, IOMode(..)) +import System.IO (stdout) import qualified Data.Enumerator.Binary as E import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S @@ -9,6 +9,7 @@ import qualified Data.Enumerator.List as EL import Data.Attoparsec.Char8 import Text.HTML.TagStream +import Blaze.ByteString.Builder.Enumerator (builderToByteString) type Protocol = ByteString type Domain = ByteString @@ -41,8 +42,9 @@ main :: IO () main = do [filename] <- getArgs - h <- openBinaryFile filename ReadMode - let bufSize = 2 - enum = E.enumHandle bufSize h - tokens <- E.run_ $ ((enum E.$= tokenStream) E.$= withUrl changeUrl) E.$$ EL.consume - S.putStrLn $ S.concat $ map (showToken id) tokens + E.run_ $ E.enumFile filename + E.$= tokenStream + E.$= withUrl changeUrl + E.$= EL.map (showToken id) + E.$= builderToByteString + E.$$ E.iterHandle stdout diff --git a/Highlight.hs b/Highlight.hs --- a/Highlight.hs +++ b/Highlight.hs @@ -8,6 +8,8 @@ import qualified Data.Enumerator as E import qualified Data.Enumerator.Binary as E import qualified Data.Enumerator.List as EL +import Blaze.ByteString.Builder (Builder) +import Blaze.ByteString.Builder.Enumerator (unsafeBuilderToByteString, allocBuffer) color :: Color -> ByteString -> ByteString color c s = S.concat [ S.pack $ setSGRCode [SetColor Foreground Dull c] @@ -15,12 +17,16 @@ , S.pack $ setSGRCode [SetColor Foreground Dull White] ] -hightlightStream :: Monad m => E.Enumeratee Token ByteString m b +hightlightStream :: Monad m => E.Enumeratee Token Builder m b hightlightStream = EL.map (showToken (color Red)) main :: IO () main = do args <- getArgs filename <- maybe (fail "pass file path") return (listToMaybe args) - let enum = (E.enumFile filename E.$= tokenStream) E.$= hightlightStream - E.run_ $ enum E.$$ E.iterHandle stdout + let iter = E.enumFile filename + E.$= tokenStream + E.$= hightlightStream + E.$= unsafeBuilderToByteString (allocBuffer 4096) + E.$$ E.iterHandle stdout + E.run_ iter diff --git a/Text/HTML/TagStream/Parser.hs b/Text/HTML/TagStream/Parser.hs --- a/Text/HTML/TagStream/Parser.hs +++ b/Text/HTML/TagStream/Parser.hs @@ -1,82 +1,182 @@ {-# LANGUAGE OverloadedStrings, TupleSections #-} module Text.HTML.TagStream.Parser where -import Prelude hiding (takeWhile) -import Control.Applicative hiding (many) -import Data.Attoparsec.Char8 +import Control.Applicative import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S +import Data.Attoparsec.Char8 +import Blaze.ByteString.Builder (toByteString) import Text.HTML.TagStream.Types +import Text.HTML.TagStream.Utils (cons, append) -(||.) :: Applicative f => f Bool -> f Bool -> f Bool -(||.) = liftA2 (||) --- (&&.) = liftA2 (&&) +{-- + - match quoted string, can fail. + -} +quoted :: Char -> Parser ByteString +quoted q = append <$> takeTill (in2 ('\\',q)) + <*> ( char q *> pure "" + <|> char '\\' *> atLeast 1 (quoted q) ) -value :: Parser ByteString -value = char '"' *> str - <|> takeTill (inClass ">=" ||. isSpace) - where - str = S.append <$> takeTill (inClass "\\\"") - <*> (end <|> unescape) - end = char '"' *> return "" - unescape = char '\\' *> - (S.cons <$> anyChar <*> str) +quotedOr :: Parser ByteString -> Parser ByteString +quotedOr p = maybeP (satisfy (in2 ('"','\''))) >>= + maybe p quoted +{-- + - attribute value, can't fail. + -} +attrValue :: Parser ByteString +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 ByteString +attrName = quotedOr $ + 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 Attr -attr = do - skipSpace - c <- satisfy (notInClass "/>") - name' <- takeTill (inClass ">=" ||. isSpace) - let name = S.cons c name' - skipSpace - option (name, S.empty) $ do - _ <- char '=' - skipSpace - (name,) <$> value +attr = (,) <$> attrName <* skipSpace + <*> ( boolP (char '=') >>= + cond (skipSpace *> attrValue) + (pure "") + ) -attrs :: Parser [Attr] -attrs = many attr +{-- + - all attributes before tag end. can't fail. + -} +attrs :: Parser ([Attr], Bool) +attrs = loop [] + where + loop acc = skipSpace *> (Left <$> tagEnd <|> Right <$> attr) >>= + either + (return . (reverse acc,)) + (loop . (:acc)) -comment :: Parser ByteString -comment = S.append <$> - takeTill (=='-') <*> - ( string "-->" *> return "" <|> - S.cons <$> anyChar <*> comment ) +{-- + - comment tag without prefix. + -} +comment :: Parser Token +comment = Comment <$> comment' + where comment' = append <$> takeTill (=='-') + <*> ( string "-->" *> return "" + <|> atLeast 1 comment' ) +{-- + - tags begine with + -} special :: Parser Token -special = Comment <$> ( string "--" *> comment ) - <|> Special - <$> ( S.cons - <$> satisfy (not . ((=='-') ||. isSpace)) - <*> takeTill ((=='>') ||. isSpace) - <* skipSpace ) - <*> takeTill (=='>') - <* char '>' +special = Special + <$> ( cons <$> satisfy (not . ((=='-') ||. isSpace)) + <*> takeTill ((=='>') ||. isSpace) + <* skipSpace ) + <*> takeTill (=='>') <* char '>' +{-- + - parse a tag, can fail. + -} tag :: Parser Token -tag = string " special - <|> string " (TagClose <$> takeTill (=='>')) - <* char '>' - <|> char '<' - *> ( TagOpen - <$> ( S.cons - <$> satisfy (not . (isSpace ||. (inClass "!>"))) - <*> takeTill (inClass "/>" ||. isSpace) ) - <*> attrs <* skipSpace - <*> ( char '>' *> return False - <|> string "/>" *> return True ) ) +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 + skipSpace + return $ TagOpen name as close +{-- + - record incomplete tag for streamline processing. + -} +incomplete :: Parser Token +incomplete = Incomplete . cons '<' <$> takeByteString + +{-- + - parse text node. consume at least one char, to make sure progress. + -} text :: Parser Token -text = Text <$> ( - S.cons <$> anyChar <*> takeTill (=='<') - ) +text = Text <$> atLeast 1 (takeTill (=='<')) token :: Parser Token -token = tag <|> text +token = char '<' *> (tag <|> incomplete) + <|> text +{-- + - treat script tag specially, can't fail. + -} +tillScriptEnd :: Token -> Parser [Token] +tillScriptEnd t = reverse <$> loop [t] + <|> (:[]) . Incomplete . append script <$> takeByteString + where + script = toByteString $ showToken id t + surround q s = S.concat [S.singleton q, s, S.singleton q] + loop acc = do + s <- takeTill (in3 ('<','\'','"')) + let acc' = if S.null s then acc else Text s:acc + mq <- maybeP (satisfy (in2 ('"','\''))) + case mq of + Just q -> Text . surround q <$> quoted q >>= + loop . (:acc') + Nothing -> (:acc') <$> scriptEnd + + scriptEnd = string "" *> return (TagClose "script") + html :: Parser [Token] -html = many token +html = tokens <|> pure [] + where + tokens :: Parser [Token] + tokens = do + t <- token + case t of + (TagOpen name _ close) + | not close && name=="script" + -> (++) <$> tillScriptEnd t <*> html + _ -> (t:) <$> html decode :: ByteString -> Either String [Token] decode = parseOnly html + +{-- + - Utils {{{ + -} + +atLeast :: Int -> Parser ByteString -> Parser ByteString +atLeast 0 p = p +atLeast n p = 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 +-- }}} diff --git a/Text/HTML/TagStream/Stream.hs b/Text/HTML/TagStream/Stream.hs --- a/Text/HTML/TagStream/Stream.hs +++ b/Text/HTML/TagStream/Stream.hs @@ -17,7 +17,7 @@ where splitAccum :: [Token] -> (ByteString, [Token]) splitAccum [] = (S.empty, []) - splitAccum (reverse -> (Text s : xs)) = (s, reverse xs) + splitAccum (reverse -> (Incomplete s : xs)) = (s, reverse xs) splitAccum tokens = (S.empty, tokens) tokenStream :: Monad m => E.Enumeratee ByteString Token m b diff --git a/Text/HTML/TagStream/Types.hs b/Text/HTML/TagStream/Types.hs --- a/Text/HTML/TagStream/Types.hs +++ b/Text/HTML/TagStream/Types.hs @@ -1,8 +1,10 @@ {-# LANGUAGE OverloadedStrings, FlexibleInstances #-} module Text.HTML.TagStream.Types where +import Data.Monoid import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S +import Blaze.ByteString.Builder (Builder, fromByteString, toByteString) type Attr' s = (s, s) type Attr = Attr' ByteString @@ -11,28 +13,37 @@ | Text s | Comment s | Special s s + | Incomplete s deriving (Eq, Show) +data TagType = TagTypeClose + | TagTypeSpecial + | TagTypeNormal + type Token = Token' ByteString -showToken :: (ByteString -> ByteString) -> Token -> ByteString +cc :: [ByteString] -> Builder +cc = mconcat . map fromByteString + +showToken :: (ByteString -> ByteString) -> Token -> Builder showToken hl (TagOpen name as close) = - S.concat $ [hl "<", name] - ++ map showAttr as - ++ [hl (if close then "/>" else ">")] + cc $ [hl "<", name] + ++ map showAttr as + ++ [hl (if close then "/>" else ">")] where showAttr :: Attr -> ByteString - showAttr (key, value) = S.concat [" ", key, hl "=\"", S.pack . concatMap escape . S.unpack $ value, hl "\""] + showAttr (key, value) = S.concat $ [" ", key, hl "=\""] ++ map escape (S.unpack value) ++ [hl "\""] escape '"' = "\\\"" escape '\\' = "\\\\" - escape c = [c] -showToken hl (TagClose name) = S.concat [hl ""] -showToken _ (Text s) = s -showToken hl (Comment s) = S.concat [hl ""] -showToken hl (Special name s) = S.concat [hl ""] + escape c = S.singleton c +showToken hl (TagClose name) = cc [hl ""] +showToken _ (Text s) = fromByteString s +showToken hl (Comment s) = cc [hl ""] +showToken hl (Special name s) = cc [hl ""] +showToken _ (Incomplete s) = fromByteString s encode :: [Token] -> ByteString encode = encodeHL id -encodeHL :: (ByteString -> ByteString) -> [Token] -> ByteString -encodeHL hl = S.concat . map (showToken hl) +encodeHL :: (ByteString -> ByteString) -> [Token] -> ByteString +encodeHL hl = toByteString . mconcat . map (showToken hl) diff --git a/Text/HTML/TagStream/Utils.hs b/Text/HTML/TagStream/Utils.hs new file mode 100644 --- /dev/null +++ b/Text/HTML/TagStream/Utils.hs @@ -0,0 +1,22 @@ +module Text.HTML.TagStream.Utils where +import Data.Word +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) +import Foreign.Storable (Storable(peekByteOff)) +import qualified Data.ByteString as S +import qualified Data.ByteString.Internal as S + +peekByteOff' :: Storable a => ForeignPtr b -> Int -> a +peekByteOff' p i = S.inlinePerformIO $ withForeignPtr p $ \p' -> peekByteOff p' i + +cons' :: Word8 -> S.ByteString -> S.ByteString +cons' c bs@(S.PS p s l) + | s>0 && peekByteOff' p (s-1)==c = S.PS p (s-1) (l+1) + | otherwise = S.cons c bs + +cons :: Char -> S.ByteString -> S.ByteString +cons = cons' . S.c2w + +append :: S.ByteString -> S.ByteString -> S.ByteString +append (S.PS p1 s1 l1) (S.PS p2 s2 l2) + | p1==p2 && (s1+l1)==s2 = S.PS p1 s1 (l1+l2) +append xs ys = S.append xs ys diff --git a/tag-stream.cabal b/tag-stream.cabal --- a/tag-stream.cabal +++ b/tag-stream.cabal @@ -1,7 +1,12 @@ Name: tag-stream -Version: 0.1.0 +Version: 0.2.0 Synopsis: streamlined html tag parser -Description: Tag-stream is a library for parsing HTML/XML to a token stream. It can parse unstructured and malformed HTML from the web. It also provides an Enumeratee which can parse streamline html, which means it consumes constant memory. You can start from `tests/Tests.hs` to see what it can do. +Description: + Tag-stream is a library for parsing HTML//XML to a token stream. + It can parse unstructured and malformed HTML from the web. + It also provides an Enumeratee which can parse streamline html, which means it consumes constant memory. + + Users can start from the `tests/Tests.hs` module to see what it can do. Homepage: http://github.com/yihuang/tag-stream License: BSD3 License-file: LICENSE @@ -19,12 +24,14 @@ location: git://github.com/yihuang/tag-stream.git Library - GHC-Options: -Wall + GHC-Options: -Wall -O2 Exposed-modules: Text.HTML.TagStream , Text.HTML.TagStream.Parser , Text.HTML.TagStream.Types , Text.HTML.TagStream.Stream + , Text.HTML.TagStream.Utils Build-depends: base >= 4 && < 5 , bytestring + , enumerator >= 0.4.15 , attoparsec - , enumerator + , blaze-builder diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -1,7 +1,6 @@ {-# LANGUAGE FlexibleInstances, OverloadedStrings #-} module Main where -import Debug.Trace import Control.Applicative import Test.Framework (defaultMain, testGroup, Test) import Test.Framework.Providers.HUnit @@ -10,17 +9,149 @@ import Test.QuickCheck import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S +import qualified Data.Enumerator as E +import qualified Data.Enumerator.List as EL import Text.HTML.TagStream main :: IO () -main = defaultMain tests +main = defaultMain + [ testGroup "Property" + [ testProperty "Text nodes can't be empty" propTextNotEmpty + , testProperty "Parse results can't empty" propResultNotEmpty + ] + , testGroup "One pass parse" onePassTests + , testGroup "Streamline parse" streamlineTests + ] -atLeast :: Arbitrary a => Int -> Gen [a] -atLeast 0 = arbitrary -atLeast n = (:) <$> arbitrary <*> atLeast (n-1) +propTextNotEmpty :: ByteString -> Bool +propTextNotEmpty = either (const False) text_not_empty . decode + where text_not_empty = all not_empty + not_empty (Text s) = S.length s > 0 + not_empty _ = True +propResultNotEmpty :: ByteString -> Bool +propResultNotEmpty s = either (const False) not_empty . decode $ s + where not_empty tokens = (S.null s && null tokens) + || (not (S.null s) && not (null tokens)) + +onePassTests :: [Test] +onePassTests = map one testcases + where + one (str, tokens) = testCase (S.unpack str) $ do + result <- combineText <$> assertDecode str + assertEqual "one-pass parse result incorrect" tokens result + +streamlineTests :: [Test] +streamlineTests = map one testcases + where + isIncomplete (Incomplete _) = True + isIncomplete _ = False + one (str, tokens) = testCase (S.unpack str) $ do + -- streamline parse result don't contain the trailing Incomplete token. + let tokens' = reverse . dropWhile isIncomplete . reverse $ tokens + result <- combineText <$> E.run_ ( + E.enumList 1 (map S.singleton (S.unpack str)) + E.$= tokenStream + E.$$ EL.consume ) + assertEqual "streamline parse result incorrect" tokens' result + +testcases :: [(ByteString, [Token])] +testcases = + -- attributes {{{ + [ ( "