module Network.HTTP.Conduit.Response
( Response (..)
, getResponse
, lbsResponse
) where
import Control.Arrow (first)
import Data.Typeable (Typeable)
import Data.Monoid (mempty)
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 (ResourceT, ResourceIO)
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
data Response body = Response
{ statusCode :: W.Status
, responseHeaders :: W.ResponseHeaders
, responseBody :: body
}
deriving (Show, Eq, Typeable)
instance Functor Response where
fmap f (Response status headers body) = Response status headers (f body)
lbsResponse :: C.Resource m
=> ResourceT m (Response (C.Source m S8.ByteString))
-> ResourceT m (Response L.ByteString)
lbsResponse mres = do
res <- mres
bss <- responseBody res C.$$ CL.consume
return res
{ responseBody = L.fromChunks bss
}
getResponse :: ResourceIO m
=> ConnRelease m
-> Request m
-> C.BufferedSource m S8.ByteString
-> ResourceT m (Response (C.Source m S8.ByteString))
getResponse connRelease req@(Request {..}) bsrc = do
((_, sc, sm), hs) <- bsrc C.$$ sinkHeaders
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 = connRelease $ if toPut then Reuse else DontReuse
body <-
if hasNoBody method sc || mcl == Just 0
then do
cleanup
return mempty
else do
let bsrc' =
if ("transfer-encoding", "chunked") `elem` hs'
then bsrc C.$= chunkedConduit rawBody
else
case mcl of
Just len -> bsrc C.$= CB.isolate len
Nothing -> C.unbufferSource bsrc
let bsrc'' =
if needsGunzip req hs'
then bsrc' C.$= CZ.ungzip
else bsrc'
return $ addCleanup cleanup bsrc''
return $ Response s hs' body
addCleanup :: C.ResourceIO m
=> ResourceT m ()
-> C.Source m a
-> C.Source m a
addCleanup cleanup (C.Source msrc) = C.Source $ do
src <- msrc
return C.PreparedSource
{ C.sourcePull = do
res <- C.sourcePull src
case res of
C.Closed -> cleanup
C.Open _ -> return ()
return res
, C.sourceClose = do
C.sourceClose src
cleanup
}