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