diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ +## 0.4.27 + +* Enable managerModifyRequest to modify checkStatus [#179](https://github.com/snoyberg/http-client/pull/179) + ## 0.4.26.2 * Fix compilation for GHC 7.4 diff --git a/Network/HTTP/Client.hs b/Network/HTTP/Client.hs --- a/Network/HTTP/Client.hs +++ b/Network/HTTP/Client.hs @@ -215,19 +215,19 @@ reqRef <- newIORef req0 historyRef <- newIORef id let go req = do - res <- httpRaw req man + (req', res) <- httpRaw' req man case getRedirectedRequest - req + req' (responseHeaders res) (responseCookieJar res) (statusCode $ responseStatus res) of - Nothing -> return (res, Nothing) - Just req' -> do - writeIORef reqRef req' + Nothing -> return (res, req', False) + Just req'' -> do + writeIORef reqRef req'' body <- brReadSome (responseBody res) 1024 modifyIORef historyRef (. ((req, res { responseBody = body }):)) - return (res, Just req') - res <- httpRedirect (redirectCount req0) go req0 + return (res, req'', True) + (_, res) <- httpRedirect' (redirectCount req0) go req0 reqFinal <- readIORef reqRef history <- readIORef historyRef return HistoriedResponse diff --git a/Network/HTTP/Client/Core.hs b/Network/HTTP/Client/Core.hs --- a/Network/HTTP/Client/Core.hs +++ b/Network/HTTP/Client/Core.hs @@ -6,10 +6,12 @@ , httpLbs , httpNoBody , httpRaw + , httpRaw' , responseOpen , responseClose , applyCheckStatus , httpRedirect + , httpRedirect' ) where #if !MIN_VERSION_base(4,6,0) @@ -22,6 +24,7 @@ import Network.HTTP.Client.Request import Network.HTTP.Client.Response import Network.HTTP.Client.Cookies +import Data.Maybe (fromMaybe, isJust) import Data.Time import Control.Exception import qualified Data.ByteString as S @@ -69,12 +72,22 @@ httpNoBody :: Request -> Manager -> IO (Response ()) httpNoBody req man = withResponse req man $ return . void + -- | Get a 'Response' without any redirect following. httpRaw :: Request -> Manager -> IO (Response BodyReader) -httpRaw req0 m = do +httpRaw = fmap (fmap snd) . httpRaw' + +-- | Get a 'Response' without any redirect following. +-- +-- This extended version of 'httpRaw' also returns the Request potentially modified by @managerModifyRequest@. +httpRaw' + :: Request + -> Manager + -> IO (Request, Response BodyReader) +httpRaw' req0 m = do req' <- mModifyRequest m $ mSetProxy m req0 (req, cookie_jar') <- case cookieJar req' of Just cj -> do @@ -100,7 +113,8 @@ -- Connection was reused, and might have been closed. Try again (Left e, Reused) | mRetryableException m e -> do connRelease DontReuse - responseOpen req m + res <- responseOpen req m + return (req, res) -- Not reused, or a non-retry, so this is a real exception (Left e, _) -> throwIO e -- Everything went ok, so the connection is good. If any exceptions get @@ -109,8 +123,8 @@ Just _ -> do now' <- getCurrentTime let (cookie_jar, _) = updateCookieJar res req now' cookie_jar' - return $ res {responseCookieJar = cookie_jar} - Nothing -> return res + return (req, res {responseCookieJar = cookie_jar}) + Nothing -> return (req, res) where responseTimeout' req @@ -150,21 +164,21 @@ -- Since 0.1.0 responseOpen :: Request -> Manager -> IO (Response BodyReader) responseOpen req0 manager = handle addTlsHostPort $ mWrapIOException manager $ do - res <- + (req, res) <- if redirectCount req0 == 0 - then httpRaw req0 manager + then httpRaw' req0 manager else go (redirectCount req0) req0 - maybe (return res) throwIO =<< applyCheckStatus req0 (checkStatus req0) res + maybe (return res) throwIO =<< applyCheckStatus req (checkStatus req) res where addTlsHostPort (TlsException e) = throwIO $ TlsExceptionHostPort e (host req0) (port req0) addTlsHostPort e = throwIO e - go count req' = httpRedirect + go count req' = httpRedirect' count (\req -> do - res <- httpRaw req manager - let mreq = getRedirectedRequest req (responseHeaders res) (responseCookieJar res) (statusCode (responseStatus res)) - return (res, mreq)) + (req'', res) <- httpRaw' req manager + let mreq = getRedirectedRequest req'' (responseHeaders res) (responseCookieJar res) (statusCode (responseStatus res)) + return (res, fromMaybe req'' mreq, isJust mreq)) req' -- | Apply 'Request'\'s 'checkStatus' and return resulting exception if any. @@ -202,34 +216,49 @@ toStrict' = S.concat . L.toChunks #endif --- | Redirect loop +-- | Redirect loop. httpRedirect :: Int -- ^ 'redirectCount' -> (Request -> IO (Response BodyReader, Maybe Request)) -- ^ function which performs a request and returns a response, and possibly another request if there's a redirect. -> Request -> IO (Response BodyReader) -httpRedirect count0 http' req0 = go count0 req0 [] +httpRedirect count0 http0 req0 = fmap snd $ httpRedirect' count0 http' req0 where + -- adapt callback API + http' req' = do + (res, mbReq) <- http0 req' + return (res, fromMaybe req0 mbReq, isJust mbReq) + +-- | Redirect loop. +-- +-- This extended version of 'httpRaw' also returns the Request potentially modified by @managerModifyRequest@. +httpRedirect' + :: Int -- ^ 'redirectCount' + -> (Request -> IO (Response BodyReader, Request, Bool)) -- ^ function which performs a request and returns a response, the potentially modified request, and a Bool indicating if there was a redirect. + -> Request + -> IO (Request, Response BodyReader) +httpRedirect' count0 http' req0 = go count0 req0 [] + where go count _ ress | count < 0 = throwIO $ TooManyRedirects ress go count req' ress = do - (res, mreq) <- http' req' - case mreq of - Just req -> do - -- Allow the original connection to return to the - -- connection pool immediately by flushing the body. - -- If the response body is too large, don't flush, but - -- instead just close the connection. - let maxFlush = 1024 - lbs <- brReadSome (responseBody res) maxFlush - -- The connection may already be closed, e.g. - -- when using withResponseHistory. See - -- https://github.com/snoyberg/http-client/issues/169 - `catch` \(_ :: ConnectionClosed) -> return L.empty - responseClose res + (res, req, isRedirect) <- http' req' + if isRedirect then do + -- Allow the original connection to return to the + -- connection pool immediately by flushing the body. + -- If the response body is too large, don't flush, but + -- instead just close the connection. + let maxFlush = 1024 + lbs <- brReadSome (responseBody res) maxFlush + -- The connection may already be closed, e.g. + -- when using withResponseHistory. See + -- https://github.com/snoyberg/http-client/issues/169 + `catch` \(_ :: ConnectionClosed) -> return L.empty + responseClose res - -- And now perform the actual redirect - go (count - 1) req (res { responseBody = lbs }:ress) - Nothing -> return res + -- And now perform the actual redirect + go (count - 1) req (res { responseBody = lbs }:ress) + else + return (req, res) -- | Close any open resources associated with the given @Response@. In general, -- this will either close an active @Connection@ or return it to the @Manager@ diff --git a/http-client.cabal b/http-client.cabal --- a/http-client.cabal +++ b/http-client.cabal @@ -1,5 +1,5 @@ name: http-client -version: 0.4.26.2 +version: 0.4.27 synopsis: An HTTP client engine, intended as a base layer for more user-friendly packages. description: Hackage documentation generation is not reliable. For up to date documentation, please see: . homepage: https://github.com/snoyberg/http-client diff --git a/test/Network/HTTP/ClientSpec.hs b/test/Network/HTTP/ClientSpec.hs --- a/test/Network/HTTP/ClientSpec.hs +++ b/test/Network/HTTP/ClientSpec.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module Network.HTTP.ClientSpec where +import Control.Exception (toException) import Network (withSocketsDo) import Network.HTTP.Client import Network.HTTP.Types (status200) @@ -24,3 +25,9 @@ withManager settings $ \man -> do res <- httpLbs "http://httpbin.org:1234" man responseStatus res `shouldBe` status200 + + it "managerModifyRequestCheckStatus" $ do + let modify req = return req { checkStatus = \s hs cj -> Just $ toException $ StatusCodeException s hs cj } + settings = defaultManagerSettings { managerModifyRequest = modify } + withManager settings $ \man -> + httpLbs "http://httpbin.org" man `shouldThrow` anyException