html-conduit (empty) → 0.0.0

raw patch · 5 files changed

+187/−0 lines, 5 filesdep +HUnitdep +basedep +bytestringsetup-changed

Dependencies added: HUnit, base, bytestring, conduit, containers, filesystem-conduit, hspec, html-conduit, resourcet, system-filepath, tagstream-conduit, text, transformers, xml-conduit, xml-types

Files

LICENSE +20/−0
Setup.hs +2/−0
Text/HTML/DOM.hs +97/−0
html-conduit.cabal +43/−0
test/main.hs +25/−0

+ LICENSE view

@@ -0,0 +1,20 @@+Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ Text/HTML/DOM.hs view

@@ -0,0 +1,97 @@+{-# LANGUAGE OverloadedStrings #-}+module Text.HTML.DOM+    ( eventConduit+    , sinkDoc+    , readFile+    , parseLBS+    ) where++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 Data.Conduit+import qualified Data.Conduit.List as CL+import Control.Arrow ((***))+import Data.Text.Encoding (decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode)+import qualified Data.Set as Set+import qualified Text.XML as X+import qualified Filesystem.Path.CurrentOS as F+import Data.Conduit.Filesystem (sourceFile)+import qualified Data.ByteString.Lazy as L+import Control.Monad.Trans.Resource (runExceptionT_)+import Data.Functor.Identity (runIdentity)++-- | Converts a stream of bytes to a stream of properly balanced @Event@s.+eventConduit :: Monad m => Conduit S.ByteString m XT.Event+eventConduit =+    TS.tokenStream =$= go []+  where+    go stack = do+        mx <- await+        case fmap (fmap' $ decodeUtf8With lenientDecode) mx of+            Nothing -> closeStack 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)++    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 = eventConduit =$ X.fromEvents++readFile :: F.FilePath -> IO X.Document+readFile fp = runResourceT $ sourceFile fp $$ sinkDoc++parseLBS :: L.ByteString -> X.Document+parseLBS lbs = runIdentity $ runExceptionT_ $ CL.sourceList (L.toChunks lbs) $$ sinkDoc

+ html-conduit.cabal view

@@ -0,0 +1,43 @@+Name:                html-conduit+Version:             0.0.0+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.+Homepage:            https://github.com/snoyberg/xml+License:             MIT+License-file:        LICENSE+Author:              Michael Snoyman+Maintainer:          michael@snoyman.com+Category:            Web, Text, Conduit+Build-type:          Simple+Extra-source-files:  test/main.hs+Cabal-version:       >=1.8++Library+  Exposed-modules:     Text.HTML.DOM+  Build-depends:       base                             >= 4              && < 5+                     , transformers+                     , bytestring+                     , containers+                     , text+                     , resourcet                        >= 0.3            && < 0.4+                     , conduit                          >= 0.4            && < 0.5+                     , filesystem-conduit               >= 0.4            && < 0.5+                     , system-filepath                  >= 0.4            && < 0.5+                     , xml-conduit                      >= 0.7            && < 0.8+                     , tagstream-conduit                >= 0.3            && < 0.4+                     , xml-types                        >= 0.3            && < 0.4++test-suite test+    type: exitcode-stdio-1.0+    main-is: main.hs+    hs-source-dirs: test+    build-depends:          base+                          , hspec+                          , HUnit+                          , xml-conduit+                          , html-conduit+                          , bytestring++source-repository head+  type: git+  location: git://github.com/snoyberg/xml.conduit

+ test/main.hs view

@@ -0,0 +1,25 @@+{-# LANGUAGE OverloadedStrings #-}+import Test.HUnit hiding (Test)+import Test.Hspec.Monadic+import Test.Hspec.HUnit ()+import Data.ByteString.Lazy.Char8 ()+import qualified Text.HTML.DOM as H+import qualified Text.XML as X++main :: IO ()+main = hspecX $ do+    describe "parses" $ do+        it "well-formed document" $+            X.parseLBS_ X.def "<foo><bar>baz</bar></foo>" @=?+            H.parseLBS        "<foo><bar>baz</bar></foo>"+        it "adds missing close tags" $+            X.parseLBS_ X.def "<foo><bar>baz</bar></foo>" @=?+            H.parseLBS        "<foo><bar>baz</foo>"+            {- Need to fix in tagstream-conduit+        it "entities" $+            X.parseLBS_ X.def "<foo><bar>baz&#160;</bar></foo>" @=?+            H.parseLBS        "<foo><bar>baz&nbsp;</foo>"+            -}+        it "void tags" $+            X.parseLBS_ X.def "<foo><bar><img/>foo</bar></foo>" @=?+            H.parseLBS        "<foo><bar><img>foo</foo>"