module Network.HTTP.Toolkit.Response (
Response(..)
, readResponse
, readResponseWithLimit
, parseStatusLine
, simpleResponse
, sendResponse
, formatStatusLine
, determineResponseBodyType
) where
import Control.Applicative
import Control.Monad (guard)
import Control.Exception
import Text.Read (readMaybe)
import Data.Maybe
import Data.Foldable
import Data.Traversable
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as B
import Network.HTTP.Types
import Network.HTTP.Toolkit.Error
import Network.HTTP.Toolkit.InputStream
import Network.HTTP.Toolkit.Header
import Network.HTTP.Toolkit.Body
data Response a = Response {
responseStatus :: Status
, responseHeaders :: [Header]
, responseBody :: a
} deriving (Eq, Show, Functor, Foldable, Traversable)
readResponse :: Bool -> Method -> InputStream -> IO (Response BodyReader)
readResponse = readResponseWithLimit defaultHeaderSizeLimit
readResponseWithLimit :: Limit -> Bool -> Method -> InputStream -> IO (Response BodyReader)
readResponseWithLimit limit raw method c = do
(startLine, headers) <- readMessageHeader limit c
status <- parseStatusLine_ startLine
Response status headers <$> makeBodyReader raw (determineResponseBodyType method status headers) c
parseStatusLine_ :: ByteString -> IO Status
parseStatusLine_ input = maybe (throwIO $ InvalidStatusLine input) return (parseStatusLine input)
parseStatusLine :: ByteString -> Maybe Status
parseStatusLine input = case B.words input of
_ : status : xs -> mkStatus <$> (readMaybe $ B.unpack status) <*> (listToMaybe xs <|> Just "")
_ -> Nothing
determineResponseBodyType :: Method -> Status -> [Header] -> BodyType
determineResponseBodyType method status headers = fromMaybe Unlimited $ none <|> bodyTypeFromHeaders headers
where
none = guard hasNoResponseBody >> Just None
code = statusCode status
hasNoResponseBody =
method == methodHead
|| (100 <= code && code < 200)
|| code == 204
|| code == 304
formatStatusLine :: Status -> ByteString
formatStatusLine status = B.concat ["HTTP/1.1 ", B.pack $ show (statusCode status), " ", statusMessage status]
simpleResponse :: (ByteString -> IO ()) -> Status -> [Header] -> ByteString -> IO ()
simpleResponse send status headers_ body = do
fromByteString body >>= sendResponse send . Response status headers
where
headers = ("Content-Length", B.pack . show . B.length $ body) : headers_
sendResponse :: (ByteString -> IO ()) -> (Response BodyReader) -> IO ()
sendResponse send (Response status headers body) = do
sendHeader send (formatStatusLine status) headers
sendBody send body