http-client 0.4.26.2 → 0.4.27
raw patch · 5 files changed
+78/−38 lines, 5 files
Files
- ChangeLog.md +4/−0
- Network/HTTP/Client.hs +7/−7
- Network/HTTP/Client/Core.hs +59/−30
- http-client.cabal +1/−1
- test/Network/HTTP/ClientSpec.hs +7/−0
ChangeLog.md view
@@ -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
Network/HTTP/Client.hs view
@@ -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
Network/HTTP/Client/Core.hs view
@@ -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@
http-client.cabal view
@@ -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: <http://www.stackage.org/package/http-client>. homepage: https://github.com/snoyberg/http-client
test/Network/HTTP/ClientSpec.hs view
@@ -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