diff --git a/Network/HTTP/Conduit/Browser.hs b/Network/HTTP/Conduit/Browser.hs --- a/Network/HTTP/Conduit/Browser.hs +++ b/Network/HTTP/Conduit/Browser.hs @@ -1,4 +1,61 @@ {-# LANGUAGE CPP #-} +-- | This module is designed to work similarly to the Network.Browser module in the HTTP package. +-- The idea is that there are two new types defined: 'BrowserState' and 'BrowserAction'. The +-- purpose of this module is to make it easy to describe a browsing session, including navigating +-- to multiple pages, and have things like cookie jar updates work as expected as you browse +-- around. +-- +-- BrowserAction is a monad that handles all your browser-related activities. This monad is +-- actually implemented as a specialization of the State monad, over the BrowserState type. The +-- BrowserState type has various bits of information that a web browser keeps, such as a current +-- cookie jar, the number of times to retry a request on failure, HTTP proxy information, etc. In +-- the BrowserAction monad, there is one BrowserState at any given time, and you can modify it by +-- using the convenience functions in this module. +-- +-- A special kind of modification of the current browser state is the action of making a HTTP +-- request. This will do the request according to the params in the current BrowserState, as well +-- as modifying the current state with, for example, an updated cookie jar. +-- +-- To use this module, you would bind together a series of BrowserActions (This simulates the user +-- clicking on links or using a settings dialogue etc.) to describe your browsing session. When +-- you've described your session, you call 'browse' on your top-level BrowserAction to actually +-- convert your actions into the ResourceT IO monad. +-- +-- Here is an example program: +-- +-- > import qualified Data.ByteString as B +-- > import qualified Data.ByteString.Lazy as LB +-- > import qualified Data.ByteString.UTF8 as UB +-- > import Data.Conduit +-- > import Network.HTTP.Conduit +-- > import Network.HTTP.Conduit.Browser +-- > +-- > -- The web request to log in to a service +-- > req1 :: IO (Request (ResourceT IO)) +-- > req1 = do +-- > req <- parseUrl "http://www.myurl.com/login.php" +-- > return $ urlEncodedBody [ (UB.fromString "name", UB.fromString "litherum") +-- > , (UB.fromString "pass", UB.fromString "S33kRe7") +-- > ] req +-- > +-- > -- Once authenticated, run this request +-- > req2 :: IO (Request m') +-- > req2 = parseUrl "http://www.myurl.com/main.php" +-- > +-- > -- Bind two BrowserActions together +-- > action :: Request (ResourceT IO) -> Request (ResourceT IO) -> BrowserAction (Response LB.ByteString) +-- > action r1 r2 = do +-- > _ <- makeRequestLbs r1 +-- > makeRequestLbs r2 +-- > +-- > main :: IO () +-- > main = do +-- > man <- newManager def +-- > r1 <- req1 +-- > r2 <- req2 +-- > out <- runResourceT $ browse man $ action r1 r2 +-- > putStrLn $ UB.toString $ B.concat $ LB.toChunks $ responseBody out + module Network.HTTP.Conduit.Browser ( BrowserState , BrowserAction diff --git a/Network/HTTP/Conduit/Manager.hs b/Network/HTTP/Conduit/Manager.hs --- a/Network/HTTP/Conduit/Manager.hs +++ b/Network/HTTP/Conduit/Manager.hs @@ -37,8 +37,9 @@ import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Exception (mask_, SomeException, catch) import Control.Monad.Trans.Resource - ( ResourceT, runResourceT, MonadResource (..) + ( ResourceT, runResourceT, MonadResource , MonadThrow, MonadUnsafeIO + , allocate, resourceMask, register, release ) import Control.Concurrent (forkIO, threadDelay) import Data.Time (UTCTime (..), Day (..), DiffTime, getCurrentTime, addUTCTime) diff --git a/http-conduit.cabal b/http-conduit.cabal --- a/http-conduit.cabal +++ b/http-conduit.cabal @@ -1,5 +1,5 @@ name: http-conduit -version: 1.6.0.1 +version: 1.6.0.2 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -19,16 +19,16 @@ library build-depends: base >= 4 && < 5 - , bytestring >= 0.9.1.4 && < 0.11 - , transformers >= 0.2 && < 0.4 + , bytestring >= 0.9.1.4 + , transformers >= 0.2 , failure >= 0.1 - , resourcet >= 0.3 && < 0.4 + , resourcet >= 0.3 && < 0.5 , conduit >= 0.5 && < 0.6 , zlib-conduit >= 0.5 && < 0.6 , blaze-builder-conduit >= 0.5 && < 0.6 , attoparsec-conduit >= 0.5 && < 0.6 , attoparsec >= 0.8.0.2 && < 0.11 - , utf8-string >= 0.3.4 && < 0.4 + , utf8-string >= 0.3.4 , blaze-builder >= 0.2.1 && < 0.4 , http-types >= 0.6 && < 0.8 , cprng-aes >= 0.2 && < 0.3 diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -9,6 +9,8 @@ import qualified Network.Wai import Network.Wai.Handler.Warp (run) import Network.HTTP.Conduit +import Network.HTTP.Conduit.Browser +import Data.ByteString.Base64 (encode) import Control.Concurrent (forkIO, killThread, threadDelay) import Network.HTTP.Types import Control.Exception.Lifted (try, SomeException) @@ -27,14 +29,40 @@ import qualified Data.ByteString.Lazy as L import Blaze.ByteString.Builder (fromByteString) +strictToLazy :: S.ByteString -> L.ByteString +strictToLazy = L.fromChunks . replicate 1 + +lazyToStrict :: L.ByteString -> S.ByteString +lazyToStrict = S.concat . L.toChunks + +dummy :: S.ByteString +dummy = "dummy" + +user :: S.ByteString +user = "user" + +pass :: S.ByteString +pass = "pass" + app :: Application app req = case pathInfo req of [] -> return $ responseLBS status200 [] "homepage" ["cookies"] -> return $ responseLBS status200 [tastyCookie] "cookies" + ["print-cookies"] -> return $ responseLBS status200 [] $ getHeader "Cookie" + ["useragent"] -> return $ responseLBS status200 [] $ getHeader "User-Agent" + ["authorities"] -> return $ responseLBS status200 [] $ getHeader "Authorization" + ["redir1"] -> return $ responseLBS temporaryRedirect307 [redir2] L.empty + ["redir2"] -> return $ responseLBS temporaryRedirect307 [redir3] L.empty + ["redir3"] -> return $ responseLBS status200 [] $ strictToLazy dummy _ -> return $ responseLBS status404 [] "not found" where tastyCookie = (mk (fromString "Set-Cookie"), fromString "flavor=chocolate-chip;") + getHeader s = strictToLazy $ case lookup s $ Network.Wai.requestHeaders req of + Just a -> a + Nothing -> S.empty + redir2 = (mk (fromString "Location"), fromString "/redir2") + redir3 = (mk (fromString "Location"), fromString "/redir3") main :: IO () main = hspecX $ do @@ -52,6 +80,94 @@ case elbs of Left (_ :: SomeException) -> return () Right _ -> error "Expected an exception" + describe "browser" $ do + it "cookie jar works" $ do + tid <- forkIO $ run 3011 app + request1 <- parseUrl "http://127.0.0.1:3011/cookies" + request2 <- parseUrl "http://127.0.0.1:3011/print-cookies" + elbs <- withManager $ \manager -> do + browse manager $ do + _ <- makeRequestLbs request1 + makeRequestLbs request2 + killThread tid + if (lazyToStrict $ responseBody elbs) /= fromString "flavor=chocolate-chip" + then error "Should have gotten the cookie back!" + else return () + it "cookie filter can deny cookies" $ do + tid <- forkIO $ run 3011 app + request1 <- parseUrl "http://127.0.0.1:3011/cookies" + request2 <- parseUrl "http://127.0.0.1:3011/print-cookies" + elbs <- withManager $ \manager -> do + browse manager $ do + setCookieFilter $ const $ const $ return False + _ <- makeRequestLbs request1 + makeRequestLbs request2 + killThread tid + if (lazyToStrict $ responseBody elbs) /= S.empty + then error "Shouldn't have gotten the cookie back!" + else return () + it "can save and load cookie jar" $ do + tid <- forkIO $ run 3011 app + request1 <- parseUrl "http://127.0.0.1:3011/cookies" + request2 <- parseUrl "http://127.0.0.1:3011/print-cookies" + (elbs1, elbs2) <- withManager $ \manager -> do + browse manager $ do + _ <- makeRequestLbs request1 + cookie_jar <- getCookieJar + setCookieJar def + elbs1 <- makeRequestLbs request2 + setCookieJar cookie_jar + elbs2 <- makeRequestLbs request2 + return (elbs1, elbs2) + killThread tid + if (((lazyToStrict $ responseBody elbs1) /= S.empty) || + ((lazyToStrict $ responseBody elbs2) /= fromString "flavor=chocolate-chip")) + then error "Cookie jar got garbled up!" + else return () + it "user agent sets correctly" $ do + tid <- forkIO $ run 3012 app + request <- parseUrl "http://127.0.0.1:3012/useragent" + elbs <- withManager $ \manager -> do + browse manager $ do + setUserAgent $ fromString "abcd" + makeRequestLbs request + killThread tid + if (lazyToStrict $ responseBody elbs) /= fromString "abcd" + then error "Should have gotten the user agent back!" + else return () + it "authorities get set correctly" $ do + tid <- forkIO $ run 3013 app + request <- parseUrl "http://127.0.0.1:3013/authorities" + elbs <- withManager $ \manager -> do + browse manager $ do + setAuthorities $ const $ Just (user, pass) + makeRequestLbs request + killThread tid + if (lazyToStrict $ responseBody elbs) /= (fromString "Basic " `S.append` (encode $ user `S.append` ":" `S.append` pass)) + then error "Authorities didn't get set correctly!" + else return () + it "can follow redirects" $ do + tid <- forkIO $ run 3014 app + request <- parseUrl "http://127.0.0.1:3014/redir1" + elbs <- withManager $ \manager -> do + browse manager $ do + setMaxRedirects 2 + makeRequestLbs request + killThread tid + if (lazyToStrict $ responseBody elbs) /= dummy + then error "Should be able to follow 2 redirects" + else return () + it "max redirects fails correctly" $ do + tid <- forkIO $ run 3015 app + request <- parseUrl "http://127.0.0.1:3015/redir1" + elbs <- try $ withManager $ \manager -> do + browse manager $ do + setMaxRedirects 1 + makeRequestLbs request + killThread tid + case elbs of + Left (TooManyRedirects _) -> return () + _ -> error "Shouldn't have followed all those redirects!" describe "httpLbs" $ do it "preserves 'set-cookie' headers" $ do tid <- forkIO $ run 3010 app