{-# 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(..))
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 = IO (Response BodyReader)
-> (Response BodyReader -> IO ())
-> (Response BodyReader -> IO a)
-> IO a
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) Response BodyReader -> IO ()
forall a. Response a -> IO ()
responseClose Response BodyReader -> IO a
f
httpLbs :: Request -> Manager -> IO (Response L.ByteString)
httpLbs :: Request -> Manager -> IO (Response ByteString)
httpLbs Request
req Manager
man = Request
-> Manager
-> (Response BodyReader -> IO (Response ByteString))
-> IO (Response ByteString)
forall a.
Request -> Manager -> (Response BodyReader -> IO a) -> IO a
withResponse Request
req Manager
man ((Response BodyReader -> IO (Response ByteString))
-> IO (Response ByteString))
-> (Response BodyReader -> IO (Response ByteString))
-> IO (Response ByteString)
forall a b. (a -> b) -> a -> b
$ \Response BodyReader
res -> do
bss <- BodyReader -> IO [ByteString]
brConsume (BodyReader -> IO [ByteString]) -> BodyReader -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ Response BodyReader -> BodyReader
forall body. Response body -> body
responseBody Response BodyReader
res
return res { responseBody = L.fromChunks bss }
httpNoBody :: Request -> Manager -> IO (Response ())
httpNoBody :: Request -> Manager -> IO (Response ())
httpNoBody Request
req Manager
man = Request
-> Manager
-> (Response BodyReader -> IO (Response ()))
-> IO (Response ())
forall a.
Request -> Manager -> (Response BodyReader -> IO a) -> IO a
withResponse Request
req Manager
man ((Response BodyReader -> IO (Response ())) -> IO (Response ()))
-> (Response BodyReader -> IO (Response ())) -> IO (Response ())
forall a b. (a -> b) -> a -> b
$ Response () -> IO (Response ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Response () -> IO (Response ()))
-> (Response BodyReader -> Response ())
-> Response BodyReader
-> IO (Response ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response BodyReader -> Response ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
httpRaw
:: Request
-> Manager
-> IO (Response BodyReader)
httpRaw :: Request -> Manager -> IO (Response BodyReader)
httpRaw = (IO (Request, Response BodyReader) -> IO (Response BodyReader))
-> (Manager -> IO (Request, Response BodyReader))
-> Manager
-> IO (Response BodyReader)
forall a b. (a -> b) -> (Manager -> a) -> Manager -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Request, Response BodyReader) -> Response BodyReader)
-> IO (Request, Response BodyReader) -> IO (Response BodyReader)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Request, Response BodyReader) -> Response BodyReader
forall a b. (a, b) -> b
snd) ((Manager -> IO (Request, Response BodyReader))
-> Manager -> IO (Response BodyReader))
-> (Request -> Manager -> IO (Request, Response BodyReader))
-> Request
-> Manager
-> IO (Response BodyReader)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Manager -> IO (Request, Response BodyReader)
httpRaw'
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
(req, cookie_jar') <- case Request -> Maybe CookieJar
cookieJar Request
req' of
Just CookieJar
cj -> do
now <- IO UTCTime
getCurrentTime
return $ insertCookiesIntoRequest req' (evictExpiredCookies cj now) now
Maybe CookieJar
Nothing -> (Request, CookieJar) -> IO (Request, CookieJar)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Request
req', CookieJar
forall a. Monoid a => a
Data.Monoid.mempty)
(timeout', mconn) <- getConnectionWrapper
(responseTimeout' req)
(getConn req m)
ex <- try $ do
cont <- requestBuilder (dropProxyAuthSecure req) (managedResource mconn)
getResponse (mMaxHeaderLength m) (mMaxNumberHeaders m) timeout' req mconn cont
case ex of
Left SomeException
e | Managed Connection -> Bool
forall resource. Managed resource -> Bool
managedReused Managed Connection
mconn Bool -> Bool -> Bool
&& Manager -> SomeException -> Bool
mRetryableException Manager
m SomeException
e -> do
Managed Connection -> Reuse -> IO ()
forall resource. Managed resource -> Reuse -> IO ()
managedRelease Managed Connection
mconn Reuse
DontReuse
Request -> Manager -> IO (Request, Response BodyReader)
httpRaw' Request
req Manager
m
Left SomeException
e -> do
Managed Connection -> Reuse -> IO ()
forall resource. Managed resource -> Reuse -> IO ()
managedRelease Managed Connection
mconn Reuse
DontReuse
SomeException -> IO (Request, Response BodyReader)
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO SomeException
e
Right Response BodyReader
res -> case Request -> Maybe CookieJar
cookieJar Request
req' of
Just CookieJar
_ -> do
now' <- IO UTCTime
getCurrentTime
let (cookie_jar, _) = updateCookieJar res req now' cookie_jar'
return (req, res {responseCookieJar = cookie_jar})
Maybe CookieJar
Nothing -> (Request, Response BodyReader) -> IO (Request, Response BodyReader)
forall a. a -> IO a
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 -> (Managed resource -> (Maybe a, Managed resource))
-> IO (Managed resource) -> IO (Maybe a, Managed resource)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((,) Maybe a
forall a. Maybe a
Nothing) IO (Managed resource)
f
Just Int
timeout' -> do
before <- IO UTCTime
getCurrentTime
mres <- timeout timeout' f
case mres of
Maybe (Managed resource)
Nothing -> HttpExceptionContent -> IO (Maybe a, Managed resource)
forall a. HttpExceptionContent -> IO a
throwHttp HttpExceptionContent
ConnectionTimeout
Just Managed resource
mConn -> do
now <- IO UTCTime
getCurrentTime
let timeSpentMicro = UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
now UTCTime
before NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
1000000
remainingTime = NominalDiffTime -> a
forall b. Integral b => NominalDiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (NominalDiffTime -> a) -> NominalDiffTime -> a
forall a b. (a -> b) -> a -> b
$ Int -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
timeout' NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
- NominalDiffTime
timeSpentMicro
if remainingTime <= 0
then do
managedRelease mConn DontReuse
throwHttp ConnectionTimeout
else return (Just remainingTime, 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 -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
30000000
ResponseTimeout
ResponseTimeoutNone -> Maybe Int
forall a. Maybe a
Nothing
ResponseTimeoutMicro Int
u -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
u
ResponseTimeout
ResponseTimeoutNone -> Maybe Int
forall a. Maybe a
Nothing
ResponseTimeoutMicro Int
u -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
u
getModifiedRequestManager :: Manager -> Request -> IO (Manager, Request)
getModifiedRequestManager :: Manager -> Request -> IO (Manager, Request)
getModifiedRequestManager Manager
manager0 Request
req0 = do
let manager :: Manager
manager = Manager -> Maybe Manager -> Manager
forall a. a -> Maybe a -> a
fromMaybe Manager
manager0 (Request -> Maybe Manager
requestManagerOverride Request
req0)
req <- Manager -> Request -> IO Request
mModifyRequest Manager
manager Request
req0
return (manager, req)
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 -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
BadHeaders ByteString
reason -> HttpExceptionContent -> IO ()
forall a. HttpExceptionContent -> IO a
throwHttp (HttpExceptionContent -> IO ()) -> HttpExceptionContent -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> HttpExceptionContent
InvalidRequestHeader ByteString
reason
(manager, req0) <- Manager -> Request -> IO (Manager, Request)
getModifiedRequestManager Manager
manager' Request
inputReq
wrapExc req0 $ mWrapException manager req0 $ do
(req, res) <- go manager (redirectCount req0) req0
checkResponse req req res
mModifyResponse manager res
{ responseBody = wrapExc req0 (responseBody res)
}
where
wrapExc :: Request -> IO a -> IO a
wrapExc :: forall a. Request -> IO a -> IO a
wrapExc Request
req0 = (HttpExceptionContentWrapper -> IO a) -> IO a -> IO a
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle ((HttpExceptionContentWrapper -> IO a) -> IO a -> IO a)
-> (HttpExceptionContentWrapper -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ HttpException -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (HttpException -> IO a)
-> (HttpExceptionContentWrapper -> HttpException)
-> HttpExceptionContentWrapper
-> IO a
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, modReq) <- Manager -> Request -> IO (Manager, Request)
getModifiedRequestManager Manager
manager0 Request
req
(req'', res) <- httpRaw' modReq manager
let mreq = if Request -> Int
redirectCount Request
modReq Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
then Maybe Request
forall a. Maybe a
Nothing
else Request
-> Request -> RequestHeaders -> CookieJar -> Int -> Maybe Request
getRedirectedRequest Request
req' Request
req'' (Response BodyReader -> RequestHeaders
forall body. Response body -> RequestHeaders
responseHeaders Response BodyReader
res) (Response BodyReader -> CookieJar
forall body. Response body -> CookieJar
responseCookieJar Response BodyReader
res) (Status -> Int
statusCode (Response BodyReader -> Status
forall body. Response body -> Status
responseStatus Response BodyReader
res))
return (res, fromMaybe req'' mreq, isJust mreq))
Request
req'
httpRedirect
:: Int
-> (Request -> IO (Response BodyReader, Maybe Request))
-> 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 = ((Request, Response BodyReader) -> Response BodyReader)
-> IO (Request, Response BodyReader) -> IO (Response BodyReader)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Request, Response BodyReader) -> Response BodyReader
forall a b. (a, b) -> b
snd (IO (Request, Response BodyReader) -> IO (Response BodyReader))
-> IO (Request, Response BodyReader) -> IO (Response BodyReader)
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
http' :: Request -> IO (Response BodyReader, Request, Bool)
http' Request
req' = do
(res, mbReq) <- Request -> IO (Response BodyReader, Maybe Request)
http0 Request
req'
return (res, fromMaybe req0 mbReq, isJust mbReq)
handleClosedRead :: SomeException -> IO L.ByteString
handleClosedRead :: SomeException -> IO ByteString
handleClosedRead SomeException
se
| Just HttpExceptionContent
ConnectionClosed <- (HttpExceptionContentWrapper -> HttpExceptionContent)
-> Maybe HttpExceptionContentWrapper -> Maybe HttpExceptionContent
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HttpExceptionContentWrapper -> HttpExceptionContent
unHttpExceptionContentWrapper (SomeException -> Maybe HttpExceptionContentWrapper
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se)
= ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
L.empty
| Just (HttpExceptionRequest Request
_ HttpExceptionContent
ConnectionClosed) <- SomeException -> Maybe HttpException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se
= ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
L.empty
| Just (IOError Maybe Handle
_ IOErrorType
ResourceVanished String
_ String
_ Maybe CInt
_ Maybe String
_) <- SomeException -> Maybe IOException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se
= ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
L.empty
| Bool
otherwise
= SomeException -> IO ByteString
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO SomeException
se
httpRedirect'
:: Int
-> (Request -> IO (Response BodyReader, Request, Bool))
-> 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 = Int
-> Request
-> [Response ByteString]
-> IO (Request, Response BodyReader)
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 t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< t
0 = HttpExceptionContent -> IO (Request, Response BodyReader)
forall a. HttpExceptionContent -> IO a
throwHttp (HttpExceptionContent -> IO (Request, Response BodyReader))
-> HttpExceptionContent -> IO (Request, Response BodyReader)
forall a b. (a -> b) -> a -> b
$ [Response ByteString] -> HttpExceptionContent
TooManyRedirects [Response ByteString]
ress
go t
count Request
req' [Response ByteString]
ress = do
(res, req, isRedirect) <- Request -> IO (Response BodyReader, Request, Bool)
http' Request
req'
if isRedirect then do
let maxFlush = Int
1024
lbs <- brReadSome (responseBody res) maxFlush
`Control.Exception.catch` handleClosedRead
responseClose res
go (count - 1) req (res { responseBody = lbs }:ress)
else
return (req, res)
responseClose :: Response a -> IO ()
responseClose :: forall a. Response a -> IO ()
responseClose = ResponseClose -> IO ()
runResponseClose (ResponseClose -> IO ())
-> (Response a -> ResponseClose) -> Response a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response a -> ResponseClose
forall body. Response body -> ResponseClose
responseClose'
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
mHttpConn <- Request -> Manager -> IO (Managed Connection)
getConn (Manager -> Request -> Request
mSetProxy Manager
man Request
origReq) Manager
man
action (managedResource mHttpConn) <* keepAlive mHttpConn
`finally` managedRelease mHttpConn DontReuse