module Network.Wai.Handler.Warp.Response (
sendResponse
, fileRange
, warpVersion
, defaultServerValue
) where
import Blaze.ByteString.Builder (fromByteString, Builder, toByteStringIO, 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)
import Data.Monoid (mappend)
import Data.Version (showVersion)
import Network.HTTP.Attoparsec (parseByteRanges)
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.ResponseHeader
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
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 . 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 b needsChunked) = do
header <- composeHeaderBuilder ver s hs needsChunked
let body
| needsChunked = header `mappend` chunkedTransferEncoding b
`mappend` chunkedTransferTerminator
| otherwise = header `mappend` b
flip toByteStringIO body $ \bs -> connSendAll conn bs
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 = connBuffer 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 -> H.ResponseHeaders -> IO H.ResponseHeaders
addDate dc hdrs = do
gmtdate <- D.getDate dc
return $ (H.hDate, gmtdate) : 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