warp-3.2.15: Network/Wai/Handler/Warp/HTTP2/File.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}

module Network.Wai.Handler.Warp.HTTP2.File (
    RspFileInfo(..)
  , conditionalRequest
  , addContentHeadersForFilePart
  , H.parseByteRanges
  ) where

import qualified Data.ByteString.Char8 as C8 (pack)
import Network.HPACK
import Network.HPACK.Token
import Network.HTTP.Date
import qualified Network.HTTP.Types as H
import Network.Wai

import qualified Network.Wai.Handler.Warp.FileInfoCache as I
import Network.Wai.Handler.Warp.Imports
import Network.Wai.Handler.Warp.PackInt

-- $setup
-- >>> import Test.QuickCheck

----------------------------------------------------------------

data RspFileInfo = WithoutBody !H.Status
                 | WithBody !H.Status !TokenHeaderList !Integer !Integer
                 deriving (Eq,Show)

----------------------------------------------------------------

conditionalRequest :: I.FileInfo
                   -> TokenHeaderList -- Response
                   -> ValueTable -- Request
                   -> RspFileInfo
conditionalRequest (I.FileInfo _ size mtime date) ths0 reqtbl = case condition of
    nobody@(WithoutBody _) -> nobody
    WithBody s _ off len   -> let !hs = (tokenLastModified,date) :
                                        addContentHeaders ths0 off len size
                              in WithBody s hs off len
  where
    !mcondition = ifmodified    reqtbl size mtime
              <|> ifunmodified  reqtbl size mtime
              <|> ifrange       reqtbl size mtime
    !condition = fromMaybe (unconditional reqtbl size) mcondition

----------------------------------------------------------------

{-# INLINE ifModifiedSince #-}
ifModifiedSince :: ValueTable -> Maybe HTTPDate
ifModifiedSince reqtbl = getHeaderValue tokenIfModifiedSince reqtbl >>= parseHTTPDate

{-# INLINE ifUnmodifiedSince #-}
ifUnmodifiedSince :: ValueTable -> Maybe HTTPDate
ifUnmodifiedSince reqtbl = getHeaderValue tokenIfUnmodifiedSince reqtbl >>= parseHTTPDate

{-# INLINE ifRange #-}
ifRange :: ValueTable -> Maybe HTTPDate
ifRange reqtbl = getHeaderValue tokenIfRange reqtbl >>= parseHTTPDate

----------------------------------------------------------------

{-# INLINE ifmodified #-}
ifmodified :: ValueTable -> Integer -> HTTPDate -> Maybe RspFileInfo
ifmodified reqtbl size mtime = do
    date <- ifModifiedSince reqtbl
    return $ if date /= mtime
             then unconditional reqtbl size
             else WithoutBody H.notModified304

{-# INLINE ifunmodified #-}
ifunmodified :: ValueTable -> Integer -> HTTPDate -> Maybe RspFileInfo
ifunmodified reqtbl size mtime = do
    date <- ifUnmodifiedSince reqtbl
    return $ if date == mtime
             then unconditional reqtbl size
             else WithoutBody H.preconditionFailed412

{-# INLINE ifrange #-}
ifrange :: ValueTable -> Integer -> HTTPDate -> Maybe RspFileInfo
ifrange reqtbl size mtime = do
    date <- ifRange reqtbl
    rng  <- getHeaderValue tokenRange reqtbl
    return $ if date == mtime
             then parseRange rng size
             else WithBody H.ok200 [] 0 size

{-# INLINE unconditional #-}
unconditional :: ValueTable -> Integer -> RspFileInfo
unconditional reqtbl size = case getHeaderValue tokenRange reqtbl of
    Nothing  -> WithBody H.ok200 [] 0 size
    Just rng -> parseRange rng size

----------------------------------------------------------------

{-# INLINE parseRange #-}
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

{-# INLINE checkRange #-}
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)

----------------------------------------------------------------

{-# INLINE contentRangeHeader #-}
-- | @contentRangeHeader beg end total@ constructs a Content-Range 'H.Header'
-- for the range specified.
contentRangeHeader :: Integer -> Integer -> Integer -> TokenHeader
contentRangeHeader beg end total = (tokenContentRange, range)
  where
    range = C8.pack
      -- building with ShowS
      $ 'b' : 'y': 't' : 'e' : 's' : ' '
      : (if beg > end then ('*':) else
          showInt beg
          . ('-' :)
          . showInt end)
      ( '/'
      : showInt total "")

{-# INLINE addContentHeaders #-}
addContentHeaders :: TokenHeaderList -> Integer -> Integer -> Integer -> TokenHeaderList
addContentHeaders ths off len size
  | len == size = ths'
  | otherwise   = let !ctrng = contentRangeHeader off (off + len - 1) size
                  in ctrng:ths'
  where
    !lengthBS = packIntegral len
    !ths' = (tokenContentLength, lengthBS) : (tokenAcceptRanges,"bytes") : ths

{-# INLINE addContentHeadersForFilePart #-}
-- |
--
-- >>> addContentHeadersForFilePart [] (FilePart 2 10 16)
-- [(Token {ix = 20, shouldBeIndexed = True, isPseudo = False, tokenKey = "Content-Range"},"bytes 2-11/16"),(Token {ix = 18, shouldBeIndexed = False, isPseudo = False, tokenKey = "Content-Length"},"10"),(Token {ix = 8, shouldBeIndexed = True, isPseudo = False, tokenKey = "Accept-Ranges"},"bytes")]
-- >>> addContentHeadersForFilePart [] (FilePart 0 16 16)
-- [(Token {ix = 18, shouldBeIndexed = False, isPseudo = False, tokenKey = "Content-Length"},"16"),(Token {ix = 8, shouldBeIndexed = True, isPseudo = False, tokenKey = "Accept-Ranges"},"bytes")]
addContentHeadersForFilePart :: TokenHeaderList -> FilePart -> TokenHeaderList
addContentHeadersForFilePart hs part = addContentHeaders hs off len size
  where
    off = filePartOffset part
    len = filePartByteCount part
    size = filePartFileSize part