packages feed

crawlchain 0.1.1.7 → 0.1.2.0

raw patch · 6 files changed

+124/−93 lines, 6 filesdep +crawlchaindep +http-streamsdep +textdep −HTTPdep ~base

Dependencies added: crawlchain, http-streams, text

Dependencies removed: HTTP

Dependency ranges changed: base

Files

crawlchain.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                crawlchain-version:             0.1.1.7+version:             0.1.2.0 synopsis:            Simulation user crawl paths description:         Library for simulating user crawl paths (trees) with selectors - takes an initial action and a chain of processing actions to crawl a tree (lazy, depth first) searching for a matching branch. stability:           experimental@@ -35,13 +35,28 @@                      , Network.CrawlChain.Downloading                      , Network.CrawlChain.Report                      , Network.CrawlChain.Util-  build-depends:       base < 4.9+  build-depends:       base < 4.10                      , bytestring                      , directory-                     , HTTP+                     , http-streams                      , network-uri                      , split                      , tagsoup+                     , text                      , time+  default-language:    Haskell2010+  ghc-options:         -Wall+++Test-Suite html-tests+  type: exitcode-stdio-1.0+  main-is: HtmlFilteringTests.hs+  other-modules:       Text.HTML.CrawlChain.HtmlFiltering+                     , Network.CrawlChain.CrawlAction+  hs-source-dirs:      src, test/src+  build-depends:       base+                     , crawlchain+                     , split+                     , tagsoup   default-language:    Haskell2010   ghc-options:         -Wall
src/Network/CrawlChain/CrawlChain.hs view
@@ -1,13 +1,10 @@ module Network.CrawlChain.CrawlChain (-  crawlChain, crawlChains, -- primary interface+  crawlChain, crawlChains, -- primary interface    executeActions, crawlForUrl, -- legacy, deprecated   executeCrawlChain -- visible for tests   ) where  import Data.List (intersperse)-import Data.List.Split (splitOn)-import System.Environment (getArgs, getProgName)-import System.Exit (exitFailure)  import Network.CrawlChain.CrawlAction import Network.CrawlChain.CrawlingParameters@@ -15,8 +12,6 @@ import Network.CrawlChain.CrawlingContext (defaultContext, storingContext) import Network.CrawlChain.DirectiveChainResult (extractFirstResult) import Network.CrawlChain.Downloading-import Network.CrawlChain.Storing-import Network.CrawlChain.BasicTemplates  executeActions :: CrawlingParameters -> String -> String -> IO () executeActions args dir fName = do
src/Network/CrawlChain/Crawling.hs view
@@ -1,25 +1,35 @@+{-# LANGUAGE OverloadedStrings #-} module Network.CrawlChain.Crawling (   crawl,   crawlAndStore, CrawlActionDescriber,   Crawler ) where -import Network.HTTP-import Network.Stream (Result)-import Network.URI +import Control.Exception (bracket)+import qualified Data.ByteString.Char8 as BC+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Network.Http.Client as C+import Network.URI (URI (..), parseURI)+ import Network.CrawlChain.CrawlAction import Network.CrawlChain.CrawlResult import Network.CrawlChain.Util-import Network.URI.Util -type RequestType = Request_String type Crawler = CrawlAction -> IO CrawlResult type CrawlActionDescriber = CrawlAction -> String +{-|+ Processes one step of a crawl chain: does the actual loading.+-} crawl :: Crawler-crawl action = delaySeconds 1 >> crawl' action 3 (toRequest action)+crawl action = delaySeconds 1 >> crawlInternal action +{-|+ Used for preparation of integration tests: additionally stores the crawl result+ using the given file name strategy.+-} crawlAndStore :: CrawlActionDescriber -> Crawler crawlAndStore describer = (>>= store) . crawl     where@@ -37,71 +47,58 @@                   putStrLn $ "writing to " ++ n                   writeFile n c -toRequest :: CrawlAction -> RequestType-toRequest (GetRequest url) = addStandardHeader $ mkRequest GET (toURI url)-toRequest (PostRequest url params postType) =-  plainPost {rqBody = formParams,-             rqHeaders = makePostHeaders postType formParams-            }-    where-     plainPost :: RequestType-     plainPost = addStandardHeader $ mkRequest POST (toURI url)-     formParams = urlEncodeVars params--addStandardHeader :: (HasHeaders h) => h -> h-addStandardHeader = insertHeaders [-  Header HdrUserAgent "Mozilla/5.0 (X11; Ubuntu; Linux i686; rv:38.0) Gecko/20100101 Firefox/38.0"-  ]--makePostHeaders :: PostType -> String -> [Header]-makePostHeaders PostForm formParams =-  [-    mkHeader HdrContentType "application/x-www-form-urlencoded",-    mkHeader HdrContentLength (show $ length formParams)-  ]-makePostHeaders PostAJAX formParams = ajaxHeader:(makePostHeaders PostForm formParams) where-  ajaxHeader = mkHeader (HdrCustom "X-Requested-With") "XMLHttpRequest"-makePostHeaders _ _ = []--crawl' :: CrawlAction -> Int -> RequestType -> IO CrawlResult-crawl' originalAction maxRedirects request = do+crawlInternal :: CrawlAction -> IO CrawlResult+crawlInternal action = do --  print request-  response <- simpleHTTP request---  print response-  body <- getResponseBody response---  print body-  code <- getResponseCode response-  logMsg $ "Crawled " ++ (showRequest request) ++ " with result: " ++ (show code)-  checkRedirect maxRedirects request (crawlResult response body code)-  where-     crawlResult :: (HasHeaders a) => Result a -> String -> ResponseCode -> CrawlResult-     crawlResult response body code = CrawlResult originalAction body (parseResonseCode code (locationHeaders response))-      where-        locationHeaders :: (HasHeaders a) => Result a -> [Header]-        locationHeaders = either (\_ -> []) (retrieveHeaders HdrLocation)---- this reinvents the wheel and should be switched to using http-client if problems occur-checkRedirect :: Int -> RequestType -> CrawlResult -> IO CrawlResult-checkRedirect 0 _ result = return result-checkRedirect maxRedirects previousRequest result =-  maybe (return result) (crawl' (crawlingAction result) (maxRedirects -1)) (extractRedirectAction $ crawlingResultStatus result)+  response <- doRequest action+-- print response+  logMsg $ "Crawled " ++ (show action)+  return $ CrawlResult action (BC.unpack response) CrawlingOk   where-    extractRedirectAction :: CrawlingResultStatus -> Maybe (Request String)-     -- unclean: converts PostRequest to Get, should do something more sensible-    extractRedirectAction (CrawlingRedirect url) = Just $ previousRequest { rqURI = toURI url }-    extractRedirectAction _ = Nothing--parseResonseCode :: ResponseCode -> [Header] -> CrawlingResultStatus-parseResonseCode (2, _, _) _ = CrawlingOk-parseResonseCode code@(3, _, _) hdrLoc = maybe (CrawlingFailed (show code)) CrawlingRedirect (extractRedirectUrl hdrLoc)-parseResonseCode code _ = CrawlingFailed (show code)--extractRedirectUrl :: [Header] -> Maybe String-extractRedirectUrl [] = Nothing-extractRedirectUrl ((Header _ value):xs) =-  let parsedHeader = (parseURIReference value)-  in maybe (extractRedirectUrl xs) (Just . show) parsedHeader--showRequest :: RequestType -> String-showRequest r = (show $ rqURI r) ++ " - " ++ (show $ rqMethod r) ++ ": " ++ (rqBody r)+    doRequest :: CrawlAction -> IO (BC.ByteString)+    doRequest (GetRequest url) = C.get (BC.pack url) C.concatHandler -- TODO check exceptions with concatHandler'+    doRequest (PostRequest urlString ps pType) = doPost (BC.pack urlString) formParams pType where+      formParams = map (\(a, b) -> (BC.pack a, BC.pack b)) ps+      doPost :: BC.ByteString -> [(BC.ByteString, BC.ByteString)] -> PostType -> IO BC.ByteString+      doPost url params postType = doPost' postType where+        doPost' :: PostType -> IO BC.ByteString+        doPost' Undefined = doPost' PostForm+        doPost' PostForm = C.postForm url params C.concatHandler+        doPost' PostAJAX = ajaxRequest url params +ajaxRequest :: BC.ByteString -> [(BC.ByteString, BC.ByteString)] -> IO BC.ByteString+ajaxRequest = postRequest C.concatHandler ajaxRequestChanges where+  ajaxRequestChanges = do+    C.setContentType "application/x-www-form-urlencoded; charset=UTF-8"+    C.setAccept "application/json, text/javascript, */*"+    C.setHeader "X-Requested-With" "XMLHttpRequest"+  -- I am not terribly enthusiastic about the http-streams interface when changing headers+  postRequest handler requestChanges url formParams  = do+    bracket+      (C.establishConnection url)+      (C.closeConnection)+      (process)+    where+      u = parseURL url where+        parseURL :: C.URL -> URI+        parseURL r' =+          case parseURI r of+          Just u'  -> u'+          Nothing -> error ("Can't parse URI " ++ r)+          where r = T.unpack $ T.decodeUtf8 r'+      q = C.buildRequest1 $ do+        C.http C.POST (path u)+        C.setAccept $ BC.pack "*/*"+        C.setContentType $ BC.pack "application/x-www-form-urlencoded"+        requestChanges where+          path :: URI -> BC.ByteString+          path u' =+            case url' of+             ""  -> "/"+             _   -> url'+            where+              url' = T.encodeUtf8 $! T.pack $! concat [uriPath u', uriQuery u', uriFragment u']+      process c = do+        _ <- C.sendRequest c q (C.encodedFormBody formParams)+        x <- C.receiveResponse c handler+        return x
src/Network/CrawlChain/Downloading.hs view
@@ -1,11 +1,7 @@ module Network.CrawlChain.Downloading (downloadTo, storeDownloadAction) where -import Data.ByteString as B-import Network.HTTP---import Network.Stream---import Pipes---import Pipes.HTTP---import qualified Pipes.ByteString as PB  -- from `pipes-bytestring`+import qualified Data.ByteString.Char8 as BC+import qualified Network.Http.Client as C  import Network.CrawlChain.CrawlAction import Network.URI.Util@@ -14,9 +10,8 @@ downloadTo :: Maybe String -> String -> CrawlAction -> IO () downloadTo dir destination (GetRequest url) = buildAndCreateTargetDir True dir destination >>= \fulldestination -> do   Prelude.putStrLn $ "Downloading from "++url++" to "++fulldestination-  downloadResult <- simpleHTTP (defaultGETRequest_ (toURI url))-  responseBody <- getResponseBody downloadResult-  B.writeFile fulldestination responseBody+  downloadResult <- C.get (BC.pack url) C.concatHandler+  BC.writeFile fulldestination downloadResult   Prelude.putStrLn $ "Download finished" downloadTo _ _ req = Prelude.putStrLn $ "POST Requests not supported: " ++ show req
src/Text/HTML/CrawlChain/HtmlFiltering.hs view
@@ -1,5 +1,5 @@ module Text.HTML.CrawlChain.HtmlFiltering (-  extractLinks, extractLinksMatching, extractLinksWithAttributes, extractLinksFilteringUrlAttrs, extractLinksFilteringAll,+  extractLinks, extractLinksMatching, extractLinksWithAttributes, extractLinksFilteringUrlAttrs, extractLinksFilteringAll, unevaluated,   findAllUrlsEndingWith, findFirstLinkAfter,   extractFirstForm,   Method(..),@@ -66,7 +66,8 @@   parseTags   where     filterAndGroupLinks :: [TagS] -> [[TagS]]-    filterAndGroupLinks = map cleanupLinkGroup . splitWhen' (isTagOpenName "a")+    filterAndGroupLinks =+      map cleanupLinkGroup . splitWhen' (\t -> isTagOpenName "a" t || isTagOpenName "iframe" t)       where         splitWhen' :: (a -> Bool) -> [a] -> [[a]]         splitWhen' f = splitWhen'' []@@ -74,7 +75,10 @@             splitWhen'' col [] = [col]             splitWhen'' col (x:rest) = if f x then col:(splitWhen'' [x] rest) else splitWhen'' (col++[x]) rest         cleanupLinkGroup :: [TagS] -> [TagS]-        cleanupLinkGroup = takeWhile (not . (isTagCloseName "a")) . dropWhile (not . (isTagOpenName "a"))+        cleanupLinkGroup = takeWhile notEndSrcTag . dropWhile notStartSrcTag where+          notStartSrcTag t = not $ any (flip isTagOpenName t) supportedTags -- (not . (isTagOpenName "a"))+          notEndSrcTag t = not $ any (flip isTagCloseName t) supportedTags+          supportedTags =  ["a", "iframe"]  findFirstLinkAfter :: String -> [(String, String)] -> String -> [CrawlAction] findFirstLinkAfter tagName tagAttrs =@@ -92,7 +96,7 @@     isLink _ = False  getSrc :: Tag String -> String-getSrc (TagOpen _ as) = fromMaybe "" (lookup "href" as)+getSrc (TagOpen _ attributes) = fromMaybe (fromMaybe "" (lookup "src" attributes)) (lookup "href" attributes) getSrc _ = []  getTagAttrs :: Tag String -> [(String, String)]
+ test/src/HtmlFilteringTests.hs view
@@ -0,0 +1,25 @@+module Main (main) where++import System.Exit (exitFailure)++import Network.CrawlChain.CrawlAction+import Text.HTML.CrawlChain.HtmlFiltering++main :: IO ()+main = do+  match extractLinks "<a href=\"link\">text</a>" ["link"]+  match extractLinks "<a href=\"link\" />" ["link"]+  match extractLinks "<a href=\"link\">sdf</a><a href=\"link2\">sdf</a>" ["link", "link2"]+  match (extractLinksFilteringAll unevaluated unevaluated unevaluated) "<a href=\"link\">text<span>bla</span></a>" ["link"]+  match (extractLinksFilteringAll unevaluated unevaluated (any (=="bla"))) "<a href=\"link\">text<span>bla</span></a>" ["link"]+  match (extractLinksFilteringAll unevaluated unevaluated (not . any (=="bla"))) "<a href=\"link\">text<span>bla</span></a>" []+  match extractLinks "<iframe src=\"link\"></iframe>" ["link"]+  match extractLinks "<iframe src=\"link\"/>" ["link"]+    where+      match method input expected = +        if actual /= map GetRequest expected+        then putStrLn ("could not find " ++ (show expected) ++ " in; " ++ input) >> exitFailure+        else pure ()+        where+          actual = method input+