tag-stream (empty) → 0.1.0
raw patch · 10 files changed
+429/−0 lines, 10 filesdep +attoparsecdep +basedep +bytestringsetup-changed
Dependencies added: attoparsec, base, bytestring, enumerator
Files
- FilterUrl.hs +48/−0
- Highlight.hs +26/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- Text/HTML/TagStream.hs +15/−0
- Text/HTML/TagStream/Parser.hs +82/−0
- Text/HTML/TagStream/Stream.hs +24/−0
- Text/HTML/TagStream/Types.hs +38/−0
- tag-stream.cabal +30/−0
- tests/Tests.hs +134/−0
+ FilterUrl.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE OverloadedStrings #-}+import Control.Applicative+import System.Environment (getArgs)+import System.IO (openBinaryFile, IOMode(..))+import qualified Data.Enumerator.Binary as E+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 Data.Attoparsec.Char8+import Text.HTML.TagStream++type Protocol = ByteString+type Domain = ByteString+type Path = ByteString+url :: Parser (Protocol, Domain, Path)+url = (,,) <$> (string "http://" <|> string "https://")+ <*> takeTill (=='/')+ <*> takeByteString++changeUrl :: ByteString -> ByteString+changeUrl s = either (const s) changeDomain $ parseOnly url s+ where+ changeDomain (prop, domain, path) =+ S.concat [ prop+ , domain+ , ".proxy.com"+ , path+ ]++withUrl :: Monad m => (ByteString -> ByteString) -> E.Enumeratee Token Token m b+withUrl f = EL.map filter'+ where filter' :: Token -> Token+ filter' (TagOpen name as close) = TagOpen name (map filter'' as) close+ filter' t = t+ filter'' :: Attr -> Attr+ filter'' (name, value)+ | name=="href" || name=="src" = (name, f value)+ | otherwise = (name, value)++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
+ Highlight.hs view
@@ -0,0 +1,26 @@+import Data.Maybe+import System.IO+import System.Environment+import Text.HTML.TagStream+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as S+import System.Console.ANSI+import qualified Data.Enumerator as E+import qualified Data.Enumerator.Binary as E+import qualified Data.Enumerator.List as EL++color :: Color -> ByteString -> ByteString+color c s = S.concat [ S.pack $ setSGRCode [SetColor Foreground Dull c]+ , s+ , S.pack $ setSGRCode [SetColor Foreground Dull White]+ ]++hightlightStream :: Monad m => E.Enumeratee Token ByteString 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
+ LICENSE 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Text/HTML/TagStream.hs view
@@ -0,0 +1,15 @@+module Text.HTML.TagStream+ ( tokenStream+ , Token+ , Token'(..)+ , Attr+ , Attr'+ , showToken+ , encode+ , encodeHL+ , decode+ ) where++import Text.HTML.TagStream.Types+import Text.HTML.TagStream.Stream+import Text.HTML.TagStream.Parser
+ Text/HTML/TagStream/Parser.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE OverloadedStrings, TupleSections #-}+module Text.HTML.TagStream.Parser where++import Prelude hiding (takeWhile)+import Control.Applicative hiding (many)+import Data.Attoparsec.Char8+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as S+import Text.HTML.TagStream.Types++(||.) :: Applicative f => f Bool -> f Bool -> f Bool+(||.) = liftA2 (||)+-- (&&.) = liftA2 (&&)++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)++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++attrs :: Parser [Attr]+attrs = many attr++comment :: Parser ByteString+comment = S.append <$>+ takeTill (=='-') <*>+ ( string "-->" *> return "" <|>+ S.cons <$> anyChar <*> comment )++special :: Parser Token+special = Comment <$> ( string "--" *> comment )+ <|> Special+ <$> ( S.cons+ <$> satisfy (not . ((=='-') ||. isSpace))+ <*> takeTill ((=='>') ||. isSpace)+ <* skipSpace )+ <*> takeTill (=='>')+ <* char '>'++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 ) )++text :: Parser Token+text = Text <$> (+ S.cons <$> anyChar <*> takeTill (=='<')+ )++token :: Parser Token+token = tag <|> text++html :: Parser [Token]+html = many token++decode :: ByteString -> Either String [Token]+decode = parseOnly html
+ Text/HTML/TagStream/Stream.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE OverloadedStrings, ViewPatterns #-}+module Text.HTML.TagStream.Stream where++import Control.Monad (liftM)+import Data.ByteString (ByteString)+import Data.Attoparsec.Char8 (parseOnly)+import qualified Data.ByteString.Char8 as S+import qualified Data.Enumerator as E+import qualified Data.Enumerator.List as EL+import Text.HTML.TagStream.Parser+import Text.HTML.TagStream.Types++accumParse :: Monad m => ByteString -> ByteString -> m (ByteString, [Token])+accumParse acc input = liftM splitAccum $+ either fail return $+ parseOnly html (acc `S.append` input)+ where+ splitAccum :: [Token] -> (ByteString, [Token])+ splitAccum [] = (S.empty, [])+ splitAccum (reverse -> (Text s : xs)) = (s, reverse xs)+ splitAccum tokens = (S.empty, tokens)++tokenStream :: Monad m => E.Enumeratee ByteString Token m b+tokenStream = EL.concatMapAccumM accumParse S.empty
+ Text/HTML/TagStream/Types.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE OverloadedStrings, FlexibleInstances #-}+module Text.HTML.TagStream.Types where++import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as S++type Attr' s = (s, s)+type Attr = Attr' ByteString+data Token' s = TagOpen s [Attr' s] Bool+ | TagClose s+ | Text s+ | Comment s+ | Special s s+ deriving (Eq, Show)++type Token = Token' ByteString++showToken :: (ByteString -> ByteString) -> Token -> ByteString+showToken hl (TagOpen name as close) =+ S.concat $ [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 "\""]+ escape '"' = "\\\""+ escape '\\' = "\\\\"+ escape c = [c]+showToken hl (TagClose name) = S.concat [hl "</", name, hl ">"]+showToken _ (Text s) = s+showToken hl (Comment s) = S.concat [hl "<!--", s, hl "-->"]+showToken hl (Special name s) = S.concat [hl "<!", name, " ", s, hl ">"]++encode :: [Token] -> ByteString+encode = encodeHL id++encodeHL :: (ByteString -> ByteString) -> [Token] -> ByteString +encodeHL hl = S.concat . map (showToken hl)
+ tag-stream.cabal view
@@ -0,0 +1,30 @@+Name: tag-stream+Version: 0.1.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.+Homepage: http://github.com/yihuang/tag-stream+License: BSD3+License-file: LICENSE+Author: yihuang+Maintainer: yi.codeplayer@gmail.com+Category: Web+Build-type: Simple+Extra-source-files: tests/Tests.hs+ , Highlight.hs+ , FilterUrl.hs+Cabal-version: >=1.6++source-repository head+ type: git+ location: git://github.com/yihuang/tag-stream.git++Library+ GHC-Options: -Wall+ Exposed-modules: Text.HTML.TagStream+ , Text.HTML.TagStream.Parser+ , Text.HTML.TagStream.Types+ , Text.HTML.TagStream.Stream+ Build-depends: base >= 4 && < 5+ , bytestring+ , attoparsec+ , enumerator
+ tests/Tests.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE FlexibleInstances, OverloadedStrings #-}+module Main where++import Debug.Trace+import Control.Applicative+import Test.Framework (defaultMain, testGroup, Test)+import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2+import Test.HUnit hiding (Test)+import Test.QuickCheck+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as S+import Text.HTML.TagStream++main :: IO ()+main = defaultMain tests++atLeast :: Arbitrary a => Int -> Gen [a]+atLeast 0 = arbitrary+atLeast n = (:) <$> arbitrary <*> atLeast (n-1)++testChar :: Gen Char+testChar = growingElements "<>=\"' \tabcde\\"+testString :: Gen String+testString = listOf testChar+testBS :: Gen ByteString+testBS = S.pack <$> testString++instance Arbitrary ByteString where+ arbitrary = testBS++instance Arbitrary (Token' ByteString) where+ arbitrary = oneof [ TagOpen <$> arbitrary <*> arbitrary <*> arbitrary+ , TagClose <$> arbitrary+ , Text <$> S.pack <$> atLeast 1+ ]++tests :: [Test]+tests = [ testGroup "Property"+ [-- testProperty "revertiable" prop_revertiable1+ ]+ , testGroup "Special cases"+ [ testCase "special cases" testSpecialCases+ --, testCase "parse real world file" testRealworldFiles+ ]+ ]++prop_revertiable1 :: ByteString -> Bool+prop_revertiable1 = either (const False) prop_revertiable . decode++prop_revertiable :: [Token] -> Bool+prop_revertiable tokens = either (const False) (==tokens) . decode . encode $ tokens++assertEither :: Either String a -> Assertion+assertEither = either (assertFailure . ("Left:"++)) (const $ return ())++assertDecode :: ByteString -> IO [Token]+assertDecode s = do+ let result = decode s+ assertEither result+ let (Right tokens) = result+ return tokens++testSpecialCases :: Assertion+testSpecialCases = mapM_ testOne testcases+ where+ testOne (str, tokens) =+ trace (show' str tokens) $+ assertDecode str >>= assertEqual "parse result incorrect" tokens+ show' str tokens = S.unpack $ S.concat [str, "\n", S.pack (show tokens)]+ testcases =+ [( "<a readonly title=xxx href=\"f<o/>o\" class=\"foo bar\">bar</a>",+ [TagOpen "a" [("readonly", ""), ("title", "xxx"), ("href", "f<o/>o"), ("class", "foo bar")] False,+ Text "bar",+ TagClose "a"] )+ ,( "<a href=fo\"o >",+ [TagOpen "a" [("href", "fo\"o")] False] )+ ,( "<a href=\"f\\\"oo\" >",+ [TagOpen "a" [("href", "f\"oo")] False] )+ ,( "<a href=\"f\\\\\\\"oo\" >",+ [TagOpen "a" [("href", "f\\\"oo")] False] )+ ,( "<a href=\"f\noo\" >",+ [TagOpen "a" [("href", "f\noo")] False] )+ ,( "<a href=>",+ [TagOpen "a" [("href", "")] False] )+ ,( "<a href=http://www.douban.com/>",+ [TagOpen "a" [("href", "http://www.douban.com/")] False] )+ ,( "<a alt=foo />",+ [TagOpen "a" [("alt", "foo")] True] )+ ,( "<a href>",+ [TagOpen "a" [("href", "")] False] )+ ,( "<a href src=/>",+ [TagOpen "a" [("href", ""), ("src", "/")] False] )+ ,( "<a\tsrc\t\r\nhref\n=\n\"\nfo\t\no\n\" title\r\n\t=>",+ [TagOpen "a" [("src", ""), ("href", "\nfo\t\no\n"), ("title", "")] False] )+ ,( "<br />",+ [TagOpen "br" [] True] )+ ,( "</br/>",+ [TagClose "br/"] )+ ,( "<\n/br/>",+ [Text "<\n/br/>"] )+ ,( "< asafasd>",+ [Text "< asafasd>"] )+ ,( "<a href=\"http://",+ [Text "<a href=\"http://"] )+ ,( "<>",+ [Text "<>"] )+ ,( "</>",+ [TagClose ""] )+ ,( "</\ndiv>",+ [TagClose "\ndiv"] )+ ,( "<!--foo-->",+ [Comment "foo"] )+ ,( "<!--f--oo->-->",+ [Comment "f--oo->"] )+ ,( "<!--fo--o->",+ [Text "<!--fo--o->"] )+ ,( "<!--fo--o->",+ [Text "<!--fo--o->"] )+ ,( "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\">",+ [Special "DOCTYPE" "html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\""] )+ ,( "<!DOCTYPE/>",+ [Special "DOCTYPE/" ""] )+ ]++testRealworldFiles :: Assertion+testRealworldFiles = mapM_ testFile files+ where+ testFile file = do+ result <- decode <$> S.readFile file+ assertEither result+ assertEqual "not equal" result $ encode <$> result >>= decode+ files = [ "qq.html"+ ]