diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,49 @@ ## HEAD +## 0.6.2.2 + +- Fix build breakage on GHC 9.8 / mtl 2.3 + +## 0.6.2.1 + +- Match Content-Type case-insensitively. + +## 0.6.2 + +- Add the monad transformer `ScraperT`. + +## 0.6.1 + +- Support GHC 8.8. + +## 0.6.0 + +### Breaking Changes + +- `anySelector` now captures text nodes. This causes different results when used + with a plural scraper (e.g. `chroots`). Usage with a singular scraper (e.g. + `chroot`) should be unaffected. +- The dependency on `curl` has been replaced with `http-client` and + `http-client-tls`. This has the following observable changes. + - `scrapeURLWithOpts` is removed. + - The `Config` type used with `scrapeURLWithConfig` no longer contains a list + of curl options. Instead it now takes a `Maybe Manager` from `http-client`. + - The `Decoder` function type now takes in a `Response` type from + `http-client`. + - `scrapeURL` will now throw an exception if there is a problem connecting to + a URL. + +### Other Changes + +- Remove `Ord` constraint from public APIs. +- Add `atDepth` operator which allows for selecting nodes at a specified depth + in relation to another node (#21). +- Fix issue selecting malformed HTML where `"a" // "c"` would not match + ``. +- Add `textSelector` for selecting text nodes. +- Add `SerialScraper` type and associated primitives (#48). + ## 0.5.1 - Fix bug (#59, #54) in DFS traversal order. diff --git a/scalpel-core.cabal b/scalpel-core.cabal --- a/scalpel-core.cabal +++ b/scalpel-core.cabal @@ -1,5 +1,5 @@ name: scalpel-core -version: 0.5.1 +version: 0.6.2.2 synopsis: A high level web scraping library for Haskell. description: Scalpel core provides a subset of the scalpel web scraping library that is @@ -24,7 +24,7 @@ source-repository this type: git location: https://github.com/fimad/scalpel.git - tag: v0.5.1 + tag: v0.6.2.2 library other-extensions: @@ -36,6 +36,7 @@ , Text.HTML.Scalpel.Internal.Select , Text.HTML.Scalpel.Internal.Select.Combinators , Text.HTML.Scalpel.Internal.Select.Types + , Text.HTML.Scalpel.Internal.Serial exposed-modules: Text.HTML.Scalpel.Core hs-source-dirs: src/ @@ -46,11 +47,14 @@ , containers , data-default , fail + , pointedlist , regex-base , regex-tdfa , tagsoup >= 0.12.2 , text , vector + , transformers + , mtl default-extensions: ParallelListComp , PatternGuards diff --git a/src/Text/HTML/Scalpel/Core.hs b/src/Text/HTML/Scalpel/Core.hs --- a/src/Text/HTML/Scalpel/Core.hs +++ b/src/Text/HTML/Scalpel/Core.hs @@ -18,10 +18,12 @@ , AttributeName (..) , TagName (..) , tagSelector +, textSelector -- ** Wildcards , anySelector -- ** Tag combinators , (//) +, atDepth -- ** Attribute predicates , (@:) , (@=) @@ -32,6 +34,7 @@ -- * Scrapers , Scraper +, ScraperT -- ** Primitives , attr , attrs @@ -44,12 +47,28 @@ , chroot , chroots , position +, matches -- ** Executing scrapers , scrape +, scrapeT , scrapeStringLike +, scrapeStringLikeT + +-- * Serial Scraping +, SerialScraper +, SerialScraperT +, inSerial +-- ** Primitives +, stepNext +, stepBack +, seekNext +, seekBack +, untilNext +, untilBack ) where import Text.HTML.Scalpel.Internal.Scrape import Text.HTML.Scalpel.Internal.Scrape.StringLike import Text.HTML.Scalpel.Internal.Select.Combinators import Text.HTML.Scalpel.Internal.Select.Types +import Text.HTML.Scalpel.Internal.Serial diff --git a/src/Text/HTML/Scalpel/Internal/Scrape.hs b/src/Text/HTML/Scalpel/Internal/Scrape.hs --- a/src/Text/HTML/Scalpel/Internal/Scrape.hs +++ b/src/Text/HTML/Scalpel/Internal/Scrape.hs @@ -1,7 +1,16 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK hide #-} module Text.HTML.Scalpel.Internal.Scrape ( Scraper +, ScraperT (..) , scrape +, scrapeT , attr , attrs , html @@ -12,6 +21,7 @@ , texts , chroot , chroots +, matches , position ) where @@ -20,6 +30,14 @@ import Control.Applicative import Control.Monad +import Control.Monad.Except (MonadError) +import Control.Monad.Cont (MonadCont) +import Control.Monad.Reader +import Control.Monad.State (MonadState) +import Control.Monad.Trans.Maybe +import Control.Monad.Writer (MonadWriter) +import Control.Monad.Fix +import Data.Functor.Identity import Data.Maybe import qualified Control.Monad.Fail as Fail @@ -28,47 +46,44 @@ import qualified Text.StringLike as TagSoup --- | A value of 'Scraper' @a@ defines a web scraper that is capable of consuming --- a list of 'TagSoup.Tag's and optionally producing a value of type @a@. -newtype Scraper str a = MkScraper { - scrapeTagSpec :: TagSpec str -> Maybe a - } +-- | A 'ScraperT' operates like 'Scraper' but also acts as a monad transformer. +newtype ScraperT str m a = MkScraper (ReaderT (TagSpec str) (MaybeT m) a) + deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadFix, + MonadIO, MonadCont, MonadError e, MonadState s, MonadWriter w) -instance Functor (Scraper str) where - fmap f (MkScraper a) = MkScraper $ fmap (fmap f) a +#if MIN_VERSION_base(4,9,0) +deriving instance Monad m => Fail.MonadFail (ScraperT str m) +#else +instance Fail.MonadFail m => Fail.MonadFail (ScraperT str m) where + fail = lift . Fail.fail +#endif -instance Applicative (Scraper str) where - pure = MkScraper . const . Just - (MkScraper f) <*> (MkScraper a) = MkScraper applied - where applied tags | (Just aVal) <- a tags = ($ aVal) <$> f tags - | otherwise = Nothing +instance MonadTrans (ScraperT str) where + lift op = MkScraper . lift . lift $ op -instance Alternative (Scraper str) where - empty = MkScraper $ const Nothing - (MkScraper a) <|> (MkScraper b) = MkScraper choice - where choice tags | (Just aVal) <- a tags = Just aVal - | otherwise = b tags +instance MonadReader s m => MonadReader s (ScraperT str m) where + ask = MkScraper (lift . lift $ ask) + local f (MkScraper op) = (fmap MkScraper . mapReaderT . local) f op -instance Monad (Scraper str) where - fail = Fail.fail - return = pure - (MkScraper a) >>= f = MkScraper combined - where combined tags | (Just aVal) <- a tags = let (MkScraper b) = f aVal - in b tags - | otherwise = Nothing +-- | A value of 'Scraper' @a@ defines a web scraper that is capable of consuming +-- a list of 'TagSoup.Tag's and optionally producing a value of type @a@. +type Scraper str = ScraperT str Identity -instance MonadPlus (Scraper str) where - mzero = empty - mplus = (<|>) +scrapeTagSpec :: ScraperT str m a -> TagSpec str -> m (Maybe a) +scrapeTagSpec (MkScraper r) = runMaybeT . runReaderT r -instance Fail.MonadFail (Scraper str) where - fail _ = mzero +-- | The 'scrapeT' function executes a 'ScraperT' on a list of 'TagSoup.Tag's +-- and produces an optional value. Since 'ScraperT' is a monad transformer, the +-- result is monadic. +scrapeT :: (TagSoup.StringLike str) + => ScraperT str m a -> [TagSoup.Tag str] -> m (Maybe a) +scrapeT s = scrapeTagSpec s . tagsToSpec . TagSoup.canonicalizeTags --- | The 'scrape' function executes a 'Scraper' on a list of --- 'TagSoup.Tag's and produces an optional value. -scrape :: (Ord str, TagSoup.StringLike str) +-- | The 'scrape' function executes a 'Scraper' on a list of 'TagSoup.Tag's and +-- produces an optional value. +scrape :: (TagSoup.StringLike str) => Scraper str a -> [TagSoup.Tag str] -> Maybe a -scrape s = scrapeTagSpec s . tagsToSpec . TagSoup.canonicalizeTags +scrape = fmap runIdentity . scrapeT -- | The 'chroot' function takes a selector and an inner scraper and executes -- the inner scraper as if it were scraping a document that consists solely of @@ -76,8 +91,8 @@ -- -- This function will match only the first set of tags matching the selector, to -- match every set of tags, use 'chroots'. -chroot :: (Ord str, TagSoup.StringLike str) - => Selector -> Scraper str a -> Scraper str a +chroot :: (TagSoup.StringLike str, Monad m) + => Selector -> ScraperT str m a -> ScraperT str m a chroot selector inner = do maybeResult <- listToMaybe <$> chroots selector inner guard (isJust maybeResult) @@ -86,39 +101,55 @@ -- | The 'chroots' function takes a selector and an inner scraper and executes -- the inner scraper as if it were scraping a document that consists solely of -- the tags corresponding to the selector. The inner scraper is executed for --- each set of tags matching the given selector. -chroots :: (Ord str, TagSoup.StringLike str) - => Selector -> Scraper str a -> Scraper str [a] -chroots selector (MkScraper inner) = MkScraper - $ return . mapMaybe inner . select selector +-- each set of tags (possibly nested) matching the given selector. +-- +-- > s = "
A
" +-- > scrapeStringLike s (chroots "div" (pure 0)) == Just [0, 0] +chroots :: (TagSoup.StringLike str, Monad m) + => Selector -> ScraperT str m a -> ScraperT str m [a] +chroots selector (MkScraper (ReaderT inner)) = + MkScraper $ ReaderT $ \tags -> MaybeT $ do + mvalues <- forM (select selector tags) (runMaybeT . inner) + return $ Just $ catMaybes mvalues +-- | The 'matches' function takes a selector and returns `()` if the selector +-- matches any node in the DOM. +matches :: (TagSoup.StringLike str, Monad m) => Selector -> ScraperT str m () +matches s = MkScraper $ (guard . not . null) =<< reader (select s) + -- | The 'text' function takes a selector and returns the inner text from the -- set of tags described by the given selector. -- -- This function will match only the first set of tags matching the selector, to -- match every set of tags, use 'texts'. -text :: (Ord str, TagSoup.StringLike str) => Selector -> Scraper str str -text s = MkScraper $ withHead tagsToText . select s +text :: (TagSoup.StringLike str, Monad m) => Selector -> ScraperT str m str +text s = MkScraper $ withHead tagsToText =<< reader (select s) -- | The 'texts' function takes a selector and returns the inner text from every --- set of tags matching the given selector. -texts :: (Ord str, TagSoup.StringLike str) - => Selector -> Scraper str [str] -texts s = MkScraper $ withAll tagsToText . select s +-- set of tags (possibly nested) matching the given selector. +-- +-- > s = "
Hello
World
" +-- > scrapeStringLike s (texts "div") == Just ["Hello World", "World"] +texts :: (TagSoup.StringLike str, Monad m) + => Selector -> ScraperT str m [str] +texts s = MkScraper $ withAll tagsToText =<< reader (select s) -- | The 'html' function takes a selector and returns the html string from the -- set of tags described by the given selector. -- -- This function will match only the first set of tags matching the selector, to -- match every set of tags, use 'htmls'. -html :: (Ord str, TagSoup.StringLike str) => Selector -> Scraper str str -html s = MkScraper $ withHead tagsToHTML . select s +html :: (TagSoup.StringLike str, Monad m) => Selector -> ScraperT str m str +html s = MkScraper $ withHead tagsToHTML =<< reader (select s) -- | The 'htmls' function takes a selector and returns the html string from --- every set of tags matching the given selector. -htmls :: (Ord str, TagSoup.StringLike str) - => Selector -> Scraper str [str] -htmls s = MkScraper $ withAll tagsToHTML . select s +-- every set of tags (possibly nested) matching the given selector. +-- +-- > s = "
A
" +-- > scrapeStringLike s (htmls "div") == Just ["
A
", "
A
"] +htmls :: (TagSoup.StringLike str, Monad m) + => Selector -> ScraperT str m [str] +htmls s = MkScraper $ withAll tagsToHTML =<< reader (select s) -- | The 'innerHTML' function takes a selector and returns the inner html string -- from the set of tags described by the given selector. Inner html here meaning @@ -126,15 +157,18 @@ -- -- This function will match only the first set of tags matching the selector, to -- match every set of tags, use 'innerHTMLs'. -innerHTML :: (Ord str, TagSoup.StringLike str) - => Selector -> Scraper str str -innerHTML s = MkScraper $ withHead tagsToInnerHTML . select s +innerHTML :: (TagSoup.StringLike str, Monad m) + => Selector -> ScraperT str m str +innerHTML s = MkScraper $ withHead tagsToInnerHTML =<< reader (select s) -- | The 'innerHTMLs' function takes a selector and returns the inner html --- string from every set of tags matching the given selector. -innerHTMLs :: (Ord str, TagSoup.StringLike str) - => Selector -> Scraper str [str] -innerHTMLs s = MkScraper $ withAll tagsToInnerHTML . select s +-- string from every set of tags (possibly nested) matching the given selector. +-- +-- > s = "
A
" +-- > scrapeStringLike s (innerHTMLs "div") == Just ["
A
", "A"] +innerHTMLs :: (TagSoup.StringLike str, Monad m) + => Selector -> ScraperT str m [str] +innerHTMLs s = MkScraper $ withAll tagsToInnerHTML =<< reader (select s) -- | The 'attr' function takes an attribute name and a selector and returns the -- value of the attribute of the given name for the first opening tag that @@ -142,18 +176,23 @@ -- -- This function will match only the opening tag matching the selector, to match -- every tag, use 'attrs'. -attr :: (Ord str, Show str, TagSoup.StringLike str) - => String -> Selector -> Scraper str str -attr name s = MkScraper - $ join . withHead (tagsToAttr $ TagSoup.castString name) . select s +attr :: (Show str, TagSoup.StringLike str, Monad m) + => String -> Selector -> ScraperT str m str +attr name s = MkScraper $ ReaderT $ MaybeT + . return . listToMaybe . catMaybes + . fmap (tagsToAttr $ TagSoup.castString name) . select s -- | The 'attrs' function takes an attribute name and a selector and returns the --- value of the attribute of the given name for every opening tag that matches --- the given selector. -attrs :: (Ord str, Show str, TagSoup.StringLike str) - => String -> Selector -> Scraper str [str] -attrs name s = MkScraper - $ fmap catMaybes . withAll (tagsToAttr nameStr) . select s +-- value of the attribute of the given name for every opening tag +-- (possibly nested) that matches the given selector. +-- +-- > s = "
" +-- > scrapeStringLike s (attrs "id" "div") == Just ["out", "in"] +attrs :: (Show str, TagSoup.StringLike str, Monad m) + => String -> Selector -> ScraperT str m [str] +attrs name s = MkScraper $ ReaderT $ MaybeT + . return . Just . catMaybes + . fmap (tagsToAttr nameStr) . select s where nameStr = TagSoup.castString name -- | The 'position' function is intended to be used within the do-block of a @@ -190,15 +229,15 @@ -- , (2, "Third paragraph.") -- ] -- @ -position :: (Ord str, TagSoup.StringLike str) => Scraper str Int -position = MkScraper $ Just . tagsToPosition +position :: (TagSoup.StringLike str, Monad m) => ScraperT str m Int +position = MkScraper $ reader tagsToPosition -withHead :: (a -> b) -> [a] -> Maybe b -withHead _ [] = Nothing -withHead f (x:_) = Just $ f x +withHead :: Monad m => (a -> b) -> [a] -> ReaderT (TagSpec str) (MaybeT m) b +withHead _ [] = empty +withHead f (x:_) = return $ f x -withAll :: (a -> b) -> [a] -> Maybe [b] -withAll f xs = Just $ map f xs +withAll :: Monad m => (a -> b) -> [a] -> ReaderT (TagSpec str) (MaybeT m) [b] +withAll f xs = return $ map f xs foldSpec :: TagSoup.StringLike str => (TagSoup.Tag str -> str -> str) -> TagSpec str -> str @@ -222,11 +261,11 @@ tagsToAttr :: (Show str, TagSoup.StringLike str) => str -> TagSpec str -> Maybe str -tagsToAttr attr (tags, _, _) = do +tagsToAttr tagName (tags, _, _) = do guard $ 0 < Vector.length tags let tag = infoTag $ tags Vector.! 0 guard $ TagSoup.isTagOpen tag - return $ TagSoup.fromAttrib attr tag + return $ TagSoup.fromAttrib tagName tag tagsToPosition :: TagSpec str -> Int tagsToPosition (_, _, ctx) = ctxPosition ctx diff --git a/src/Text/HTML/Scalpel/Internal/Scrape/StringLike.hs b/src/Text/HTML/Scalpel/Internal/Scrape/StringLike.hs --- a/src/Text/HTML/Scalpel/Internal/Scrape/StringLike.hs +++ b/src/Text/HTML/Scalpel/Internal/Scrape/StringLike.hs @@ -1,17 +1,25 @@ {-# OPTIONS_HADDOCK hide #-} module Text.HTML.Scalpel.Internal.Scrape.StringLike ( scrapeStringLike +, scrapeStringLikeT ) where +import Data.Functor.Identity import Text.HTML.Scalpel.Internal.Scrape import qualified Text.HTML.TagSoup as TagSoup import qualified Text.StringLike as TagSoup - -- | The 'scrapeStringLike' function parses a 'StringLike' value into a list of -- tags and executes a 'Scraper' on it. -scrapeStringLike :: (Ord str, TagSoup.StringLike str) +scrapeStringLike :: (TagSoup.StringLike str) => str -> Scraper str a -> Maybe a -scrapeStringLike html scraper - = scrape scraper (TagSoup.parseTagsOptions TagSoup.parseOptionsFast html) +scrapeStringLike = fmap runIdentity . scrapeStringLikeT + +-- | The 'scrapeStringLikeT' function parses a 'StringLike' value into a list of +-- tags and executes a 'ScraperT' on it. Since 'ScraperT' is a monad +-- transformer, the result is monadic. +scrapeStringLikeT :: (TagSoup.StringLike str, Monad m) + => str -> ScraperT str m a -> m (Maybe a) +scrapeStringLikeT tags scraper = scrapeT scraper + (TagSoup.parseTagsOptions TagSoup.parseOptionsFast tags) diff --git a/src/Text/HTML/Scalpel/Internal/Select.hs b/src/Text/HTML/Scalpel/Internal/Select.hs --- a/src/Text/HTML/Scalpel/Internal/Select.hs +++ b/src/Text/HTML/Scalpel/Internal/Select.hs @@ -45,7 +45,6 @@ data TagInfo str = TagInfo { infoTag :: !(TagSoup.Tag str) , infoName :: !Name - , infoIndex :: !Index , infoOffset :: !CloseOffset } @@ -61,6 +60,10 @@ -- selector. This indicates the index in the result list -- that this TagSpec corresponds to. ctxPosition :: !Index + -- | True if the current context is the result of chrooting + -- to a sub-tree. This is used by serial scrapers to + -- determine how to generate zippered sibling nodes. + , ctxInChroot :: !Bool } -- | A structured representation of the parsed tags that provides fast element @@ -70,22 +73,23 @@ -- | The 'select' function takes a 'Selectable' value and a list of -- 'TagSoup.Tag's and returns a list of every subsequence of the given list of -- Tags that matches the given selector. -select :: (Ord str, TagSoup.StringLike str) +select :: (TagSoup.StringLike str) => Selector -> TagSpec str -> [TagSpec str] select s tagSpec = newSpecs where (MkSelector nodes) = s - newSpecs = zipWith applyPosition [0..] (selectNodes nodes tagSpec []) - applyPosition p (tags, f, ctx) = (tags, f, SelectContext p) + newSpecs = + zipWith applyPosition [0..] (selectNodes nodes tagSpec tagSpec []) + applyPosition p (tags, f, _) = (tags, f, SelectContext p True) -- | Creates a TagSpec from a list of tags parsed by TagSoup. -tagsToSpec :: forall str. (Ord str, TagSoup.StringLike str) +tagsToSpec :: forall str. (TagSoup.StringLike str) => [TagSoup.Tag str] -> TagSpec str tagsToSpec tags = (vector, tree, ctx) where vector = tagsToVector tags tree = vectorToTree vector - ctx = SelectContext 0 + ctx = SelectContext 0 False -- | Annotate each tag with the offset to the corresponding closing tag. This -- annotating is done in O(n * log(n)). @@ -109,7 +113,7 @@ -- closing offset. -- -- (5) The result set is then sorted by their indices. -tagsToVector :: forall str. (Ord str, TagSoup.StringLike str) +tagsToVector :: forall str. (TagSoup.StringLike str) => [TagSoup.Tag str] -> TagVector str tagsToVector tags = let indexed = zip tags [0..] total = length indexed @@ -120,38 +124,40 @@ go :: [(TagSoup.Tag str, Index)] -> Map.Map T.Text [(TagSoup.Tag str, Index)] -> [(Index, TagInfo str)] - go [] state = map (\(t, i) -> (i, TagInfo t (maybeName t) i Nothing)) - $ concat - $ Map.elems state + go [] state = + map (\(t, i) -> (i, TagInfo t (maybeName t) Nothing)) + $ concat + $ Map.elems state where maybeName t | TagSoup.isTagOpen t = Just $ getTagName t | TagSoup.isTagClose t = Just $ getTagName t | otherwise = Nothing - go (x@(tag, index) : xs) state + go ((tag, index) : xs) state | TagSoup.isTagClose tag = let maybeOpen = head <$> Map.lookup tagName state state' = Map.alter popTag tagName state - info = TagInfo tag (Just tagName) index Nothing + info = TagInfo tag (Just tagName) Nothing res = catMaybes [ Just (index, info) , calcOffset <$> maybeOpen ] in res ++ go xs state' - | TagSoup.isTagOpen tag = go xs (Map.alter appendTag tagName state) - | otherwise = - let info = TagInfo tag Nothing index Nothing + | TagSoup.isTagOpen tag = + go xs (Map.alter appendTag tagName state) + | otherwise = + let info = TagInfo tag Nothing Nothing in (index, info) : go xs state where tagName = getTagName tag appendTag :: Maybe [(TagSoup.Tag str, Index)] -> Maybe [(TagSoup.Tag str, Index)] - appendTag m = (x :) <$> (m <|> Just []) + appendTag m = ((tag, index) :) <$> (m <|> Just []) - calcOffset :: (TagSoup.Tag str, Int) -> (Index, TagInfo str) + calcOffset :: (TagSoup.Tag str, Index) -> (Index, TagInfo str) calcOffset (t, i) = let offset = index - i - info = TagInfo t (Just tagName) i (Just offset) + info = TagInfo t (Just tagName) (Just offset) in offset `seq` (i, info) popTag :: Maybe [a] -> Maybe [a] @@ -174,12 +180,14 @@ forestWithin :: Int -> Int -> TagForest forestWithin !lo !hi | hi <= lo = [] - | not isOpen = forestWithin (lo + 1) hi + | shouldSkip = forestWithin (lo + 1) hi | otherwise = Tree.Node (Span lo closeIndex) subForest : forestWithin (closeIndex + 1) hi where info = tags Vector.! lo isOpen = TagSoup.isTagOpen $ infoTag info + isText = TagSoup.isTagText $ infoTag info + shouldSkip = not isOpen && not isText closeIndex = lo + fromMaybe 0 (infoOffset info) subForest = forestWithin (lo + 1) closeIndex @@ -210,17 +218,25 @@ -- with the remaining SelectNodes. If there is only a single SelectNode then any -- node encountered that satisfies the SelectNode is returned as an answer. selectNodes :: TagSoup.StringLike str - => [SelectNode] -> TagSpec str -> [TagSpec str] -> [TagSpec str] -selectNodes [] _ acc = acc -selectNodes [_] (_, [], _) acc = acc + => [(SelectNode, SelectSettings)] + -> TagSpec str + -> TagSpec str + -> [TagSpec str] + -> [TagSpec str] +selectNodes [] _ _ acc = acc +selectNodes [_] (_, [], _) _ acc = acc -- Now that there is only a single SelectNode to satisfy, search the remaining -- forests and generates a TagSpec for each node that satisfies the condition. -selectNodes [n] (tags, f : fs, ctx) acc - | nodeMatches n info = (shrunkSpec :) - $ selectNodes [n] (tags, fs, ctx) - $ selectNodes [n] (tags, Tree.subForest f, ctx) acc - | otherwise = selectNodes [n] (tags, Tree.subForest f, ctx) - $ selectNodes [n] (tags, fs, ctx) acc +selectNodes [n] cur@(tags, f : fs, ctx) root acc + | MatchOk == matchResult + = (shrunkSpec :) + $ selectNodes [n] (tags, fs, ctx) root + $ selectNodes [n] (tags, Tree.subForest f, ctx) root acc + | MatchCull == matchResult + = selectNodes [n] (tags, fs, ctx) root acc + | otherwise + = selectNodes [n] (tags, Tree.subForest f, ctx) root + $ selectNodes [n] (tags, fs, ctx) root acc where Span lo hi = Tree.rootLabel f shrunkSpec = ( @@ -230,38 +246,115 @@ ) recenter (Span nLo nHi) = Span (nLo - lo) (nHi - lo) info = tags Vector.! lo + matchResult = nodeMatches n info cur root -- There are multiple SelectNodes that need to be satisfied. If the current node -- satisfies the condition, then the current nodes sub-forest is searched for -- matches of the remaining SelectNodes. -selectNodes (_ : _) (_, [], _) acc = acc -selectNodes (n : ns) (tags, f : fs, ctx) acc - | nodeMatches n info = selectNodes ns (tags, Tree.subForest f, ctx) - $ selectNodes (n : ns) (tags, fs, ctx) acc - | otherwise = selectNodes (n : ns) (tags, Tree.subForest f, ctx) - $ selectNodes (n : ns) (tags, fs, ctx) acc +selectNodes (_ : _) (_, [], _) _ acc = acc +selectNodes (n : ns) cur@(tags, f : fs, ctx) root acc + | MatchOk == matchResult + = selectNodes ns (tags, Tree.subForest f ++ siblings, ctx) + -- The new root node is the just matched node + -- plus the lifted siblings. + (tags, f : siblings, ctx) + $ selectNodes (n : ns) (tags, fs, ctx) root acc + | MatchCull == matchResult + = selectNodes (n : ns) (tags, fs, ctx) root acc + | otherwise + = selectNodes (n : ns) (tags, Tree.subForest f, ctx) root + $ selectNodes (n : ns) (tags, fs, ctx) root acc where - Span lo _ = Tree.rootLabel f + Span lo hi = Tree.rootLabel f info = tags Vector.! lo + matchResult = nodeMatches n info cur root + -- In the case of a match, it is possible that there are children nested + -- within the sibling forests that are potentially valid matches for the + -- current node despite not being direct children. This can happen with + -- malformed HTML, for example . In this case + -- would be a child of which would be a sibling of . + -- + -- In order to match it must be lifted out of 's sub forest when + -- matching . + treeLo tree | (Span lo _) <- Tree.rootLabel tree = lo + treeHi tree | (Span _ hi) <- Tree.rootLabel tree = hi + + liftSiblings [] acc = acc + liftSiblings (t : ts) acc + | lo < treeLo t && treeHi t < hi = t : liftSiblings ts acc + | hi < treeLo t || treeHi t < lo = liftSiblings ts acc + | otherwise = liftSiblings (Tree.subForest t) + $ liftSiblings ts acc + siblings = liftSiblings fs [] + +-- | The result of nodeMatches, can either be a match, a failure, or a failure +-- that culls all children of the current node. +data MatchResult = MatchOk | MatchFail | MatchCull + deriving (Eq) + +-- | Ands together two MatchResult values. +andMatch :: MatchResult -> MatchResult -> MatchResult +andMatch MatchOk MatchOk = MatchOk +andMatch MatchCull _ = MatchCull +andMatch _ MatchCull = MatchCull +andMatch _ _ = MatchFail + +-- | Turns a boolean value into a MatchResult. +boolMatch :: Bool -> MatchResult +boolMatch True = MatchOk +boolMatch False = MatchFail + -- | Returns True if a tag satisfies a given SelectNode's condition. -nodeMatches :: TagSoup.StringLike str => SelectNode -> TagInfo str -> Bool -nodeMatches (SelectNode node preds) info = checkTag node preds info -nodeMatches (SelectAny preds) info = checkPreds preds (infoTag info) +nodeMatches :: TagSoup.StringLike str + => (SelectNode, SelectSettings) + -> TagInfo str + -> TagSpec str + -> TagSpec str + -> MatchResult +nodeMatches (SelectNode node preds, settings) info cur root = + checkSettings settings cur root `andMatch` checkTag node preds info +nodeMatches (SelectAny preds , settings) info cur root = + checkSettings settings cur root `andMatch` checkPreds preds (infoTag info) +nodeMatches (SelectText , settings) info cur root = + checkSettings settings cur root `andMatch` + boolMatch (TagSoup.isTagText $ infoTag info) +-- | Given a SelectSettings, the current node under consideration, and the last +-- matched node, returns true IFF the current node satisfies all of the +-- selection settings. +checkSettings :: TagSoup.StringLike str + => SelectSettings -> TagSpec str -> TagSpec str -> MatchResult +checkSettings (SelectSettings (Just depth)) + (_, curRoot : _, _) + (_, root, _) + | depthOfCur < depth = MatchFail + | depthOfCur > depth = MatchCull + | otherwise = MatchOk + where + Span curLo curHi = Tree.rootLabel curRoot + mapTree f = map f . concatMap Tree.flatten + depthOfCur = sum $ mapTree oneIfContainsCur root + oneIfContainsCur (Span lo hi) + | lo < curLo && curHi < hi = 1 + | otherwise = 0 +checkSettings (SelectSettings _) _ _ = MatchOk + -- | Given a tag name and a list of attribute predicates return a function that -- returns true if a given tag matches the supplied name and predicates. checkTag :: TagSoup.StringLike str - => T.Text -> [AttributePredicate] -> TagInfo str -> Bool -checkTag name preds (TagInfo tag tagName _ _) - = TagSoup.isTagOpen tag - && isJust tagName - && name == fromJust tagName - && checkPreds preds tag + => T.Text -> [AttributePredicate] -> TagInfo str -> MatchResult +checkTag name preds (TagInfo tag tagName _) + = boolMatch ( + TagSoup.isTagOpen tag + && isJust tagName + && name == fromJust tagName + ) `andMatch` checkPreds preds tag -- | Returns True if a tag satisfies a list of attribute predicates. checkPreds :: TagSoup.StringLike str - => [AttributePredicate] -> TagSoup.Tag str -> Bool -checkPreds preds tag - = TagSoup.isTagOpen tag - && all (flip checkPred attrs) preds + => [AttributePredicate] -> TagSoup.Tag str -> MatchResult +checkPreds [] tag = boolMatch + $ TagSoup.isTagOpen tag || TagSoup.isTagText tag +checkPreds preds tag = boolMatch + $ TagSoup.isTagOpen tag && all (`checkPred` attrs) preds where (TagSoup.TagOpen _ attrs) = tag diff --git a/src/Text/HTML/Scalpel/Internal/Select/Combinators.hs b/src/Text/HTML/Scalpel/Internal/Select/Combinators.hs --- a/src/Text/HTML/Scalpel/Internal/Select/Combinators.hs +++ b/src/Text/HTML/Scalpel/Internal/Select/Combinators.hs @@ -7,9 +7,10 @@ , (@:) , (@=) , (@=~) +, atDepth , hasClass -, notP , match +, notP ) where import Text.HTML.Scalpel.Internal.Select.Types @@ -22,7 +23,7 @@ -- | The '@:' operator creates a 'Selector' by combining a 'TagName' with a list -- of 'AttributePredicate's. (@:) :: TagName -> [AttributePredicate] -> Selector -(@:) tag attrs = MkSelector [toSelectNode tag attrs] +(@:) tag attrs = MkSelector [(toSelectNode tag attrs, defaultSelectSettings)] infixl 9 @: -- | The '@=' operator creates an 'AttributePredicate' that will match @@ -46,6 +47,20 @@ && RE.matchTest re (TagSoup.toString attrValue) infixl 6 @=~ +-- | The 'atDepth' operator constrains a 'Selector' to only match when it is at +-- @depth@ below the previous selector. +-- +-- For example, @"div" // "a" `atDepth` 1@ creates a 'Selector' that matches +-- anchor tags that are direct children of a div tag. +atDepth :: Selector -> Int -> Selector +atDepth (MkSelector xs) depth = MkSelector (addDepth xs) + where addDepth [] = [] + addDepth [(node, settings)] = [ + (node, settings { selectSettingsDepth = Just depth }) + ] + addDepth (x : xs) = x : addDepth xs +infixl 6 `atDepth` + -- | The '//' operator creates an 'Selector' by nesting one 'Selector' in -- another. For example, @"div" // "a"@ will create a 'Selector' that matches -- anchor tags that are nested arbitrarily deep within a div tag. @@ -68,7 +83,7 @@ textClasses = TagSoup.castString classes classList = T.split (== ' ') textClasses --- | Negates an 'AttributePredicate'. +-- | Negates an 'AttributePredicate'. notP :: AttributePredicate -> AttributePredicate notP (MkAttributePredicate p) = MkAttributePredicate $ not . p diff --git a/src/Text/HTML/Scalpel/Internal/Select/Types.hs b/src/Text/HTML/Scalpel/Internal/Select/Types.hs --- a/src/Text/HTML/Scalpel/Internal/Select/Types.hs +++ b/src/Text/HTML/Scalpel/Internal/Select/Types.hs @@ -14,7 +14,10 @@ , SelectNode (..) , tagSelector , anySelector +, textSelector , toSelectNode +, SelectSettings (..) +, defaultSelectSettings ) where import Data.Char (toLower) @@ -56,20 +59,42 @@ -- | 'Selector' defines a selection of an HTML DOM tree to be operated on by -- a web scraper. The selection includes the opening tag that matches the -- selection, all of the inner tags, and the corresponding closing tag. -newtype Selector = MkSelector [SelectNode] +newtype Selector = MkSelector [(SelectNode, SelectSettings)] +-- | 'SelectSettings' defines additional criteria for a Selector that must be +-- satisfied in addition to the SelectNode. This includes criteria that are +-- dependent on the context of the current node, for example the depth in +-- relation to the previously matched SelectNode. +data SelectSettings = SelectSettings { + -- | The required depth of the current select node in relation to the + -- previously matched SelectNode. + selectSettingsDepth :: Maybe Int +} + +defaultSelectSettings :: SelectSettings +defaultSelectSettings = SelectSettings { + selectSettingsDepth = Nothing +} + tagSelector :: String -> Selector -tagSelector tag = MkSelector [toSelectNode (TagString tag) []] +tagSelector tag = MkSelector [ + (toSelectNode (TagString tag) [], defaultSelectSettings) + ] --- | A selector which will match all tags +-- | A selector which will match any node (including tags and bare text). anySelector :: Selector -anySelector = MkSelector [SelectAny []] +anySelector = MkSelector [(SelectAny [], defaultSelectSettings)] +-- | A selector which will match all text nodes. +textSelector :: Selector +textSelector = MkSelector [(SelectText, defaultSelectSettings)] + instance IsString Selector where fromString = tagSelector data SelectNode = SelectNode !T.Text [AttributePredicate] | SelectAny [AttributePredicate] + | SelectText -- | The 'TagName' type is used when creating a 'Selector' to specify the name -- of a tag. diff --git a/src/Text/HTML/Scalpel/Internal/Serial.hs b/src/Text/HTML/Scalpel/Internal/Serial.hs new file mode 100644 --- /dev/null +++ b/src/Text/HTML/Scalpel/Internal/Serial.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_HADDOCK hide #-} +module Text.HTML.Scalpel.Internal.Serial ( + SerialScraper +, SerialScraperT +, inSerial +, stepBack +, stepNext +, seekBack +, seekNext +, untilBack +, untilNext +) where + +import Text.HTML.Scalpel.Internal.Scrape +import Text.HTML.Scalpel.Internal.Select + +import Control.Applicative +import Control.Monad +import Control.Monad.Trans +import Control.Monad.Except (MonadError) +import Control.Monad.Cont (MonadCont) +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Trans.Maybe +import Control.Monad.Writer (MonadWriter) +import Control.Monad.Fix +import Data.Bifunctor +import Data.Functor.Identity +import Data.List.PointedList (PointedList) +import Data.Maybe +import Prelude hiding (until) + +import qualified Control.Monad.Fail as Fail +import qualified Data.List.PointedList as PointedList +import qualified Data.Tree as Tree +import qualified Text.StringLike as TagSoup + + +-- | Serial scrapers operate on a zipper of tag specs that correspond to the +-- root nodes / siblings in a document. +-- +-- Access to the zipper is always performed in a move-then-read manner. For this +-- reason it is valid for the current focus of the zipper to be just off either +-- end of list such that moving forward or backward would result in reading the +-- first or last node. +-- +-- These valid focuses are expressed as Nothing values at either end of the +-- zipper since they are valid positions for the focus to pass over, but not +-- valid positions to read. +type SpecZipper str = PointedList (Maybe (TagSpec str)) + +-- | A 'SerialScraper' allows for the application of 'Scraper's on a sequence of +-- sibling nodes. This allows for use cases like targeting the sibling of a +-- node, or extracting a sequence of sibling nodes (e.g. paragraphs (\) +-- under a header (\)). +-- +-- Conceptually serial scrapers operate on a sequence of tags that correspond to +-- the immediate children of the currently focused node. For example, given the +-- following HTML: +-- +-- @ +-- \ +-- \title\ +-- \Section 1\ +-- \Paragraph 1.1\ +-- \Paragraph 1.2\ +-- \Section 2\ +-- \Paragraph 2.1\ +-- \Paragraph 2.2\ +-- \ +-- @ +-- +-- A serial scraper that visits the header and paragraph nodes can be executed +-- with the following: +-- +-- @ +-- 'chroot' "article" $ 'inSerial' $ do ... +-- @ +-- +-- Each 'SerialScraper' primitive follows the pattern of first moving the focus +-- backward or forward and then extracting content from the new focus. +-- Attempting to extract content from beyond the end of the sequence causes the +-- scraper to fail. +-- +-- To complete the above example, the article's structure and content can be +-- extracted with the following code: +-- +-- @ +-- 'chroot' "article" $ 'inSerial' $ do +-- title <- 'seekNext' $ 'text' "h1" +-- sections <- many $ do +-- section <- 'seekNext' $ text "h2" +-- ps <- 'untilNext' ('matches' "h2") (many $ 'seekNext' $ 'text' "p") +-- return (section, ps) +-- return (title, sections) +-- @ +-- +-- Which will evaluate to: +-- +-- @ +-- ("title", [ +-- ("Section 1", ["Paragraph 1.1", "Paragraph 1.2"]), +-- ("Section 2", ["Paragraph 2.1", "Paragraph 2.2"]), +-- ]) +-- @ +type SerialScraper str a = SerialScraperT str Identity a + +-- | Run a serial scraper transforming over a monad 'm'. +newtype SerialScraperT str m a = + MkSerialScraper (StateT (SpecZipper str) (MaybeT m) a) + deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadFix, + MonadIO, MonadCont, MonadError e, MonadReader r, MonadWriter w) + +#if MIN_VERSION_base(4,9,0) +deriving instance Monad m => Fail.MonadFail (SerialScraperT str m) +#else +instance Fail.MonadFail m => Fail.MonadFail (SerialScraperT str m) where + fail = lift . Fail.fail +#endif + +instance MonadTrans (SerialScraperT str) where + lift op = MkSerialScraper . lift . lift $ op + +instance MonadState s m => MonadState s (SerialScraperT str m) where + get = MkSerialScraper (lift . lift $ get) + put = MkSerialScraper . lift . lift . put + +-- | Executes a 'SerialScraper' in the context of a 'Scraper'. The immediate +-- children of the currently focused node are visited serially. +inSerial :: (TagSoup.StringLike str, Monad m) + => SerialScraperT str m a -> ScraperT str m a +inSerial (MkSerialScraper serialScraper) = MkScraper $ ReaderT $ scraper + where + scraper spec@(vec, root : _, ctx) + | ctxInChroot ctx = evalStateT serialScraper + (toZipper (vec, Tree.subForest root, ctx)) + | otherwise = evalStateT serialScraper (toZipper spec) + scraper _ = empty + + -- Create a zipper from the current tag spec by generating a new tag spec + -- that just contains each root node in the forest. + toZipper (vector, forest, context) = + zipperFromList $ map ((vector, , context) . return) forest + +-- | Creates a SpecZipper from a list of tag specs. This requires bookending the +-- zipper with Nothing values to denote valid focuses that are just off either +-- end of the list. +zipperFromList :: TagSoup.StringLike str => [TagSpec str] -> SpecZipper str +zipperFromList = PointedList.insertLeft Nothing + . foldr (PointedList.insertLeft . Just) + (PointedList.singleton Nothing) + +stepWith :: (TagSoup.StringLike str, Monad m) + => (SpecZipper str -> Maybe (SpecZipper str)) + -> ScraperT str m b + -> SerialScraperT str m b +stepWith moveList (MkScraper (ReaderT scraper)) = MkSerialScraper . StateT $ + \zipper -> do + zipper' <- maybeT $ moveList zipper + focus <- maybeT $ PointedList._focus zipper' + value <- scraper focus + return (value, zipper') + +-- | Move the cursor back one node and execute the given scraper on the new +-- focused node. +stepBack :: (TagSoup.StringLike str, Monad m) => ScraperT str m a -> SerialScraperT str m a +stepBack = stepWith PointedList.previous + +-- | Move the cursor forward one node and execute the given scraper on the new +-- focused node. +stepNext :: (TagSoup.StringLike str, Monad m) + => ScraperT str m a -> SerialScraperT str m a +stepNext = stepWith PointedList.next + +seekWith :: (TagSoup.StringLike str, Monad m) + => (SpecZipper str -> Maybe (SpecZipper str)) + -> ScraperT str m b + -> SerialScraperT str m b +seekWith moveList (MkScraper (ReaderT scraper)) = MkSerialScraper (StateT go) + where + go zipper = do zipper' <- maybeT $ moveList zipper + runScraper zipper' <|> go zipper' + runScraper zipper = do + focus <- maybeT $ PointedList._focus zipper + value <- scraper focus + return (value, zipper) + +-- | Move the cursor backward until the given scraper is successfully able to +-- execute on the focused node. If the scraper is never successful then the +-- serial scraper will fail. +seekBack :: (TagSoup.StringLike str, Monad m) + => ScraperT str m a -> SerialScraperT str m a +seekBack = seekWith PointedList.previous + +-- | Move the cursor forward until the given scraper is successfully able to +-- execute on the focused node. If the scraper is never successful then the +-- serial scraper will fail. +seekNext :: (TagSoup.StringLike str, Monad m) + => ScraperT str m a -> SerialScraperT str m a +seekNext = seekWith PointedList.next + +untilWith :: (TagSoup.StringLike str, Monad m) + => (SpecZipper str -> Maybe (SpecZipper str)) + -> (Maybe (TagSpec str) -> SpecZipper str -> SpecZipper str) + -> ScraperT str m a + -> SerialScraperT str m b + -> SerialScraperT str m b +untilWith moveList appendNode (MkScraper (ReaderT until)) (MkSerialScraper scraper) = + MkSerialScraper $ do + inner <- StateT split + lift (evalStateT scraper (appendNode Nothing inner)) + where + split zipper = + do zipper' <- maybeT $ moveList zipper + spec <- maybeT $ PointedList._focus zipper' + do until spec + return (PointedList.singleton Nothing, zipper) + <|> (first (appendNode (Just spec)) `liftM` split zipper') + <|> return (PointedList.singleton Nothing, zipper) + +-- | Create a new serial context by moving the focus backward and collecting +-- nodes until the scraper matches the focused node. The serial scraper is then +-- executed on the collected nodes. +untilBack :: (TagSoup.StringLike str, Monad m) + => ScraperT str m a -> SerialScraperT str m b -> SerialScraperT str m b +untilBack = untilWith PointedList.previous PointedList.insertRight + +-- | Create a new serial context by moving the focus forward and collecting +-- nodes until the scraper matches the focused node. The serial scraper is then +-- executed on the collected nodes. +-- +-- The provided serial scraper is unable to see nodes outside the new restricted +-- context. +untilNext :: (TagSoup.StringLike str, Monad m) + => ScraperT str m a -> SerialScraperT str m b -> SerialScraperT str m b +untilNext = untilWith PointedList.next PointedList.insertLeft + +maybeT :: Monad m => Maybe a -> MaybeT m a +maybeT = MaybeT . return diff --git a/tests/TestMain.hs b/tests/TestMain.hs --- a/tests/TestMain.hs +++ b/tests/TestMain.hs @@ -8,14 +8,16 @@ import Control.Applicative import Control.Monad (guard) import Data.List (isInfixOf) -import System.Exit -import Test.HUnit +import System.Exit (ExitCode(..), exitSuccess, exitWith) +import Test.HUnit (Test(..), (@=?), (~:), runTestTT, failures) import qualified Text.HTML.TagSoup as TagSoup import qualified Text.Regex.TDFA - -main = exit . failures =<< runTestTT (TestList [scrapeTests]) +main :: IO () +main = do + n <- runTestTT (TestList [scrapeTests]) + exit $ failures n exit :: Int -> IO () exit 0 = exitSuccess @@ -26,226 +28,271 @@ scrapeTests = "scrapeTests" ~: TestList [ scrapeTest + "htmls should extract matching tag" "foo" (Just ["foo"]) (htmls ("a" @: [])) , scrapeTest + "htmls should ignore non-matching tag" "foobar" (Just ["foo", "bar"]) (htmls ("a" @: [])) , scrapeTest + "htmls should extract matching tag when it is nested" "foo" (Just ["foo"]) (htmls ("a" @: [])) , scrapeTest + "htmls should extract each matching tag even if it is nested" "foo" (Just ["foo", "foo"]) (htmls ("a" @: [])) , scrapeTest + "htmls with no matching nodes should result in an empty list" "foo" (Just []) (htmls ("b" @: [])) , scrapeTest + "unclosed tags should be treated as immediately closed" "foo" (Just [""]) (htmls ("a" @: [])) , scrapeTest + "scraping should obey attribute predicates" "foobar" (Just ["bar"]) (htmls ("a" @: ["key" @= "value"])) , scrapeTest + "selectors using // should match the deepest node" "foo" (Just ["foo"]) (htmls ("a" // "b" @: [] // "c")) , scrapeTest + "selectors using // should skip over irrelevant nodes" "foobarbaz" (Just ["foo", "bar"]) (htmls ("a" // "b")) , scrapeTest + "hasClass should match tags with multiple classes" "foo" (Just ["foo"]) (htmls ("a" @: [hasClass "a"])) , scrapeTest + "hasClass should not match tags without the specified class" "foo" (Just []) (htmls ("a" @: [hasClass "c"])) , scrapeTest + "notP should negate attribute predicates" "foobarbaz" (Just ["foo", "baz"]) (texts ("a" @: [notP $ hasClass "a"])) , scrapeTest + "@=~ should match via regular expressions" "foo" (Just ["foo"]) (htmls ("a" @: ["key" @=~ re "va(foo|bar|lu)e"])) , scrapeTest + "AnyAttribute should match any attribute key" "foobar" (Just ["foo", "bar"]) (htmls ("a" @: [AnyAttribute @= "value"])) , scrapeTest + "AnyAttribute should not match any attribute value" "foobar" (Just ["bar"]) (htmls ("a" @: [AnyAttribute @= "value"])) , scrapeTest + "AnyTag should match any tag with the corresponding attributes" "foobar" (Just ["foo", "bar"]) (htmls (AnyTag @: [AnyAttribute @= "value"])) , scrapeTest + "AnyTag should not match tags without the corresponding attributes" "foobar" (Just ["bar"]) (htmls (AnyTag @: [AnyAttribute @= "value"])) , scrapeTest + "Custom predicates" "123" (Just ["2", "3"]) (htmls (AnyTag @: [match (==)])) , scrapeTest + "text should extract inner text from the first matching tag" "foo" (Just "foo") (text "a") , scrapeTest + "text should extract inner text from only the first matching tag" "foobar" (Just "foo") (text "a") , scrapeTest + "texts should extract inner text from all matching tags" "foobar" (Just ["foo", "bar"]) (texts "a") , scrapeTest + "fmap should work as expected" "foobar" (Just [True, False]) (map (== "foo") <$> texts "a") , scrapeTest + "attr extract matching attribute value" "" (Just "foo") (attr "key" "a") , scrapeTest + "attr extract matching attribute value with complex predicates" "" (Just "baz") (attr "key2" $ "a" @: ["key1" @= "bar"]) , scrapeTest + "chroot should limit context to just selected node" "foobar" (Just ["foo"]) (chroot "a" $ texts "b") , scrapeTest + "chroots should work for all matching nodes" "foobar" (Just ["foo", "bar"]) (chroots "a" $ text "b") , scrapeTest + "<|> should return first match if valid" "foobar" (Just "foo") (text ("a" // "b") <|> text ("a" // "c")) , scrapeTest + "<|> should return second match if valid" "foobar" (Just "bar") (text ("a" // "d") <|> text ("a" // "c")) , scrapeTest + "Unclosed tags should be treated as immediately closed" "" (Just "foobar") (attr "src" "img") , scrapeTest + "scraping should work for self-closing tags" "" (Just "foobar") (attr "src" "img") , scrapeTest + "lower case selectors should match any case tag" "foobar" (Just ["foo", "bar"]) (texts "a") , scrapeTest + "upper case selectors should match any case tag" "foobar" (Just ["foo", "bar"]) (texts "A") , scrapeTest + "attribute key matching should be case-insensitive" "foo" (Just ["foo"]) (texts $ "A" @: ["b" @= "C"]) , scrapeTest + "attribute value matching should be case-sensitive" "foo" (Just []) (texts $ "A" @: ["b" @= "c"]) , scrapeTest + "notP should invert attribute value matching" "foobarbaz" (Just ["foo", "baz"]) (texts ("a" @: [notP $ "b" @= "C"])) , scrapeTest + "html should work when matching the root node" "foo" (Just "foo") (html "a") , scrapeTest + "html should work when matching a nested node" "
  • 1
  • 2
" (Just "
  • 1
    • ") (html "li") , scrapeTest + "html should work when matching a node with no inner text" "
    " (Just "
    ") (html "div") , scrapeTest + "htmls should return html matching root nodes" "foobar" (Just ["foo","bar"]) (htmls "a") , scrapeTest + "htmls should return html matching nested nodes" "
    • 1
    • 2
    " (Just ["
  • 1
    • ", "
  • 2
    • "]) (htmls "li") , scrapeTest + "htmls should return html matching empty nested nodes" "
    " (Just ["
    "]) (htmls "div") , scrapeTest + "innerHTML should exclude root tags" "123" (Just "123") (innerHTML anySelector) , scrapeTest + "innerHTML of a self closed tag should be the empty string" "" (Just "") (innerHTML anySelector) , scrapeTest + "innerHTML should match root nodes" "foobar" (Just ["foo","bar"]) (innerHTMLs "a") , scrapeTest + "guard should stop matches" "foobarbaz" (Just "bar") (chroot "a" $ do @@ -254,21 +301,25 @@ html anySelector) , scrapeTest + "// should force a decent before matching" "
    inner text
    " (Just ["inner"]) (attrs "id" ("div" // "div")) , scrapeTest + "div // div should match div/div/div twice" "
    " (Just ["b", "c"]) (attrs "id" ("div" // "div")) , scrapeTest + "anySelector should match the root node" "12345" (Just "12345") (text anySelector) , scrapeTest + "failing a pattern match should stop a scraper" "1" Nothing $ do @@ -276,12 +327,14 @@ return "OK" , scrapeTest + "passing a pattern match should not stop a scraper" "1" (Just "OK") $ do "1" <- text "a" return "OK" , scrapeTest + "position should return the index of the match" "

    A

    B

    C

    " (Just [(0, "A"), (1, "B"), (2, "C")]) (chroots ("article" // "p") $ do @@ -290,6 +343,7 @@ return (index, content)) , scrapeTest + "position should return the index of most recent match" "

    A

    B

    C

    " (Just [[(0, "A")], [(0, "B"), (1, "C")]]) (chroots "article" $ chroots "p" $ do @@ -298,28 +352,276 @@ return (index, content)) , scrapeTest + "DFS regression test for #59 (1)" "

    p1

    p2

    p3

    p4

    " (Just ["p1", "p2", "p3", "p4"]) (texts "p") , scrapeTest + "DFS regression test for #59 (2)" "123" (Just ["1","2","3"]) (texts "a") , scrapeTest + "DFS regression test for #59 (3)" "123" (Just ["1","2","3"]) (texts $ "a" // "b") , scrapeTest + "DFS regression test for #59 (4)" "123" (Just ["1","2","3"]) (texts "b") + + , scrapeTest + "atDepth 1 should select immediate children" + "12" + (Just ["1"]) + (texts $ "a" // "b" `atDepth` 1) + + , scrapeTest + "atDepth 2 should select children children" + "12" + (Just ["2"]) + (texts $ "a" // "b" `atDepth` 2) + + , scrapeTest + "atDepth should compose with attribute predicates" + "12" + (Just ["1"]) + (texts $ "a" // "b" @: [hasClass "foo"] `atDepth` 1) + + -- Depth should handle malformed HTML correctly. Below and are not + -- closed in the proper order, but since is nested within both in the + -- context of , is still at depth 3. + , scrapeTest + "atDepth should handle tags closed out of order (full context)" + "1" + (Just ["1"]) + (texts $ "a" // "d" `atDepth` 3) + + -- However, from the context of , is only at depth 1 because there is + -- no closing tag within the tag so the tag is assumed to be + -- self-closing. + , scrapeTest + "atDepth should handle tags closed out of order (partial context)" + "2" + (Just ["2"]) + (texts $ "b" // "d" `atDepth` 1) + + , scrapeTest + "// should handle tags closed out of order" + "2" + (Just ["2"]) + (texts $ "b" // "d") + + , scrapeTest + "// should handle tags closed out of order for the root (1)" + "2" + (Just ["2"]) + (texts $ "b" // "d") + + , scrapeTest + "// should handle tags closed out of order for the root (2)" + "2" + (Just ["2"]) + (texts $ "c" // "d") + + , scrapeTest + "textSelector should select each text node" + "1234567" + (Just $ map show [1..7]) + (texts textSelector) + + , scrapeTest + "anySelector should select text nodes" + "1234567" + (Just ["1", "2", "3", "456", "7"]) + (texts $ anySelector `atDepth` 0) + + , scrapeTest + "atDepth should treat out of focus close tags as immediately closed" + "2" + (Just ["2"]) + (texts $ "a" // "d" `atDepth` 2) + + , scrapeTest + "Applicative sanity checks for SerialScraper" + "123" + (Just ("1", "2")) + (inSerial $ (,) <$> stepNext (text "a") + <*> stepNext (text "b")) + + , scrapeTest + "Monad sanity checks for SerialScraper" + "123" + (Just ("1", "2")) + (inSerial $ do + a <- stepNext (text "a") + b <- stepNext (text "b") + return (a, b)) + + , scrapeTest + "stepping off the end of the list without reading should be allowed" + "123" + (Just ["1", "2", "3", "2" , "1"]) + (inSerial $ do + a <- stepNext $ text anySelector + b <- stepNext $ text anySelector + c <- stepNext $ text anySelector + d <- stepBack $ text anySelector + e <- stepBack $ text anySelector + return [a, b, c, d, e]) + + , scrapeTest + "stepping off the end of the list and reading should fail" + "123" + Nothing + (inSerial $ (,,,) <$> stepNext (text anySelector) + <*> stepNext (text anySelector) + <*> stepNext (text anySelector) + <*> stepNext (text anySelector)) + + , scrapeTest + "seeking should skip over nodes" + "123" + (Just ("2", "3")) + (inSerial $ (,) <$> seekNext (text "b") + <*> seekNext (text "a")) + + , scrapeTest + "seeking should fail if there is not matching node" + "123" + Nothing + (inSerial $ seekNext $ text "c") + + , scrapeTest + "seeking off the end the zipper should be allowed without reading" + "123" + (Just ("3", "1")) + (inSerial $ (,) <$> seekNext (text "c") + <*> seekBack (text "a")) + + , scrapeTest + "Alternative sanity check for SerialScraper" + "123" + (Just ["1", "bar", "3"]) + (inSerial $ many + $ stepNext (text $ textSelector `atDepth` 0) + <|> stepNext (attr "foo" $ "a" `atDepth` 0)) + + , scrapeTest + "MonadFail sanity check for SerialScraper (passing check)" + "1" + (Just "OK") + (inSerial $ do + "1" <- stepNext $ text textSelector + return "OK") + + , scrapeTest + "MonadFail sanity check for SerialScraper (failing check)" + "1" + Nothing + (inSerial $ do + "mismatch" <- stepNext $ text textSelector + return "OK") + + , scrapeTest + "untilNext should stop at first match" + "123" + (Just ["1", "2"]) + (inSerial $ untilNext (matches "b") + $ many $ stepNext $ text anySelector) + + , scrapeTest + "untilNext should go till end of the zipper on no match" + "123" + (Just ["1", "2", "3"]) + (inSerial $ untilNext (matches "c") + $ many $ stepNext $ text anySelector) + + , scrapeTest + "untilNext should leave the focus at the match" + "123" + (Just "3") + (inSerial $ do + untilNext (matches "b") $ many $ stepNext $ text anySelector + stepNext $ text "b") + + , scrapeTest + "untilNext should create valid a empty context" + "12" + (Just "1") + (inSerial $ do + untilNext (matches "a") $ return () + stepNext $ text "a") + + , scrapeTest + "scraping within an empty context should fail" + "12" + Nothing + (inSerial $ do + untilNext (matches "a") $ stepNext $ text anySelector + stepNext $ text "a") + + , scrapeTest + "untilBack should leave the focus of the new context at the end" + "123" + (Just ("bar", ["1", "2", "3"], ["2", "1"])) + (inSerial $ do + as <- many $ seekNext $ text "a" + as' <- untilBack (matches "b") $ many $ stepBack $ text "a" + b <- stepBack $ attr "foo" "b" + return (b, as, as')) + + , scrapeTest + "inSerial in a chroot should visit immediate children" + "12" + (Just ["1", "2"]) + (chroot "parent" $ inSerial $ + many $ stepNext $ text anySelector) + + , scrapeTest + "Issue #41 regression test" + "

    Here

    Other stuff that matters

    " + (Just "Other stuff that matters") + (inSerial $ do + seekNext $ matches $ "p" @: [hasClass "something"] + stepNext $ text "p") + + , scrapeTest + "Issue #45 regression test" + (unlines [ + "" + , "

    title1

    " + , "

    title2 1

    " + , "

    text 1

    " + , "

    text 2

    " + , "

    title2 2

    " + , "

    text 3

    " + , "

    title2 3

    " + , "" + ]) + (Just [ + ("title2 1", ["text 1", "text 2"]) + , ("title2 2", ["text 3"]) + , ("title2 3", []) + ]) + (chroot "body" $ inSerial $ many $ do + title <- seekNext $ text "h2" + ps <- untilNext (matches "h2") (many $ do + -- New lines between tags count as text nodes, skip over + -- these. + optional $ stepNext $ matches textSelector + stepNext $ text "p") + return (title, ps)) ] -scrapeTest :: (Eq a, Show a) => String -> Maybe a -> Scraper String a -> Test -scrapeTest html expected scraper = label ~: expected @=? actual +scrapeTest :: (Eq a, Show a) + => String -> String -> Maybe a -> Scraper String a -> Test +scrapeTest label html expected scraper = label' ~: expected @=? actual where - label = "scrape (" ++ show html ++ ")" + label' = label ++ ": scrape (" ++ html ++ ")" actual = scrape scraper (TagSoup.parseTags html)