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 @@ -91,7 +91,11 @@ , withLocation -- ** Cookies -- *** Cookie jar - -- | All the cookies! + -- | Global cookie jar. + -- Cookies in Request's 'cookieJar' are preferred to global cookies if + -- there's a name collision. + -- + -- default: @'def'@ , getCookieJar , setCookieJar , withCookieJar @@ -212,11 +216,15 @@ where import Network.HTTP.Conduit -import Network.HTTP.Conduit.Internal (httpRedirect, getUri, setUri) +import Network.HTTP.Conduit.Internal (httpRedirect + ,getUri + ,setUri + ,generateCookie + ,insertCheckedCookie + ) import qualified Network.HTTP.Types as HT -import qualified Network.HTTP.Types.Header as HT import Network.Socks5 (SocksConf) -import Network.URI (URI (..), URIAuth (..), parseRelativeReference, relativeTo, uriToString) +import Network.URI (URI (..), parseRelativeReference, relativeTo) import Data.Time.Clock (getCurrentTime, UTCTime) import Web.Cookie (parseSetCookie) import Data.Certificate.X509 (X509) @@ -224,23 +232,27 @@ import Data.Conduit import qualified Data.Conduit.Binary as CB -import Data.Conduit.List (sinkNull) import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L -import Data.List (partition) +import Data.Function (on) +import Data.List (partition + ,union + ) import Data.Maybe (catMaybes, fromMaybe) import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.State import Control.Monad.Trans.Resource (liftResourceT) +#if !MIN_VERSION_conduit(0,5,3) import Control.Monad.Trans.Control (MonadBaseControl) +#endif import Control.Failure import qualified Control.Exception.Lifted as LE -import Control.Exception (SomeException, IOException, toException) +import Control.Exception (SomeException + ,toException) import qualified Data.Map as Map data BrowserState = BrowserState @@ -251,12 +263,12 @@ , authorities :: Request (ResourceT IO) -> Maybe (BS.ByteString, BS.ByteString) , browserClientCertificates :: Maybe [(X509, Maybe PrivateKey)] , cookieFilter :: Request (ResourceT IO) -> Cookie -> IO Bool - , cookieJar :: CookieJar + , browserCookieJar :: CookieJar , currentProxy :: Maybe Proxy , currentSocksProxy :: Maybe SocksConf , overrideHeaders :: Map.Map HT.HeaderName BS.ByteString , defaultHeaders :: Map.Map HT.HeaderName BS.ByteString - , browserCheckStatus :: Maybe (HT.Status -> HT.ResponseHeaders -> Maybe SomeException) + , browserCheckStatus :: Maybe (HT.Status -> HT.ResponseHeaders -> CookieJar -> Maybe SomeException) , manager :: Manager } @@ -268,7 +280,7 @@ , authorities = const Nothing , browserClientCertificates = Nothing , cookieFilter = const $ const $ return True - , cookieJar = def + , browserCookieJar = def , currentProxy = Nothing , currentSocksProxy = Nothing , overrideHeaders = Map.empty @@ -319,60 +331,58 @@ (applyOverrideHeaders override_headers $ applyDefaultHeaders default_headers $ req { redirectCount = 0 - , proxy = maybe (proxy req) Just current_proxy - , socksProxy = maybe (socksProxy req) Just current_socks_proxy - , checkStatus = \ _ _ -> Nothing - , responseTimeout = maybe (responseTimeout req) Just time_out - , clientCertificates = fromMaybe (clientCertificates req) client_certificates - }) max_retry_count - (fromMaybe (redirectCount req) max_redirects) - (fromMaybe (checkStatus req) current_check_status) - Nothing + , proxy = maybe (proxy req) Just current_proxy + , socksProxy = maybe (socksProxy req) Just current_socks_proxy + , checkStatus = \ _ _ _ -> Nothing + , responseTimeout = maybe (responseTimeout req) Just time_out + , clientCertificates = fromMaybe (clientCertificates req) client_certificates + }) max_retry_count + (fromMaybe (redirectCount req) max_redirects) + (fromMaybe (checkStatus req) current_check_status) + Nothing where - snd3 (_, a, _) = a retryHelper request' retry_count max_redirects check_status e | retry_count < 0 = case e of Just e' -> LE.throwIO e' Nothing -> LE.throwIO TooManyRetries | otherwise = do - resp <- LE.catches + res <- LE.catch (if max_redirects == 0 - then snd3 `fmap` performRequest request' + then performRequest request' else runRedirectionChain request' max_redirects) - [ LE.Handler $ \(e'::HttpException) -> retryHelper request' (retry_count - 1) max_redirects check_status $ Just $ toException e' - , LE.Handler $ \(e'::IOException) -> retryHelper request' (retry_count - 1) max_redirects check_status $ Just $ toException e' - ] - case check_status (responseStatus resp) (responseHeaders resp) of - Nothing -> return resp + (\(e'::HttpException) -> retryHelper request' (retry_count - 1) max_redirects check_status $ Just $ toException e') + case check_status (responseStatus res) (responseHeaders res) (responseCookieJar res) of + Nothing -> return res Just e' -> retryHelper request' (retry_count - 1) max_redirects check_status (Just e') - runRedirectionChain request'' redirect_count + runRedirectionChain request' redirect_count = httpRedirect redirect_count - (\request' -> do - (request, res, res') <- performRequest request' - let mreq = getRedirectedRequest request (responseHeaders res') (HT.statusCode $ responseStatus res') + (\request -> do + res <- performRequest request + let mreq = getRedirectedRequest request (responseHeaders res) (responseCookieJar res) (HT.statusCode $ responseStatus res) return (res, mreq)) liftResourceT - request'' - performRequest request' = do + request' + performRequest request'' = do s@(BrowserState { manager = manager' , authorities = auths - , cookieJar = cookie_jar + , browserCookieJar = cookie_jar' , cookieFilter = cookie_filter }) <- get - now <- liftIO getCurrentTime - let (request'', cookie_jar') = - insertCookiesIntoRequest - (applyAuthorities auths request') - (evictExpiredCookies cookie_jar now) now - res <- liftResourceT $ http request'' manager' - now' <- liftIO getCurrentTime - (cookie_jar'', response) <- liftIO $ - updateMyCookieJar res request'' now' cookie_jar' cookie_filter - put $ s { cookieJar = cookie_jar'' - , currentLocation = Just $ getUri request'' + let request' = (applyAuthorities auths request'') + {cookieJar = Just $ createCookieJar $ + (union `on` destroyCookieJar) + (fromMaybe def $ cookieJar request'') + cookie_jar' } - return (request'', res, response) + res <- liftResourceT $ http request' manager' + (cookie_jar, _) <- liftIO $ do + now <- getCurrentTime + updateMyCookieJar res request' now cookie_jar' cookie_filter + put $ s { browserCookieJar = cookie_jar + , currentLocation = Just $ getUri request' + } + return res applyAuthorities :: (Request a -> Maybe (BS.ByteString, BS.ByteString)) -> Request a -> Request a applyAuthorities auths request' = @@ -458,13 +468,13 @@ GENERIC_FIELD(CookieFilter, cookieFilter, Request (ResourceT IO) -> Cookie -> IO Bool) -GENERIC_FIELD(CookieJar, cookieJar, CookieJar) +GENERIC_FIELD(CookieJar, browserCookieJar, CookieJar) GENERIC_FIELD(CurrentProxy, currentProxy, Maybe Proxy) GENERIC_FIELD(CurrentSocksProxy, currentSocksProxy, Maybe SocksConf) -GENERIC_FIELD(CheckStatus, browserCheckStatus, Maybe (HT.Status -> HT.ResponseHeaders -> Maybe SomeException)) +GENERIC_FIELD(CheckStatus, browserCheckStatus, Maybe (HT.Status -> HT.ResponseHeaders -> CookieJar -> Maybe SomeException)) #undef GENERIC_FIELD #undef CONCAT diff --git a/http-conduit-browser.cabal b/http-conduit-browser.cabal --- a/http-conduit-browser.cabal +++ b/http-conduit-browser.cabal @@ -1,5 +1,5 @@ name: http-conduit-browser -version: 1.8.1.1 +version: 1.9.0 license: BSD3 license-file: LICENSE author: Myles C. Maxfield @@ -22,7 +22,7 @@ library build-depends: base >= 4 && < 5 - , http-conduit >= 1.8.5 && < 1.9 + , http-conduit >= 1.9 && < 1.10 , data-default , cookie , case-insensitive @@ -35,7 +35,7 @@ , containers , socks , network >= 2.3 - , failure >= 0.2 + , failure , monad-control , resourcet >= 0.3 && < 0.5 , certificate, tls @@ -43,12 +43,14 @@ ghc-options: -Wall test-suite test - main-is: test/main.hs + main-is: main.hs type: exitcode-stdio-1.0 - hs-source-dirs: ., test + hs-source-dirs: test ghc-options: -Wall - build-depends: base >= 4 && < 5 + build-depends: + http-conduit-browser + , base >= 4 && < 5 , HUnit , hspec >= 1.3 , http-conduit diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE CPP #-} import Test.Hspec import Test.HUnit import Control.Applicative @@ -14,6 +15,9 @@ import qualified Network.Wai as Wai import Network.Wai.Handler.Warp (run) import Network.HTTP.Conduit +#if MIN_VERSION_http_conduit(1,9,0) +import Network.HTTP.Conduit.Internal (receiveSetCookie) +#endif import Network.HTTP.Conduit.Browser import Data.ByteString.Base64 (encode) import Data.Typeable (Typeable) @@ -123,7 +127,7 @@ if lazyToStrict (responseBody elbs) /= S.empty then error "Shouldn't have gotten the cookie back!" else return () - it "user-defined cookies survive redirects" $ do + it "custom cookies in global cookie jar survive redirects" $ do tid <- forkIO $ run 3019 app req <- parseUrl "http://127.0.0.1:3019/cookie_redir2" let setCookie = def @@ -136,8 +140,8 @@ responseBody <$> makeRequestLbs req killThread tid elbs @?= "nom-nom-nom" -{- http-conduit-1.9+ cookieJar - it "user-defined cookies in req survive redirects" $ do +#if MIN_VERSION_http_conduit(1,9,0) + it "custom cookies in Request's cookie jar survive redirects" $ do tid <- forkIO $ run 3019 app req <- parseUrl "http://127.0.0.1:3019/cookie_redir2" let setCookie = def @@ -147,11 +151,27 @@ elbs <- withManager $ \manager -> do browse manager $ do cjar <- receiveSetCookie setCookie req default_time True <$> getCookieJar - let request = fst $ insertCookiesIntoRequest req cjar default_time + let request = req {cookieJar = Just cjar} responseBody <$> makeRequestLbs request killThread tid liftIO $ elbs @?= "nom-nom-nom" --} + it "custom cookies in Request's cookie jar take priority over global cookiejar" $ do + tid <- forkIO $ run 3019 app + req <- parseUrl "http://127.0.0.1:3019/cookie_redir2" + let setCookie a = def + { setCookieName = "flavor" + , setCookieValue = a } + default_time = UTCTime (ModifiedJulianDay 56200) (secondsToDiffTime 0) + elbs <- withManager $ \manager -> do + browse manager $ do + cjar_glb <- receiveSetCookie (setCookie "another-cookie") req default_time True <$> getCookieJar + setCookieJar cjar_glb + cjar_req <- receiveSetCookie (setCookie "chocolate-chip") req default_time True <$> getCookieJar + let request = req {cookieJar = Just cjar_req} + responseBody <$> makeRequestLbs request + killThread tid + liftIO $ elbs @?= "nom-nom-nom" +#endif it "can save and load cookie jar" $ do tid <- forkIO $ run 3011 app request1 <- parseUrl "http://127.0.0.1:3011/cookies" @@ -275,7 +295,7 @@ makeRequestLbs request killThread tid case elbs of - Left (StatusCodeException _ _) -> return () + Left StatusCodeException{} -> return () _ -> error "1 redirect shouldn't be enough!" it "Makes multiple retries" $ do writeIORef ref True @@ -327,7 +347,7 @@ request <- parseUrl "http://127.0.0.1:3012/useragent" elbs <- try $ withManager $ \manager -> do browse manager $ do - setCheckStatus $ Just $ \ _ _ -> Just $ toException TestException + setCheckStatus $ Just $ \ _ _ _ -> Just $ toException TestException makeRequestLbs request killThread tid case elbs of