packages feed

tagstream-conduit (empty) → 0.2.1

raw patch · 11 files changed

+595/−0 lines, 11 filesdep +HUnitdep +QuickCheckdep +attoparsecsetup-changed

Dependencies added: HUnit, QuickCheck, attoparsec, base, blaze-builder, blaze-builder-conduit, bytestring, conduit, tagstream-conduit, test-framework, test-framework-hunit, test-framework-quickcheck2

Files

+ Highlight.hs view
@@ -0,0 +1,29 @@+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.Conduit as C+import qualified Data.Conduit.Binary as CB+import qualified Data.Conduit.List as CL+import Blaze.ByteString.Builder (Builder)+import Data.Conduit.Blaze (builderToByteString)++color :: Color -> ByteString -> ByteString+color c s = S.concat [ S.pack $ setSGRCode [SetColor Foreground Dull c]+                     , s+                     , S.pack $ setSGRCode [SetColor Foreground Dull White]+                     ]++main :: IO ()+main = do+    args <- getArgs+    filename <- maybe (fail "Highlight file") return (listToMaybe args)+    C.runResourceT $+        CB.sourceFile filename+        C.$= tokenStream+        C.$= CL.map (showToken (color Red))+        C.$= builderToByteString+        C.$$ CB.sinkHandle 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.
+ Parse.hs view
@@ -0,0 +1,16 @@+import Data.Maybe+import System.Environment+import Text.HTML.TagStream+import qualified Data.Conduit as C+import qualified Data.Conduit.Binary as C+import qualified Data.Conduit.List as CL++main :: IO ()+main = do+    args <- getArgs+    filename <- maybe (fail "pass file path") return (listToMaybe args)+    _ <- C.runResourceT $+           C.sourceFile filename+           C.$= tokenStream+           C.$$ CL.consume+    return ()
+ 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,173 @@+{-# LANGUAGE OverloadedStrings, TupleSections #-}+module Text.HTML.TagStream.Parser where++import Control.Applicative+import Data.ByteString (ByteString)+import Data.Attoparsec.Char8+import Blaze.ByteString.Builder (toByteString)+import Text.HTML.TagStream.Types+import Text.HTML.TagStream.Utils (cons, append)++{--+ - match quoted string, can fail.+ -}+quoted :: Char -> Parser ByteString+quoted q = append <$> takeTill (in2 ('\\',q))+                  <*> ( char q *> pure ""+                        <|> char '\\' *> atLeast 1 (quoted q) )++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 = (,) <$> attrName <* skipSpace+           <*> ( boolP (char '=') >>=+                 cond (skipSpace *> attrValue)+                      (pure "")+               )++{--+ - 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 tag without prefix.+ -}+comment :: Parser Token+comment = Comment <$> comment'+  where comment' = append <$> takeTill (=='-')+                          <*> ( string "-->" *> return ""+                                <|> atLeast 1 comment' )++{--+ - tags begine with <! , e.g. <!DOCTYPE ...>+ -}+special :: Parser Token+special = Special+          <$> ( 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+            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 <$> atLeast 1 (takeTill (=='<'))++token :: Parser Token+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+    loop acc = (:acc) <$> scriptEnd+           <|> (text >>= loop . (:acc))+    scriptEnd = string "</script>" *> return (TagClose "script")++html :: Parser [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+-- }}}
+ Text/HTML/TagStream/Stream.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE OverloadedStrings, ViewPatterns #-}+module Text.HTML.TagStream.Stream where++import Data.ByteString (ByteString)+import Data.Attoparsec.Char8 (parseOnly)+import qualified Data.ByteString.Char8 as S+import Data.Conduit+import Text.HTML.TagStream.Parser+import Text.HTML.TagStream.Types++-- | like concatMap, with a accumerator.+--+-- Since 0.0.0+tokenStream :: Resource m => Conduit ByteString m Token+tokenStream = conduitState S.empty push close+  where+    push accum input =+        case parseOnly html (accum `S.append` input) of+            Left err -> fail err+            Right (splitAccum -> (accum', tokens)) -> return (accum', Producing tokens)++    close s = return $ if S.null s then [] else [Text s]++    splitAccum :: [Token] -> (ByteString, [Token])+    splitAccum [] = (S.empty, [])+    splitAccum (reverse -> (Incomplete s : xs)) = (s, reverse xs)+    splitAccum tokens = (S.empty, tokens)
+ Text/HTML/TagStream/Types.hs view
@@ -0,0 +1,49 @@+{-# 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+data Token' s = TagOpen s [Attr' s] Bool+              | TagClose s+              | Text s+              | Comment s+              | Special s s+              | Incomplete s+    deriving (Eq, Show)++data TagType = TagTypeClose+             | TagTypeSpecial+             | TagTypeNormal++type Token = Token' ByteString++cc :: [ByteString] -> Builder+cc = mconcat . map fromByteString++showToken :: (ByteString -> ByteString) -> Token -> Builder+showToken hl (TagOpen name as close) =+    cc $ [hl "<", name]+      ++ map showAttr as+      ++ [hl (if close then "/>" else ">")]+  where+    showAttr :: Attr -> ByteString+    showAttr (key, value) = S.concat $ [" ", key, hl "=\""] ++ map escape (S.unpack value) ++ [hl "\""]+    escape '"' = "\\\""+    escape '\\' = "\\\\"+    escape c = S.singleton c+showToken hl (TagClose name) = cc [hl "</", name, hl ">"]+showToken _ (Text s) = fromByteString s+showToken hl (Comment s) = cc [hl "<!--", s, hl "-->"]+showToken hl (Special name s) = cc [hl "<!", name, " ", s, hl ">"]+showToken _ (Incomplete s) = fromByteString s++encode :: [Token] -> ByteString+encode = encodeHL id++encodeHL :: (ByteString -> ByteString) -> [Token] -> ByteString+encodeHL hl = toByteString . mconcat . map (showToken hl)
+ Text/HTML/TagStream/Utils.hs view
@@ -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
+ tagstream-conduit.cabal view
@@ -0,0 +1,53 @@+Name:                tagstream-conduit+Version:             0.2.1+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 the `tests/Tests.hs` module to see what it can do.+Homepage:            http://github.com/yihuang/tagstream-conduit+License:             BSD3+License-file:        LICENSE+Author:              yihuang+Maintainer:          yi.codeplayer@gmail.com+Category:            Web, Conduit+Build-type:          Simple+Extra-source-files:    tests/Tests.hs+                     , Highlight.hs+                     , Parse.hs+Cabal-version:       >=1.8++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+                     , Text.HTML.TagStream.Utils+  Build-depends:       base >= 4 && < 5+                     , bytestring+                     , conduit >= 0.0.2+                     , attoparsec+                     , blaze-builder+                     , blaze-builder-conduit++test-suite test+    hs-source-dirs: tests+    main-is: Tests.hs+    type: exitcode-stdio-1.0+    build-depends:     base >= 4 && < 5+                     , bytestring+                     , conduit >= 0.0.2+                     , QuickCheck+                     , HUnit+                     , test-framework+                     , test-framework-quickcheck2+                     , test-framework-hunit+                     , tagstream-conduit+    ghc-options:     -Wall
+ tests/Tests.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE FlexibleInstances, OverloadedStrings #-}+module Main where++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 qualified Data.Conduit as C+import qualified Data.Conduit.List as CL+import Text.HTML.TagStream++main :: IO ()+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+         ]++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 <$> C.runResourceT (+                      CL.sourceList (map S.singleton (S.unpack str))+                      C.$= tokenStream+                      C.$$ CL.consume )+        assertEqual "streamline parse result incorrect" tokens' result++testcases :: [(ByteString, [Token])]+testcases =+  -- attributes {{{+  [ ( "<span readonly title=foo class=\"foo bar\" style='display:none;'>"+    , [TagOpen "span" [("readonly", ""), ("title", "foo"), ("class", "foo bar"), ("style", "display:none;")] False]+    )+  , ( "<span a = b = c = d>"+    , [TagOpen "span" [("a", "b"), ("=", ""), ("c", "d")] False]+    )+  , ( "<span a = b = c>"+    , [TagOpen "span" [("a", "b"), ("=", ""), ("c", "")] False]+    )+  , ( "<span /foo=bar>"+    , [TagOpen "span" [("/foo", "bar")] False]+    )+  -- }}}+  -- quoted string and escaping {{{+  , ( "<span \"<p>xx \\\"'\\\\</p>\"=\"<p>xx \\\"'\\\\</p>\">"+    , [TagOpen "span" [("<p>xx \"'\\</p>", "<p>xx \"'\\</p>")] False]+    )+  , ( "<span '<p>xx \\\"\\'\\\\</p>'='<p>xx \\\"\\'\\\\</p>'>"+    , [TagOpen "span" [("<p>xx \"'\\</p>", "<p>xx \"'\\</p>")] False]+    )+  -- }}}+  -- attribute and tag end {{{+  , ( "<br/>"+    , [TagOpen "br" [] True]+    )+  , ( "<img src=http://foo.bar.com/foo.jpg />"+    , [TagOpen "img" [("src", "http://foo.bar.com/foo.jpg")] True]+    )+  , ( "<span foo>"+    , [TagOpen "span" [("foo", "")] False]+    )+  , ( "<span foo/>"+    , [TagOpen "span" [("foo", "")] True]+    )+  , ( "<span foo=/>"+    , [TagOpen "span" [("foo", "/")] False]+    )+  -- }}}+  -- normal tag {{{+  , ( "<p>text</p>"+    , [TagOpen "p" [] False, Text "text", TagClose "p"]+    )+  , ( "<>"+    , [TagOpen "" [] False]+    )+  , ( "<a\ttitle\n=\r\"foo bar\" alt=\n/\r\t>"+    , [TagOpen "a" [("title", "foo bar"), ("alt", "/")] False]+    )+  -- }}}+  -- comment tag {{{+  , ( "<!--foo-->"+    , [Comment "foo"] )+  , ( "<!--f--oo->-->"+    , [Comment "f--oo->"] )+  , ( "<!--foo-->bar-->"+    , [Comment "foo", Text "bar-->"]+    )+  -- }}}+  -- special tag {{{+  , ( "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\">"+    , [Special "DOCTYPE" "html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\""]+    )+  , ( "<!DOCTYPE html>"+    , [Special "DOCTYPE" "html"]+    )+  -- }}}+  -- close tag {{{+  , ( "</\r\t\nbr>"+    , [TagClose "\r\t\nbr"]+    )+  , ( "</br/>"+    , [TagClose "br/"]+    )+  , ( "</>"+    , [TagClose ""]+    )+  -- }}}+  -- incomplete test {{{+  -- }}}+  -- script tag TODO{{{+  , ( "<script></script>"+    , [TagOpen "script" [] False, TagClose "script"]+    )+  , ( "<script>var x=\"</script>"+    , [TagOpen "script" [] False, Text "var x=\"", TagClose "script"]+    )+  --, ( "<script>var x=\"</script>\";</script>"+  --  , [TagOpen "script" [] False, Text "var x=\"</script>\";", TagClose "script"]+  --  )+  , ( "<script>// '\r\n</script>"+    , [TagOpen "script" [] False, Text "// '\r\n", TagClose "script"]+    )+  -- }}}+  ]++testChar :: Gen Char+testChar = growingElements "<>/=\"' \t\r\nabcde\\"+testString :: Gen String+testString = listOf testChar+testBS :: Gen ByteString+testBS = S.pack <$> testString++instance Arbitrary ByteString where+    arbitrary = testBS++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++combineText :: [Token] -> [Token]+combineText [] = []+combineText (Text t1 : Text t2 : xs) = combineText $ Text (S.append t1 t2) : xs+combineText (x:xs) = x : combineText xs