module Network.Wai.Handler.Warp.Response (
sendResponse
, fileRange
, warpVersion
, defaultServerValue
) where
import Blaze.ByteString.Builder (fromByteString, Builder, flush)
import Blaze.ByteString.Builder.HTTP (chunkedTransferEncoding, chunkedTransferTerminator)
import Control.Applicative
import Control.Exception
import Control.Monad.IO.Class (liftIO)
import Data.Array ((!))
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as B (pack)
import qualified Data.CaseInsensitive as CI
import Data.Conduit
import Data.Conduit.Blaze (unsafeBuilderToByteString)
import Data.Function (on)
import Data.List (deleteBy)
import Data.Maybe (isJust, listToMaybe)
#if MIN_VERSION_base(4,5,0)
import Data.Monoid ((<>))
#else
import Data.Monoid (mappend)
#endif
import Data.Version (showVersion)
import qualified Network.HTTP.Types as H
import Network.Wai
import qualified Network.Wai.Handler.Warp.Date as D
import Network.Wai.Handler.Warp.Header
import Network.Wai.Handler.Warp.Buffer (toBlazeBuffer)
import Network.Wai.Handler.Warp.IO (toBufIOWith)
import Network.Wai.Handler.Warp.ResponseHeader
import Network.Wai.Handler.Warp.RequestHeader (parseByteRanges)
import qualified Network.Wai.Handler.Warp.Timeout as T
import Network.Wai.Handler.Warp.Types
import Network.Wai.Internal
import Numeric (showInt)
import qualified Paths_warp
import qualified System.PosixCompat.Files as P
#if !MIN_VERSION_base(4,5,0)
(<>) :: Monoid m => m -> m -> m
(<>) = mappend
#endif
fileRange :: H.Status -> H.ResponseHeaders -> FilePath
-> Maybe FilePart -> Maybe HeaderValue
-> IO (Either SomeException
(H.Status, H.ResponseHeaders, Integer, Integer))
fileRange s0 hs0 path mPart mRange = try $ do
fileSize <- checkFileSize mPart
let (beg, end, len, isEntire) = checkPartRange fileSize mPart mRange
let hs1 = addContentLength len hs0
hs | isEntire = hs1
| otherwise = addContentRange beg end fileSize hs1
s | isEntire = s0
| otherwise = H.status206
return (s, hs, beg, len)
where
checkFileSize Nothing = fromIntegral . P.fileSize <$> P.getFileStatus path
checkFileSize (Just part) = return $ filePartFileSize part
checkPartRange :: Integer -> Maybe FilePart -> Maybe HeaderValue
-> (Integer, Integer, Integer, Bool)
checkPartRange fileSize mPart mRange = checkPart mPart mRange
where
checkPart Nothing Nothing = (0, fileSize 1, fileSize, True)
checkPart Nothing (Just range) = case parseByteRanges range >>= listToMaybe of
Nothing -> (0, fileSize 1, fileSize, True)
Just hrange -> checkRange hrange
checkPart (Just part) _ = (beg, end, len, isEntire)
where
beg = filePartOffset part
len = filePartByteCount part
end = beg + len 1
isEntire = beg == 0 && len == fileSize
checkRange (H.ByteRangeFrom beg) = fromRange beg (fileSize 1)
checkRange (H.ByteRangeFromTo beg end) = fromRange beg end
checkRange (H.ByteRangeSuffix count) = fromRange (fileSize count) (fileSize 1)
fromRange beg end = (beg, end, len, isEntire)
where
len = end beg + 1
isEntire = beg == 0 && len == fileSize
sendResponse :: Connection
-> InternalInfo
-> (forall a. IO a -> IO a)
-> Request
-> IndexedHeader
-> Response
-> IO Bool
sendResponse conn ii restore req reqidxhdr response = restore $ do
hs <- addServerAndDate hs0
if hasBody s req then do
sendRsp conn ver s hs rsp
T.tickle th
return ret
else do
sendResponseNoBody conn ver s hs response
T.tickle th
return isPersist
where
ver = httpVersion req
s = responseStatus response
hs0 = responseHeaders response
rspidxhdr = indexResponseHeader hs0
th = threadHandle ii
dc = dateCacher ii
addServerAndDate = addDate dc rspidxhdr . addServer rspidxhdr
mRange = reqidxhdr ! idxRange
reqinfo@(isPersist,_) = infoFromRequest req reqidxhdr
(isKeepAlive, needsChunked) = infoFromResponse rspidxhdr reqinfo
rsp = case response of
ResponseFile _ _ path mPart -> RspFile path mPart mRange (T.tickle th)
ResponseBuilder _ _ b -> RspBuilder b needsChunked
ResponseSource _ _ fb -> RspSource fb needsChunked th
ret = case response of
ResponseFile _ _ _ _ -> isPersist
ResponseBuilder _ _ _ -> isKeepAlive
ResponseSource _ _ _ -> isKeepAlive
data Rsp = RspFile FilePath (Maybe FilePart) (Maybe HeaderValue) (IO ())
| RspBuilder Builder Bool
| RspSource (forall b. WithSource IO (Flush Builder) b) Bool T.Handle
sendRsp :: Connection
-> H.HttpVersion
-> H.Status
-> H.ResponseHeaders
-> Rsp
-> IO ()
sendRsp conn ver s0 hs0 (RspFile path mPart mRange hook) = do
ex <- fileRange s0 hs path mPart mRange
case ex of
Left _ -> sendRsp conn ver s2 hs2 (RspBuilder body True)
Right (s, hs1, beg, len) -> do
lheader <- composeHeader ver s hs1
connSendFile conn path beg len hook [lheader]
where
hs = addAcceptRanges hs0
s2 = H.status404
hs2 = replaceHeader H.hContentType "text/plain" hs0
body = fromByteString "File not found"
sendRsp conn ver s hs (RspBuilder body needsChunked) = do
header <- composeHeaderBuilder ver s hs needsChunked
let hdrBdy
| needsChunked = header <> chunkedTransferEncoding body
<> chunkedTransferTerminator
| otherwise = header <> body
buffer = connBuffer conn
size = connBufferSize conn
toBufIOWith buffer size (connSendAll conn) hdrBdy
sendRsp conn ver s hs (RspSource withBodyFlush needsChunked th) = withBodyFlush $ \bodyFlush -> do
header <- composeHeaderBuilder ver s hs needsChunked
let src = yield header >> cbody bodyFlush
buffer <- toBlazeBuffer (connBuffer conn) (connBufferSize conn)
src $$ unsafeBuilderToByteString (return buffer) =$ connSink conn th
where
cbody bodyFlush = if needsChunked then body $= chunk else body
where
body = mapOutput (\x -> case x of
Flush -> flush
Chunk builder -> builder)
bodyFlush
chunk :: Conduit Builder IO Builder
chunk = await >>= maybe (yield chunkedTransferTerminator) (\x -> yield (chunkedTransferEncoding x) >> chunk)
sendResponseNoBody :: Connection
-> H.HttpVersion
-> H.Status
-> H.ResponseHeaders
-> Response
-> IO ()
sendResponseNoBody conn ver s hs (ResponseSource _ _ withBodyFlush) =
withBodyFlush $ \_bodyFlush ->
composeHeader ver s hs >>= connSendAll conn
sendResponseNoBody conn ver s hs _ =
composeHeader ver s hs >>= connSendAll conn
connSink :: Connection -> T.Handle -> Sink ByteString IO ()
connSink Connection { connSendAll = send } th = sink
where
sink = await >>= maybe close push
close = liftIO (T.resume th)
push x = do
liftIO $ T.resume th
liftIO $ send x
liftIO $ T.pause th
sink
infoFromRequest :: Request -> IndexedHeader -> (Bool
,Bool)
infoFromRequest req reqidxhdr = (checkPersist req reqidxhdr, checkChunk req)
checkPersist :: Request -> IndexedHeader -> Bool
checkPersist req reqidxhdr
| ver == H.http11 = checkPersist11 conn
| otherwise = checkPersist10 conn
where
ver = httpVersion req
conn = reqidxhdr ! idxConnection
checkPersist11 (Just x)
| CI.foldCase x == "close" = False
checkPersist11 _ = True
checkPersist10 (Just x)
| CI.foldCase x == "keep-alive" = True
checkPersist10 _ = False
checkChunk :: Request -> Bool
checkChunk req = httpVersion req == H.http11
infoFromResponse :: IndexedHeader -> (Bool,Bool) -> (Bool,Bool)
infoFromResponse rspidxhdr (isPersist,isChunked) = (isKeepAlive, needsChunked)
where
needsChunked = isChunked && not hasLength
isKeepAlive = isPersist && (isChunked || hasLength)
hasLength = isJust $ rspidxhdr ! idxContentLength
hasBody :: H.Status -> Request -> Bool
hasBody s req = sc /= 204
&& sc /= 304
&& sc >= 200
&& method /= H.methodHead
where
sc = H.statusCode s
method = requestMethod req
addAcceptRanges :: H.ResponseHeaders -> H.ResponseHeaders
addAcceptRanges hdrs = (hAcceptRanges, "bytes") : hdrs
addTransferEncoding :: H.ResponseHeaders -> H.ResponseHeaders
addTransferEncoding hdrs = (hTransferEncoding, "chunked") : hdrs
addContentLength :: Integer -> H.ResponseHeaders -> H.ResponseHeaders
addContentLength cl hdrs = (H.hContentLength, len) : hdrs
where
len = B.pack $ show cl
addContentRange :: Integer -> Integer -> Integer
-> H.ResponseHeaders -> H.ResponseHeaders
addContentRange beg end total hdrs = (hContentRange, range) : hdrs
where
range = B.pack
$ 'b' : 'y': 't' : 'e' : 's' : ' '
: showInt beg
( '-'
: showInt end
( '/'
: showInt total ""))
addDate :: D.DateCache -> IndexedHeader -> H.ResponseHeaders -> IO H.ResponseHeaders
addDate dc rspidxhdr hdrs = case rspidxhdr ! idxDate of
Nothing -> do
gmtdate <- D.getDate dc
return $ (H.hDate, gmtdate) : hdrs
Just _ -> return hdrs
warpVersion :: String
warpVersion = showVersion Paths_warp.version
defaultServerValue :: HeaderValue
defaultServerValue = B.pack $ "Warp/" ++ warpVersion
addServer :: IndexedHeader -> H.ResponseHeaders -> H.ResponseHeaders
addServer rspidxhdr hdrs = case rspidxhdr ! idxServer of
Nothing -> (hServer, defaultServerValue) : hdrs
_ -> hdrs
replaceHeader :: H.HeaderName -> HeaderValue -> H.ResponseHeaders -> H.ResponseHeaders
replaceHeader k v hdrs = (k,v) : deleteBy ((==) `on` fst) (k,v) hdrs
composeHeaderBuilder :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> IO Builder
composeHeaderBuilder ver s hs True =
fromByteString <$> composeHeader ver s (addTransferEncoding hs)
composeHeaderBuilder ver s hs False =
fromByteString <$> composeHeader ver s hs