warp-3.4.13.1: Network/Wai/Handler/Warp/File.hs
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
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
----------------------------------------------------------------
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