diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,10 @@ +## 0.5.13 + +* Adds `setRequestCheckStatus` and `throwErrorStatusCodes` functions. + See [#304](https://github.com/snoyberg/http-client/issues/304) +* Add `withConnection` function. + See [#352](https://github.com/snoyberg/http-client/pull/352). + ## 0.5.12.1 * Make the chunked transfer-encoding detection case insensitive diff --git a/Data/KeyedPool.hs b/Data/KeyedPool.hs --- a/Data/KeyedPool.hs +++ b/Data/KeyedPool.hs @@ -33,6 +33,7 @@ , managedResource , managedReused , managedRelease + , keepAlive , Reuse (..) , dummyManaged ) where @@ -45,7 +46,7 @@ import Data.Maybe (isJust) import qualified Data.Map.Strict as Map import Data.Time (UTCTime, getCurrentTime, addUTCTime) -import Data.IORef (IORef, newIORef, mkWeakIORef) +import Data.IORef (IORef, newIORef, mkWeakIORef, readIORef) import qualified Data.Foldable as F import GHC.Conc (unsafeIOToSTM) import System.IO.Unsafe (unsafePerformIO) @@ -318,3 +319,7 @@ ignoreExceptions :: IO () -> IO () ignoreExceptions f = f `catch` \(_ :: SomeException) -> return () + +-- | Prevent the managed resource from getting released before you want to use. +keepAlive :: Managed resource -> IO () +keepAlive = readIORef . _managedAlive diff --git a/Network/HTTP/Client.hs b/Network/HTTP/Client.hs --- a/Network/HTTP/Client.hs +++ b/Network/HTTP/Client.hs @@ -136,11 +136,11 @@ , requestFromURI , requestFromURI_ , defaultRequest - , applyBasicAuth , urlEncodedBody , getUri , setRequestIgnoreStatus + , setRequestCheckStatus , setQueryString #if MIN_VERSION_http_types(0,12,1) , setQueryStringPartialEscape @@ -178,6 +178,7 @@ , responseHeaders , responseBody , responseCookieJar + , throwErrorStatusCodes -- ** Response body , BodyReader , brRead @@ -192,6 +193,7 @@ , Cookie (..) , CookieJar , Proxy (..) + , withConnection -- * Cookies , module Network.HTTP.Client.Cookies ) where 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 @@ -11,6 +11,7 @@ , responseClose , httpRedirect , httpRedirect' + , withConnection ) where import Network.HTTP.Types @@ -270,3 +271,15 @@ -- Since 0.1.0 responseClose :: Response a -> IO () responseClose = runResponseClose . responseClose' + +-- | Perform an action using a @Connection@ acquired from the given @Manager@. +-- +-- You should use this only when you have to read and write interactively +-- through the connection (e.g. connection by the WebSocket protocol). +-- +-- @since 0.5.13 +withConnection :: Request -> Manager -> (Connection -> IO a) -> IO a +withConnection origReq man action = do + mHttpConn <- getConn (mSetProxy man origReq) man + action (managedResource mHttpConn) <* keepAlive mHttpConn + `finally` managedRelease mHttpConn DontReuse diff --git a/Network/HTTP/Client/Request.hs b/Network/HTTP/Client/Request.hs --- a/Network/HTTP/Client/Request.hs +++ b/Network/HTTP/Client/Request.hs @@ -26,6 +26,7 @@ , needsGunzip , requestBuilder , setRequestIgnoreStatus + , setRequestCheckStatus , setQueryString #if MIN_VERSION_http_types(0,12,1) , setQueryStringPartialEscape @@ -33,6 +34,7 @@ , streamFile , observedStreamFile , extractBasicAuthInfo + , throwErrorStatusCodes ) where import Data.Int (Int64) @@ -42,6 +44,7 @@ import Data.Char (toLower) import Control.Applicative as A ((<$>)) import Control.Monad (unless, guard) +import Control.Monad.IO.Class (MonadIO, liftIO) import Numeric (showHex) import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString, toByteStringIO, flush) @@ -77,25 +80,33 @@ parseUrl = parseUrlThrow {-# DEPRECATED parseUrl "Please use parseUrlThrow, parseRequest, or parseRequest_ instead" #-} --- | Same as 'parseRequest', except will throw an 'HttpException' in --- the event of a non-2XX response. +-- | Same as 'parseRequest', except will throw an 'HttpException' in the +-- event of a non-2XX response. This uses 'throwErrorStatusCodes' to +-- implement 'checkResponse'. -- -- @since 0.4.30 parseUrlThrow :: MonadThrow m => String -> m Request parseUrlThrow = liftM yesThrow . parseRequest where - yesThrow req = req - { checkResponse = \_req res -> - let W.Status sci _ = responseStatus res in - if 200 <= sci && sci < 300 - then return () - else do - chunk <- brReadSome (responseBody res) 1024 - let res' = fmap (const ()) res - throwHttp $ StatusCodeException res' (L.toStrict chunk) - } + yesThrow req = req { checkResponse = throwErrorStatusCodes } +-- | Throws a 'StatusCodeException' wrapped in 'HttpExceptionRequest', +-- if the response's status code indicates an error (if it isn't 2xx). +-- This can be used to implement 'checkResponse'. +-- +-- @since 0.5.13 +throwErrorStatusCodes :: MonadIO m => Request -> Response BodyReader -> m () +throwErrorStatusCodes req res = do + let W.Status sci _ = responseStatus res + if 200 <= sci && sci < 300 + then return () + else liftIO $ do + chunk <- brReadSome (responseBody res) 1024 + let res' = fmap (const ()) res + let ex = StatusCodeException res' (L.toStrict chunk) + throwIO $ HttpExceptionRequest req ex + -- | Convert a URL into a 'Request'. -- -- This function defaults some of the values in 'Request', such as setting 'method' to @@ -114,7 +125,7 @@ -- Note that the request method must be provided as all capital letters. -- -- A 'Request' created by this function won't cause exceptions on non-2XX --- response status codes. +-- response status codes. -- -- To create a request which throws on non-2XX status codes, see 'parseUrlThrow' -- @@ -136,23 +147,23 @@ Nothing -> req Just m -> req { method = S8.pack m } --- | Same as 'parseRequest', but in the cases of a parse error --- generates an impure exception. Mostly useful for static strings which --- are known to be correctly formatted. +-- | Same as 'parseRequest', but parse errors cause an impure exception. +-- Mostly useful for static strings which are known to be correctly +-- formatted. parseRequest_ :: String -> Request parseRequest_ = either throw id . parseRequest -- | Convert a 'URI' into a 'Request'. -- --- This can fail if the given 'URI' is not absolute, or if the +-- This can fail if the given 'URI' is not absolute, or if the -- 'URI' scheme is not @"http"@ or @"https"@. In these cases the function -- will throw an error via 'MonadThrow'. -- -- This function defaults some of the values in 'Request', such as setting 'method' to -- @"GET"@ and 'requestHeaders' to @[]@. --- +-- -- A 'Request' created by this function won't cause exceptions on non-2XX --- response status codes. +-- response status codes. -- -- @since 0.5.12 requestFromURI :: MonadThrow m => URI -> m Request @@ -246,8 +257,11 @@ False {- HTTP -} -> return 80 True {- HTTPS -} -> return 443 --- | A default request value +-- | A default request value, a GET request of localhost/:80, with an +-- empty request body. -- +-- Note that the default 'checkResponse' does nothing. +-- -- @since 0.4.30 defaultRequest :: Request defaultRequest = Request @@ -503,6 +517,13 @@ -- @since 0.4.29 setRequestIgnoreStatus :: Request -> Request setRequestIgnoreStatus req = req { checkResponse = \_ _ -> return () } + +-- | Modify the request so that non-2XX status codes generate a runtime +-- 'StatusCodeException', by using 'throwErrorStatusCodes' +-- +-- @since 0.5.13 +setRequestCheckStatus :: Request -> Request +setRequestCheckStatus req = req { checkResponse = throwErrorStatusCodes } -- | Set the query string to the given key/value pairs. -- 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.5.12.1 +version: 0.5.13 synopsis: An HTTP client engine description: Hackage documentation generation is not reliable. For up to date documentation, please see: . homepage: https://github.com/snoyberg/http-client