crawlchain 0.3.0.1 → 0.3.1.0
raw patch · 5 files changed
+170/−50 lines, 5 filesdep +HsOpenSSLdep ~base
Dependencies added: HsOpenSSL
Dependency ranges changed: base
Files
- crawlchain.cabal +26/−4
- src/Network/CrawlChain/Crawling.hs +2/−44
- src/Network/Http/ClientFacade.hs +115/−0
- test/src/HtmlFilteringTests.hs +0/−2
- test/src/HttpTests.hs +27/−0
crawlchain.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: crawlchain-version: 0.3.0.1+version: 0.3.1.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@@ -34,10 +34,11 @@ , Network.CrawlChain.Downloading , Network.CrawlChain.Report , Network.CrawlChain.Util+ , Network.Http.ClientFacade build-depends: base < 4.10 , bytestring , directory- , http-streams+ , http-streams, HsOpenSSL , network-uri , split , tagsoup@@ -47,6 +48,27 @@ ghc-options: -Wall +Test-Suite http-tests+ type: exitcode-stdio-1.0+ main-is: HttpTests.hs+ other-modules: Network.CrawlChain.CrawlAction+ , Network.CrawlChain.CrawlResult+ , Network.CrawlChain.Crawling+ , Network.CrawlChain.Util+ , Network.URI.Util+ , Network.Http.ClientFacade+ hs-source-dirs: src, test/src+ build-depends: base+ , crawlchain+ , bytestring+ , http-streams, HsOpenSSL+ , network-uri+ , split+ , text+ , time+ default-language: Haskell2010+ ghc-options: -Wall+ Test-Suite html-tests type: exitcode-stdio-1.0 main-is: HtmlFilteringTests.hs@@ -56,7 +78,6 @@ hs-source-dirs: src, test/src build-depends: base , crawlchain- , network-uri , split , tagsoup default-language: Haskell2010@@ -80,13 +101,14 @@ , Network.CrawlChain.Storing , Network.CrawlChain.Util , Network.URI.Util+ , Network.Http.ClientFacade , Text.HTML.CrawlChain.HtmlFiltering hs-source-dirs: src, test/src build-depends: base , crawlchain , bytestring , directory- , http-streams+ , http-streams, HsOpenSSL , network-uri , text , time
src/Network/CrawlChain/Crawling.hs view
@@ -1,21 +1,16 @@-{-# LANGUAGE OverloadedStrings #-} module Network.CrawlChain.Crawling ( crawl, crawlAndStore, CrawlActionDescriber, Crawler ) where --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, escapeURIString, isUnescapedInURI) import Network.CrawlChain.CrawlAction import Network.CrawlChain.CrawlResult import Network.CrawlChain.Util+import Network.Http.ClientFacade type Crawler = CrawlAction -> IO CrawlResult type CrawlActionDescriber = CrawlAction -> String@@ -56,7 +51,7 @@ return $ CrawlResult action (BC.unpack response) CrawlingOk where doRequest :: CrawlAction -> IO (BC.ByteString)- doRequest (GetRequest url) = C.get (BC.pack url) C.concatHandler -- TODO check exceptions with concatHandler'+ doRequest (GetRequest url) = getRequest (BC.pack url) 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@@ -65,40 +60,3 @@ 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' = -- TODO use Network.URI.Util to have only one piece of code doing this- case parseURI r of- Just u' -> u'- Nothing -> error ("Can't parse URI - FIXME Crawling?: " ++ r)- where r = escapeURIString isUnescapedInURI $ 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
+ src/Network/Http/ClientFacade.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE OverloadedStrings #-}+{-|+ Working with http-streams - this code exists because:+ - there is no simple usage for AJAX+ - its internal parseUrl does not escape and fails if that would have been necessary, a deadly combination for this usage.++ Hoping at least the latter will be fixed upstream.+-}+module Network.Http.ClientFacade (getRequest, ajaxRequest) where++import Control.Exception (bracket)+import qualified Data.ByteString.Char8 as BC+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Word (Word16)+import qualified Network.Http.Client as C+import qualified Network.URI as U+import OpenSSL.Session (SSLContext)+import qualified System.IO.Unsafe as Unsafe (unsafePerformIO)++import Network.URI.Util++-- reworked from http-streams due to inappropriate escaping/error handling+getRequest :: BC.ByteString -> IO BC.ByteString+getRequest = doRequest C.concatHandler -- TODO check exceptions with concatHandler+ where+ doRequest handler url = do+ bracket+ (openConnection url)+ (C.closeConnection)+ (process)+ where+ u = parseURL url+ q = C.buildRequest1 $ do+ C.http C.GET (path u)+ C.setAccept "*/*" where+ path :: U.URI -> BC.ByteString+ path u' =+ case url' of+ "" -> "/"+ _ -> url'+ where+ url' = T.encodeUtf8 $! T.pack $! concat [U.uriPath u', U.uriQuery u', U.uriFragment u']+ process c = do+ C.sendRequest c q C.emptyBody+ C.receiveResponse c handler -- wrapRedirect is not exposed: (C.wrapRedirect u 0 handler)++parseURL :: BC.ByteString -> U.URI+parseURL = toURI . T.unpack . T.decodeUtf8++openConnection :: C.URL -> IO C.Connection+--openConnection = C.establishConnection+openConnection = establish . parseURL+ where -- copy/paste from http-streams+ establish u =+ case scheme of+ "http:" -> do+ C.openConnection host port+ "https:" -> do+ ctx <- readIORef global+ C.openConnectionSSL ctx host ports+-- "unix:" -> do+-- openConnectionUnix $ U.uriPath u+ _ -> error ("Unknown URI scheme " ++ scheme)+ where+ scheme = U.uriScheme u++ auth = case U.uriAuthority u of+ Just x -> x+ Nothing -> U.URIAuth "" "localhost" ""++ host = BC.pack (U.uriRegName auth)+ port = case U.uriPort auth of+ "" -> 80+ _ -> read $ tail $ U.uriPort auth :: Word16+ ports = case U.uriPort auth of+ "" -> 443+ _ -> read $ tail $ U.uriPort auth :: Word16++ global :: IORef SSLContext+ global = Unsafe.unsafePerformIO $ do+ ctx <- C.baselineContextSSL+ newIORef ctx++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+ (openConnection url)+ (C.closeConnection)+ (process)+ where+ u = parseURL url+ 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 :: U.URI -> BC.ByteString+ path u' =+ case url' of+ "" -> "/"+ _ -> url'+ where+ url' = T.encodeUtf8 $! T.pack $! concat [U.uriPath u', U.uriQuery u', U.uriFragment u']+ process c = do+ _ <- C.sendRequest c q (C.encodedFormBody formParams)+ x <- C.receiveResponse c handler+ return x
test/src/HtmlFilteringTests.hs view
@@ -3,7 +3,6 @@ import System.Exit (exitFailure) import Network.CrawlChain.CrawlAction-import Network.URI.Util import Text.HTML.CrawlChain.HtmlFiltering main :: IO ()@@ -22,7 +21,6 @@ match extractTagsContent "<div>sdf</div>" [("div", "sdf", [])] match extractTagsContent "<div attr=\"1\">sdf</div>" [("div", "sdf", [("attr", "1")])] match extractTagsContent "<script attr=\"some_url\">content</script><div>bla</div>" [("script", "content", [("attr","some_url")]),("div", "bla", [])]- match toURI "http://sdf.sdf/α" (toURI "http://sdf.sdf/α") where match method input expected = if actual /= expected
+ test/src/HttpTests.hs view
@@ -0,0 +1,27 @@+module Main (main) where++import System.Exit (exitFailure)++import Network.CrawlChain.CrawlAction+import Network.CrawlChain.CrawlResult+import Network.CrawlChain.Crawling+import Network.URI.Util++main :: IO ()+main = do+ match toURI "http://sdf.sdf/α" (toURI "http://sdf.sdf/α")+ crawlResult <- crawl $ GetRequest "http://example.com/\206\177"+ -- do not care about result, testing for no exceptions with url parsing (yes, doing an external request here is bad style)+ dummyCheck crawlResult+ where+ match method input expected =+ if actual /= expected+ then putStrLn ("could not find " ++ (show expected) ++ " in; " ++ input) >> exitFailure+ else pure ()+ where+ actual = method input+ dummyCheck r =+ if crawlingResultStatus r /= (CrawlingRedirect "sdf")+ then pure ()+ else putStrLn "unexpected" >> exitFailure +