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.2.0.0 +version: 0.3.0.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 @@ -16,7 +16,7 @@ library hs-source-dirs: src - exposed-modules: Network.CrawlChain.CrawlChain + exposed-modules: Network.CrawlChain , Network.CrawlChain.CrawlingParameters , Network.CrawlChain.BasicTemplates , Network.CrawlChain.CrawlAction @@ -64,8 +64,8 @@ Test-Suite crawling-tests type: exitcode-stdio-1.0 main-is: CrawlingTests.hs - other-modules: Network.CrawlChain.CrawlAction - , Network.CrawlChain.CrawlChain + other-modules: Network.CrawlChain + , Network.CrawlChain.CrawlAction , Network.CrawlChain.CrawlChains , Network.CrawlChain.CrawlDirective , Network.CrawlChain.CrawlResult diff --git a/src/Network/CrawlChain.hs b/src/Network/CrawlChain.hs new file mode 100644 --- /dev/null +++ b/src/Network/CrawlChain.hs @@ -0,0 +1,63 @@ +module Network.CrawlChain ( + crawlChain, crawlChains, -- primary interface + executeActions, crawlForUrl, -- legacy, deprecated + executeCrawlChain -- visible for tests + ) where + +import Data.List (intersperse) + +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 + +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 + +{-| + Returns only the first result of a completely matching branch of the crawling directive. +-} +crawlChain :: CrawlingParameters -> IO (Maybe CrawlAction) +crawlChain args = do + results <- crawlChains args + logAndReturnFirstOk results + +{-| + Returns all possible results of the craling directive - meant to be used with lazyness in mind as needed. +-} +crawlChains :: CrawlingParameters -> IO [DirectiveChainResult] +crawlChains args = + executeCrawlChain context (paramInitialAction args) (paramCrawlDirective args) + where + context = if paramDoStore args then storingContext (paramName args) 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 + putDetailsOnFailure firstOk results + return firstOk + +putDetailsOnFailure :: Maybe CrawlAction -> [DirectiveChainResult] -> IO () +putDetailsOnFailure firstSuccess results = + case firstSuccess of + Just a -> putStr " Using result: " >> print a + Nothing -> do + putStrLn $ " No results found - details: " ++ showAllFailures where + showAllFailures = concat $ intersperse "\n\n" $ map showResultPath results diff --git a/src/Network/CrawlChain/CrawlChain.hs b/src/Network/CrawlChain/CrawlChain.hs deleted file mode 100644 --- a/src/Network/CrawlChain/CrawlChain.hs +++ /dev/null @@ -1,63 +0,0 @@ -module Network.CrawlChain.CrawlChain ( - crawlChain, crawlChains, -- primary interface - executeActions, crawlForUrl, -- legacy, deprecated - executeCrawlChain -- visible for tests - ) where - -import Data.List (intersperse) - -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 - -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 - -{-| - Returns only the first result of a completely matching branch of the crawling directive. --} -crawlChain :: CrawlingParameters -> IO (Maybe CrawlAction) -crawlChain args = do - results <- crawlChains args - logAndReturnFirstOk results - -{-| - Returns all possible results of the craling directive - meant to be used with lazyness in mind as needed. --} -crawlChains :: CrawlingParameters -> IO [DirectiveChainResult] -crawlChains args = - executeCrawlChain context (paramInitialAction args) (paramCrawlDirective args) - where - context = if paramDoStore args then storingContext (paramName args) 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 - putDetailsOnFailure firstOk results - return firstOk - -putDetailsOnFailure :: Maybe CrawlAction -> [DirectiveChainResult] -> IO () -putDetailsOnFailure firstSuccess results = - case firstSuccess of - Just a -> putStr " Using result: " >> print a - Nothing -> do - putStrLn $ " No results found - details: " ++ showAllFailures where - showAllFailures = concat $ intersperse "\n\n" $ map showResultPath results diff --git a/src/Text/HTML/CrawlChain/HtmlFiltering.hs b/src/Text/HTML/CrawlChain/HtmlFiltering.hs --- a/src/Text/HTML/CrawlChain/HtmlFiltering.hs +++ b/src/Text/HTML/CrawlChain/HtmlFiltering.hs @@ -1,4 +1,5 @@ module Text.HTML.CrawlChain.HtmlFiltering ( + extractTagsContent, findAttributes, extractLinks, extractLinksMatching, extractLinksWithAttributes, extractLinksFilteringUrlAttrs, extractLinksFilteringAll, unevaluated, findAllUrlsEndingWith, findFirstLinkAfter, extractFirstForm, @@ -17,6 +18,33 @@ type TagS = Tag String type AttrFilter = [(String, String)] -> Bool type ContainedTextFilter = [String] -> Bool + +{-| (name, content, attributes)-} +type TagContent = (String, String, [(String, String)]) + +{-| + Content of the tags up to the first child tag (as simplification) - with attributes. +-} +extractTagsContent :: String -> [TagContent] +extractTagsContent = + extractContentFromTagStream ("", "", []) . + canonicalizeTags . + parseTags + where + extractContentFromTagStream :: TagContent -> [TagS] -> [(String, String, [(String, String)])] + extractContentFromTagStream tagContent@(name, _, _) [] + | null name = [] + | otherwise = [tagContent] + extractContentFromTagStream tagContent@(name,content,attributes) (t:ts) = handle t where + handle (TagText c) = extractContentFromTagStream (name, content ++ c, attributes) ts + handle (TagOpen n as) = (if null name then [] else [tagContent]) ++ extractContentFromTagStream (n, "", as) ts + handle _ = extractContentFromTagStream tagContent ts + +findAttributes :: String -> [TagContent] -> [String] +findAttributes name = foldr ((++) . findAttr') [] + where + findAttr' :: TagContent -> [String] + findAttr' (_, _, as) = map snd $ filter (\(n,_) -> n==name) as noUrlFilter :: String -> Bool noUrlFilter = unevaluated diff --git a/test/src/CrawlingTests.hs b/test/src/CrawlingTests.hs --- a/test/src/CrawlingTests.hs +++ b/test/src/CrawlingTests.hs @@ -3,9 +3,9 @@ import Data.Maybe (listToMaybe) import System.Exit (exitFailure) +import Network.CrawlChain import Network.CrawlChain.CrawlingContext import Network.CrawlChain.CrawlAction -import Network.CrawlChain.CrawlChain import Network.CrawlChain.CrawlDirective import Network.CrawlChain.DirectiveChainResult import Text.HTML.CrawlChain.HtmlFiltering diff --git a/test/src/HtmlFilteringTests.hs b/test/src/HtmlFilteringTests.hs --- a/test/src/HtmlFilteringTests.hs +++ b/test/src/HtmlFilteringTests.hs @@ -7,19 +7,26 @@ main :: IO () main = do - match extractLinks "text" ["link"] - match extractLinks "" ["link"] - match extractLinks "sdfsdf" ["link", "link2"] - match (extractLinksFilteringAll unevaluated unevaluated unevaluated) "textbla" ["link"] - match (extractLinksFilteringAll unevaluated unevaluated (any (=="bla"))) "textbla" ["link"] - match (extractLinksFilteringAll unevaluated unevaluated (not . any (=="bla"))) "textbla" [] - match extractLinks "" ["link"] - match extractLinks "" ["link"] + matchR extractLinks "