http-conduit-browser 1.8.1.1 → 1.9.0

raw patch · 3 files changed

+94/−62 lines, 3 filesdep +http-conduit-browserdep ~failuredep ~http-conduitPVP ok

version bump matches the API change (PVP)

Dependencies added: http-conduit-browser

Dependency ranges changed: failure, http-conduit

API changes (from Hackage documentation)

Files

• Network/HTTP/Conduit/Browser.hs +59/−49
• http-conduit-browser.cabal +8/−6
• test/main.hs +27/−7

@@ -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

@@ -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 <myles.maxfield@gmail.com>@@ -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

@@ -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