{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Network.HTTP.Client.Response
( getRedirectedRequest
, getResponse
, lbsResponse
, getOriginalRequest
) where
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import qualified Data.CaseInsensitive as CI
import Control.Arrow (second)
import Data.Monoid (mempty)
import Data.List (nubBy)
import qualified Network.HTTP.Types as W
import Network.URI (parseURIReference, escapeURIString, isAllowedInURI)
import Network.HTTP.Client.Types
import Network.HTTP.Client.Request
import Network.HTTP.Client.Util
import Network.HTTP.Client.Body
import Network.HTTP.Client.Headers
import Data.KeyedPool
getRedirectedRequest :: Request -> Request -> W.ResponseHeaders -> CookieJar -> Int -> Maybe Request
getRedirectedRequest :: Request
-> Request -> ResponseHeaders -> CookieJar -> Int -> Maybe Request
getRedirectedRequest Request
origReq Request
req ResponseHeaders
hs CookieJar
cookie_jar Int
code
| Int
300 forall a. Ord a => a -> a -> Bool
<= Int
code Bool -> Bool -> Bool
&& Int
code forall a. Ord a => a -> a -> Bool
< Int
400 = do
ByteString
l' <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"location" ResponseHeaders
hs
let l :: String
l = (Char -> Bool) -> String -> String
escapeURIString Char -> Bool
isAllowedInURI (ByteString -> String
S8.unpack ByteString
l')
Request
req' <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Request -> Request
stripHeaders forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadThrow m => Request -> URI -> m Request
setUriRelative Request
req forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Maybe URI
parseURIReference String
l
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
if Int
code forall a. Eq a => a -> a -> Bool
== Int
302 Bool -> Bool -> Bool
|| Int
code forall a. Eq a => a -> a -> Bool
== Int
303
then Request
req'
{ method :: ByteString
method = ByteString
"GET"
, requestBody :: RequestBody
requestBody = ByteString -> RequestBody
RequestBodyBS ByteString
""
, cookieJar :: Maybe CookieJar
cookieJar = Maybe CookieJar
cookie_jar'
, requestHeaders :: ResponseHeaders
requestHeaders = forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
/= HeaderName
W.hContentType) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ Request -> ResponseHeaders
requestHeaders Request
req'
}
else Request
req' {cookieJar :: Maybe CookieJar
cookieJar = Maybe CookieJar
cookie_jar'}
| Bool
otherwise = forall a. Maybe a
Nothing
where
cookie_jar' :: Maybe CookieJar
cookie_jar' :: Maybe CookieJar
cookie_jar' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const CookieJar
cookie_jar) forall a b. (a -> b) -> a -> b
$ Request -> Maybe CookieJar
cookieJar Request
req
hostDiffer :: Request -> Bool
hostDiffer :: Request -> Bool
hostDiffer Request
req = Request -> ByteString
host Request
origReq forall a. Eq a => a -> a -> Bool
/= Request -> ByteString
host Request
req
shouldStripOnlyIfHostDiffer :: Bool
shouldStripOnlyIfHostDiffer :: Bool
shouldStripOnlyIfHostDiffer = Request -> Bool
shouldStripHeaderOnRedirectIfOnDifferentHostOnly Request
req
mergeHeaders :: W.RequestHeaders -> W.RequestHeaders -> W.RequestHeaders
mergeHeaders :: ResponseHeaders -> ResponseHeaders -> ResponseHeaders
mergeHeaders ResponseHeaders
lhs ResponseHeaders
rhs = forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (\(HeaderName
a, ByteString
_) (HeaderName
a', ByteString
_) -> HeaderName
a forall a. Eq a => a -> a -> Bool
== HeaderName
a') (ResponseHeaders
lhs forall a. [a] -> [a] -> [a]
++ ResponseHeaders
rhs)
stripHeaders :: Request -> Request
stripHeaders :: Request -> Request
stripHeaders Request
r = do
case (Request -> Bool
hostDiffer Request
r, Bool
shouldStripOnlyIfHostDiffer) of
(Bool
True, Bool
True) -> Request -> Request
stripHeaders' Request
r
(Bool
True, Bool
False) -> Request -> Request
stripHeaders' Request
r
(Bool
False, Bool
False) -> Request -> Request
stripHeaders' Request
r
(Bool
False, Bool
True) -> do
let strippedHeaders :: ResponseHeaders
strippedHeaders = forall a. (a -> Bool) -> [a] -> [a]
filter (Request -> HeaderName -> Bool
shouldStripHeaderOnRedirect Request
r forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) (Request -> ResponseHeaders
requestHeaders Request
origReq)
Request
r{requestHeaders :: ResponseHeaders
requestHeaders = ResponseHeaders -> ResponseHeaders -> ResponseHeaders
mergeHeaders (Request -> ResponseHeaders
requestHeaders Request
r) ResponseHeaders
strippedHeaders}
stripHeaders' :: Request -> Request
stripHeaders' :: Request -> Request
stripHeaders' Request
r = Request
r{requestHeaders :: ResponseHeaders
requestHeaders =
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> HeaderName -> Bool
shouldStripHeaderOnRedirect Request
req forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$
Request -> ResponseHeaders
requestHeaders Request
r}
lbsResponse :: Response BodyReader -> IO (Response L.ByteString)
lbsResponse :: Response BodyReader -> IO (Response ByteString)
lbsResponse 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
}
getResponse :: Maybe MaxHeaderLength
-> Maybe Int
-> Request
-> Managed Connection
-> Maybe (IO ())
-> IO (Response BodyReader)
getResponse :: Maybe MaxHeaderLength
-> Maybe Int
-> Request
-> Managed Connection
-> Maybe (IO ())
-> IO (Response BodyReader)
getResponse Maybe MaxHeaderLength
mhl Maybe Int
timeout' req :: Request
req@(Request {Bool
Int
ResponseHeaders
Maybe HostAddress
Maybe Manager
Maybe Proxy
Maybe CookieJar
ByteString
Set HeaderName
HttpVersion
ResponseTimeout
RequestBody
ProxySecureMode
ByteString -> Bool
SomeException -> IO ()
HeaderName -> Bool
Request -> Response BodyReader -> IO ()
redactHeaders :: Request -> Set HeaderName
proxySecureMode :: Request -> ProxySecureMode
requestManagerOverride :: Request -> Maybe Manager
onRequestBodyException :: Request -> SomeException -> IO ()
requestVersion :: Request -> HttpVersion
responseTimeout :: Request -> ResponseTimeout
checkResponse :: Request -> Request -> Response BodyReader -> IO ()
redirectCount :: Request -> Int
decompress :: Request -> ByteString -> Bool
rawBody :: Request -> Bool
hostAddress :: Request -> Maybe HostAddress
proxy :: Request -> Maybe Proxy
queryString :: Request -> ByteString
path :: Request -> ByteString
port :: Request -> Int
secure :: Request -> Bool
redactHeaders :: Set HeaderName
proxySecureMode :: ProxySecureMode
shouldStripHeaderOnRedirectIfOnDifferentHostOnly :: Bool
shouldStripHeaderOnRedirect :: HeaderName -> Bool
requestManagerOverride :: Maybe Manager
onRequestBodyException :: SomeException -> IO ()
requestVersion :: HttpVersion
cookieJar :: Maybe CookieJar
responseTimeout :: ResponseTimeout
checkResponse :: Request -> Response BodyReader -> IO ()
redirectCount :: Int
decompress :: ByteString -> Bool
rawBody :: Bool
hostAddress :: Maybe HostAddress
proxy :: Maybe Proxy
requestBody :: RequestBody
requestHeaders :: ResponseHeaders
queryString :: ByteString
path :: ByteString
port :: Int
host :: ByteString
secure :: Bool
method :: ByteString
shouldStripHeaderOnRedirect :: Request -> HeaderName -> Bool
shouldStripHeaderOnRedirectIfOnDifferentHostOnly :: Request -> Bool
host :: Request -> ByteString
requestHeaders :: Request -> ResponseHeaders
cookieJar :: Request -> Maybe CookieJar
requestBody :: Request -> RequestBody
method :: Request -> ByteString
..}) Managed Connection
mconn Maybe (IO ())
cont = do
let conn :: Connection
conn = forall resource. Managed resource -> resource
managedResource Managed Connection
mconn
StatusHeaders Status
s HttpVersion
version ResponseHeaders
hs <- Maybe MaxHeaderLength
-> Connection -> Maybe Int -> Maybe (IO ()) -> IO StatusHeaders
parseStatusHeaders Maybe MaxHeaderLength
mhl Connection
conn Maybe Int
timeout' Maybe (IO ())
cont
let mcl :: Maybe Int
mcl = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"content-length" ResponseHeaders
hs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe Int
readPositiveInt forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
S8.unpack
isChunked :: Bool
isChunked = (HeaderName
"transfer-encoding", forall s. FoldCase s => s -> CI s
CI.mk ByteString
"chunked") forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall s. FoldCase s => s -> CI s
CI.mk) ResponseHeaders
hs
toPut :: Bool
toPut = forall a. a -> Maybe a
Just ByteString
"close" forall a. Eq a => a -> a -> Bool
/= forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"connection" ResponseHeaders
hs Bool -> Bool -> Bool
&& HttpVersion
version forall a. Ord a => a -> a -> Bool
> Int -> Int -> HttpVersion
W.HttpVersion Int
1 Int
0
cleanup :: Bool -> IO ()
cleanup Bool
bodyConsumed = do
forall resource. Managed resource -> Reuse -> IO ()
managedRelease Managed Connection
mconn forall a b. (a -> b) -> a -> b
$ if Bool
toPut Bool -> Bool -> Bool
&& Bool
bodyConsumed then Reuse
Reuse else Reuse
DontReuse
forall resource. Managed resource -> IO ()
keepAlive Managed Connection
mconn
BodyReader
body <-
if ByteString -> Int -> Bool
hasNoBody ByteString
method (Status -> Int
W.statusCode Status
s) Bool -> Bool -> Bool
|| (Maybe Int
mcl forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Int
0 Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isChunked)
then do
Bool -> IO ()
cleanup Bool
True
forall (m :: * -> *) a. Monad m => a -> m a
return BodyReader
brEmpty
else do
BodyReader
body1 <-
if Bool
isChunked
then Maybe MaxHeaderLength
-> IO () -> Bool -> Connection -> IO BodyReader
makeChunkedReader Maybe MaxHeaderLength
mhl (Bool -> IO ()
cleanup Bool
True) Bool
rawBody Connection
conn
else
case Maybe Int
mcl of
Just Int
len -> IO () -> Int -> Connection -> IO BodyReader
makeLengthReader (Bool -> IO ()
cleanup Bool
True) Int
len Connection
conn
Maybe Int
Nothing -> IO () -> Connection -> IO BodyReader
makeUnlimitedReader (Bool -> IO ()
cleanup Bool
True) Connection
conn
if Request -> ResponseHeaders -> Bool
needsGunzip Request
req ResponseHeaders
hs
then BodyReader -> IO BodyReader
makeGzipReader BodyReader
body1
else forall (m :: * -> *) a. Monad m => a -> m a
return BodyReader
body1
forall (m :: * -> *) a. Monad m => a -> m a
return Response
{ responseStatus :: Status
responseStatus = Status
s
, responseVersion :: HttpVersion
responseVersion = HttpVersion
version
, responseHeaders :: ResponseHeaders
responseHeaders = ResponseHeaders
hs
, responseBody :: BodyReader
responseBody = BodyReader
body
, responseCookieJar :: CookieJar
responseCookieJar = forall a. Monoid a => a
Data.Monoid.mempty
, responseClose' :: ResponseClose
responseClose' = IO () -> ResponseClose
ResponseClose (Bool -> IO ()
cleanup Bool
False)
, responseOriginalRequest :: Request
responseOriginalRequest = Request
req {requestBody :: RequestBody
requestBody = RequestBody
""}
}
hasNoBody :: ByteString
-> Int
-> Bool
hasNoBody :: ByteString -> Int -> Bool
hasNoBody ByteString
"HEAD" Int
_ = Bool
True
hasNoBody ByteString
_ Int
204 = Bool
True
hasNoBody ByteString
_ Int
304 = Bool
True
hasNoBody ByteString
_ Int
i = Int
100 forall a. Ord a => a -> a -> Bool
<= Int
i Bool -> Bool -> Bool
&& Int
i forall a. Ord a => a -> a -> Bool
< Int
200
getOriginalRequest :: Response a -> Request
getOriginalRequest :: forall a. Response a -> Request
getOriginalRequest = forall a. Response a -> Request
responseOriginalRequest