diff --git a/crawlchain.cabal b/crawlchain.cabal --- a/crawlchain.cabal +++ b/crawlchain.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: crawlchain -version: 0.1.0.9 +version: 0.1.1.4 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 @@ -34,6 +34,7 @@ , Network.CrawlChain.Crawling , Network.CrawlChain.Downloading , Network.CrawlChain.Report + , Network.CrawlChain.Util build-depends: base < 4.9 , bytestring , directory diff --git a/src/Network/CrawlChain/BasicTemplates.hs b/src/Network/CrawlChain/BasicTemplates.hs --- a/src/Network/CrawlChain/BasicTemplates.hs +++ b/src/Network/CrawlChain/BasicTemplates.hs @@ -17,6 +17,7 @@ searchWebTemplate :: String -> String -> (CrawlAction, CrawlDirective) searchWebTemplate site searchTerm = searchWebTemplateAndProcessHits site searchTerm [] Nothing (id . snd) + searchWebTemplateAndProcessHits :: String -> String -> [String] -> Maybe ContainedTextFilter -> ((CrawlAction, [CrawlAction]) -> [CrawlAction]) diff --git a/src/Network/CrawlChain/CrawlChains.hs b/src/Network/CrawlChain/CrawlChains.hs --- a/src/Network/CrawlChain/CrawlChains.hs +++ b/src/Network/CrawlChain/CrawlChains.hs @@ -16,7 +16,7 @@ import Network.CrawlChain.CrawlDirective import Network.CrawlChain.DirectiveChainResult import Network.CrawlChain.Report - +import Network.CrawlChain.Util executeCrawlChain :: CrawlingContext a => a -> CrawlAction -> CrawlDirective -> IO [DirectiveChainResult] executeCrawlChain = followDirective [] [] @@ -51,6 +51,14 @@ followDirective' (SimpleDirective logic) = crawlAndSearch (logic . crawlingContent) followDirective' (RelativeDirective logic) = crawlAndSearch (makeAbsoluteLogicMapper logic) followDirective' (FollowUpDirective logic) = crawlAndSearch logic + followDirective' (DelayDirective sec d) = delaySeconds sec >> followDirective' d + followDirective' (RetryDirective num d) = do + results <- followDirective' d + if num > 0 && all (null . lastResult) results + then do + putStrLn $ "retrying "++(show num)++" more times" + followDirective' $ RetryDirective (num-1) d + else return results followDirective' (AlternativeDirective a1 a2) = do a1Results <- followDirective' a1 if all (null . lastResult) a1Results -- only use alternative if no results at all @@ -62,11 +70,13 @@ crawlAndSearch :: (CrawlResult -> [CrawlAction]) -> IO [DirectiveChainResult] crawlAndSearch searchLogic = crawler context crawlAction >>= processCrawlingResult where - processCrawlingResult crawlingResult = return searchCrawlingResult >>= logSearchResults >>= return . wrapActions >>= appendResult - 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 + 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) [] diff --git a/src/Network/CrawlChain/CrawlDirective.hs b/src/Network/CrawlChain/CrawlDirective.hs --- a/src/Network/CrawlChain/CrawlDirective.hs +++ b/src/Network/CrawlChain/CrawlDirective.hs @@ -4,9 +4,11 @@ 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 + 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 + | DelayDirective Int CrawlDirective -- | wait additional seconds before executing + | RetryDirective Int CrawlDirective -- | if given directive yields no results use add. retries + | AlternativeDirective CrawlDirective CrawlDirective -- | fallback to second argument if first yields no results + | RestartChainDirective (CrawlAction, CrawlDirective)-- | the possibility to start a new chain (when using alternative) + | DirectiveSequence [CrawlDirective] -- | chaining of directives diff --git a/src/Network/CrawlChain/Crawling.hs b/src/Network/CrawlChain/Crawling.hs --- a/src/Network/CrawlChain/Crawling.hs +++ b/src/Network/CrawlChain/Crawling.hs @@ -4,17 +4,13 @@ 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.CrawlChain.Util import Network.URI.Util type RequestType = Request_String @@ -22,7 +18,7 @@ type CrawlActionDescriber = CrawlAction -> String crawl :: Crawler -crawl action = log "delaying crawl for 1s" >> threadDelay 1000000 >> crawl' action 3 (toRequest action) +crawl action = delaySeconds 1 >> crawl' action 3 (toRequest action) crawlAndStore :: CrawlActionDescriber -> Crawler crawlAndStore describer = (>>= store) . crawl @@ -41,13 +37,6 @@ 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) = @@ -77,7 +66,7 @@ response <- simpleHTTP request body <- getResponseBody response code <- getResponseCode response - log $ "Crawled " ++ (showRequest request) ++ " with result: " ++ (show code) + logMsg $ "Crawled " ++ (showRequest request) ++ " with result: " ++ (show code) checkRedirect maxRedirects request (crawlResult response body code) where crawlResult :: (HasHeaders a) => Result a -> String -> ResponseCode -> CrawlResult diff --git a/src/Network/CrawlChain/Util.hs b/src/Network/CrawlChain/Util.hs new file mode 100644 --- /dev/null +++ b/src/Network/CrawlChain/Util.hs @@ -0,0 +1,20 @@ +module Network.CrawlChain.Util where + +import Prelude hiding (log) + +import Control.Concurrent (threadDelay) +import Data.Time.Format (formatTime, defaultTimeLocale) +import Data.Time.LocalTime (getZonedTime) + +logMsg :: String -> IO () +logMsg msg = printTime >> putStr ("> " ++ msg ++ "\n") + where + printTime = getZonedTime >>= return . formatTime' >>= putStr + where + formatTime' = formatTime defaultTimeLocale "%Y-%m-%d_%H:%M:%S" + + +delaySeconds :: Int -> IO () +delaySeconds s = do + logMsg $ "delaying for "++(show s)++"s" + threadDelay $ s*1000000