diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/crawlchain.cabal b/crawlchain.cabal new file mode 100644 --- /dev/null +++ b/crawlchain.cabal @@ -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 diff --git a/src/Network/CrawlChain/BasicTemplates.hs b/src/Network/CrawlChain/BasicTemplates.hs new file mode 100644 --- /dev/null +++ b/src/Network/CrawlChain/BasicTemplates.hs @@ -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) diff --git a/src/Network/CrawlChain/Constants.hs b/src/Network/CrawlChain/Constants.hs new file mode 100644 --- /dev/null +++ b/src/Network/CrawlChain/Constants.hs @@ -0,0 +1,4 @@ +module Network.CrawlChain.Constants where + +testResourcePath :: String +testResourcePath = "test/resources/" diff --git a/src/Network/CrawlChain/CrawlAction.hs b/src/Network/CrawlChain/CrawlAction.hs new file mode 100644 --- /dev/null +++ b/src/Network/CrawlChain/CrawlAction.hs @@ -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 diff --git a/src/Network/CrawlChain/CrawlChain.hs b/src/Network/CrawlChain/CrawlChain.hs new file mode 100644 --- /dev/null +++ b/src/Network/CrawlChain/CrawlChain.hs @@ -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 diff --git a/src/Network/CrawlChain/CrawlChains.hs b/src/Network/CrawlChain/CrawlChains.hs new file mode 100644 --- /dev/null +++ b/src/Network/CrawlChain/CrawlChains.hs @@ -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 diff --git a/src/Network/CrawlChain/CrawlDirective.hs b/src/Network/CrawlChain/CrawlDirective.hs new file mode 100644 --- /dev/null +++ b/src/Network/CrawlChain/CrawlDirective.hs @@ -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 diff --git a/src/Network/CrawlChain/CrawlResult.hs b/src/Network/CrawlChain/CrawlResult.hs new file mode 100644 --- /dev/null +++ b/src/Network/CrawlChain/CrawlResult.hs @@ -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) diff --git a/src/Network/CrawlChain/Crawling.hs b/src/Network/CrawlChain/Crawling.hs new file mode 100644 --- /dev/null +++ b/src/Network/CrawlChain/Crawling.hs @@ -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) + diff --git a/src/Network/CrawlChain/CrawlingContext.hs b/src/Network/CrawlChain/CrawlingContext.hs new file mode 100644 --- /dev/null +++ b/src/Network/CrawlChain/CrawlingContext.hs @@ -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 diff --git a/src/Network/CrawlChain/CrawlingParameters.hs b/src/Network/CrawlChain/CrawlingParameters.hs new file mode 100644 --- /dev/null +++ b/src/Network/CrawlChain/CrawlingParameters.hs @@ -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 + } diff --git a/src/Network/CrawlChain/DirectiveChainResult.hs b/src/Network/CrawlChain/DirectiveChainResult.hs new file mode 100644 --- /dev/null +++ b/src/Network/CrawlChain/DirectiveChainResult.hs @@ -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 " Maybe CrawlAction +extractFirstResult [] = Nothing +extractFirstResult (r:rs) = let res = lastResult r + in if null res then extractFirstResult rs else Just (head res) diff --git a/src/Network/CrawlChain/Downloading.hs b/src/Network/CrawlChain/Downloading.hs new file mode 100644 --- /dev/null +++ b/src/Network/CrawlChain/Downloading.hs @@ -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 +-} + diff --git a/src/Network/CrawlChain/Report.hs b/src/Network/CrawlChain/Report.hs new file mode 100644 --- /dev/null +++ b/src/Network/CrawlChain/Report.hs @@ -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) + diff --git a/src/Network/CrawlChain/Storing.hs b/src/Network/CrawlChain/Storing.hs new file mode 100644 --- /dev/null +++ b/src/Network/CrawlChain/Storing.hs @@ -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" diff --git a/src/Network/URI/Util.hs b/src/Network/URI/Util.hs new file mode 100644 --- /dev/null +++ b/src/Network/URI/Util.hs @@ -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) diff --git a/src/Text/HTML/CrawlChain/HtmlFiltering.hs b/src/Text/HTML/CrawlChain/HtmlFiltering.hs new file mode 100644 --- /dev/null +++ b/src/Text/HTML/CrawlChain/HtmlFiltering.hs @@ -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