{-# 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

-- | If a request is a redirection (status code 3xx) this function will create
-- a new request from the old request, the server headers returned with the
-- redirection, and the redirection code itself. This function returns 'Nothing'
-- if the code is not a 3xx, there is no 'location' header included, or if the
-- redirected response couldn't be parsed with 'parseRequest'.
--
-- If a user of this library wants to know the url chain that results from a
-- specific request, that user has to re-implement the redirect-following logic
-- themselves. An example of that might look like this:
--
-- > myHttp req man = do
-- >    (res, redirectRequests) <- (`runStateT` []) $
-- >         'httpRedirect'
-- >             9000
-- >             (\req' -> do
-- >                res <- http req'{redirectCount=0} man
-- >                modify (\rqs -> req' : rqs)
-- >                return (res, getRedirectedRequest req req' (responseHeaders res) (responseCookieJar res) (W.statusCode (responseStatus res))
-- >                )
-- >             'lift'
-- >             req
-- >    applyCheckStatus (checkStatus req) res
-- >    return redirectRequests
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
code Bool -> Bool -> Bool
&& Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
400 = do
        ByteString
l' <- HeaderName -> ResponseHeaders -> Maybe ByteString
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' <- (Request -> Request) -> Maybe Request -> Maybe Request
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Request -> Request
stripHeaders (Maybe Request -> Maybe Request)
-> (URI -> Maybe Request) -> URI -> Maybe Request
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> URI -> Maybe Request
forall (m :: * -> *). MonadThrow m => Request -> URI -> m Request
setUriRelative Request
req (URI -> Maybe Request) -> Maybe URI -> Maybe Request
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Maybe URI
parseURIReference String
l
        Request -> Maybe Request
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Request -> Maybe Request) -> Request -> Maybe Request
forall a b. (a -> b) -> a -> b
$
            if Int
code Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
302 Bool -> Bool -> Bool
|| Int
code Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
303
                -- According to the spec, this should *only* be for status code
                -- 303. However, almost all clients mistakenly implement it for
                -- 302 as well. So we have to be wrong like everyone else...
                then Request
req'
                    { method = "GET"
                    , requestBody = RequestBodyBS ""
                    , cookieJar = cookie_jar'
                    , requestHeaders = filter ((/= W.hContentType) . fst) $ requestHeaders req'
                    }
                else Request
req' {cookieJar = cookie_jar'}
    | Bool
otherwise = Maybe Request
forall a. Maybe a
Nothing
  where
    cookie_jar' :: Maybe CookieJar
    cookie_jar' :: Maybe CookieJar
cookie_jar' = (CookieJar -> CookieJar) -> Maybe CookieJar -> Maybe CookieJar
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CookieJar -> CookieJar -> CookieJar
forall a b. a -> b -> a
const CookieJar
cookie_jar) (Maybe CookieJar -> Maybe CookieJar)
-> Maybe CookieJar -> Maybe CookieJar
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 ByteString -> ByteString -> Bool
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 = (Header -> Header -> Bool) -> ResponseHeaders -> ResponseHeaders
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (\(HeaderName
a, ByteString
_) (HeaderName
a', ByteString
_) -> HeaderName
a HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
a') (ResponseHeaders
lhs ResponseHeaders -> ResponseHeaders -> ResponseHeaders
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
                -- We need to check if we have omitted headers in previous
                -- request chain. Consider request chain:
                --
                --  1. example-1.com 
                --  2. example-2.com (we may have removed some headers here from 1)
                --  3. example-1.com (since we are back at same host as 1, we need re-add stripped headers)
                --
                let strippedHeaders :: ResponseHeaders
strippedHeaders = (Header -> Bool) -> ResponseHeaders -> ResponseHeaders
forall a. (a -> Bool) -> [a] -> [a]
filter (Request -> HeaderName -> Bool
shouldStripHeaderOnRedirect Request
r (HeaderName -> Bool) -> (Header -> HeaderName) -> Header -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header -> HeaderName
forall a b. (a, b) -> a
fst) (Request -> ResponseHeaders
requestHeaders Request
origReq)
                Request
r{requestHeaders = mergeHeaders (requestHeaders r) strippedHeaders}

    stripHeaders' :: Request -> Request
    stripHeaders' :: Request -> Request
stripHeaders' Request
r = Request
r{requestHeaders =
                        filter (not . shouldStripHeaderOnRedirect req . fst) $
                        requestHeaders r}

-- | Convert a 'Response' that has a 'Source' body to one with a lazy
-- 'L.ByteString' body.
lbsResponse :: Response BodyReader -> IO (Response L.ByteString)
lbsResponse :: Response BodyReader -> IO (Response ByteString)
lbsResponse Response BodyReader
res = do
    [ByteString]
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
    Response ByteString -> IO (Response ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Response BodyReader
res
        { responseBody = L.fromChunks bss
        }

getResponse :: Maybe MaxHeaderLength
            -> Maybe Int
            -> Request
            -> Managed Connection
            -> Maybe (IO ()) -- ^ Action to run in case of a '100 Continue'.
            -> 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
ResponseHeaders -> IO ()
ByteString -> Bool
SomeException -> IO ()
HeaderName -> Bool
Request -> Response BodyReader -> IO ()
method :: Request -> ByteString
requestBody :: Request -> RequestBody
cookieJar :: Request -> Maybe CookieJar
requestHeaders :: Request -> ResponseHeaders
host :: Request -> ByteString
shouldStripHeaderOnRedirectIfOnDifferentHostOnly :: Request -> Bool
shouldStripHeaderOnRedirect :: Request -> HeaderName -> Bool
method :: ByteString
secure :: Bool
host :: ByteString
port :: Int
path :: ByteString
queryString :: ByteString
requestHeaders :: ResponseHeaders
requestBody :: RequestBody
proxy :: Maybe Proxy
hostAddress :: Maybe HostAddress
rawBody :: Bool
decompress :: ByteString -> Bool
redirectCount :: Int
checkResponse :: Request -> Response BodyReader -> IO ()
responseTimeout :: ResponseTimeout
cookieJar :: Maybe CookieJar
requestVersion :: HttpVersion
onRequestBodyException :: SomeException -> IO ()
requestManagerOverride :: Maybe Manager
shouldStripHeaderOnRedirect :: HeaderName -> Bool
shouldStripHeaderOnRedirectIfOnDifferentHostOnly :: Bool
proxySecureMode :: ProxySecureMode
redactHeaders :: Set HeaderName
earlyHintHeadersReceived :: ResponseHeaders -> IO ()
secure :: Request -> Bool
port :: Request -> Int
path :: Request -> ByteString
queryString :: Request -> ByteString
proxy :: Request -> Maybe Proxy
hostAddress :: Request -> Maybe HostAddress
rawBody :: Request -> Bool
decompress :: Request -> ByteString -> Bool
redirectCount :: Request -> Int
checkResponse :: Request -> Request -> Response BodyReader -> IO ()
responseTimeout :: Request -> ResponseTimeout
requestVersion :: Request -> HttpVersion
onRequestBodyException :: Request -> SomeException -> IO ()
requestManagerOverride :: Request -> Maybe Manager
proxySecureMode :: Request -> ProxySecureMode
redactHeaders :: Request -> Set HeaderName
earlyHintHeadersReceived :: Request -> ResponseHeaders -> IO ()
..}) Managed Connection
mconn Maybe (IO ())
cont = do
    let conn :: Connection
conn = Managed Connection -> Connection
forall resource. Managed resource -> resource
managedResource Managed Connection
mconn
    StatusHeaders Status
s HttpVersion
version ResponseHeaders
earlyHs ResponseHeaders
hs <- Maybe MaxHeaderLength
-> Connection
-> Maybe Int
-> (ResponseHeaders -> IO ())
-> Maybe (IO ())
-> IO StatusHeaders
parseStatusHeaders Maybe MaxHeaderLength
mhl Connection
conn Maybe Int
timeout' ResponseHeaders -> IO ()
earlyHintHeadersReceived Maybe (IO ())
cont
    let mcl :: Maybe Int
mcl = HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"content-length" ResponseHeaders
hs Maybe ByteString -> (ByteString -> Maybe Int) -> Maybe Int
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe Int
readPositiveInt (String -> Maybe Int)
-> (ByteString -> String) -> ByteString -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
S8.unpack
        isChunked :: Bool
isChunked = (HeaderName
"transfer-encoding", ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
CI.mk ByteString
"chunked") (HeaderName, HeaderName) -> [(HeaderName, HeaderName)] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Header -> (HeaderName, HeaderName))
-> ResponseHeaders -> [(HeaderName, HeaderName)]
forall a b. (a -> b) -> [a] -> [b]
map ((ByteString -> HeaderName) -> Header -> (HeaderName, HeaderName)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
CI.mk) ResponseHeaders
hs

        -- should we put this connection back into the connection manager?
        toPut :: Bool
toPut = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"close" Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"connection" ResponseHeaders
hs Bool -> Bool -> Bool
&& HttpVersion
version HttpVersion -> HttpVersion -> Bool
forall a. Ord a => a -> a -> Bool
> Int -> Int -> HttpVersion
W.HttpVersion Int
1 Int
0
        cleanup :: Bool -> IO ()
cleanup Bool
bodyConsumed = do
            Managed Connection -> Reuse -> IO ()
forall resource. Managed resource -> Reuse -> IO ()
managedRelease Managed Connection
mconn (Reuse -> IO ()) -> Reuse -> IO ()
forall a b. (a -> b) -> a -> b
$ if Bool
toPut Bool -> Bool -> Bool
&& Bool
bodyConsumed then Reuse
Reuse else Reuse
DontReuse
            -- Keep alive the `Managed Connection` until we're done with it, to prevent an early
            -- collection.
            -- Reasoning: as long as someone holds a reference to the explicit cleanup,
            -- we shouldn't perform an implicit cleanup.
            Managed Connection -> IO ()
forall resource. Managed resource -> IO ()
keepAlive Managed Connection
mconn


    BodyReader
body <-
        -- RFC 2616 section 4.4_1 defines responses that must not include a body
        if ByteString -> Int -> Bool
hasNoBody ByteString
method (Status -> Int
W.statusCode Status
s) Bool -> Bool -> Bool
|| (Maybe Int
mcl Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0 Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isChunked)
            then do
                Bool -> IO ()
cleanup Bool
True
                BodyReader -> IO BodyReader
forall a. a -> IO a
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 BodyReader -> IO BodyReader
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return BodyReader
body1

    Response BodyReader -> IO (Response BodyReader)
forall a. a -> IO a
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 = CookieJar
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 = ""}
        , responseEarlyHints :: ResponseHeaders
responseEarlyHints = ResponseHeaders
earlyHs
        }

-- | Does this response have no body?
hasNoBody :: ByteString -- ^ request method
          -> Int -- ^ status code
          -> 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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
i Bool -> Bool -> Bool
&& Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
200

-- | Retrieve the orignal 'Request' from a 'Response'
--
-- Note that the 'requestBody' is not available and always set to empty.
--
-- @since 0.7.8
getOriginalRequest :: Response a -> Request
getOriginalRequest :: forall a. Response a -> Request
getOriginalRequest = Response a -> Request
forall a. Response a -> Request
responseOriginalRequest