module Network.HTTP.Conduit.Response
( Response (..)
, getRedirectedRequest
, getResponse
, lbsResponse
) where
import Control.Arrow (first)
import Data.Typeable (Typeable)
import Data.Monoid (mempty)
import Control.Monad (liftM)
import Control.Exception (throwIO)
import Control.Monad.IO.Class (liftIO)
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import qualified Data.CaseInsensitive as CI
import Control.Monad.Trans.Resource (MonadResource)
import qualified Data.Conduit as C
import qualified Data.Conduit.Zlib as CZ
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import qualified Network.HTTP.Types as W
import Network.HTTP.Conduit.Manager
import Network.HTTP.Conduit.Request
import Network.HTTP.Conduit.Util
import Network.HTTP.Conduit.Parser
import Network.HTTP.Conduit.Chunk
import Data.Void (absurd)
data Response body = Response
{ responseStatus :: W.Status
, responseVersion :: W.HttpVersion
, responseHeaders :: W.ResponseHeaders
, responseBody :: body
}
deriving (Show, Eq, Typeable)
instance Functor Response where
fmap f (Response status v headers body) = Response status v headers (f body)
getRedirectedRequest :: Request m -> W.ResponseHeaders -> Int -> Maybe (Request m)
getRedirectedRequest req hs code
| 300 <= code && code < 400 = do
l' <- lookup "location" hs
l <- parseUrl $ case S8.uncons l' of
Just ('/', _) -> concat
[ "http"
, if secure req then "s" else ""
, "://"
, S8.unpack $ host req
, ":"
, show $ port req
, S8.unpack l'
]
_ -> S8.unpack l'
return req
{ host = host l
, port = port l
, secure = secure l
, path = path l
, queryString = queryString l
, method =
if code == 302 || code == 303
then "GET"
else method l
}
| otherwise = Nothing
lbsResponse :: Monad m
=> m (Response (C.Source m S8.ByteString))
-> m (Response L.ByteString)
lbsResponse mres = do
res <- mres
bss <- responseBody res C.$$ CL.consume
return res
{ responseBody = L.fromChunks bss
}
checkHeaderLength :: MonadResource m
=> Int
-> C.Sink S8.ByteString m a
-> C.Sink S8.ByteString m a
checkHeaderLength len C.NeedInput{}
| len <= 0 =
let x = liftIO $ throwIO OverlongHeaders
in C.PipeM x x
checkHeaderLength len (C.NeedInput pushI closeI) = C.NeedInput
(\bs -> checkHeaderLength
(len S8.length bs)
(pushI bs)) closeI
checkHeaderLength len (C.PipeM msink close) = C.PipeM (liftM (checkHeaderLength len) msink) close
checkHeaderLength _ s@C.Done{} = s
checkHeaderLength _ (C.HaveOutput _ _ o) = absurd o
getResponse :: MonadResource m
=> ConnRelease m
-> Request m
-> C.Source m S8.ByteString
-> m (Response (C.Source m S8.ByteString))
getResponse connRelease req@(Request {..}) src1 = do
(src2, ((vbs, sc, sm), hs)) <- src1 C.$$+ checkHeaderLength 4096 sinkHeaders
let version = if vbs == "1.1" then W.http11 else W.http10
let s = W.Status sc sm
let hs' = map (first CI.mk) hs
let mcl = lookup "content-length" hs' >>= readDec . S8.unpack
let toPut = Just "close" /= lookup "connection" hs'
let cleanup bodyConsumed = connRelease $ if toPut && bodyConsumed then Reuse else DontReuse
body <-
if hasNoBody method sc || mcl == Just 0
then do
cleanup True
return mempty
else do
let src3 =
if ("transfer-encoding", "chunked") `elem` hs'
then src2 C.$= chunkedConduit rawBody
else
case mcl of
Just len -> src2 C.$= CB.isolate len
Nothing -> src2
let src4 =
if needsGunzip req hs'
then src3 C.$= CZ.ungzip
else src3
return $ addCleanup cleanup src4
return $ Response s version hs' body
addCleanup :: Monad m
=> (Bool -> m ())
-> C.Source m a
-> C.Source m a
addCleanup cleanup (C.Done leftover ()) = C.PipeM
(cleanup True >> return (C.Done leftover ()))
(cleanup True)
addCleanup cleanup (C.HaveOutput src close x) = C.HaveOutput
(addCleanup cleanup src)
(cleanup False >> close)
x
addCleanup cleanup (C.PipeM msrc close) = C.PipeM
(liftM (addCleanup cleanup) msrc)
(cleanup False >> close)
addCleanup cleanup (C.NeedInput p c) = C.NeedInput
(addCleanup cleanup . p)
(addCleanup cleanup c)