{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.HTTP.Client.Core
    ( withResponse
    , httpLbs
    , httpNoBody
    , httpRaw
    , httpRaw'
    , getModifiedRequestManager
    , responseOpen
    , responseClose
    , httpRedirect
    , httpRedirect'
    , withConnection
    , handleClosedRead
    ) where

import Network.HTTP.Types
import Network.HTTP.Client.Manager
import Network.HTTP.Client.Types
import Network.HTTP.Client.Headers
import Network.HTTP.Client.Body
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.Lazy as L
import Data.Monoid
import Control.Monad (void)
import System.Timeout (timeout)
import Data.KeyedPool
import GHC.IO.Exception (IOException(..), IOErrorType(..))

-- | Perform a @Request@ using a connection acquired from the given @Manager@,
-- and then provide the @Response@ to the given function. This function is
-- fully exception safe, guaranteeing that the response will be closed when the
-- inner function exits. It is defined as:
--
-- > withResponse req man f = bracket (responseOpen req man) responseClose f
--
-- It is recommended that you use this function in place of explicit calls to
-- 'responseOpen' and 'responseClose'.
--
-- You will need to use functions such as 'brRead' to consume the response
-- body.
--
-- Since 0.1.0
withResponse :: Request
             -> Manager
             -> (Response BodyReader -> IO a)
             -> IO a
withResponse :: forall a.
Request -> Manager -> (Response BodyReader -> IO a) -> IO a
withResponse Request
req Manager
man Response BodyReader -> IO a
f = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Request -> Manager -> IO (Response BodyReader)
responseOpen Request
req Manager
man) forall a. Response a -> IO ()
responseClose Response BodyReader -> IO a
f

-- | A convenience wrapper around 'withResponse' which reads in the entire
-- response body and immediately closes the connection. Note that this function
-- performs fully strict I\/O, and only uses a lazy ByteString in its response
-- for memory efficiency. If you are anticipating a large response body, you
-- are encouraged to use 'withResponse' and 'brRead' instead.
--
-- Since 0.1.0
httpLbs :: Request -> Manager -> IO (Response L.ByteString)
httpLbs :: Request -> Manager -> IO (Response ByteString)
httpLbs Request
req Manager
man = forall a.
Request -> Manager -> (Response BodyReader -> IO a) -> IO a
withResponse Request
req Manager
man forall a b. (a -> b) -> a -> b
$ \Response BodyReader
res -> do
    [ByteString]
bss <- BodyReader -> IO [ByteString]
brConsume forall a b. (a -> b) -> a -> b
$ forall body. Response body -> body
responseBody Response BodyReader
res
    forall (m :: * -> *) a. Monad m => a -> m a
return Response BodyReader
res { responseBody :: ByteString
responseBody = [ByteString] -> ByteString
L.fromChunks [ByteString]
bss }

-- | A convenient wrapper around 'withResponse' which ignores the response
-- body. This is useful, for example, when performing a HEAD request.
--
-- Since 0.3.2
httpNoBody :: Request -> Manager -> IO (Response ())
httpNoBody :: Request -> Manager -> IO (Response ())
httpNoBody Request
req Manager
man = forall a.
Request -> Manager -> (Response BodyReader -> IO a) -> IO a
withResponse Request
req Manager
man forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Functor f => f a -> f ()
void


-- | Get a 'Response' without any redirect following.
httpRaw
     :: Request
     -> Manager
     -> IO (Response BodyReader)
httpRaw :: Request -> Manager -> IO (Response BodyReader)
httpRaw = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Manager -> IO (Request, Response BodyReader)
httpRaw'

-- | Get a 'Response' without any redirect following.
--
-- This extended version of 'httpRaw' also returns the potentially modified Request.
httpRaw'
     :: Request
     -> Manager
     -> IO (Request, Response BodyReader)
httpRaw' :: Request -> Manager -> IO (Request, Response BodyReader)
httpRaw' Request
req0 Manager
m = do
    let req' :: Request
req' = Manager -> Request -> Request
mSetProxy Manager
m Request
req0
    (Request
req, CookieJar
cookie_jar') <- case Request -> Maybe CookieJar
cookieJar Request
req' of
        Just CookieJar
cj -> do
            UTCTime
now <- IO UTCTime
getCurrentTime
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Request -> CookieJar -> UTCTime -> (Request, CookieJar)
insertCookiesIntoRequest Request
req' (CookieJar -> UTCTime -> CookieJar
evictExpiredCookies CookieJar
cj UTCTime
now) UTCTime
now
        Maybe CookieJar
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (Request
req', forall a. Monoid a => a
Data.Monoid.mempty)
    (Maybe Int
timeout', Managed Connection
mconn) <- forall {a} {resource}.
Integral a =>
Maybe Int
-> IO (Managed resource) -> IO (Maybe a, Managed resource)
getConnectionWrapper
        (Request -> Maybe Int
responseTimeout' Request
req)
        (Request -> Manager -> IO (Managed Connection)
getConn Request
req Manager
m)

    -- Originally, we would only test for exceptions when sending the request,
    -- not on calling @getResponse@. However, some servers seem to close
    -- connections after accepting the request headers, so we need to check for
    -- exceptions in both.
    Either SomeException (Response BodyReader)
ex <- forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$ do
        Maybe (IO ())
cont <- Request -> Connection -> IO (Maybe (IO ()))
requestBuilder (Request -> Request
dropProxyAuthSecure Request
req) (forall resource. Managed resource -> resource
managedResource Managed Connection
mconn)

        Maybe MaxHeaderLength
-> Maybe Int
-> Request
-> Managed Connection
-> Maybe (IO ())
-> IO (Response BodyReader)
getResponse (Manager -> Maybe MaxHeaderLength
mMaxHeaderLength Manager
m) Maybe Int
timeout' Request
req Managed Connection
mconn Maybe (IO ())
cont

    case Either SomeException (Response BodyReader)
ex of
        -- Connection was reused, and might have been closed. Try again
        Left SomeException
e | forall resource. Managed resource -> Bool
managedReused Managed Connection
mconn Bool -> Bool -> Bool
&& Manager -> SomeException -> Bool
mRetryableException Manager
m SomeException
e -> do
            forall resource. Managed resource -> Reuse -> IO ()
managedRelease Managed Connection
mconn Reuse
DontReuse
            Request -> Manager -> IO (Request, Response BodyReader)
httpRaw' Request
req Manager
m
        -- Not reused, or a non-retry, so this is a real exception
        Left SomeException
e -> do
          -- Explicitly release connection for all real exceptions:
          -- https://github.com/snoyberg/http-client/pull/454
          forall resource. Managed resource -> Reuse -> IO ()
managedRelease Managed Connection
mconn Reuse
DontReuse
          forall e a. Exception e => e -> IO a
throwIO SomeException
e
        -- Everything went ok, so the connection is good. If any exceptions get
        -- thrown in the response body, just throw them as normal.
        Right Response BodyReader
res -> case Request -> Maybe CookieJar
cookieJar Request
req' of
            Just CookieJar
_ -> do
                UTCTime
now' <- IO UTCTime
getCurrentTime
                let (CookieJar
cookie_jar, Response BodyReader
_) = forall a.
Response a
-> Request -> UTCTime -> CookieJar -> (CookieJar, Response a)
updateCookieJar Response BodyReader
res Request
req UTCTime
now' CookieJar
cookie_jar'
                forall (m :: * -> *) a. Monad m => a -> m a
return (Request
req, Response BodyReader
res {responseCookieJar :: CookieJar
responseCookieJar = CookieJar
cookie_jar})
            Maybe CookieJar
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (Request
req, Response BodyReader
res)
  where
    getConnectionWrapper :: Maybe Int
-> IO (Managed resource) -> IO (Maybe a, Managed resource)
getConnectionWrapper Maybe Int
mtimeout IO (Managed resource)
f =
        case Maybe Int
mtimeout of
            Maybe Int
Nothing -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((,) forall a. Maybe a
Nothing) IO (Managed resource)
f
            Just Int
timeout' -> do
                UTCTime
before <- IO UTCTime
getCurrentTime
                Maybe (Managed resource)
mres <- forall a. Int -> IO a -> IO (Maybe a)
timeout Int
timeout' IO (Managed resource)
f
                case Maybe (Managed resource)
mres of
                     Maybe (Managed resource)
Nothing -> forall a. HttpExceptionContent -> IO a
throwHttp HttpExceptionContent
ConnectionTimeout
                     Just Managed resource
mConn -> do
                         UTCTime
now <- IO UTCTime
getCurrentTime
                         let timeSpentMicro :: NominalDiffTime
timeSpentMicro = UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
now UTCTime
before forall a. Num a => a -> a -> a
* NominalDiffTime
1000000
                             remainingTime :: a
remainingTime = forall a b. (RealFrac a, Integral b) => a -> b
round forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
timeout' forall a. Num a => a -> a -> a
- NominalDiffTime
timeSpentMicro
                         if a
remainingTime forall a. Ord a => a -> a -> Bool
<= a
0
                             then do
                                 forall resource. Managed resource -> Reuse -> IO ()
managedRelease Managed resource
mConn Reuse
DontReuse
                                 forall a. HttpExceptionContent -> IO a
throwHttp HttpExceptionContent
ConnectionTimeout
                             else forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just a
remainingTime, Managed resource
mConn)

    responseTimeout' :: Request -> Maybe Int
responseTimeout' Request
req =
        case Request -> ResponseTimeout
responseTimeout Request
req of
            ResponseTimeout
ResponseTimeoutDefault ->
                case Manager -> ResponseTimeout
mResponseTimeout Manager
m of
                    ResponseTimeout
ResponseTimeoutDefault -> forall a. a -> Maybe a
Just Int
30000000
                    ResponseTimeout
ResponseTimeoutNone -> forall a. Maybe a
Nothing
                    ResponseTimeoutMicro Int
u -> forall a. a -> Maybe a
Just Int
u
            ResponseTimeout
ResponseTimeoutNone -> forall a. Maybe a
Nothing
            ResponseTimeoutMicro Int
u -> forall a. a -> Maybe a
Just Int
u

-- | The used Manager can be overridden (by requestManagerOverride) and the used
-- Request can be modified (through managerModifyRequest). This function allows
-- to retrieve the possibly overridden Manager and the possibly modified
-- Request.
--
-- (In case the Manager is overridden by requestManagerOverride, the Request is
-- being modified by managerModifyRequest of the new Manager, not the old one.)
getModifiedRequestManager :: Manager -> Request -> IO (Manager, Request)
getModifiedRequestManager :: Manager -> Request -> IO (Manager, Request)
getModifiedRequestManager Manager
manager0 Request
req0 = do
  let manager :: Manager
manager = forall a. a -> Maybe a -> a
fromMaybe Manager
manager0 (Request -> Maybe Manager
requestManagerOverride Request
req0)
  Request
req <- Manager -> Request -> IO Request
mModifyRequest Manager
manager Request
req0
  forall (m :: * -> *) a. Monad m => a -> m a
return (Manager
manager, Request
req)

-- | The most low-level function for initiating an HTTP request.
--
-- The first argument to this function gives a full specification
-- on the request: the host to connect to, whether to use SSL,
-- headers, etc. Please see 'Request' for full details.  The
-- second argument specifies which 'Manager' should be used.
--
-- This function then returns a 'Response' with a
-- 'BodyReader'.  The 'Response' contains the status code
-- and headers that were sent back to us, and the
-- 'BodyReader' contains the body of the request.  Note
-- that this 'BodyReader' allows you to have fully
-- interleaved IO actions during your HTTP download, making it
-- possible to download very large responses in constant memory.
--
-- An important note: the response body returned by this function represents a
-- live HTTP connection. As such, if you do not use the response body, an open
-- socket will be retained indefinitely. You must be certain to call
-- 'responseClose' on this response to free up resources.
--
-- This function automatically performs any necessary redirects, as specified
-- by the 'redirectCount' setting.
--
-- When implementing a (reverse) proxy using this function or relating
-- functions, it's wise to remove Transfer-Encoding:, Content-Length:,
-- Content-Encoding: and Accept-Encoding: from request and response
-- headers to be relayed.
--
-- Since 0.1.0
responseOpen :: Request -> Manager -> IO (Response BodyReader)
responseOpen :: Request -> Manager -> IO (Response BodyReader)
responseOpen Request
inputReq Manager
manager' = do
  case RequestHeaders -> HeadersValidationResult
validateHeaders (Request -> RequestHeaders
requestHeaders Request
inputReq) of
    HeadersValidationResult
GoodHeaders -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    BadHeaders ByteString
reason -> forall a. HttpExceptionContent -> IO a
throwHttp forall a b. (a -> b) -> a -> b
$ ByteString -> HttpExceptionContent
InvalidRequestHeader ByteString
reason
  (Manager
manager, Request
req0) <- Manager -> Request -> IO (Manager, Request)
getModifiedRequestManager Manager
manager' Request
inputReq
  forall a. Request -> IO a -> IO a
wrapExc Request
req0 forall a b. (a -> b) -> a -> b
$ Manager -> forall a. Request -> IO a -> IO a
mWrapException Manager
manager Request
req0 forall a b. (a -> b) -> a -> b
$ do
    (Request
req, Response BodyReader
res) <- Manager -> Int -> Request -> IO (Request, Response BodyReader)
go Manager
manager (Request -> Int
redirectCount Request
req0) Request
req0
    Request -> Request -> Response BodyReader -> IO ()
checkResponse Request
req Request
req Response BodyReader
res
    Manager -> Response BodyReader -> IO (Response BodyReader)
mModifyResponse Manager
manager Response BodyReader
res
        { responseBody :: BodyReader
responseBody = forall a. Request -> IO a -> IO a
wrapExc Request
req0 (forall body. Response body -> body
responseBody Response BodyReader
res)
        }
  where
    wrapExc :: Request -> IO a -> IO a
    wrapExc :: forall a. Request -> IO a -> IO a
wrapExc Request
req0 = forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> HttpExceptionContentWrapper -> HttpException
toHttpException Request
req0

    go :: Manager -> Int -> Request -> IO (Request, Response BodyReader)
go Manager
manager0 Int
count Request
req' = Int
-> (Request -> IO (Response BodyReader, Request, Bool))
-> Request
-> IO (Request, Response BodyReader)
httpRedirect'
      Int
count
      (\Request
req -> do
        (Manager
manager, Request
modReq) <- Manager -> Request -> IO (Manager, Request)
getModifiedRequestManager Manager
manager0 Request
req
        (Request
req'', Response BodyReader
res) <- Request -> Manager -> IO (Request, Response BodyReader)
httpRaw' Request
modReq Manager
manager
        let mreq :: Maybe Request
mreq = if Request -> Int
redirectCount Request
modReq forall a. Eq a => a -> a -> Bool
== Int
0
              then forall a. Maybe a
Nothing
              else Request
-> Request -> RequestHeaders -> CookieJar -> Int -> Maybe Request
getRedirectedRequest Request
req' Request
req'' (forall body. Response body -> RequestHeaders
responseHeaders Response BodyReader
res) (forall body. Response body -> CookieJar
responseCookieJar Response BodyReader
res) (Status -> Int
statusCode (forall body. Response body -> Status
responseStatus Response BodyReader
res))
        forall (m :: * -> *) a. Monad m => a -> m a
return (Response BodyReader
res, forall a. a -> Maybe a -> a
fromMaybe Request
req'' Maybe Request
mreq, forall a. Maybe a -> Bool
isJust Maybe Request
mreq))
      Request
req'

-- | 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 :: Int
-> (Request -> IO (Response BodyReader, Maybe Request))
-> Request
-> IO (Response BodyReader)
httpRedirect Int
count0 Request -> IO (Response BodyReader, Maybe Request)
http0 Request
req0 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ Int
-> (Request -> IO (Response BodyReader, Request, Bool))
-> Request
-> IO (Request, Response BodyReader)
httpRedirect' Int
count0 Request -> IO (Response BodyReader, Request, Bool)
http' Request
req0
  where
    -- adapt callback API
    http' :: Request -> IO (Response BodyReader, Request, Bool)
http' Request
req' = do
        (Response BodyReader
res, Maybe Request
mbReq) <- Request -> IO (Response BodyReader, Maybe Request)
http0 Request
req'
        forall (m :: * -> *) a. Monad m => a -> m a
return (Response BodyReader
res, forall a. a -> Maybe a -> a
fromMaybe Request
req0 Maybe Request
mbReq, forall a. Maybe a -> Bool
isJust Maybe Request
mbReq)

handleClosedRead :: SomeException -> IO L.ByteString
handleClosedRead :: SomeException -> IO ByteString
handleClosedRead SomeException
se
    | Just HttpExceptionContent
ConnectionClosed <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HttpExceptionContentWrapper -> HttpExceptionContent
unHttpExceptionContentWrapper (forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se)
        = forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
L.empty
    | Just (HttpExceptionRequest Request
_ HttpExceptionContent
ConnectionClosed) <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se
        = forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
L.empty
    | Just (IOError Maybe Handle
_ IOErrorType
ResourceVanished String
_ String
_ Maybe CInt
_ Maybe String
_) <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se
        = forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
L.empty
    | Bool
otherwise
        = forall e a. Exception e => e -> IO a
throwIO SomeException
se

-- | 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' :: Int
-> (Request -> IO (Response BodyReader, Request, Bool))
-> Request
-> IO (Request, Response BodyReader)
httpRedirect' Int
count0 Request -> IO (Response BodyReader, Request, Bool)
http' Request
req0 = forall {t}.
(Ord t, Num t) =>
t
-> Request
-> [Response ByteString]
-> IO (Request, Response BodyReader)
go Int
count0 Request
req0 []
  where
    go :: t
-> Request
-> [Response ByteString]
-> IO (Request, Response BodyReader)
go t
count Request
_ [Response ByteString]
ress | t
count forall a. Ord a => a -> a -> Bool
< t
0 = forall a. HttpExceptionContent -> IO a
throwHttp forall a b. (a -> b) -> a -> b
$ [Response ByteString] -> HttpExceptionContent
TooManyRedirects [Response ByteString]
ress
    go t
count Request
req' [Response ByteString]
ress = do
        (Response BodyReader
res, Request
req, Bool
isRedirect) <- Request -> IO (Response BodyReader, Request, Bool)
http' Request
req'
        if Bool
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 :: Int
maxFlush = Int
1024
            ByteString
lbs <- BodyReader -> Int -> IO ByteString
brReadSome (forall body. Response body -> body
responseBody Response BodyReader
res) Int
maxFlush
                -- The connection may already be closed, e.g.
                -- when using withResponseHistory. See
                -- https://github.com/snoyberg/http-client/issues/169
                forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Control.Exception.catch` SomeException -> IO ByteString
handleClosedRead
            forall a. Response a -> IO ()
responseClose Response BodyReader
res

            -- And now perform the actual redirect
            t
-> Request
-> [Response ByteString]
-> IO (Request, Response BodyReader)
go (t
count forall a. Num a => a -> a -> a
- t
1) Request
req (Response BodyReader
res { responseBody :: ByteString
responseBody = ByteString
lbs }forall a. a -> [a] -> [a]
:[Response ByteString]
ress)
        else
            forall (m :: * -> *) a. Monad m => a -> m a
return (Request
req, Response BodyReader
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@
-- to be reused.
--
-- Since 0.1.0
responseClose :: Response a -> IO ()
responseClose :: forall a. Response a -> IO ()
responseClose = ResponseClose -> IO ()
runResponseClose forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall body. Response body -> ResponseClose
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 :: forall a. Request -> Manager -> (Connection -> IO a) -> IO a
withConnection Request
origReq Manager
man Connection -> IO a
action = do
    Managed Connection
mHttpConn <- Request -> Manager -> IO (Managed Connection)
getConn (Manager -> Request -> Request
mSetProxy Manager
man Request
origReq) Manager
man
    Connection -> IO a
action (forall resource. Managed resource -> resource
managedResource Managed Connection
mHttpConn) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall resource. Managed resource -> IO ()
keepAlive Managed Connection
mHttpConn
        forall a b. IO a -> IO b -> IO a
`finally` forall resource. Managed resource -> Reuse -> IO ()
managedRelease Managed Connection
mHttpConn Reuse
DontReuse