hs-scrape (empty) → 0.1.0.0
raw patch · 5 files changed
+447/−0 lines, 5 filesdep +basedep +bytestringdep +containerssetup-changed
Dependencies added: base, bytestring, containers, data-default, exceptions, hs-scrape, hspec, html-conduit, lens, retry, safe, tasty, tasty-hunit, text, transformers, url, wreq, xml-conduit
Files
- LICENSE +20/−0
- Setup.hs +2/−0
- hs-scrape.cabal +39/−0
- src/Network/Scraper/State.hs +326/−0
- tests/Tests.hs +60/−0
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2014 Cody Goodman++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
+ hs-scrape.cabal view
@@ -0,0 +1,39 @@+-- Initial hs-scrape.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: hs-scrape+version: 0.1.0.0+synopsis: Simple and easy web scraping and automation in Haskell.+description: Shpider/mechanize inspired web automation with a focus on convenience for web scraping.+homepage: https://github.com/codygman/hs-scrape/+bug-reports: https://github.com/codygman/hs-scrape/issues+license: MIT+license-file: LICENSE+author: Cody Goodman+maintainer: codygman.consulting@gmail.com+-- copyright: +category: Web+build-type: Simple+-- extra-source-files: +cabal-version: >=1.10++library+ exposed-modules: Network.Scraper.State+ -- other-modules: + -- other-extensions: + -- TODO: Sort out dependencies... no idea how to do this yet... for now set to exacts for wreq/lens+ build-depends: base >=4.7 && <4.8, bytestring, text, wreq==0.2.0.0, html-conduit, xml-conduit, safe, transformers, lens==4.4.0.2, containers, url, hspec, retry, data-default, exceptions+ hs-source-dirs: src+ default-language: Haskell2010++test-suite tests+ -- ghc-options: -Wall+ type: exitcode-stdio-1.0+ main-is: Tests.hs+ hs-source-dirs: tests+ build-depends: base, tasty, hspec, tasty-hunit, hs-scrape, xml-conduit, containers+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/codygman/hs-scrape
+ src/Network/Scraper/State.hs view
@@ -0,0 +1,326 @@+{-# LANGUAGE OverloadedStrings #-}+module Network.Scraper.State (+ get,+ runScraper,+ InpFilter (..),+ FormAttr(..),+ Scraper,+ getCurrentCursor,+ toCursor,+ isDisplayed,+ hasDisplayNone,+ getFormBy,+ getCurrentHtml,+ fillForm,+ hasHide,+ getInputs,+ postToForm,+ printFormNames+ ) where++import Control.Applicative+import Control.Arrow ((***))+import Control.Lens ((^.))+import Control.Monad+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Class+import qualified Control.Monad.Trans.State.Strict as ST+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Map as M+import Data.Maybe (fromJust, fromMaybe, isJust,+ listToMaybe)+import Data.Monoid+import qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8)+import qualified Data.Text.IO as TIO+import Network.URL+import Network.Wreq (FormParam (..))+import qualified Network.Wreq as Wreq+import Network.Wreq.Session (Session (..), withSession)+import qualified Network.Wreq.Session as Sesh+import Network.Wreq.Types+import Safe+import Text.HTML.DOM (parseLBS)+import Text.XML.Cursor+import qualified Text.XML.Cursor.Generic as CG++data ScraperState =+ PS { currentOptions :: Wreq.Options+ , currentHtml :: LBS.ByteString+ , currentCursor :: Maybe Cursor+ , currentSession :: Session+ , currentURL :: Maybe URL+ } deriving (Show)++type Scraper = ST.StateT ScraperState IO++toCursor = fromDocument . parseLBS++withInitialState :: (ScraperState -> IO a) -> IO a+withInitialState callback = withSession $ \s -> do+ let initialState = PS { currentOptions = Wreq.defaults+ , currentHtml = ("" :: LBS.ByteString)+ , currentCursor = Nothing+ , currentSession = s+ , currentURL = Nothing+ }+ callback initialState++runScraper :: Scraper a -> IO a+runScraper k = withInitialState (evalScraperWith k)++evalScraperWith :: Scraper a -> ScraperState -> IO a+evalScraperWith k s = ST.evalStateT k s++-- TODO: Move somewhere else???+setCurrentOptions :: Wreq.Options -> Scraper ()+setCurrentOptions o = do+ scraper <- ST.get+ ST.put $ scraper { currentOptions = o }++setCurrentURL :: Maybe URL -> Scraper ()+setCurrentURL u = ST.get >>= (\s -> ST.put $ s { currentURL = u })++getCurrentURL :: Scraper(Maybe URL)+getCurrentURL = ST.get >>= return . currentURL++getCurrentHtml :: Scraper(LBS.ByteString)+getCurrentHtml = ST.get >>= return . currentHtml++-- TODO: Move somewhere else???+-- getCurrentPage :: Shpider Page+getCurrentCursor :: Scraper (Maybe Cursor)+getCurrentCursor = do+ scraper <- ST.get+ return $ currentCursor scraper++-- TODO: Move somewhere else???+getCurrentSession :: Scraper (Session)+getCurrentSession = do+ scraper <- ST.get+ return $ currentSession scraper++-- TODO: Move somewhere else???+setCurrentSession :: Session -> Scraper ()+setCurrentSession s = do+ scraper <- ST.get+ ST.put $ scraper { currentSession = s}++-- TODO: Move somewhere else???+setCurrentCursor :: Cursor -> Scraper ( )+setCurrentCursor c = do+ scraper <- ST.get+ ST.put $ scraper { currentCursor = Just c }++-- TODO: Move somewhere else???+setCurrentHtml :: LBS.ByteString -> Scraper ()+setCurrentHtml html = do+ scraper <- ST.get+ ST.put $ scraper { currentHtml = html }++-- TODO: Move somewhere else???+formShortInfo' f = formInfo'+ where+ go Nothing = "N/A"+ go (Just x) = x+ formInfo = (headMay . attribute "name" $ f, headMay . attribute "action" $ f)+ formInfo' = (\(x,y) -> (go x, go y)) formInfo++-- TODO: Move somewhere else...+ppTuple :: (T.Text, T.Text) -> T.Text+ppTuple = \(x,y) -> "[" <> x <> "]" <> ": " <> y++-- TODO: Move somewhere else...+printFormNames :: Scraper ()+printFormNames = do+ c <- getCurrentCursor+ let c' = fromMaybe (error "No cursor set") c+ forms = c' $// element "form"+ formInfo = map (ppTuple . formShortInfo') forms+ liftIO $ mapM_ (TIO.putStrLn) formInfo++-- TODO: Move somewhere else???+get :: String -> Scraper (LBS.ByteString)+get urlStr = do+ let url = fromMaybe (error ("invalid urlStr: " ++ urlStr)) (importURL urlStr)+ urlStr' = exportURL url+ -- TODO: Display under debug mode+ -- liftIO . putStrLn $ "GET: " ++ url ++ "\n"+ opts <- ST.gets currentOptions+ sesh <- ST.gets currentSession+++ r <- liftIO $ Sesh.getWith opts sesh urlStr'+ let html = r ^. Wreq.responseBody+ setCurrentURL (Just url)+ setCurrentHtml html+ setCurrentCursor (toCursor html)+ return html++-- TODO: Move somewhere else???+post :: Postable a => String -> a -> Scraper (LBS.ByteString)+post urlStr params = do+ opts <- ST.gets currentOptions+ sesh <- ST.gets currentSession+ -- TODO: should take an actual url.. makes api more difficult...+ -- TODO: Make url absolute by storing host of current site+ -- TODO: Display under debug mode+ -- liftIO . print $ params+ -- TODO: Make minimal repro and ask question... not sure how to print something so polymorphic+ -- liftIO . putStrLn $ "POST: " ++ url ++ "\n"+ let url = fromMaybe (error ("invalid urlStr: " ++ urlStr)) (importURL urlStr)+ absURL <- toAbsUrl url+ let url' = exportURL absURL++ r <- liftIO $ Sesh.postWith opts sesh url' params+ let html = r ^. Wreq.responseBody+ setCurrentHtml html+ setCurrentCursor (toCursor html)+ return html++toAbsUrl :: URL -> Scraper(URL)+toAbsUrl u@(URL (Absolute _) _ _) = return u+toAbsUrl u@(URL _ _ _) = do+ hostUrl <- getCurrentURL+ let hostUrl' = fromMaybe (error errMsg) hostUrl+ absUrl = u { url_type = url_type hostUrl' }+ return absUrl+ where errMsg = "You must 'get' or 'post' to something before making urls absolute"+-- toAbsUrl u@(URL _ _ _) = return u++-- TODO: Move to tests+testToAbsUrl :: Scraper()+testToAbsUrl = do+ setCurrentURL (importURL "http://www.google.com")+ aUrl <- toAbsUrl (fromJust . importURL $ "blah.php")+ liftIO . print . exportURL $ aUrl++hasDisplayNone el = fromMaybe False . fmap (== "display: none;") . headMay $ (attribute "style" el)+hasHide el = fromMaybe False . fmap (T.isInfixOf "hide") . headMay $ (attribute "class" el)++anyParentIsHidden el = isJust . listToMaybe . join $ map (\c -> (c $/ check (hasHide))) cs+ where cs = ancestor el++-- checks to see if an eleemnt is displayed+-- isDisplayed el = any (== True) $ [displayNone el, hide el]+isDisplayed :: Cursor -> Bool+isDisplayed el = all (== False) $+ [ hasDisplayNone el+ , hasHide el+ , anyParentIsHidden el -- this was hiding inputs on the paypal billing form+ ]++-- TODO: Move somewhere else???+ -- let aForm = toCursor "<form><input name=\"NOOO\" style=\"display: none;\"><input name=\"YES\"></form>"+getVisibleInputs :: Cursor -> M.Map T.Text T.Text+getVisibleInputs c = do+ let inputs' = filter isDisplayed inputs+ mayPairs = map (\e -> (listToMaybe $ attribute "name" e, listToMaybe $ attribute "value" e)) inputs'+ pairs = map (fromMaybe "" *** fromMaybe "") mayPairs+ M.fromList $ filter ((/= "") . fst) pairs+ where inputs = c $// element "input"++data InpFilter a = Custom ([T.Text]) | AllVisible | AllInps deriving (Show)++getInputs :: InpFilter a -> Cursor -> M.Map T.Text T.Text+getInputs (Custom paramFilterList) c = do+ let mayPairs = map (\e -> (listToMaybe $ attribute "name" e, listToMaybe $ attribute "value" e)) inputs+ pairs = map (fromMaybe "" *** fromMaybe "") mayPairs+ m = M.fromList $ filter ((/= "") . fst) pairs+ -- filter out keys user didn't want+ M.filterWithKey (\k _ -> not . any (== k) $ paramFilterList) m+ where inputs = c $// element "input"+getInputs AllVisible c = getVisibleInputs c+getInputs AllInps c = getAllInputs c++getAllInputs :: Cursor -> M.Map T.Text T.Text+getAllInputs c = do+ let mayPairs = map (\e -> (listToMaybe $ attribute "name" e, listToMaybe $ attribute "value" e)) inputs+ pairs = map (fromMaybe "" *** fromMaybe "") mayPairs+ M.fromList $ filter ((/= "") . fst) pairs+ where inputs = c $// element "input"++-- test get inputs+-- todo: Move to tests+tgi = do+ LBS.readFile "mismatchedinputkeyvalsform.html" >>= return . getAllInputs . toCursor++-- TODO: Move somewhere else???+getLoginForm url = get url >>= return . getAllInputs . toCursor++-- TODO: Move somewhere else???+toWreqFormParams :: [(T.Text, T.Text)] -> [FormParam]+toWreqFormParams params = map (\(k,v) -> k := v) (map (encodeUtf8 *** encodeUtf8) params)++-- TODO: Move somewhere else???+linkWithText :: T.Text -> Cursor -> Maybe Cursor+linkWithText t cursor = listToMaybe $ filter (\c -> (any (T.isInfixOf t)) (c $/ content)) (cursor $// element "a")++-- TODO: Move somewhere else???+addToMap pairs m = foldl (\m ->(\(k,v) -> M.insert k v m)) m pairs++-- TODO: Move somewhere else???+getFormByName :: T.Text -> Scraper (Maybe Cursor)+getFormByName name = do+ c <- getCurrentCursor+ let c' = fromMaybe (error "Nocursor set") c+ formList = c' $// element "form" >=> attributeIs "name" name+ return . listToMaybe $ formList++-- TODO: Move somewhere else???+data FormAttr = Name T.Text | ActionUrl T.Text | FormId T.Text deriving Show++-- TODO: Move somewhere else???+getFormBy :: FormAttr -> Scraper (Maybe Cursor)+getFormBy formAttr = do+ c <- getCurrentCursor+ let c' = fromMaybe (error "Nocursor set") c+ return . listToMaybe $ formList formAttr c'+ where formList (Name val) c =+ c $// element "form" >=> attributeIs "name" val+ formList (ActionUrl val) c =+ c $// element "form" >=> attributeIs "action" val+ formList (FormId val) c =+ c $// element "form" >=> attributeIs "id" val++fillForm :: Maybe Cursor -> Maybe [(T.Text, T.Text)] -> InpFilter a -> [FormParam]+fillForm form Nothing paramFilterList = do+ -- liftIO . putStrLn $ "old inputs: " ++ show (map (attribute "class") $ filter (not . isDisplayed) form)+ let formParams = fromMaybe (error "no params in form") (getInputs paramFilterList <$> form)+ toWreqFormParams . M.toList $ formParams+fillForm form (Just params) paramFilterList = do+ -- putStrLn $ "filling form: " ++ show form+ let formParams = fromMaybe (error "no params in form") (getInputs paramFilterList <$> form)+ formParams' = addToMap params formParams+ toWreqFormParams . M.toList $ formParams'++-- TODO: Move somewhere else???+-- Takes a form name, fields to fill out in the form, then submits the form+-- TODO: Change all[ (T.Text,T.Text)] to just be wreq formvalues... neater api anyway+postToForm :: FormAttr -> Maybe [(T.Text,T.Text)] -> InpFilter a -> Scraper (LBS.ByteString)+postToForm formAttr params paramFilterList = do+ form <- getFormBy formAttr+ c <- getCurrentCursor+ case form of+ Just _ -> do+ -- liftIO $ putStrLn $ "Found form: " ++ show formAttr+ return ()+ Nothing -> do+ -- liftIO $ do+ -- putStrLn "forms found: "+ -- mapM_ TIO.putStrLn $ join $ (map (attribute "name") $ (fromJust c) $// element "form")+ error ("Couldn't find form: " ++ show formAttr)++ let formParams = fillForm form params paramFilterList+ -- todo, this is duplicated above... delete one or the other if possible+ mActionUrl = T.strip <$> (join $ listToMaybe <$> attribute "action" <$> form)+ actionUrl = fromMaybe (error "Couldn't find action url in form") mActionUrl++ -- liftIO $ do+ -- TIO.putStrLn $ "POST " <> actionUrl+ -- print formParams++ -- getCurrentHtml >>= liftIO . LBS.writeFile "last.html"++ html <- post (T.unpack actionUrl) formParams+ return html
+ tests/Tests.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE OverloadedStrings #-}+import qualified Data.Map as M+import Network.Scraper.State+import Test.Tasty (defaultMain, testGroup)+import Test.Tasty.HUnit+import Text.XML.Cursor++trivialTest = testCase "mytest" $ assertEqual "" 1 1++testDisplayNone = testCase "testDisplayNone" $ do+ assertEqual "" True (hasDisplayNone inp)+ where inp = toCursor "<input name=\"t\" style=\"display: none;\">"++testClassHide = testCase "testClassHide" $ do+ assertEqual "" True (hasHide inp)+ where inp = toCursor "<input name=\"t\" class=\"hide;\">"++testIsDisplayedAll = testCase "testIsDisplayedAll" $ do+ assertEqual "Not Displayed (has display: none;)" False (isDisplayed dispNone)+ assertEqual "Not Displayed (has class: hide)" False (isDisplayed classHidden)+ assertEqual "Not Displayed (has hide and dispNone)" False (isDisplayed dispNoneClassHidden)+ assertEqual "Is Displayed" True (isDisplayed visibleInp)+ assertEqual "Parent hidden" False (isDisplayed parentHiddenInps)+ where dispNone = toCursor "<input name=\"t\" style=\"display: none;\">"+ classHidden = toCursor "<input name=\"t\" class=\"hide;\">"+ dispNoneClassHidden = toCursor "<input name=\"t\" class=\"hide;\">"+ visibleInp = toCursor "<input name=\"shown\">"+ parentHiddenInps = toCursor $ "\+ \<div class=\"domcheckertldselect hide\" id=\"tlds\">\+ \<div class=\"col4 textcenter\"><label class=\"full\"><input name=\"tlds[]\" value=\".ph\" checked=\"\" type=\"checkbox\"> .ph</label></div>\+ \<div class=\"col4 textcenter\"><label class=\"full\"><input name=\"tlds[]\" value=\".com.ph\" type=\"checkbox\"> .com.ph</label></div>\+ \<div class=\"col4 textcenter\"><label class=\"full\"><input name=\"tlds[]\" value=\".net.ph\" type=\"checkbox\"> .net.ph</label></div>\+ \<div class=\"col4 textcenter\"><label class=\"full\"><input name=\"tlds[]\" value=\".org.ph\" type=\"checkbox\"> .org.ph</label></div>\+ \<div class=\"col4 textcenter\"><label class=\"full\"><input name=\"tlds[]\" value=\".ngo.ph\" type=\"checkbox\"> .ngo.ph</label></div>\+ \<div class=\"col4 textcenter\"><label class=\"full\"><input name=\"tlds[]\" value=\".mil.ph\" type=\"checkbox\"> .mil.ph</label></div>\+ \<div class=\"col4 textcenter\"><label class=\"full\"><input name=\"tlds[]\" value=\".com\" type=\"checkbox\"> .com</label></div>\+ \<div class=\"col4 textcenter\"><label class=\"full\"><input name=\"tlds[]\" value=\".net\" type=\"checkbox\"> .net</label></div>\+ \<div class=\"col4 textcenter\"><label class=\"full\"><input name=\"tlds[]\" value=\".org\" type=\"checkbox\"> .org</label></div>\+ \<div class=\"col4 textcenter\"><label class=\"full\"><input name=\"tlds[]\" value=\".biz\" type=\"checkbox\"> .biz</label></div>\+ \<div class=\"col4 textcenter\"><label class=\"full\"><input name=\"tlds[]\" value=\".info\" type=\"checkbox\"> .info</label></div>\+ \<div class=\"col4 textcenter\"><label class=\"full\"><input name=\"tlds[]\" value=\".name\" type=\"checkbox\"> .name</label></div>\+ \<div class=\"col4 textcenter\"><label class=\"full\"><input name=\"tlds[]\" value=\".us\" type=\"checkbox\"> .us</label></div>\+ \<div class=\"col4 textcenter\"><label class=\"full\"><input name=\"tlds[]\" value=\".ws\" type=\"checkbox\"> .ws</label></div>\+ \<div class=\"col4 textcenter\"><label class=\"full\"><input name=\"tlds[]\" value=\".asia\" type=\"checkbox\"> .asia</label></div>\+ \<div class=\"col4 textcenter\"><label class=\"full\"><input name=\"tlds[]\" value=\".tv\" type=\"checkbox\"> .tv</label></div>\+ \<div class=\"clear\"></div>\+ \</div>"++testVisibleGetInputs = testCase "testGetInputs" $ do+ assertEqual "" (getInputs AllVisible form) (M.fromList [("YES","")])+ where form = toCursor "<form><input name=\"NOOO\" style=\"display: none;\"><input name=\"YES\"></form>"++tests = testGroup "All tests" [ testDisplayNone+ , testClassHide+ , testIsDisplayedAll+ , testVisibleGetInputs+ ]++main :: IO ()+main = defaultMain tests