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