1{-# LANGUAGE ScopedTypeVariables #-} 2{-# LANGUAGE OverloadedStrings #-} 3module Network.HTTP.Client.Core 4 ( withResponse 5 , httpLbs 6 , httpNoBody 7 , httpRaw 8 , httpRaw' 9 , getModifiedRequestManager 10 , responseOpen 11 , responseClose 12 , httpRedirect 13 , httpRedirect' 14 , withConnection 15 ) where 16 17import Network.HTTP.Types 18import Network.HTTP.Client.Manager 19import Network.HTTP.Client.Types 20import Network.HTTP.Client.Headers 21import Network.HTTP.Client.Body 22import Network.HTTP.Client.Request 23import Network.HTTP.Client.Response 24import Network.HTTP.Client.Cookies 25import Data.Maybe (fromMaybe, isJust) 26import Data.Time 27import Control.Exception 28import qualified Data.ByteString.Lazy as L 29import Data.Monoid 30import Control.Monad (void) 31import System.Timeout (timeout) 32import Data.KeyedPool 33 34-- | Perform a @Request@ using a connection acquired from the given @Manager@, 35-- and then provide the @Response@ to the given function. This function is 36-- fully exception safe, guaranteeing that the response will be closed when the 37-- inner function exits. It is defined as: 38-- 39-- > withResponse req man f = bracket (responseOpen req man) responseClose f 40-- 41-- It is recommended that you use this function in place of explicit calls to 42-- 'responseOpen' and 'responseClose'. 43-- 44-- You will need to use functions such as 'brRead' to consume the response 45-- body. 46-- 47-- Since 0.1.0 48withResponse :: Request 49 -> Manager 50 -> (Response BodyReader -> IO a) 51 -> IO a 52withResponse req man f = bracket (responseOpen req man) responseClose f 53 54-- | A convenience wrapper around 'withResponse' which reads in the entire 55-- response body and immediately closes the connection. Note that this function 56-- performs fully strict I\/O, and only uses a lazy ByteString in its response 57-- for memory efficiency. If you are anticipating a large response body, you 58-- are encouraged to use 'withResponse' and 'brRead' instead. 59-- 60-- Since 0.1.0 61httpLbs :: Request -> Manager -> IO (Response L.ByteString) 62httpLbs req man = withResponse req man $ \res -> do 63 bss <- brConsume $ responseBody res 64 return res { responseBody = L.fromChunks bss } 65 66-- | A convenient wrapper around 'withResponse' which ignores the response 67-- body. This is useful, for example, when performing a HEAD request. 68-- 69-- Since 0.3.2 70httpNoBody :: Request -> Manager -> IO (Response ()) 71httpNoBody req man = withResponse req man $ return . void 72 73 74-- | Get a 'Response' without any redirect following. 75httpRaw 76 :: Request 77 -> Manager 78 -> IO (Response BodyReader) 79httpRaw = fmap (fmap snd) . httpRaw' 80 81-- | Get a 'Response' without any redirect following. 82-- 83-- This extended version of 'httpRaw' also returns the potentially modified Request. 84httpRaw' 85 :: Request 86 -> Manager 87 -> IO (Request, Response BodyReader) 88httpRaw' req0 m = do 89 let req' = mSetProxy m req0 90 (req, cookie_jar') <- case cookieJar req' of 91 Just cj -> do 92 now <- getCurrentTime 93 return $ insertCookiesIntoRequest req' (evictExpiredCookies cj now) now 94 Nothing -> return (req', Data.Monoid.mempty) 95 (timeout', mconn) <- getConnectionWrapper 96 (responseTimeout' req) 97 (getConn req m) 98 99 -- Originally, we would only test for exceptions when sending the request, 100 -- not on calling @getResponse@. However, some servers seem to close 101 -- connections after accepting the request headers, so we need to check for 102 -- exceptions in both. 103 ex <- try $ do 104 cont <- requestBuilder (dropProxyAuthSecure req) (managedResource mconn) 105 106 getResponse timeout' req mconn cont 107 108 case ex of 109 -- Connection was reused, and might have been closed. Try again 110 Left e | managedReused mconn && mRetryableException m e -> do 111 managedRelease mconn DontReuse 112 httpRaw' req m 113 -- Not reused, or a non-retry, so this is a real exception 114 Left e -> throwIO e 115 -- Everything went ok, so the connection is good. If any exceptions get 116 -- thrown in the response body, just throw them as normal. 117 Right res -> case cookieJar req' of 118 Just _ -> do 119 now' <- getCurrentTime 120 let (cookie_jar, _) = updateCookieJar res req now' cookie_jar' 121 return (req, res {responseCookieJar = cookie_jar}) 122 Nothing -> return (req, res) 123 where 124 getConnectionWrapper mtimeout f = 125 case mtimeout of 126 Nothing -> fmap ((,) Nothing) f 127 Just timeout' -> do 128 before <- getCurrentTime 129 mres <- timeout timeout' f 130 case mres of 131 Nothing -> throwHttp ConnectionTimeout 132 Just res -> do 133 now <- getCurrentTime 134 let timeSpentMicro = diffUTCTime now before * 1000000 135 remainingTime = round $ fromIntegral timeout' - timeSpentMicro 136 if remainingTime <= 0 137 then throwHttp ConnectionTimeout 138 else return (Just remainingTime, res) 139 140 responseTimeout' req = 141 case responseTimeout req of 142 ResponseTimeoutDefault -> 143 case mResponseTimeout m of 144 ResponseTimeoutDefault -> Just 30000000 145 ResponseTimeoutNone -> Nothing 146 ResponseTimeoutMicro u -> Just u 147 ResponseTimeoutNone -> Nothing 148 ResponseTimeoutMicro u -> Just u 149 150-- | The used Manager can be overridden (by requestManagerOverride) and the used 151-- Request can be modified (through managerModifyRequest). This function allows 152-- to retrieve the possibly overridden Manager and the possibly modified 153-- Request. 154-- 155-- (In case the Manager is overridden by requestManagerOverride, the Request is 156-- being modified by managerModifyRequest of the new Manager, not the old one.) 157getModifiedRequestManager :: Manager -> Request -> IO (Manager, Request) 158getModifiedRequestManager manager0 req0 = do 159 let manager = fromMaybe manager0 (requestManagerOverride req0) 160 req <- mModifyRequest manager req0 161 return (manager, req) 162 163-- | The most low-level function for initiating an HTTP request. 164-- 165-- The first argument to this function gives a full specification 166-- on the request: the host to connect to, whether to use SSL, 167-- headers, etc. Please see 'Request' for full details. The 168-- second argument specifies which 'Manager' should be used. 169-- 170-- This function then returns a 'Response' with a 171-- 'BodyReader'. The 'Response' contains the status code 172-- and headers that were sent back to us, and the 173-- 'BodyReader' contains the body of the request. Note 174-- that this 'BodyReader' allows you to have fully 175-- interleaved IO actions during your HTTP download, making it 176-- possible to download very large responses in constant memory. 177-- 178-- An important note: the response body returned by this function represents a 179-- live HTTP connection. As such, if you do not use the response body, an open 180-- socket will be retained indefinitely. You must be certain to call 181-- 'responseClose' on this response to free up resources. 182-- 183-- This function automatically performs any necessary redirects, as specified 184-- by the 'redirectCount' setting. 185-- 186-- When implementing a (reverse) proxy using this function or relating 187-- functions, it's wise to remove Transfer-Encoding:, Content-Length:, 188-- Content-Encoding: and Accept-Encoding: from request and response 189-- headers to be relayed. 190-- 191-- Since 0.1.0 192responseOpen :: Request -> Manager -> IO (Response BodyReader) 193responseOpen inputReq manager' = do 194 case validateHeaders (requestHeaders inputReq) of 195 GoodHeaders -> return () 196 BadHeaders reason -> throwHttp $ InvalidRequestHeader reason 197 (manager, req0) <- getModifiedRequestManager manager' inputReq 198 wrapExc req0 $ mWrapException manager req0 $ do 199 (req, res) <- go manager (redirectCount req0) req0 200 checkResponse req req res 201 mModifyResponse manager res 202 { responseBody = wrapExc req0 (responseBody res) 203 } 204 where 205 wrapExc :: Request -> IO a -> IO a 206 wrapExc req0 = handle $ throwIO . toHttpException req0 207 208 go manager0 count req' = httpRedirect' 209 count 210 (\req -> do 211 (manager, modReq) <- getModifiedRequestManager manager0 req 212 (req'', res) <- httpRaw' modReq manager 213 let mreq = if redirectCount modReq == 0 214 then Nothing 215 else getRedirectedRequest req'' (responseHeaders res) (responseCookieJar res) (statusCode (responseStatus res)) 216 return (res, fromMaybe req'' mreq, isJust mreq)) 217 req' 218 219-- | Redirect loop. 220httpRedirect 221 :: Int -- ^ 'redirectCount' 222 -> (Request -> IO (Response BodyReader, Maybe Request)) -- ^ function which performs a request and returns a response, and possibly another request if there's a redirect. 223 -> Request 224 -> IO (Response BodyReader) 225httpRedirect count0 http0 req0 = fmap snd $ httpRedirect' count0 http' req0 226 where 227 -- adapt callback API 228 http' req' = do 229 (res, mbReq) <- http0 req' 230 return (res, fromMaybe req0 mbReq, isJust mbReq) 231 232-- | Redirect loop. 233-- 234-- This extended version of 'httpRaw' also returns the Request potentially modified by @managerModifyRequest@. 235httpRedirect' 236 :: Int -- ^ 'redirectCount' 237 -> (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. 238 -> Request 239 -> IO (Request, Response BodyReader) 240httpRedirect' count0 http' req0 = go count0 req0 [] 241 where 242 go count _ ress | count < 0 = throwHttp $ TooManyRedirects ress 243 go count req' ress = do 244 (res, req, isRedirect) <- http' req' 245 if isRedirect then do 246 -- Allow the original connection to return to the 247 -- connection pool immediately by flushing the body. 248 -- If the response body is too large, don't flush, but 249 -- instead just close the connection. 250 let maxFlush = 1024 251 lbs <- brReadSome (responseBody res) maxFlush 252 -- The connection may already be closed, e.g. 253 -- when using withResponseHistory. See 254 -- https://github.com/snoyberg/http-client/issues/169 255 `Control.Exception.catch` \se -> 256 case () of 257 () 258 | Just ConnectionClosed <- 259 fmap unHttpExceptionContentWrapper 260 (fromException se) -> return L.empty 261 | Just (HttpExceptionRequest _ ConnectionClosed) <- 262 fromException se -> return L.empty 263 _ -> throwIO se 264 responseClose res 265 266 -- And now perform the actual redirect 267 go (count - 1) req (res { responseBody = lbs }:ress) 268 else 269 return (req, res) 270 271-- | Close any open resources associated with the given @Response@. In general, 272-- this will either close an active @Connection@ or return it to the @Manager@ 273-- to be reused. 274-- 275-- Since 0.1.0 276responseClose :: Response a -> IO () 277responseClose = runResponseClose . responseClose' 278 279-- | Perform an action using a @Connection@ acquired from the given @Manager@. 280-- 281-- You should use this only when you have to read and write interactively 282-- through the connection (e.g. connection by the WebSocket protocol). 283-- 284-- @since 0.5.13 285withConnection :: Request -> Manager -> (Connection -> IO a) -> IO a 286withConnection origReq man action = do 287 mHttpConn <- getConn (mSetProxy man origReq) man 288 action (managedResource mHttpConn) <* keepAlive mHttpConn 289 `finally` managedRelease mHttpConn DontReuse 290