{-# 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 (RspFileInfo -> RspFileInfo -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RspFileInfo -> RspFileInfo -> Bool
$c/= :: RspFileInfo -> RspFileInfo -> Bool
== :: RspFileInfo -> RspFileInfo -> Bool
$c== :: RspFileInfo -> RspFileInfo -> Bool
Eq,Int -> RspFileInfo -> ShowS
[RspFileInfo] -> ShowS
RspFileInfo -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RspFileInfo] -> ShowS
$cshowList :: [RspFileInfo] -> ShowS
show :: RspFileInfo -> String
$cshow :: RspFileInfo -> String
showsPrec :: Int -> RspFileInfo -> ShowS
$cshowsPrec :: Int -> RspFileInfo -> ShowS
Show)

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

conditionalRequest :: I.FileInfo
                   -> H.ResponseHeaders
                   -> IndexedHeader -- ^ Response
                   -> IndexedHeader -- ^ Request
                   -> RspFileInfo
conditionalRequest :: FileInfo
-> ResponseHeaders -> IndexedHeader -> IndexedHeader -> RspFileInfo
conditionalRequest FileInfo
finfo ResponseHeaders
hs0 IndexedHeader
rspidx IndexedHeader
reqidx = case RspFileInfo
condition of
    nobody :: RspFileInfo
nobody@(WithoutBody Status
_) -> RspFileInfo
nobody
    WithBody Status
s ResponseHeaders
_ Integer
off Integer
len   -> let !hs1 :: ResponseHeaders
hs1 = ResponseHeaders -> Integer -> Integer -> Integer -> ResponseHeaders
addContentHeaders ResponseHeaders
hs0 Integer
off Integer
len Integer
size
                                  !hasLM :: Bool
hasLM = forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ IndexedHeader
rspidx forall i e. Ix i => Array i e -> i -> e
! forall a. Enum a => a -> Int
fromEnum ResponseHeaderIndex
ResLastModified
                                  !hs :: ResponseHeaders
hs = [ (HeaderName
H.hLastModified,ByteString
date) | Bool -> Bool
not Bool
hasLM ] forall a. [a] -> [a] -> [a]
++ ResponseHeaders
hs1
                              in Status -> ResponseHeaders -> Integer -> Integer -> RspFileInfo
WithBody Status
s ResponseHeaders
hs Integer
off Integer
len
  where
    !mtime :: HTTPDate
mtime = FileInfo -> HTTPDate
I.fileInfoTime FileInfo
finfo
    !size :: Integer
size  = FileInfo -> Integer
I.fileInfoSize FileInfo
finfo
    !date :: ByteString
date  = FileInfo -> ByteString
I.fileInfoDate FileInfo
finfo
    !mcondition :: Maybe RspFileInfo
mcondition = IndexedHeader -> Integer -> HTTPDate -> Maybe RspFileInfo
ifmodified    IndexedHeader
reqidx Integer
size HTTPDate
mtime
              forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> IndexedHeader -> Integer -> HTTPDate -> Maybe RspFileInfo
ifunmodified  IndexedHeader
reqidx Integer
size HTTPDate
mtime
              forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> IndexedHeader -> Integer -> HTTPDate -> Maybe RspFileInfo
ifrange       IndexedHeader
reqidx Integer
size HTTPDate
mtime
    !condition :: RspFileInfo
condition = forall a. a -> Maybe a -> a
fromMaybe (IndexedHeader -> Integer -> RspFileInfo
unconditional IndexedHeader
reqidx Integer
size) Maybe RspFileInfo
mcondition

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

ifModifiedSince :: IndexedHeader -> Maybe HTTPDate
ifModifiedSince :: IndexedHeader -> Maybe HTTPDate
ifModifiedSince IndexedHeader
reqidx = IndexedHeader
reqidx forall i e. Ix i => Array i e -> i -> e
! forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqIfModifiedSince forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Maybe HTTPDate
parseHTTPDate

ifUnmodifiedSince :: IndexedHeader -> Maybe HTTPDate
ifUnmodifiedSince :: IndexedHeader -> Maybe HTTPDate
ifUnmodifiedSince IndexedHeader
reqidx = IndexedHeader
reqidx forall i e. Ix i => Array i e -> i -> e
! forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqIfUnmodifiedSince forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Maybe HTTPDate
parseHTTPDate

ifRange :: IndexedHeader -> Maybe HTTPDate
ifRange :: IndexedHeader -> Maybe HTTPDate
ifRange IndexedHeader
reqidx = IndexedHeader
reqidx forall i e. Ix i => Array i e -> i -> e
! forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqIfRange forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Maybe HTTPDate
parseHTTPDate

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

ifmodified :: IndexedHeader -> Integer -> HTTPDate -> Maybe RspFileInfo
ifmodified :: IndexedHeader -> Integer -> HTTPDate -> Maybe RspFileInfo
ifmodified IndexedHeader
reqidx Integer
size HTTPDate
mtime = do
    HTTPDate
date <- IndexedHeader -> Maybe HTTPDate
ifModifiedSince IndexedHeader
reqidx
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if HTTPDate
date forall a. Eq a => a -> a -> Bool
/= HTTPDate
mtime
             then IndexedHeader -> Integer -> RspFileInfo
unconditional IndexedHeader
reqidx Integer
size
             else Status -> RspFileInfo
WithoutBody Status
H.notModified304

ifunmodified :: IndexedHeader -> Integer -> HTTPDate -> Maybe RspFileInfo
ifunmodified :: IndexedHeader -> Integer -> HTTPDate -> Maybe RspFileInfo
ifunmodified IndexedHeader
reqidx Integer
size HTTPDate
mtime = do
    HTTPDate
date <- IndexedHeader -> Maybe HTTPDate
ifUnmodifiedSince IndexedHeader
reqidx
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if HTTPDate
date forall a. Eq a => a -> a -> Bool
== HTTPDate
mtime
             then IndexedHeader -> Integer -> RspFileInfo
unconditional IndexedHeader
reqidx Integer
size
             else Status -> RspFileInfo
WithoutBody Status
H.preconditionFailed412

ifrange :: IndexedHeader -> Integer -> HTTPDate -> Maybe RspFileInfo
ifrange :: IndexedHeader -> Integer -> HTTPDate -> Maybe RspFileInfo
ifrange IndexedHeader
reqidx Integer
size HTTPDate
mtime = do
    HTTPDate
date <- IndexedHeader -> Maybe HTTPDate
ifRange IndexedHeader
reqidx
    ByteString
rng  <- IndexedHeader
reqidx forall i e. Ix i => Array i e -> i -> e
! forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqRange
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if HTTPDate
date forall a. Eq a => a -> a -> Bool
== HTTPDate
mtime
             then ByteString -> Integer -> RspFileInfo
parseRange ByteString
rng Integer
size
             else Status -> ResponseHeaders -> Integer -> Integer -> RspFileInfo
WithBody Status
H.ok200 [] Integer
0 Integer
size

unconditional :: IndexedHeader -> Integer -> RspFileInfo
unconditional :: IndexedHeader -> Integer -> RspFileInfo
unconditional IndexedHeader
reqidx Integer
size = case IndexedHeader
reqidx forall i e. Ix i => Array i e -> i -> e
! forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqRange of
    Maybe ByteString
Nothing  -> Status -> ResponseHeaders -> Integer -> Integer -> RspFileInfo
WithBody Status
H.ok200 [] Integer
0 Integer
size
    Just ByteString
rng -> ByteString -> Integer -> RspFileInfo
parseRange ByteString
rng Integer
size

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

parseRange :: ByteString -> Integer -> RspFileInfo
parseRange :: ByteString -> Integer -> RspFileInfo
parseRange ByteString
rng Integer
size = case ByteString -> Maybe ByteRanges
H.parseByteRanges ByteString
rng of
    Maybe ByteRanges
Nothing    -> Status -> RspFileInfo
WithoutBody Status
H.requestedRangeNotSatisfiable416
    Just []    -> Status -> RspFileInfo
WithoutBody Status
H.requestedRangeNotSatisfiable416
    Just (ByteRange
r:ByteRanges
_) -> let (!Integer
beg, !Integer
end) = ByteRange -> Integer -> (Integer, Integer)
checkRange ByteRange
r Integer
size
                      !len :: Integer
len = Integer
end forall a. Num a => a -> a -> a
- Integer
beg forall a. Num a => a -> a -> a
+ Integer
1
                      s :: Status
s = if Integer
beg forall a. Eq a => a -> a -> Bool
== Integer
0 Bool -> Bool -> Bool
&& Integer
end forall a. Eq a => a -> a -> Bool
== Integer
size forall a. Num a => a -> a -> a
- Integer
1 then
                              Status
H.ok200
                            else
                              Status
H.partialContent206
                  in Status -> ResponseHeaders -> Integer -> Integer -> RspFileInfo
WithBody Status
s [] Integer
beg Integer
len

checkRange :: H.ByteRange -> Integer -> (Integer, Integer)
checkRange :: ByteRange -> Integer -> (Integer, Integer)
checkRange (H.ByteRangeFrom   Integer
beg)     Integer
size = (Integer
beg, Integer
size forall a. Num a => a -> a -> a
- Integer
1)
checkRange (H.ByteRangeFromTo Integer
beg Integer
end) Integer
size = (Integer
beg,  forall a. Ord a => a -> a -> a
min (Integer
size forall a. Num a => a -> a -> a
- Integer
1) Integer
end)
checkRange (H.ByteRangeSuffix Integer
count)   Integer
size = (forall a. Ord a => a -> a -> a
max Integer
0 (Integer
size forall a. Num a => a -> a -> a
- Integer
count), Integer
size forall a. Num a => a -> a -> a
- Integer
1)

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

-- | @contentRangeHeader beg end total@ constructs a Content-Range 'H.Header'
-- for the range specified.
contentRangeHeader :: Integer -> Integer -> Integer -> H.Header
contentRangeHeader :: Integer -> Integer -> Integer -> (HeaderName, ByteString)
contentRangeHeader Integer
beg Integer
end Integer
total = (HeaderName
H.hContentRange, ByteString
range)
  where
    range :: ByteString
range = String -> ByteString
C8.pack
      -- building with ShowS
      forall a b. (a -> b) -> a -> b
$ Char
'b' forall a. a -> [a] -> [a]
: Char
'y'forall a. a -> [a] -> [a]
: Char
't' forall a. a -> [a] -> [a]
: Char
'e' forall a. a -> [a] -> [a]
: Char
's' forall a. a -> [a] -> [a]
: Char
' '
      forall a. a -> [a] -> [a]
: (if Integer
beg forall a. Ord a => a -> a -> Bool
> Integer
end then (Char
'*'forall a. a -> [a] -> [a]
:) else
          forall a. Integral a => a -> ShowS
showInt Integer
beg
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'-' forall a. a -> [a] -> [a]
:)
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Integral a => a -> ShowS
showInt Integer
end)
      ( Char
'/'
      forall a. a -> [a] -> [a]
: forall a. Integral a => a -> ShowS
showInt Integer
total String
"")

addContentHeaders :: H.ResponseHeaders -> Integer -> Integer -> Integer -> H.ResponseHeaders
addContentHeaders :: ResponseHeaders -> Integer -> Integer -> Integer -> ResponseHeaders
addContentHeaders ResponseHeaders
hs Integer
off Integer
len Integer
size
  | Integer
len forall a. Eq a => a -> a -> Bool
== Integer
size = ResponseHeaders
hs'
  | Bool
otherwise   = let !ctrng :: (HeaderName, ByteString)
ctrng = Integer -> Integer -> Integer -> (HeaderName, ByteString)
contentRangeHeader Integer
off (Integer
off forall a. Num a => a -> a -> a
+ Integer
len forall a. Num a => a -> a -> a
- Integer
1) Integer
size
                  in (HeaderName, ByteString)
ctrngforall a. a -> [a] -> [a]
:ResponseHeaders
hs'
  where
    !lengthBS :: ByteString
lengthBS = forall a. Integral a => a -> ByteString
packIntegral Integer
len
    !hs' :: ResponseHeaders
hs' = (HeaderName
H.hContentLength, ByteString
lengthBS) forall a. a -> [a] -> [a]
: (HeaderName
H.hAcceptRanges,ByteString
"bytes") forall a. a -> [a] -> [a]
: ResponseHeaders
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 :: ResponseHeaders -> FilePart -> ResponseHeaders
addContentHeadersForFilePart ResponseHeaders
hs FilePart
part = ResponseHeaders -> Integer -> Integer -> Integer -> ResponseHeaders
addContentHeaders ResponseHeaders
hs Integer
off Integer
len Integer
size
  where
    off :: Integer
off = FilePart -> Integer
filePartOffset FilePart
part
    len :: Integer
len = FilePart -> Integer
filePartByteCount FilePart
part
    size :: Integer
size = FilePart -> Integer
filePartFileSize FilePart
part