diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,202 @@ +Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "{}" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright {yyyy} {name of copyright owner} + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/scalpel.cabal b/scalpel.cabal new file mode 100644 --- /dev/null +++ b/scalpel.cabal @@ -0,0 +1,71 @@ +name: scalpel +version: 0.1.0 +synopsis: A high level web scraping library for Haskell. +description: + Scalpel is a web scraping library inspired by libraries like Parsec and + Perl's Web::Scraper Scalpel builds on top of TagSoup to provide a + declarative and monadic interface. +homepage: https://github.com/fimad/scalpel +license: Apache-2.0 +license-file: LICENSE +author: Will Coster +maintainer: willcoster@gmail.com +category: Web +build-type: Simple +cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/fimad/scalpel.git + +source-repository this + type: git + location: https://github.com/fimad/scalpel.git + tag: 0.1.0 + +library + other-extensions: + FlexibleInstances + , FunctionalDependencies + other-modules: + Text.HTML.Scalpel.Internal.Scrape + , Text.HTML.Scalpel.Internal.Scrape.StringLike + , Text.HTML.Scalpel.Internal.Scrape.URL + , Text.HTML.Scalpel.Internal.Select + , Text.HTML.Scalpel.Internal.Select.Combinators + , Text.HTML.Scalpel.Internal.Select.Types + exposed-modules: + Text.HTML.Scalpel + hs-source-dirs: src/ + default-language: Haskell2010 + build-depends: + base >= 4.6 && < 5 + , bytestring + , download-curl + , regex-base + , regex-tdfa + , tagsoup >= 0.8 + , text + default-extensions: + OverloadedStrings + , ParallelListComp + , PatternGuards + ghc-options: -W + +test-suite lib-tests + type: exitcode-stdio-1.0 + main-is: TestMain.hs + hs-source-dirs: src/, tests/ + build-depends: + base >= 4.6 && < 5 + , bytestring + , download-curl + , HUnit + , regex-base + , regex-tdfa + , tagsoup >= 0.8 + , text + default-extensions: + ParallelListComp + , PatternGuards + ghc-options: -W diff --git a/src/Text/HTML/Scalpel.hs b/src/Text/HTML/Scalpel.hs new file mode 100644 --- /dev/null +++ b/src/Text/HTML/Scalpel.hs @@ -0,0 +1,135 @@ +-- | +-- Scalpel is a web scraping library inspired by libraries like parsec and +-- Perl's . +-- Scalpel builds on top of "Text.HTML.TagSoup" to provide a declarative and +-- monadic interface. +-- +-- There are two general mechanisms provided by this library that are used to +-- build web scrapers: Selectors and Scrapers. +-- +-- +-- Selectors describe a location within an HTML DOM tree. The simplest selector, +-- that can be written is a simple string value. For example, the selector +-- @\"div\"@ matches every single div node in a DOM. Selectors can be combined +-- using tag combinators. The '//' operator to define nested relationships +-- within a DOM tree. For example, the selector @\"div\" \/\/ \"a\"@ matches all +-- anchor tags nested arbitrarily deep within a div tag. +-- +-- In addition to describing the nested relationships between tags, selectors +-- can also include predicates on the attributes of a tag. The '@:' operator +-- creates a selector that matches a tag based on the name and various +-- conditions on the tag's attributes. An attribute predicate is just a function +-- that takes an attribute and returns a boolean indicating if the attribute +-- matches a criteria. There are several attribute operators that can be used +-- to generate common predicates. The '@=' operator creates a predicate that +-- matches the name and value of an attribute exactly. For example, the selector +-- @\"div\" \@: [\"id\" \@= \"article\"]@ matches div tags where the id +-- attribute is equal to @\"article\"@. +-- +-- +-- Scrapers are values that are parameterized over a selector and produce +-- a value from an HTML DOM tree. The 'Scraper' type takes two type parameters. +-- The first is the string like type that is used to store the text values +-- within a DOM tree. Any string like type supported by "Text.StringLike" is +-- valid. The second type is the type of value that the scraper produces. +-- +-- There are several scraper primitives that take selectors and extract content +-- from the DOM. Each primitive defined by this library comes in two variants: +-- singular and plural. The singular variants extract the first instance +-- matching the given selector, while the plural variants match every instance. +-- +-- +-- The following is an example that demonstrates most of the features provided +-- by this library. Supposed you have the following hypothetical HTML located at +-- @\"http://example.com/article.html\"@ and you would like to extract a list of +-- all of the comments. +-- +-- > +-- > +-- >
+-- >
+-- > Sally +-- >
Woo hoo!
+-- >
+-- >
+-- > Bill +-- > +-- >
\ +-- >
+-- > Susan +-- >
WTF!?!
+-- >
+-- >
+-- > +-- > +-- +-- The following snippet defines a function, @allComments@, that will download +-- the web page, and extract all of the comments into a list: +-- +-- > type Author = String +-- > +-- > data Comment +-- > = TextComment Author String +-- > | ImageComment Author URL +-- > +-- > allComments :: IO (Maybe [Comments]) +-- > allComments = scrapeURL "http://example.com/article.html" comments +-- > where +-- > comments :: Scraper String [Comment] +-- > comments = chroots ("div" @: [hasClass "container"]) comment +-- > +-- > comment :: Scraper String Comment +-- > comment = textComment <|> imageComment +-- > +-- > textComment :: Scraper String Comment +-- > textComment = do +-- > author <- text $ "span" @: [hasClass "author"] +-- > commentText <- text $ "div" @: [hasClass "text"] +-- > return $ TextComment author commentText +-- > +-- > imageComment :: Scraper String Comment +-- > imageComment = do +-- > author <- text $ "span" @: [hasClass "author"] +-- > imageURL <- attr "src" $ "img" @: [hasClass "image"] +-- > return $ ImageComment author imageURL +module Text.HTML.Scalpel ( +-- * Selectors + Selector +, Selectable (..) +, AttributePredicate +, AttributeName +, TagName +-- ** Wildcards +, Any (..) +-- ** Tag combinators +, (//) +-- ** Attribute predicates +, (@:) +, (@=) +, (@=~) +, hasClass +-- ** Executing selectors +, select + +-- * Scrapers +, Scraper +-- ** Primitives +, attr +, attrs +, text +, texts +, chroot +, chroots +-- ** Executing scrapers +, scrape +, scrapeStringLike +, URL +, scrapeURL +) where + +import Text.HTML.Scalpel.Internal.Scrape +import Text.HTML.Scalpel.Internal.Scrape.StringLike +import Text.HTML.Scalpel.Internal.Scrape.URL +import Text.HTML.Scalpel.Internal.Select +import Text.HTML.Scalpel.Internal.Select.Combinators +import Text.HTML.Scalpel.Internal.Select.Types diff --git a/src/Text/HTML/Scalpel/Internal/Scrape.hs b/src/Text/HTML/Scalpel/Internal/Scrape.hs new file mode 100644 --- /dev/null +++ b/src/Text/HTML/Scalpel/Internal/Scrape.hs @@ -0,0 +1,121 @@ +{-# OPTIONS_HADDOCK hide #-} +module Text.HTML.Scalpel.Internal.Scrape ( + Scraper (..) +, attr +, attrs +, text +, texts +, chroot +, chroots +) where + +import Text.HTML.Scalpel.Internal.Select +import Text.HTML.Scalpel.Internal.Select.Types + +import Control.Applicative +import Control.Monad +import Data.Maybe + +import qualified Text.HTML.TagSoup as TagSoup +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 { + -- | The 'scrape' function executes a 'Scraper' on a list of + -- 'TagSoup.Tag's and produces an optional value. + scrape :: [TagSoup.Tag str] -> Maybe a + } + +instance Functor (Scraper str) where + fmap f (MkScraper a) = MkScraper $ fmap (fmap f) a + +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 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 Monad (Scraper str) where + return = pure + (MkScraper a) >>= f = MkScraper combined + where combined tags | (Just aVal) <- a tags = let (MkScraper b) = f aVal + in b tags + | otherwise = Nothing + +-- | 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 +-- the tags corresponding to the selector. +-- +-- This function will match only the first set of tags matching the selector, to +-- match every set of tags, use 'chroots'. +chroot :: (TagSoup.StringLike str, Selectable str s) + => s -> Scraper str a -> Scraper str a +chroot selector (MkScraper inner) = MkScraper + $ join . (inner <$>) + . listToMaybe . select selector + +-- | 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 :: (TagSoup.StringLike str, Selectable str s) + => s -> Scraper str a -> Scraper str [a] +chroots selector (MkScraper inner) = MkScraper + $ return . catMaybes + . map inner . select selector + +-- | 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 :: (TagSoup.StringLike str, Selectable str s) => s -> Scraper str str +text s = MkScraper $ withHead tagsToText . select s + +-- | The 'texts' function takes a selector and returns the inner text from every +-- set of tags matching the given selector. +texts :: (TagSoup.StringLike str, Selectable str s) => s -> Scraper str [str] +texts s = MkScraper $ withAll tagsToText . 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 +-- matches the given selector. +-- +-- This function will match only the opening tag matching the selector, to match +-- every tag, use 'attrs'. +attr :: (Show str, TagSoup.StringLike str, Selectable str s) + => str -> s -> Scraper str str +attr name s = MkScraper $ join . withHead (tagsToAttr 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 :: (Show str, TagSoup.StringLike str, Selectable str s) + => str -> s -> Scraper str [str] +attrs name s = MkScraper $ fmap catMaybes . withAll (tagsToAttr name) . select s + +withHead :: (a -> b) -> [a] -> Maybe b +withHead _ [] = Nothing +withHead f (x:_) = Just $ f x + +withAll :: (a -> b) -> [a] -> Maybe [b] +withAll _ [] = Nothing +withAll f xs = Just $ map f xs + +tagsToText :: TagSoup.StringLike str => [TagSoup.Tag str] -> str +tagsToText = TagSoup.innerText + +tagsToAttr :: (Show str, TagSoup.StringLike str) + => str -> [TagSoup.Tag str] -> Maybe str +tagsToAttr attr tags = do + tag <- listToMaybe tags + guard $ TagSoup.isTagOpen tag + return $ TagSoup.fromAttrib attr tag diff --git a/src/Text/HTML/Scalpel/Internal/Scrape/StringLike.hs b/src/Text/HTML/Scalpel/Internal/Scrape/StringLike.hs new file mode 100644 --- /dev/null +++ b/src/Text/HTML/Scalpel/Internal/Scrape/StringLike.hs @@ -0,0 +1,15 @@ +{-# OPTIONS_HADDOCK hide #-} +module Text.HTML.Scalpel.Internal.Scrape.StringLike ( + scrapeStringLike +) where + +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 :: TagSoup.StringLike str => str -> Scraper str a -> Maybe a +scrapeStringLike html scraper = scrape scraper (TagSoup.parseTags html) diff --git a/src/Text/HTML/Scalpel/Internal/Scrape/URL.hs b/src/Text/HTML/Scalpel/Internal/Scrape/URL.hs new file mode 100644 --- /dev/null +++ b/src/Text/HTML/Scalpel/Internal/Scrape/URL.hs @@ -0,0 +1,22 @@ +{-# OPTIONS_HADDOCK hide #-} +module Text.HTML.Scalpel.Internal.Scrape.URL ( + URL +, scrapeURL +) where + +import Text.HTML.Scalpel.Internal.Scrape + +import Control.Applicative + +import qualified Network.Curl.Download as Curl +import qualified Text.StringLike as TagSoup + + +type URL = String + +-- | The 'scrapeURL' function downloads the contents of the given URL and +-- executes a 'Scraper' on it. +scrapeURL :: TagSoup.StringLike str => URL -> Scraper str a -> IO (Maybe a) +scrapeURL url scraper = (eitherToMaybeA . toStr) <$> Curl.openAsTags url + where eitherToMaybeA = either (const Nothing) (scrape scraper) + toStr = (((TagSoup.castString <$>) <$>) <$>) diff --git a/src/Text/HTML/Scalpel/Internal/Select.hs b/src/Text/HTML/Scalpel/Internal/Select.hs new file mode 100644 --- /dev/null +++ b/src/Text/HTML/Scalpel/Internal/Select.hs @@ -0,0 +1,72 @@ +{-# OPTIONS_HADDOCK hide #-} +module Text.HTML.Scalpel.Internal.Select ( + select +) where + +import Text.HTML.Scalpel.Internal.Select.Types + +import Data.List + +import qualified Text.HTML.TagSoup as TagSoup +import qualified Text.StringLike as TagSoup + + +-- | 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 :: (TagSoup.StringLike str, Selectable str s) + => s -> [TagSoup.Tag str] -> [[TagSoup.Tag str]] +select s = selectNodes nodes + where (MkSelector nodes) = toSelector s + +selectNodes :: TagSoup.StringLike str + => [SelectNode str] -> [TagSoup.Tag str] -> [[TagSoup.Tag str]] +selectNodes nodes tags = head' $ reverse $ results + where results = [concatMap (selectNode s) ts | s <- nodes + | ts <- [tags] : results] + head' [] = [] + head' (x:_) = x + +selectNode :: TagSoup.StringLike str + => SelectNode str -> [TagSoup.Tag str] -> [[TagSoup.Tag str]] +selectNode (SelectNode node attributes) tags = concatMap extractTagBlock nodes + where nodes = filter (checkTag node attributes) $ tails tags +selectNode (SelectAny attributes) tags = concatMap extractTagBlock nodes + where nodes = filter (checkPreds attributes) $ tails tags + +-- 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 + => str -> [AttributePredicate str] -> [TagSoup.Tag str] -> Bool +checkTag name preds tags@((TagSoup.TagOpen str _):_) + = name == str && checkPreds preds tags +checkTag _ _ _ = False + +checkPreds :: TagSoup.StringLike str + => [AttributePredicate str] -> [TagSoup.Tag str] -> Bool +checkPreds preds ((TagSoup.TagOpen _ attrs):_) + = and [or [p attr | attr <- attrs] | p <- preds] +checkPreds _ _ = False + +-- Given a list of tags, return the prefix that of the tags up to the closing +-- tag that corresponds to the initial tag. +extractTagBlock :: TagSoup.StringLike str + => [TagSoup.Tag str] -> [[TagSoup.Tag str]] +extractTagBlock [] = [] +extractTagBlock (openTag : tags) + | not $ TagSoup.isTagOpen openTag = [] + | otherwise = map (openTag :) + $ splitBlock (getTagName openTag) 0 tags + +splitBlock _ _ [] = [] +splitBlock name depth (tag : tags) + | depth == 0 && TagSoup.isTagCloseName name tag = [[tag]] + | TagSoup.isTagCloseName name tag = tag_ $ splitBlock name (depth - 1) tags + | TagSoup.isTagOpenName name tag = tag_ $ splitBlock name (depth + 1) tags + | otherwise = tag_ $ splitBlock name depth tags + where tag_ = map (tag :) + +getTagName :: TagSoup.StringLike str => TagSoup.Tag str -> str +getTagName (TagSoup.TagOpen name _) = name +getTagName (TagSoup.TagClose name) = name +getTagName _ = undefined diff --git a/src/Text/HTML/Scalpel/Internal/Select/Combinators.hs b/src/Text/HTML/Scalpel/Internal/Select/Combinators.hs new file mode 100644 --- /dev/null +++ b/src/Text/HTML/Scalpel/Internal/Select/Combinators.hs @@ -0,0 +1,63 @@ +{-# OPTIONS_HADDOCK hide #-} +module Text.HTML.Scalpel.Internal.Select.Combinators ( + (//) +, (@:) +, (@=) +, (@=~) +, hasClass +) where + +import Text.HTML.Scalpel.Internal.Select.Types + +import qualified Data.Text as T +import qualified Text.Regex.Base.RegexLike as RE +import qualified Text.StringLike as TagSoup + + +-- | The '@:' operator creates a 'Selector' by combining a 'TagName' with a list +-- of 'AttributePredicate's. +(@:) :: (TagSoup.StringLike str, TagName str tag) + => tag -> [AttributePredicate str] -> Selector str +(@:) tag attrs = MkSelector [toSelectNode tag attrs] +infixl 9 @: + +-- | The '@=' operator creates an 'AttributePredicate' that will match +-- attributes with the given name and value. +-- +-- If you are attempting to match a specific class of a tag with potentially +-- multiple classes, you should use the 'hasClass' utility function. +(@=) :: (TagSoup.StringLike str, AttributeName str key) + => key -> str -> AttributePredicate str +(@=) key value (attrKey, attrValue) = matchKey key attrKey + && value == attrValue +infixl 6 @= + +-- | The '@=~' operator creates an 'AttributePredicate' that will match +-- attributes with the given name and whose value matches the given regular +-- expression. +(@=~) :: (TagSoup.StringLike str, AttributeName str key, RE.RegexLike re str) + => key -> re -> AttributePredicate str +(@=~) key re (attrKey, attrValue) = matchKey key attrKey + && RE.matchTest re attrValue +infixl 6 @=~ + +-- | 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. +(//) :: (TagSoup.StringLike str, Selectable str a, Selectable str b) + => a -> b -> Selector str +(//) a b = MkSelector (as ++ bs) + where (MkSelector as) = toSelector a + (MkSelector bs) = toSelector b +infixl 5 // + +-- | The classes of a tag are defined in HTML as a space separated list given by +-- the @class@ attribute. The 'hasClass' function will match a @class@ attribute +-- if the given class appears anywhere in the space separated list of classes. +hasClass :: TagSoup.StringLike str => str -> AttributePredicate str +hasClass clazz (attrName, classes) + | "class" == TagSoup.toString attrName = any (== textClass) classList + | otherwise = False + where textClass = TagSoup.castString clazz + textClasses = TagSoup.castString classes + classList = T.split (== ' ') textClasses diff --git a/src/Text/HTML/Scalpel/Internal/Select/Types.hs b/src/Text/HTML/Scalpel/Internal/Select/Types.hs new file mode 100644 --- /dev/null +++ b/src/Text/HTML/Scalpel/Internal/Select/Types.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# OPTIONS_HADDOCK hide #-} +module Text.HTML.Scalpel.Internal.Select.Types ( + Selector (..) +, Selectable (..) +, AttributePredicate +, Any (..) +, AttributeName (..) +, TagName (..) + +, SelectNode (..) +) where + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import qualified Text.HTML.TagSoup as TagSoup + + +-- | The 'Selectable' class defines a class of types that are capable of being +-- cast into a 'Selector' which in turns describes a section of an HTML DOM +-- tree. +class Selectable str s | s -> str where + toSelector :: s -> Selector str + +-- | The 'AttributeName' class defines a class of types that can be used when +-- creating 'Selector's to specify the name of an attribute of a tag. +-- +-- The most basic types of 'AttributeName' are the string like types (e.g. +-- 'String', 'T.Text', etc). Values of these types refer to attributes with +-- names of that value. +-- +-- In addition there is also the 'Any' type which will match any attribute name. +class AttributeName str k | k -> str where + matchKey :: k -> str -> Bool + +-- | The 'TagName' class defines a class of types that can be used when creating +-- 'Selector's to specify the name of a tag. +-- +-- The most basic types of 'TagName' are the string like types (e.g. 'String', +-- 'T.Text', etc). Values of these types refer to tags of the given value. +-- +-- In addition there is also the 'Any' type which will match any tag. +class TagName str t | t -> str where + toSelectNode :: t -> [AttributePredicate str] -> SelectNode str + +-- | An 'AttributePredicate' is a method that takes a 'TagSoup.Attribute' and +-- returns a 'Bool' indicating if the given attribute matches a predicate. +type AttributePredicate str = TagSoup.Attribute str -> Bool + +-- | 'Any' can be used as a wildcard when constructing selectors to match tags +-- and attributes with any name. +-- +-- For example, the selector @Any \@: [Any \@= \"foo\"]@ matches all tags that +-- have any attribute where the value is @\"foo\"@. +data Any str = Any + +-- | '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 str = MkSelector [SelectNode str] + +data SelectNode str = SelectNode str [AttributePredicate str] + | SelectAny [AttributePredicate str] + +instance Selectable str (Selector str) where + toSelector = id + +instance Selectable String String where + toSelector node = MkSelector [SelectNode node []] + +instance Selectable BS.ByteString BS.ByteString where + toSelector node = MkSelector [SelectNode node []] + +instance Selectable LBS.ByteString LBS.ByteString where + toSelector node = MkSelector [SelectNode node []] + +instance Selectable T.Text T.Text where + toSelector node = MkSelector [SelectNode node []] + +instance Selectable LT.Text LT.Text where + toSelector node = MkSelector [SelectNode node []] + +instance Selectable str (Any str) where + toSelector = const (MkSelector [SelectAny []]) + +instance AttributeName str (Any str) where + matchKey = const . const True + +instance AttributeName String String where + matchKey = (==) + +instance AttributeName BS.ByteString BS.ByteString where + matchKey = (==) + +instance AttributeName LBS.ByteString LBS.ByteString where + matchKey = (==) + +instance AttributeName T.Text T.Text where + matchKey = (==) + +instance AttributeName LT.Text LT.Text where + matchKey = (==) + +instance TagName str (Any str) where + toSelectNode = const SelectAny + +instance TagName String String where + toSelectNode = SelectNode + +instance TagName BS.ByteString BS.ByteString where + toSelectNode = SelectNode + +instance TagName LBS.ByteString LBS.ByteString where + toSelectNode = SelectNode + +instance TagName T.Text T.Text where + toSelectNode = SelectNode + +instance TagName LT.Text LT.Text where + toSelectNode = SelectNode diff --git a/tests/TestMain.hs b/tests/TestMain.hs new file mode 100644 --- /dev/null +++ b/tests/TestMain.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE FlexibleContexts #-} +module Main (main) where + +import Text.HTML.Scalpel + +import Control.Applicative +import System.Exit +import Test.HUnit + +import qualified Text.HTML.TagSoup as TagSoup +import qualified Text.Regex.TDFA + + +main = exit . failures =<< runTestTT (TestList [ + scrapeTests + , selectTests + ]) + +exit :: Int -> IO () +exit 0 = exitSuccess +exit n = exitWith $ ExitFailure n + +selectTests = "selectTests" ~: TestList [ + selectTest + ("a" @: []) + "foo" + ["foo"] + + , selectTest + ("a" @: []) + "foobar" + ["foo", "bar"] + + , selectTest + ("a" @: []) + "foo" + ["foo"] + + , selectTest + ("a" @: []) + "foo" + ["foo", "foo"] + + , selectTest + ("b" @: []) + "foo" + [] + + , selectTest + ("a" @: []) + "foo" + [] + + , selectTest + ("a" @: ["key" @= "value"]) + "foobar" + ["bar"] + + , selectTest + ("a" // "b" @: [] // "c") + "foo" + ["foo"] + + , selectTest + ("a" // "b") + "foobarbaz" + ["foo", "bar"] + + , selectTest + ("a" @: [hasClass "a"]) + "foo" + ["foo"] + + , selectTest + ("a" @: [hasClass "c"]) + "foo" + [] + + , selectTest + ("a" @: ["key" @=~ re "va(foo|bar|lu)e"]) + "foo" + ["foo"] + + , selectTest + ("a" @: [Any @= "value"]) + "foobar" + ["foo", "bar"] + + , selectTest + ("a" @: [Any @= "value"]) + "foobar" + ["bar"] + + , selectTest + (Any @: [Any @= "value"]) + "foobar" + ["foo", "bar"] + + , selectTest + (Any @: [Any @= "value"]) + "foobar" + ["bar"] + ] + +selectTest :: Selectable String s => s -> String -> [String] -> Test +selectTest selector tags expectedText = label ~: expected @=? actual + where + label = "select (" ++ show tags ++ ")" + expected = map TagSoup.parseTags expectedText + actual = select selector (TagSoup.parseTags tags) + +re :: String -> Text.Regex.TDFA.Regex +re = Text.Regex.TDFA.makeRegex + +scrapeTests = "scrapeTests" ~: TestList [ + scrapeTest + "foo" + (Just "foo") + (text "a") + + , scrapeTest + "foobar" + (Just "foo") + (text "a") + + , scrapeTest + "foobar" + (Just ["foo", "bar"]) + (texts "a") + + , scrapeTest + "foobar" + (Just [True, False]) + (map (== "foo") <$> (texts $ "a")) + + , scrapeTest + "" + (Just "foo") + (attr "key" $ "a") + + , scrapeTest + "" + (Just "baz") + (attr "key2" $ "a" @: ["key1" @= "bar"]) + + , scrapeTest + "foobar" + (Just ["foo"]) + (chroot "a" $ texts "b") + + , scrapeTest + "foobar" + (Just ["foo", "bar"]) + (chroots "a" $ text "b") + + , scrapeTest + "foobar" + (Just "foo") + ((text $ "a" // "b") <|> (text $ "a" // "c")) + + , scrapeTest + "foobar" + (Just "bar") + ((text $ "a" // "d") <|> (text $ "a" // "c")) + ] + +scrapeTest :: (Eq a, Show a) => String -> Maybe a -> Scraper String a -> Test +scrapeTest html expected scraper = label ~: expected @=? actual + where + label = "scrape (" ++ show html ++ ")" + actual = scrape scraper (TagSoup.parseTags html)