warp-3.3.30: Network/Wai/Handler/Warp/File.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}
module Network.Wai.Handler.Warp.File (
RspFileInfo(..)
, conditionalRequest
, addContentHeadersForFilePart
, H.parseByteRanges
) where
import Data.Array ((!))
import qualified Data.ByteString.Char8 as C8 (pack)
import Network.HTTP.Date
import qualified Network.HTTP.Types as H
import qualified Network.HTTP.Types.Header as H
import Network.Wai
import qualified Network.Wai.Handler.Warp.FileInfoCache as I
import Network.Wai.Handler.Warp.Header
import Network.Wai.Handler.Warp.Imports
import Network.Wai.Handler.Warp.PackInt
-- $setup
-- >>> import Test.QuickCheck
----------------------------------------------------------------
data RspFileInfo = WithoutBody H.Status
| WithBody H.Status H.ResponseHeaders Integer Integer
deriving (Eq,Show)
----------------------------------------------------------------
conditionalRequest :: I.FileInfo
-> H.ResponseHeaders
-> H.Method
-> IndexedHeader -- ^ Response
-> IndexedHeader -- ^ Request
-> RspFileInfo
conditionalRequest finfo hs0 method rspidx reqidx = case condition of
nobody@(WithoutBody _) -> nobody
WithBody s _ off len ->
let !hs1 = addContentHeaders hs0 off len size
!hs = case rspidx ! fromEnum ResLastModified of
Just _ -> hs1
Nothing -> (H.hLastModified,date) : hs1
in WithBody s hs off len
where
!mtime = I.fileInfoTime finfo
!size = I.fileInfoSize finfo
!date = I.fileInfoDate finfo
-- According to RFC 9110:
-- "A recipient cache or origin server MUST evaluate the request
-- preconditions defined by this specification in the following order:
-- - If-Match
-- - If-Unmodified-Since
-- - If-None-Match
-- - If-Modified-Since
-- - If-Range
--
-- We don't actually implement the If-(None-)Match logic, but
-- we also don't want to block middleware or applications from
-- using ETags. And sending If-(None-)Match headers in a request
-- to a server that doesn't use them is requester's problem.
!mcondition = ifunmodified reqidx mtime
<|> ifmodified reqidx mtime method
<|> ifrange reqidx mtime method size
!condition = fromMaybe (unconditional reqidx size) mcondition
----------------------------------------------------------------
ifModifiedSince :: IndexedHeader -> Maybe HTTPDate
ifModifiedSince reqidx = reqidx ! fromEnum ReqIfModifiedSince >>= parseHTTPDate
ifUnmodifiedSince :: IndexedHeader -> Maybe HTTPDate
ifUnmodifiedSince reqidx = reqidx ! fromEnum ReqIfUnmodifiedSince >>= parseHTTPDate
ifRange :: IndexedHeader -> Maybe HTTPDate
ifRange reqidx = reqidx ! fromEnum ReqIfRange >>= parseHTTPDate
----------------------------------------------------------------
ifmodified :: IndexedHeader -> HTTPDate -> H.Method -> Maybe RspFileInfo
ifmodified reqidx mtime method = do
date <- ifModifiedSince reqidx
-- According to RFC 9110:
-- "A recipient MUST ignore If-Modified-Since if the request
-- contains an If-None-Match header field; [...]"
guard . isNothing $ reqidx ! fromEnum ReqIfNoneMatch
-- "A recipient MUST ignore the If-Modified-Since header field
-- if [...] the request method is neither GET nor HEAD."
guard $ method == H.methodGet || method == H.methodHead
guard $ date == mtime || date > mtime
Just $ WithoutBody H.notModified304
ifunmodified :: IndexedHeader -> HTTPDate -> Maybe RspFileInfo
ifunmodified reqidx mtime = do
date <- ifUnmodifiedSince reqidx
-- According to RFC 9110:
-- "A recipient MUST ignore If-Unmodified-Since if the request
-- contains an If-Match header field; [...]"
guard . isNothing $ reqidx ! fromEnum ReqIfMatch
guard $ date /= mtime && date < mtime
Just $ WithoutBody H.preconditionFailed412
-- TODO: Should technically also strongly match on ETags.
ifrange :: IndexedHeader -> HTTPDate -> H.Method -> Integer -> Maybe RspFileInfo
ifrange reqidx mtime method size = do
-- According to RFC 9110:
-- "When the method is GET and both Range and If-Range are
-- present, evaluate the If-Range precondition:"
date <- ifRange reqidx
rng <- reqidx ! fromEnum ReqRange
guard $ method == H.methodGet
return $
if date == mtime
then parseRange rng size
else WithBody H.ok200 [] 0 size
unconditional :: IndexedHeader -> Integer -> RspFileInfo
unconditional reqidx =
case reqidx ! fromEnum ReqRange of
Nothing -> WithBody H.ok200 [] 0
Just rng -> parseRange rng
----------------------------------------------------------------
parseRange :: ByteString -> Integer -> RspFileInfo
parseRange rng size = case H.parseByteRanges rng of
Nothing -> WithoutBody H.requestedRangeNotSatisfiable416
Just [] -> WithoutBody H.requestedRangeNotSatisfiable416
Just (r:_) -> let (!beg, !end) = checkRange r size
!len = end - beg + 1
s = if beg == 0 && end == size - 1 then
H.ok200
else
H.partialContent206
in WithBody s [] beg len
checkRange :: H.ByteRange -> Integer -> (Integer, Integer)
checkRange (H.ByteRangeFrom beg) size = (beg, size - 1)
checkRange (H.ByteRangeFromTo beg end) size = (beg, min (size - 1) end)
checkRange (H.ByteRangeSuffix count) size = (max 0 (size - count), size - 1)
----------------------------------------------------------------
-- | @contentRangeHeader beg end total@ constructs a Content-Range 'H.Header'
-- for the range specified.
contentRangeHeader :: Integer -> Integer -> Integer -> H.Header
contentRangeHeader beg end total = (H.hContentRange, range)
where
range = C8.pack
-- building with ShowS
$ 'b' : 'y': 't' : 'e' : 's' : ' '
: (if beg > end then ('*':) else
showInt beg
. ('-' :)
. showInt end)
( '/'
: showInt total "")
addContentHeaders :: H.ResponseHeaders -> Integer -> Integer -> Integer -> H.ResponseHeaders
addContentHeaders hs off len size
| len == size = hs'
| otherwise = let !ctrng = contentRangeHeader off (off + len - 1) size
in ctrng:hs'
where
!lengthBS = packIntegral len
!hs' = (H.hContentLength, lengthBS) : (H.hAcceptRanges,"bytes") : hs
-- |
--
-- >>> addContentHeadersForFilePart [] (FilePart 2 10 16)
-- [("Content-Range","bytes 2-11/16"),("Content-Length","10"),("Accept-Ranges","bytes")]
-- >>> addContentHeadersForFilePart [] (FilePart 0 16 16)
-- [("Content-Length","16"),("Accept-Ranges","bytes")]
addContentHeadersForFilePart :: H.ResponseHeaders -> FilePart -> H.ResponseHeaders
addContentHeadersForFilePart hs part = addContentHeaders hs off len size
where
off = filePartOffset part
len = filePartByteCount part
size = filePartFileSize part