packages feed

crawlchain (empty) → 0.1.0.8

raw patch · 19 files changed

+882/−0 lines, 19 filesdep +HTTPdep +basedep +bytestringsetup-changed

Dependencies added: HTTP, base, bytestring, directory, network-uri, split, tagsoup, time

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Axel Mannhardt (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of the author nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ crawlchain.cabal view
@@ -0,0 +1,44 @@+-- Initial crawlchain.cabal generated by cabal init.  For further +-- documentation, see http://haskell.org/cabal/users-guide/++name:                crawlchain+version:             0.1.0.8+synopsis:            Library for simulating user crawl paths (trees) with selectors.+description:         Warning: experimental+license:             BSD3+license-file:        LICENSE+author:              Axel Mannhardt+maintainer:          7a3ggptwts@snkmail.com+category:            Web+build-type:          Simple+cabal-version:       >=1.22++library+  hs-source-dirs:      src+  exposed-modules:     Network.CrawlChain.CrawlChain+                     , Network.CrawlChain.CrawlingParameters+                     , Network.CrawlChain.BasicTemplates+                     , Network.CrawlChain.CrawlAction+                     , Network.CrawlChain.CrawlDirective+                     , Network.CrawlChain.CrawlResult+-- TODO refactor: extract http utils+                     , Network.URI.Util+                     , Text.HTML.CrawlChain.HtmlFiltering+                     , Network.CrawlChain.Storing+                       -- visible for tests+                     , Network.CrawlChain.CrawlingContext+                     , Network.CrawlChain.DirectiveChainResult+  other-modules:       Network.CrawlChain.Constants+                     , Network.CrawlChain.CrawlChains+                     , Network.CrawlChain.Crawling+                     , Network.CrawlChain.Downloading+                     , Network.CrawlChain.Report+  build-depends:       base < 4.9+                     , bytestring+                     , directory+                     , HTTP+                     , network-uri+                     , split+                     , tagsoup+                     , time+  default-language:    Haskell2010
+ src/Network/CrawlChain/BasicTemplates.hs view
@@ -0,0 +1,55 @@+module Network.CrawlChain.BasicTemplates (+  searchWebTemplate,+  searchWebTemplateAndProcessHits+  ) where++import Data.List (nub, isInfixOf, isSuffixOf)+import Data.List.Split (splitOn)+import Data.Maybe (maybeToList)++import Network.CrawlChain.CrawlAction+import Network.CrawlChain.CrawlResult+import Network.CrawlChain.CrawlDirective+import Network.CrawlChain.CrawlingParameters+import Text.HTML.CrawlChain.HtmlFiltering++-- generic search template++searchWebTemplate :: String -> String -> (CrawlAction, CrawlDirective)+searchWebTemplate site searchTerm = searchWebTemplateAndProcessHits site searchTerm [] Nothing (id . snd)+searchWebTemplateAndProcessHits :: String -> String+                                   -> [String] -> Maybe ContainedTextFilter+                                   -> ((CrawlAction, [CrawlAction]) -> [CrawlAction])+                                   -> (CrawlAction, CrawlDirective)+searchWebTemplateAndProcessHits site searchTerm filterElems tFilter hitProcessor = (+  searchWebAction site searchTerm,+  DirectiveSequence [+    (FollowUpDirective (hitProcessor . extractHits))+  ])+  where+    extractHits :: CrawlResult -> (CrawlAction, [CrawlAction])+    extractHits crawlResult = (crawlingAction crawlResult, extractHits' $ crawlingContent crawlResult)+    extractHits' :: String -> [CrawlAction]+    extractHits' = nub . filterToUrlsContainingAllOf (maybe noTextFilter id tFilter) filterElems++-- using yahoo since the used libraries do not support https, which most other than google/yahoo require+searchWebAction :: String -> String -> CrawlAction+searchWebAction site term = GetRequest $+  "http://us.search.yahoo.com/search?p=" ++ term ++ "+" ++ site++filterToUrlsContainingAllOf :: ContainedTextFilter -> [String] -> String -> [CrawlAction]+filterToUrlsContainingAllOf textFilter = filterToUrlsContainingAllOf'+  where+    filterToUrlsContainingAllOf' [] = filterToUrlsContainingText textFilter ""+    filterToUrlsContainingAllOf' (x:[]) = filterToUrlsContainingText textFilter x+    filterToUrlsContainingAllOf' (x:rest) = (retainActionsContaining x) . (filterToUrlsContainingAllOf' rest)++filterToUrlsContainingText :: ContainedTextFilter -> String -> String -> [CrawlAction]+filterToUrlsContainingText textFilter marker =+  retainActionsContaining marker . extractLinksFilteringAll noUrlFilter noAttrFilter textFilter++filterToUrlsContaining :: String -> String -> [CrawlAction]+filterToUrlsContaining = filterToUrlsContainingText noTextFilter++retainActionsContaining :: String -> [CrawlAction] -> [CrawlAction]+retainActionsContaining marker = filter ((marker `isInfixOf`) . crawlUrl)
+ src/Network/CrawlChain/Constants.hs view
@@ -0,0 +1,4 @@+module Network.CrawlChain.Constants where++testResourcePath :: String+testResourcePath = "test/resources/"
+ src/Network/CrawlChain/CrawlAction.hs view
@@ -0,0 +1,19 @@+module Network.CrawlChain.CrawlAction where++data PostType = Undefined | PostForm deriving (Show, Eq)+type PostParams = [(String, String)] ++data CrawlAction = GetRequest String+                 | PostRequest String PostParams PostType+  deriving (Show, Eq)++crawlUrl :: CrawlAction -> String+crawlUrl (GetRequest url) = url+crawlUrl (PostRequest url _ _) = url++{-|+  Adds a prefix to a relative crawl action to get an absolute one.+|-}+addUrlPrefix :: String -> CrawlAction -> CrawlAction+addUrlPrefix p (GetRequest u) = GetRequest (p++u)+addUrlPrefix p (PostRequest u ps t) = PostRequest (p++u) ps t
+ src/Network/CrawlChain/CrawlChain.hs view
@@ -0,0 +1,65 @@+module Network.CrawlChain.CrawlChain+       (executeActions, crawlChain, crawlForUrl,+        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+import Network.CrawlChain.CrawlChains+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+  downloadAction <- crawlChain args+  if paramDoDownload args+    then downloadStep dir fName downloadAction+    else storeDownloadAction "external-load" (Just dir ) fName downloadAction++crawlForUrl :: CrawlingParameters -> IO (Maybe String)+crawlForUrl args = do+  crawlResult <- crawlChain args+  case crawlResult of+       (Just (GetRequest url)) -> return $ Just url+       (Just _) -> putStrLn "POST result processing not implemented" >> return Nothing+       Nothing -> return Nothing++crawlChain :: CrawlingParameters -> IO (Maybe CrawlAction)+crawlChain args = do+  results <- crawlingChain+  logAndReturnFirstOk results+  where+    crawlingChain :: IO [DirectiveChainResult]+    crawlingChain =+      executeCrawlChain context (paramInitialAction args) (paramCrawlDirective args)+        where+          context = if paramDoStore args then storingContext else defaultContext++downloadStep :: String -> String -> Maybe CrawlAction -> IO ()+downloadStep dir fName downloadAction = maybe (return ()) (downloadTo (Just dir) fName) downloadAction++logAndReturnFirstOk :: [DirectiveChainResult] -> IO (Maybe CrawlAction)+logAndReturnFirstOk results = do+  firstOk <- (return . extractFirstResult) results+  putResults firstOk results+  return firstOk++putResults :: Maybe CrawlAction -> [DirectiveChainResult] -> IO ()+putResults firstSuccess results =+  maybe writeFailures putSuccess firstSuccess+    where+      putSuccess :: CrawlAction -> IO ()+      putSuccess a = putStrLn (crawlUrl a)+      writeFailures = do+        putStrLn "no results found, look into failures.log"+        writeFile "failures.log" showAllFailures+          where showAllFailures = concat $ intersperse "\n\n" $ map showResultPath results
+ src/Network/CrawlChain/CrawlChains.hs view
@@ -0,0 +1,168 @@+module Network.CrawlChain.CrawlChains (+  executeCrawlChain,+  CrawlDirective(..),+  DirectiveChainResult, lastResult, resultHistory, showResultPath,+  (>>+),+  combineAbsoluteUrl)+  where++import Data.List (intersperse)+import Data.List.Split (splitOn)+import System.IO.Unsafe as Unsafe (unsafeInterleaveIO)++import Network.CrawlChain.CrawlAction+import Network.CrawlChain.CrawlResult+import Network.CrawlChain.CrawlingContext+import Network.CrawlChain.CrawlDirective+import Network.CrawlChain.DirectiveChainResult+import Network.CrawlChain.Report+++executeCrawlChain :: CrawlingContext a => a -> CrawlAction -> CrawlDirective -> IO [DirectiveChainResult]+executeCrawlChain = followDirective [] []++{-+ Unwraps the actions of the CrawlDirective and applies them, colling the results. Each DirectiveChainResult contains the complete history+ for crawling a chain - either till the end of a directive of a crawl failure. Having multiple in the result is the effect of+ "non-determinism" arising because of possible having multiple follow ups for each crawl.++ Internal signature:+  - collectedResults contains the actual results, updated when actual crawling is done.+  - reportPath contains the current path of the crawling tree, used when adding a new result+ + Handles the leaves directly, sequences are delegated.+ The simple actions fail, if the previous result was no success. Among these simple directives are used for crawling absolute links,+   followups have to be used to crawl relative links since they allow access to the current url.+ The alternative provides a way to peek, using the second alternative if the first failed.+ The fallback is ignored on success, but on fail initializes the crawl chain anew. This is more powerful than alternatives,+   since the initial action can have a fallback, too.++ Chaining these actions together is done in sequences. Sequences do not do anything on their own (in fact: empty sequences always fail),+   but applies the results of every element to its successors until only one successor remains.+-}+followDirective :: CrawlingContext a =>+                   [DirectiveChainResult] -> [Report] -> a -> CrawlAction -> CrawlDirective+                   -> IO [DirectiveChainResult]+followDirective collectedResults reportPath context crawlAction = followDirective'+  where+    followDirective' :: CrawlDirective -> IO [DirectiveChainResult]+    followDirective' (DirectiveSequence sequence') =+      followDirectiveSequence collectedResults reportPath context crawlAction sequence'+    followDirective' (SimpleDirective logic) = crawlAndSearch (logic . crawlingContent)+    followDirective' (RelativeDirective logic) = crawlAndSearch (makeAbsoluteLogicMapper logic)+    followDirective' (FollowUpDirective logic) = crawlAndSearch logic+    followDirective' (AlternativeDirective a1 a2) = do+      a1Results <- followDirective' a1+      if all (null . lastResult) a1Results -- only use alternative if no results at all+        then followDirective' a2+        else return a1Results+    followDirective' (RestartChainDirective restart) =+      uncurry (followDirective collectedResults reportPath context) restart+    -- actual crawling happens here (and only here):+    crawlAndSearch :: (CrawlResult -> [CrawlAction]) -> IO [DirectiveChainResult]+    crawlAndSearch searchLogic = crawler context crawlAction >>= processCrawlingResult+      where+        processCrawlingResult crawlingResult = return searchCrawlingResult >>= logSearchResults >>= return . wrapActions >>= appendResult+          where+            searchCrawlingResult :: [CrawlAction]+            searchCrawlingResult = if crawlWasNoSuccess crawlingResult then [] else searchLogic crawlingResult+            logSearchResults res = putStrLn ("  found " ++ (show $ length res) ++" follow-up actions:" ++ (show $ map crawlUrl $ res)) >> return res+            wrapActions :: [CrawlAction] -> DirectiveChainResult+            wrapActions res+                | null res = DirectiveChainResult (errReport crawlingResult:reportPath) []+                | otherwise = DirectiveChainResult updateReportPath res+              where+                updateReportPath :: [Report]+                updateReportPath = okReport crawlingResult : reportPath+            appendResult :: DirectiveChainResult -> IO [DirectiveChainResult]+            appendResult = return . (collectedResults ++) . (:[])++{-+ Whereas definition of single directives is pretty straightforward to understand, sequences are handled in this internal method. Notes:++  - sequences itself do not fail (unless defined empty), only directives with actual crawling do+  - sequences do not update the reports or results.+  - crawlingdirectives are trees - primarily not because of sequences or alternatives, but because every simple directive+    may have multiple results - the next directive in a sequence is not a sibling, but the next depth level of the+    crawling tree.+  - however, not all crawling paths must be followed - it is for the caller to decide, how many of the possible leaves are+    actually needed - unused paths should not be actually crawled, the result list needs to be lazy+  - the above also means tree traversal is depth first+  - still, as the following actions depend on the output of the ones before, we need to execute the actions in order when chaining+-}+followDirectiveSequence :: CrawlingContext a => [DirectiveChainResult] -> [Report] -> a -> CrawlAction -> [CrawlDirective] -> IO [DirectiveChainResult]+followDirectiveSequence collectedResults reportPath context crawlingAction' = followDirectiveSequence'+  where+  followDirectiveSequence' :: [CrawlDirective] -> IO [DirectiveChainResult]+  followDirectiveSequence' [] = return [DirectiveChainResult (Report "unsupported: empty sequence" "":reportPath) []]+  followDirectiveSequence' (single:[]) = followDirective collectedResults reportPath context crawlingAction' single+  followDirectiveSequence' (nextDirective:remainingDirectives) = chainDirectives+    where+      -- first things first: this is how the head is processed, its results are not end results, but are input for the next chain step+      -- so the previously collected results are only added, when the chain end is reached (see above)+      nextStepActions :: IO [DirectiveChainResult]+      nextStepActions = followDirective [] reportPath context crawlingAction' nextDirective+      -- this is how one(!) possible follow up has to be calculated+      remainingActions :: [DirectiveChainResult] -> [Report] -> CrawlAction -> IO [DirectiveChainResult]+      remainingActions nextStepResults nextStepReportPath nextStepCrawlAction =+        followDirectiveSequence nextStepResults nextStepReportPath context nextStepCrawlAction remainingDirectives+      chainDirectives :: IO [DirectiveChainResult]+      -- now do the actual crawling of the next step as these results are needed for the following steps+      chainDirectives = do+        nextStepResults <- nextStepActions+        followNextSteps nextStepResults+          where+            followNextSteps :: [DirectiveChainResult] -> IO [DirectiveChainResult]+            followNextSteps nextStepResults = nextStepsResults+              where+                nextStepsResults :: IO [DirectiveChainResult]+                 -- for lazy wrapping of [IO], probably not considered good style+                nextStepsResults = wrapResults $ nextStepsResults' allInputActionsForFollowingSteps+                  where+                    nextStepsResults' :: [CrawlAction] -> [IO [DirectiveChainResult]]+                    nextStepsResults' = map (remainingActions [] reportPath) -- TODO pass previously collected results?+                allInputActionsForFollowingSteps :: [CrawlAction]+                 -- nextStepResults contains the result of the first step as if the chain would stop there+                allInputActionsForFollowingSteps = concat $ map lastResult nextStepResults++wrapResults :: [IO [a]] -> IO [a]+wrapResults = lazyIOsequence -- resorts to unsafe IO internally++-- I do not want that depencency, this is copy/paste (but there should be a "safe" way, right?)+-- | Lazily evaluate each action in the sequence from left to right,+-- and collect the results.+-- PS: also playing around with an additional concat before returning+lazyIOsequence :: [IO [a]] -> IO [a]+lazyIOsequence (mx:mxs) = do+    x   <- mx+    xs  <- Unsafe.unsafeInterleaveIO (Prelude.sequence mxs)+    return $ concat (x : xs)+lazyIOsequence [] = return []+++errReport :: CrawlResult -> Report+errReport crawlingResult = report "crawling unsuccessful: " crawlingResult++okReport :: CrawlResult -> Report+okReport crawlingResult = report "ok: " crawlingResult++report :: String -> CrawlResult -> Report+report prefix crawlingResult = Report (prefix ++ (show $ crawlingAction crawlingResult)) (crawlingContent crawlingResult)++crawlWasNoSuccess :: CrawlResult -> Bool+crawlWasNoSuccess = (/= CrawlingOk) . crawlingResultStatus++(>>+) :: (CrawlAction, CrawlDirective) -> CrawlDirective -> (CrawlAction, CrawlDirective)+(>>+) (initialAction, first) second = (initialAction, DirectiveSequence [first, second])++makeAbsoluteLogicMapper :: (String -> [CrawlAction]) -> CrawlResult -> [CrawlAction]+makeAbsoluteLogicMapper logic crawlResult = combineAbsoluteUrls (crawlingAction crawlResult) $ logic $ crawlingContent crawlResult++combineAbsoluteUrls :: CrawlAction -> [CrawlAction] -> [CrawlAction]+combineAbsoluteUrls previousAction = map $ combineAbsoluteUrl previousAction++combineAbsoluteUrl :: CrawlAction -> CrawlAction -> CrawlAction+combineAbsoluteUrl previousAction = addUrlPrefix baseUrl+  where+    baseUrl = ((++"/") . concat . intersperse "/" . dropLast . splitOn "/") (crawlUrl previousAction)+    dropLast es = take (length es -1) es
+ src/Network/CrawlChain/CrawlDirective.hs view
@@ -0,0 +1,12 @@+module Network.CrawlChain.CrawlDirective where++import Network.CrawlChain.CrawlAction+import Network.CrawlChain.CrawlResult++data CrawlDirective =+    SimpleDirective (String -> [CrawlAction])          -- access content to find absolute follow-up urls+  | RelativeDirective (String -> [CrawlAction])        -- as simple, but found relative urls are completed+  | FollowUpDirective (CrawlResult -> [CrawlAction])   -- as simple, but with access to complete result+  | AlternativeDirective CrawlDirective CrawlDirective -- fallback to second argument if first yields no results+  | RestartChainDirective (CrawlAction, CrawlDirective)-- the possibility to start over (when using alternative)+  | DirectiveSequence [CrawlDirective]                 -- chaining of directives
+ src/Network/CrawlChain/CrawlResult.hs view
@@ -0,0 +1,14 @@+module Network.CrawlChain.CrawlResult where++import Network.CrawlChain.CrawlAction++data CrawlResult = CrawlResult {+  crawlingAction :: CrawlAction,+  crawlingContent :: String,+  crawlingResultStatus :: CrawlingResultStatus+} deriving Show++data CrawlingResultStatus = CrawlingOk+                          | CrawlingRedirect String+                          | CrawlingFailed String+  deriving (Show, Eq)
+ src/Network/CrawlChain/Crawling.hs view
@@ -0,0 +1,113 @@+module Network.CrawlChain.Crawling (+  crawl,+  crawlAndStore, CrawlActionDescriber,+  Crawler+) where++import Prelude hiding (log)++import Control.Concurrent (threadDelay)+import Data.Time.Format (formatTime, defaultTimeLocale)+import Data.Time.LocalTime (getZonedTime)+import Network.HTTP+import Network.Stream (Result)+import Network.URI++import Network.CrawlChain.CrawlAction+import Network.CrawlChain.CrawlResult+import Network.URI.Util++type RequestType = Request_String+type Crawler = CrawlAction -> IO CrawlResult+type CrawlActionDescriber = CrawlAction -> String++crawl :: Crawler+crawl action = log "delaying crawl for 1s" >> threadDelay 1000000 >> crawl' action 3 (toRequest action)++crawlAndStore :: CrawlActionDescriber -> Crawler+crawlAndStore describer = (>>= store) . crawl+    where+      store :: CrawlResult -> IO CrawlResult+      store cr = store' (crawlingResultStatus cr)+        where+          store' CrawlingOk = storeResult (crawlingContent cr)+          store' (CrawlingFailed msg) = storeResult msg+          store' status = error $ "unexpected status: " ++ (show status)+          storeResult filecontent'= do+            writeFile' (describer $ crawlingAction cr) filecontent'+            return cr+              where+                writeFile' n c = do+                  putStrLn $ "writing to " ++ n+                  writeFile n c++log :: String -> IO ()+log msg = printTime >> putStr ("> " ++ msg ++ "\n")+  where+    printTime = getZonedTime >>= return . formatTime' >>= putStr+      where+        formatTime' = formatTime defaultTimeLocale "%Y-%m-%d_%H:%M:%S"++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 _ _ = []++crawl' :: CrawlAction -> Int -> RequestType -> IO CrawlResult+crawl' originalAction maxRedirects request = do+  response <- simpleHTTP request+  body <- getResponseBody response+  code <- getResponseCode response+  log $ "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)+  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)+
+ src/Network/CrawlChain/CrawlingContext.hs view
@@ -0,0 +1,41 @@+module Network.CrawlChain.CrawlingContext (+    CrawlingContext, DefaultCrawlingContext(..), crawler,+    defaultContext, storingContext, bufferingFilename+  ) where++import Network.CrawlChain.Constants+import Network.CrawlChain.Crawling (crawl, crawlAndStore, Crawler)+import Network.CrawlChain.CrawlAction++class CrawlingContext a where+  crawler :: a -> Crawler++data DefaultCrawlingContext = DefaultCrawlingContext {+  crawlImplementation :: Crawler+}+instance CrawlingContext DefaultCrawlingContext where+  crawler = crawlImplementation++{-+ Enabling tests: provide different crawling implementations:++ - regular+ - storing the crawled URLs and its content to prepare new tests+ - reading the stored content in tests - has no real world application and is defined in the actual tests+-}+defaultContext, storingContext :: DefaultCrawlingContext+defaultContext = DefaultCrawlingContext crawl+storingContext = DefaultCrawlingContext $ crawlAndStore bufferingFilename++bufferingFilename :: CrawlAction -> String+bufferingFilename a = testResourcePath ++ (fname a) ++ if isPost a then "-POST" else ""+  where+    isPost (PostRequest _ _ _) = True+    isPost _ = False+    fname = lastSegment . crawlUrl+      where+        lastSegment :: String -> String+        lastSegment = reverse . foldl (dropOn '/') []+          where+            dropOn :: Char -> String -> Char -> String+            dropOn c = \collected nextC -> if c == nextC then "" else nextC:collected
+ src/Network/CrawlChain/CrawlingParameters.hs view
@@ -0,0 +1,11 @@+module Network.CrawlChain.CrawlingParameters where++import Network.CrawlChain.CrawlAction+import Network.CrawlChain.CrawlDirective++data CrawlingParameters = CrawlingParameters {+  paramInitialAction :: CrawlAction,+  paramCrawlDirective :: CrawlDirective,+  paramDoDownload :: Bool,+  paramDoStore :: Bool+  }
+ src/Network/CrawlChain/DirectiveChainResult.hs view
@@ -0,0 +1,24 @@+module Network.CrawlChain.DirectiveChainResult (DirectiveChainResult (..), showResultPath, extractFirstResult) where++import Data.Maybe (listToMaybe)++import Network.CrawlChain.CrawlAction+import Network.CrawlChain.Report++data DirectiveChainResult = DirectiveChainResult {+                              resultHistory :: [Report],+                              lastResult :: [CrawlAction]+  }++showResultPath :: DirectiveChainResult -> String+showResultPath rp = "next target" ++ (show $ lastResult rp) ++ "\n" +++                    ((showResult "->" . reverse . resultHistory) rp) ++ "\n" +++                    "last content:\n" ++ (maybe "<empty" showFullReport $ listToMaybe $ resultHistory rp)+  where+    showResult _ [] = ""+    showResult prefix (x:xs) = prefix ++ (reportMsg x) ++ "\n" ++ (showResult ("  " ++ prefix) xs)++extractFirstResult :: [DirectiveChainResult] -> Maybe CrawlAction+extractFirstResult [] = Nothing+extractFirstResult (r:rs) = let res = lastResult r+                            in if null res then extractFirstResult rs else Just (head res)
+ src/Network/CrawlChain/Downloading.hs view
@@ -0,0 +1,41 @@+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 Network.CrawlChain.CrawlAction+import Network.URI.Util+import Network.CrawlChain.Storing++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+  Prelude.putStrLn $ "Download finished"+downloadTo _ _ req = Prelude.putStrLn $ "POST Requests not supported: " ++ show req++storeDownloadAction :: FilePath -> Maybe String -> String -> Maybe CrawlAction -> IO ()+storeDownloadAction storeloc dir destination action = do+  maybe (Prelude.putStrLn "no results found") (go . crawlUrl) action+    where+      go url = do+        Prelude.putStrLn $ "no download requested, appending to " ++ storeloc+        curlCmd <- buildCurlCmd dir destination url+        Prelude.appendFile storeloc curlCmd++{-+downloadStreamingTo :: String -> CrawlAction -> IO ()+downloadStreamingTo destination (GetRequest url) =  do+    req <- parseUrl "https://www.example.com"+    withManager tlsManagerSettings $ \m ->+        withHTTP req m $ \resp ->+            runEffect $ responseBody resp >-> PB.stdout+downloadStreamingTo _ req = Prelude.putStrLn $ "POST Requests not supported: " ++ show req+-}+
+ src/Network/CrawlChain/Report.hs view
@@ -0,0 +1,9 @@+module Network.CrawlChain.Report (Report (..), showFullReport) where++data Report = Report { reportMsg :: String, reportDetails :: String }+instance Show Report where+  show = reportMsg++showFullReport :: Report -> String+showFullReport r = reportMsg r ++ "\n\n" ++ (reportDetails r)+
+ src/Network/CrawlChain/Storing.hs view
@@ -0,0 +1,25 @@+module Network.CrawlChain.Storing where++import System.Directory++buildCurlCmd :: Maybe String -> String -> String -> IO String+buildCurlCmd dir destination url = do+  targetPath <- buildAndCreateTargetDir False dir destination+  return $ curlLoadAction targetPath url+    where+      curlLoadAction targetPath url = "curl -s -o " ++ targetPath ++ " " ++ url ++ "\n"++buildAndCreateTargetDir :: Bool -> Maybe String -> String -> IO String+buildAndCreateTargetDir createDir dir dest = do+  maybe+   (return dest)+   (\dir' -> do+       if createDir+         then createDirectoryIfMissing True dir'+         else return ()+       return (dir' ++ "/" ++ dest)+       )+   dir++makeFilename :: String -> String -> String -> String+makeFilename series season episode = series ++ "-S" ++ season++ "E" ++ episode ++ ".mp4"
+ src/Network/URI/Util.hs view
@@ -0,0 +1,7 @@+module Network.URI.Util (toURI) where++import Data.Maybe (fromMaybe)+import Network.URI++toURI :: String -> URI+toURI url = fromMaybe (error $ "invalid URI '" ++ url ++ "'") (parseURI url)
+ src/Text/HTML/CrawlChain/HtmlFiltering.hs view
@@ -0,0 +1,198 @@+module Text.HTML.CrawlChain.HtmlFiltering (+  extractLinks, extractLinksMatching, extractLinksWithAttributes, extractLinksFilteringUrlAttrs, extractLinksFilteringAll,+  findAllUrlsEndingWith, findFirstLinkAfter,+  extractFirstForm,+  Method(..),+  noUrlFilter, AttrFilter, noAttrFilter, ContainedTextFilter, noTextFilter+  ) where++import Data.Char (toLower)+import Data.List (isSuffixOf, isPrefixOf, isInfixOf, nub, sort)+import Data.List.Split (splitOneOf)+import Data.Maybe (fromMaybe)+import Text.HTML.TagSoup++import Network.CrawlChain.CrawlAction++type TagS = Tag String+type AttrFilter = [(String, String)] -> Bool+type ContainedTextFilter = [String] -> Bool++noUrlFilter :: String -> Bool+noUrlFilter = unevaluated++noAttrFilter :: AttrFilter+noAttrFilter = unevaluated++noTextFilter :: ContainedTextFilter+noTextFilter = unevaluated++unevaluated :: a -> Bool+unevaluated _ = True++extractLinks :: String -> [CrawlAction]+extractLinks = extractLinksFilteringUrlAttrs unevaluated unevaluated++extractLinksMatching :: (String -> Bool) -> String -> [CrawlAction]+extractLinksMatching = flip extractLinksFilteringUrlAttrs unevaluated++extractLinksWithAttributes :: AttrFilter -> String -> [CrawlAction]+extractLinksWithAttributes = extractLinksFilteringUrlAttrs unevaluated++extractLinksFilteringUrlAttrs :: (String -> Bool) -> AttrFilter -> String -> [CrawlAction]+extractLinksFilteringUrlAttrs urlFilter attrFilter = extractLinksFilteringAll urlFilter attrFilter noTextFilter++extractLinksFilteringAll :: (String -> Bool) -> AttrFilter -> ContainedTextFilter -> String -> [CrawlAction]+extractLinksFilteringAll urlFilter attrFilter containsTextFilter = extractLinksFiltering combinedFilter+  where+    combinedFilter ts =+      (urlFilter $ getSrc linkTag)+      && (attrFilter $ getTagAttrs linkTag)+      && (containsTextFilter $ getTexts ts)+      where+        linkTag = if null ts then error "empty link tag group" else head ts+        getTexts :: [TagS] -> [String]+        getTexts = filter (not . null) . map (maybe "" id . maybeTagText)++extractLinksFiltering :: ([TagS] -> Bool) -> String -> [CrawlAction]+extractLinksFiltering linkFilter =+  map GetRequest .+  nub .+  filter (not . null) .+  map getSrc .+  map head . filter linkFilter . filter (not . null) .+  filterAndGroupLinks .+  canonicalizeTags .+  parseTags+  where+    filterAndGroupLinks :: [TagS] -> [[TagS]]+    filterAndGroupLinks = map cleanupLinkGroup . splitWhen' (isTagOpenName "a")+      where+        splitWhen' :: (a -> Bool) -> [a] -> [[a]]+        splitWhen' f = splitWhen'' []+          where+            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"))++findFirstLinkAfter :: String -> [(String, String)] -> String -> [CrawlAction]+findFirstLinkAfter tagName tagAttrs =+  take 1 .+  map GetRequest .+  map getSrc .+  filter isLink .+  dropWhile (not . isMarker) .+  canonicalizeTags .+  parseTags+  where+    isMarker (TagOpen tagName' as) = tagName' == tagName && sort tagAttrs == sort as+    isMarker _ = False+    isLink (TagOpen "a" as) = maybe False (not . null) $ lookup "href" as+    isLink _ = False++getSrc :: Tag String -> String+getSrc (TagOpen _ as) = fromMaybe "" (lookup "href" as)+getSrc _ = []++getTagAttrs :: Tag String -> [(String, String)]+getTagAttrs (TagOpen _ as) = as+getTagAttrs _ = []++findAllUrlsEndingWith :: String -> String -> [CrawlAction]+findAllUrlsEndingWith endMarker =+  map GetRequest . filter (endMarker `isSuffixOf`) . filter ("http" `isPrefixOf`) . splitOneOfRetainingNonEmpty " \t\r\n\"\'"++data Method = POST | GET++extractFirstForm :: [String] -> String -> Maybe Method -> String -> String -> Maybe CrawlAction+extractFirstForm extraParams previousUrl method formName content = (buildAction . extractForm method formName [] . parseTags) content+  where+    initialParams = findExtraParams extraParams content+    buildAction :: Maybe [Tag String] -> Maybe CrawlAction+    buildAction = maybe Nothing buildAction'+      where+        buildAction' :: [Tag String] -> Maybe CrawlAction+        buildAction' tags+          | null tags = Nothing+          | not (isFormStart (head tags)) = error $ show tags+          | otherwise = maybe Nothing (buildAction'' (tail tags) initialParams) determineUrl+            where+              determineUrl :: Maybe String+              determineUrl = lookup "action" (tagAttributes (head tags)) >>= (\u -> return (if null u then previousUrl else u))+              buildAction'' :: [Tag String] -> [(String, String)] -> String -> Maybe CrawlAction+              buildAction'' [] params url = Just $ PostRequest url (reverse params) PostForm+              buildAction'' (t:tags') params url = buildAction'' tags' addToParams url+                where+                  addToParams :: [(String, String)]+                  addToParams = maybe params (:params) (extractFormParam t)++isFormStart :: Tag String -> Bool+isFormStart (TagOpen tagName _) = isFormTag tagName+isFormStart _ = False++isFormClose :: Tag String -> Bool+isFormClose (TagClose tagName) = isFormTag tagName+isFormClose _ = False++isFormTag :: String -> Bool+isFormTag = (=="form") . map toLower++isFormStartOf :: Maybe Method -> String -> Tag String -> Bool+isFormStartOf method formName t = isFormStart t+                                  && (null formName || formNameMatches)+                                  && maybe True methodMatches method+  where+    formNameMatches = maybe False (==formName) (getAttributeValue "name")+    methodMatches m = maybe False (methodMatches' m) (getAttributeValue "method")+      where+        methodMatches' POST = (=="POST")+        methodMatches' GET = (=="GET")+    getAttributeValue :: String -> Maybe String+    getAttributeValue = flip lookup (tagAttributes t)++tagAttributes :: Tag String -> [(String, String)]+tagAttributes (TagOpen _ as) = as+tagAttributes _ = []++extractForm :: Maybe Method -> String -> [Tag String] -> [Tag String] -> Maybe [Tag String]+extractForm  _ _ _ [] = Nothing                         -- no complete form+extractForm m n [] (t:tags)+  | isFormStartOf m n t = extractForm m n [t] tags      -- start form element collecting+  | otherwise = extractForm m n [] tags                 -- ... or skip until it starts+extractForm m n collected (t:tags)+  | isFormClose t = Just (reverse collected)            -- first form close, return form (nested forms unsupported)+  | otherwise = extractForm m n (t:collected) tags      -- continue collecting form elements++extractFormParam :: Tag String -> Maybe (String, String)+extractFormParam (TagOpen "input" as) = maybe Nothing (Just . findValueFor) (lookup "name" as)+  where+    findValueFor :: String -> (String, String)+    findValueFor key = (key, fromMaybe [] (lookup "value" as))+extractFormParam _ = Nothing++findExtraParams :: [String] -> String -> [(String, String)]+findExtraParams keys = if null keys then \_ -> [] else findKeyValues+  where+    findKeyValues :: String -> [(String, String)]+    findKeyValues = extractValues . filter containsKey . lines+      where+        containsKey :: String -> Bool+        containsKey line = any (`isInfixOf` line) keys+        extractValues :: [String] -> [(String, String)]+        extractValues = foldr addIfIsValue []+        addIfIsValue :: String -> [(String, String)] -> [(String, String)]+        addIfIsValue line = (values ++)+          where+            splittedLine = splitOneOfRetainingNonEmpty " ,':" line+            values = foldr extractKey [] keys+            extractKey :: String -> [(String, String)] -> [(String, String)]+            extractKey k = (++ (findValue splittedLine))+              where+                findValue :: [String] -> [(String, String)]+                findValue (n':k':v':v'':rest) = if n'=="name" && k'==k && v'=="value" && not (null v'')+                                                then [(k, v'')] else findValue (k':v':v'':rest)+                findValue _ = []++splitOneOfRetainingNonEmpty :: [Char] -> String -> [String]+splitOneOfRetainingNonEmpty splitters = filter (not . null) . splitOneOf splitters