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

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

import qualified Data.ByteString.Char8 as C8 (pack)
import Network.HTTP.Date (HTTPDate, parseHTTPDate)
import qualified Network.HTTP.Types as H
import qualified Network.HTTP.Types.Header as Header
import Network.Wai (FilePart (..))

import qualified Network.Wai.Handler.Warp.FileInfoCache as I
import Network.Wai.Handler.Warp.Header (
    IndexedRequestHeader (..),
    ResponseHeaderPresence (..),
 )
import Network.Wai.Handler.Warp.Imports
import Network.Wai.Handler.Warp.PackInt (packIntegral)

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

data RspFileInfo
    = WithoutBody H.Status
    | WithBody H.Status H.ResponseHeaders Integer Integer
    deriving (RspFileInfo -> RspFileInfo -> Bool
(RspFileInfo -> RspFileInfo -> Bool)
-> (RspFileInfo -> RspFileInfo -> Bool) -> Eq RspFileInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RspFileInfo -> RspFileInfo -> Bool
== :: RspFileInfo -> RspFileInfo -> Bool
$c/= :: RspFileInfo -> RspFileInfo -> Bool
/= :: RspFileInfo -> RspFileInfo -> Bool
Eq, Int -> RspFileInfo -> ShowS
[RspFileInfo] -> ShowS
RspFileInfo -> String
(Int -> RspFileInfo -> ShowS)
-> (RspFileInfo -> String)
-> ([RspFileInfo] -> ShowS)
-> Show RspFileInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RspFileInfo -> ShowS
showsPrec :: Int -> RspFileInfo -> ShowS
$cshow :: RspFileInfo -> String
show :: RspFileInfo -> String
$cshowList :: [RspFileInfo] -> ShowS
showList :: [RspFileInfo] -> ShowS
Show)

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

conditionalRequest
    :: I.FileInfo
    -> H.ResponseHeaders
    -> H.Method
    -> ResponseHeaderPresence
    -> IndexedRequestHeader
    -> RspFileInfo
conditionalRequest :: FileInfo
-> ResponseHeaders
-> Method
-> ResponseHeaderPresence
-> IndexedRequestHeader
-> RspFileInfo
conditionalRequest FileInfo
finfo ResponseHeaders
hs0 Method
method ResponseHeaderPresence
rspidx IndexedRequestHeader
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
            !hs :: ResponseHeaders
hs
                | ResponseHeaderPresence -> Bool
hasLastModified ResponseHeaderPresence
rspidx = ResponseHeaders
hs1
                | Bool
otherwise = (HeaderName
H.hLastModified, Method
date) (HeaderName, Method) -> ResponseHeaders -> ResponseHeaders
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 :: Method
date = FileInfo -> Method
I.fileInfoDate FileInfo
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 :: Maybe RspFileInfo
mcondition =
        IndexedRequestHeader -> HTTPDate -> Maybe RspFileInfo
ifunmodified IndexedRequestHeader
reqidx HTTPDate
mtime
            Maybe RspFileInfo -> Maybe RspFileInfo -> Maybe RspFileInfo
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> IndexedRequestHeader -> HTTPDate -> Method -> Maybe RspFileInfo
ifmodified IndexedRequestHeader
reqidx HTTPDate
mtime Method
method
            Maybe RspFileInfo -> Maybe RspFileInfo -> Maybe RspFileInfo
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> IndexedRequestHeader
-> HTTPDate -> Method -> Integer -> Maybe RspFileInfo
ifrange IndexedRequestHeader
reqidx HTTPDate
mtime Method
method Integer
size
    !condition :: RspFileInfo
condition = RspFileInfo -> Maybe RspFileInfo -> RspFileInfo
forall a. a -> Maybe a -> a
fromMaybe (IndexedRequestHeader -> Integer -> RspFileInfo
unconditional IndexedRequestHeader
reqidx Integer
size) Maybe RspFileInfo
mcondition

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

ifModifiedSince :: IndexedRequestHeader -> Maybe HTTPDate
ifModifiedSince :: IndexedRequestHeader -> Maybe HTTPDate
ifModifiedSince IndexedRequestHeader
reqidx = IndexedRequestHeader -> Maybe Method
reqidxIfModifiedSince IndexedRequestHeader
reqidx Maybe Method -> (Method -> Maybe HTTPDate) -> Maybe HTTPDate
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Method -> Maybe HTTPDate
parseHTTPDate

ifUnmodifiedSince :: IndexedRequestHeader -> Maybe HTTPDate
ifUnmodifiedSince :: IndexedRequestHeader -> Maybe HTTPDate
ifUnmodifiedSince IndexedRequestHeader
reqidx = IndexedRequestHeader -> Maybe Method
reqidxIfUnmodifiedSince IndexedRequestHeader
reqidx Maybe Method -> (Method -> Maybe HTTPDate) -> Maybe HTTPDate
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Method -> Maybe HTTPDate
parseHTTPDate

ifRange :: IndexedRequestHeader -> Maybe HTTPDate
ifRange :: IndexedRequestHeader -> Maybe HTTPDate
ifRange IndexedRequestHeader
reqidx = IndexedRequestHeader -> Maybe Method
reqidxIfRange IndexedRequestHeader
reqidx Maybe Method -> (Method -> Maybe HTTPDate) -> Maybe HTTPDate
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Method -> Maybe HTTPDate
parseHTTPDate

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

ifmodified
    :: IndexedRequestHeader
    -> HTTPDate
    -> H.Method
    -> Maybe RspFileInfo
ifmodified :: IndexedRequestHeader -> HTTPDate -> Method -> Maybe RspFileInfo
ifmodified IndexedRequestHeader
reqidx HTTPDate
mtime Method
method = do
    HTTPDate
date <- IndexedRequestHeader -> Maybe HTTPDate
ifModifiedSince IndexedRequestHeader
reqidx
    -- According to RFC 9110:
    -- "A recipient MUST ignore If-Modified-Since if the request
    -- contains an If-None-Match header field; [...]"
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ())
-> (Maybe Method -> Bool) -> Maybe Method -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Method -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Method -> Maybe ()) -> Maybe Method -> Maybe ()
forall a b. (a -> b) -> a -> b
$ IndexedRequestHeader -> Maybe Method
reqidxIfNoneMatch IndexedRequestHeader
reqidx
    -- "A recipient MUST ignore the If-Modified-Since header field
    -- if [...] the request method is neither GET nor HEAD."
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Method
method Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
== Method
H.methodGet Bool -> Bool -> Bool
|| Method
method Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
== Method
H.methodHead
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ HTTPDate
date HTTPDate -> HTTPDate -> Bool
forall a. Eq a => a -> a -> Bool
== HTTPDate
mtime Bool -> Bool -> Bool
|| HTTPDate
date HTTPDate -> HTTPDate -> Bool
forall a. Ord a => a -> a -> Bool
> HTTPDate
mtime
    RspFileInfo -> Maybe RspFileInfo
forall a. a -> Maybe a
Just (RspFileInfo -> Maybe RspFileInfo)
-> RspFileInfo -> Maybe RspFileInfo
forall a b. (a -> b) -> a -> b
$ Status -> RspFileInfo
WithoutBody Status
H.notModified304

ifunmodified
    :: IndexedRequestHeader -> HTTPDate -> Maybe RspFileInfo
ifunmodified :: IndexedRequestHeader -> HTTPDate -> Maybe RspFileInfo
ifunmodified IndexedRequestHeader
reqidx HTTPDate
mtime = do
    HTTPDate
date <- IndexedRequestHeader -> Maybe HTTPDate
ifUnmodifiedSince IndexedRequestHeader
reqidx
    -- According to RFC 9110:
    -- "A recipient MUST ignore If-Unmodified-Since if the request
    -- contains an If-Match header field; [...]"
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ())
-> (Maybe Method -> Bool) -> Maybe Method -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Method -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Method -> Maybe ()) -> Maybe Method -> Maybe ()
forall a b. (a -> b) -> a -> b
$ IndexedRequestHeader -> Maybe Method
reqidxIfMatch IndexedRequestHeader
reqidx
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ HTTPDate
date HTTPDate -> HTTPDate -> Bool
forall a. Eq a => a -> a -> Bool
/= HTTPDate
mtime Bool -> Bool -> Bool
&& HTTPDate
date HTTPDate -> HTTPDate -> Bool
forall a. Ord a => a -> a -> Bool
< HTTPDate
mtime
    RspFileInfo -> Maybe RspFileInfo
forall a. a -> Maybe a
Just (RspFileInfo -> Maybe RspFileInfo)
-> RspFileInfo -> Maybe RspFileInfo
forall a b. (a -> b) -> a -> b
$ Status -> RspFileInfo
WithoutBody Status
H.preconditionFailed412

-- TODO: Should technically also strongly match on ETags.
ifrange
    :: IndexedRequestHeader
    -> HTTPDate
    -> H.Method
    -> Integer
    -> Maybe RspFileInfo
ifrange :: IndexedRequestHeader
-> HTTPDate -> Method -> Integer -> Maybe RspFileInfo
ifrange IndexedRequestHeader
reqidx HTTPDate
mtime Method
method Integer
size = do
    -- According to RFC 9110:
    -- "When the method is GET and both Range and If-Range are
    -- present, evaluate the If-Range precondition:"
    HTTPDate
date <- IndexedRequestHeader -> Maybe HTTPDate
ifRange IndexedRequestHeader
reqidx
    Method
rng <- IndexedRequestHeader -> Maybe Method
reqidxRange IndexedRequestHeader
reqidx
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Method
method Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
== Method
H.methodGet
    RspFileInfo -> Maybe RspFileInfo
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (RspFileInfo -> Maybe RspFileInfo)
-> RspFileInfo -> Maybe RspFileInfo
forall a b. (a -> b) -> a -> b
$
        if HTTPDate
date HTTPDate -> HTTPDate -> Bool
forall a. Eq a => a -> a -> Bool
== HTTPDate
mtime
            then Method -> Integer -> RspFileInfo
parseRange Method
rng Integer
size
            else Status -> ResponseHeaders -> Integer -> Integer -> RspFileInfo
WithBody Status
H.ok200 [] Integer
0 Integer
size

unconditional :: IndexedRequestHeader -> Integer -> RspFileInfo
unconditional :: IndexedRequestHeader -> Integer -> RspFileInfo
unconditional IndexedRequestHeader
reqidx =
    case IndexedRequestHeader -> Maybe Method
reqidxRange IndexedRequestHeader
reqidx of
        Maybe Method
Nothing -> Status -> ResponseHeaders -> Integer -> Integer -> RspFileInfo
WithBody Status
H.ok200 [] Integer
0
        Just Method
rng -> Method -> Integer -> RspFileInfo
parseRange Method
rng

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

parseRange :: ByteString -> Integer -> RspFileInfo
parseRange :: Method -> Integer -> RspFileInfo
parseRange Method
rng Integer
size = case Method -> Maybe ByteRanges
H.parseByteRanges Method
rng of
    Just (ByteRange
r : ByteRanges
_) | Just (!Integer
beg, !Integer
end) <- ByteRange -> Integer -> Maybe (Integer, Integer)
checkRange ByteRange
r Integer
size ->
        let !len :: Integer
len = Integer
end Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
beg Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1
            s :: Status
s =
                if Integer
beg Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 Bool -> Bool -> Bool
&& Integer
end Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
size Integer -> Integer -> Integer
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
    Maybe ByteRanges
_ -> Status -> RspFileInfo
WithoutBody Status
H.requestedRangeNotSatisfiable416

-- | The first and last byte a range asks for, or 'Nothing' when it asks
--   for nothing the file holds, which RFC 9110 section 14.4 answers with
--   416.
checkRange :: H.ByteRange -> Integer -> Maybe (Integer, Integer)
checkRange :: ByteRange -> Integer -> Maybe (Integer, Integer)
checkRange (H.ByteRangeFrom Integer
beg) Integer
size
    | Integer
beg Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 Bool -> Bool -> Bool
|| Integer
beg Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
size = Maybe (Integer, Integer)
forall a. Maybe a
Nothing
    | Bool
otherwise = (Integer, Integer) -> Maybe (Integer, Integer)
forall a. a -> Maybe a
Just (Integer
beg, Integer
size Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1)
checkRange (H.ByteRangeFromTo Integer
beg Integer
end) Integer
size
    | Integer
beg Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 Bool -> Bool -> Bool
|| Integer
beg Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
end Bool -> Bool -> Bool
|| Integer
beg Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
size = Maybe (Integer, Integer)
forall a. Maybe a
Nothing
    | Bool
otherwise = (Integer, Integer) -> Maybe (Integer, Integer)
forall a. a -> Maybe a
Just (Integer
beg, Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
min (Integer
size Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1) Integer
end)
checkRange (H.ByteRangeSuffix Integer
count) Integer
size
    | Integer
count Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0 Bool -> Bool -> Bool
|| Integer
size Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0 = Maybe (Integer, Integer)
forall a. Maybe a
Nothing
    | Bool
otherwise = (Integer, Integer) -> Maybe (Integer, Integer)
forall a. a -> Maybe a
Just (Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
0 (Integer
size Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
count), Integer
size Integer -> Integer -> Integer
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, Method)
contentRangeHeader Integer
beg Integer
end Integer
total = (HeaderName
Header.hContentRange, Method
range)
  where
    range :: Method
range =
        String -> Method
C8.pack
        -- building with ShowS
        (String -> Method) -> String -> Method
forall a b. (a -> b) -> a -> b
$
            Char
'b'
                Char -> ShowS
forall a. a -> [a] -> [a]
: Char
'y'
                Char -> ShowS
forall a. a -> [a] -> [a]
: Char
't'
                Char -> ShowS
forall a. a -> [a] -> [a]
: Char
'e'
                Char -> ShowS
forall a. a -> [a] -> [a]
: Char
's'
                Char -> ShowS
forall a. a -> [a] -> [a]
: Char
' '
                Char -> ShowS
forall a. a -> [a] -> [a]
: ( if Integer
beg Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
end
                        then (Char
'*' Char -> ShowS
forall a. a -> [a] -> [a]
:)
                        else
                            Integer -> ShowS
forall a. Integral a => a -> ShowS
showInt Integer
beg
                                ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'-' Char -> ShowS
forall a. a -> [a] -> [a]
:)
                                ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> ShowS
forall a. Integral a => a -> ShowS
showInt Integer
end
                  )
                    ( Char
'/'
                        Char -> ShowS
forall a. a -> [a] -> [a]
: Integer -> ShowS
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 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
size = ResponseHeaders
hs'
    | Bool
otherwise =
        let !ctrng :: (HeaderName, Method)
ctrng = Integer -> Integer -> Integer -> (HeaderName, Method)
contentRangeHeader Integer
off (Integer
off Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
len Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1) Integer
size
         in (HeaderName, Method)
ctrng (HeaderName, Method) -> ResponseHeaders -> ResponseHeaders
forall a. a -> [a] -> [a]
: ResponseHeaders
hs'
  where
    !lengthBS :: Method
lengthBS = Integer -> Method
forall a. Integral a => a -> Method
packIntegral Integer
len
    !hs' :: ResponseHeaders
hs' =
        (HeaderName
Header.hContentLength, Method
lengthBS)
            (HeaderName, Method) -> ResponseHeaders -> ResponseHeaders
forall a. a -> [a] -> [a]
: (HeaderName
Header.hAcceptRanges, Method
"bytes")
            (HeaderName, Method) -> ResponseHeaders -> ResponseHeaders
forall a. a -> [a] -> [a]
: ((HeaderName, Method) -> Bool)
-> ResponseHeaders -> ResponseHeaders
forall a. (a -> Bool) -> [a] -> [a]
filter (\(HeaderName
h, Method
_) -> HeaderName
h HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
/= HeaderName
Header.hContentLength Bool -> Bool -> Bool
&& HeaderName
h HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
/= HeaderName
Header.hAcceptRanges) 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