{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.HTTP.Client.Core
( withResponse
, httpLbs
, httpNoBody
, httpRaw
, httpRaw'
, requestAction
, 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 Data.IORef
import Control.Exception
import qualified Data.ByteString.Lazy as L
import Data.Monoid
import Control.Monad (void)
import System.Timeout (timeout)
import System.IO.Unsafe (unsafePerformIO)
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)
res <- makeRequest req m
case cookieJar 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)
makeRequest
:: Request
-> Manager
-> IO (Response BodyReader)
makeRequest :: Request -> Manager -> IO (Response BodyReader)
makeRequest Request
req Manager
m = do
action <- IORef (Request -> Manager -> IO (Response BodyReader))
-> IO (Request -> Manager -> IO (Response BodyReader))
forall a. IORef a -> IO a
readIORef IORef (Request -> Manager -> IO (Response BodyReader))
requestAction
action req m
requestAction :: IORef (Request -> Manager -> IO (Response BodyReader))
{-# NOINLINE requestAction #-}
requestAction :: IORef (Request -> Manager -> IO (Response BodyReader))
requestAction = IO (IORef (Request -> Manager -> IO (Response BodyReader)))
-> IORef (Request -> Manager -> IO (Response BodyReader))
forall a. IO a -> a
unsafePerformIO ((Request -> Manager -> IO (Response BodyReader))
-> IO (IORef (Request -> Manager -> IO (Response BodyReader)))
forall a. a -> IO (IORef a)
newIORef Request -> Manager -> IO (Response BodyReader)
action)
where
action
:: Request
-> Manager
-> IO (Response BodyReader)
action :: Request -> Manager -> IO (Response BodyReader)
action Request
req Manager
m = do
(timeout', mconn) <- Maybe Int
-> IO (Managed Connection) -> IO (Maybe Int, Managed Connection)
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)
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 (Response BodyReader)
action 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 (Response BodyReader)
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO SomeException
e
Right Response BodyReader
res -> Response BodyReader -> IO (Response BodyReader)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return 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