    {-# 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
    (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
                       -> IndexedHeader -- ^ Response
                       -> IndexedHeader -- ^ Request
                       -> RspFileInfo
    conditionalRequest :: FileInfo
    -> ResponseHeaders
    -> Method
    -> IndexedHeader
    -> IndexedHeader
    -> RspFileInfo
    conditionalRequest FileInfo
    finfo ResponseHeaders
    hs0 Method
    method 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
                !hs :: ResponseHeaders
    hs = case IndexedHeader
    rspidx IndexedHeader -> Int -> Maybe Method
    forall i e. Ix i => Array i e -> i -> e
    ! ResponseHeaderIndex -> Int
    forall a. Enum a => a -> Int
    fromEnum ResponseHeaderIndex
    ResLastModified of
                    Just Method
    _ -> ResponseHeaders
    hs1
                    Maybe Method
    Nothing -> (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 = IndexedHeader -> HTTPDate -> Maybe RspFileInfo
    ifunmodified  IndexedHeader
    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
    <|> IndexedHeader -> HTTPDate -> Method -> Maybe RspFileInfo
    ifmodified    IndexedHeader
    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
    <|> IndexedHeader -> HTTPDate -> Method -> Integer -> Maybe RspFileInfo
    ifrange       IndexedHeader
    reqidx HTTPDate
    mtime Method
    method Integer
    size
        !condition :: RspFileInfo
    condition = RspFileInfo -> Maybe RspFileInfo -> RspFileInfo
    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 IndexedHeader -> Int -> Maybe Method
    forall i e. Ix i => Array i e -> i -> e
    ! RequestHeaderIndex -> Int
    forall a. Enum a => a -> Int
    fromEnum RequestHeaderIndex
    ReqIfModifiedSince 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 :: IndexedHeader -> Maybe HTTPDate
    ifUnmodifiedSince :: IndexedHeader -> Maybe HTTPDate
    ifUnmodifiedSince IndexedHeader
    reqidx = IndexedHeader
    reqidx IndexedHeader -> Int -> Maybe Method
    forall i e. Ix i => Array i e -> i -> e
    ! RequestHeaderIndex -> Int
    forall a. Enum a => a -> Int
    fromEnum RequestHeaderIndex
    ReqIfUnmodifiedSince 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 :: IndexedHeader -> Maybe HTTPDate
    ifRange :: IndexedHeader -> Maybe HTTPDate
    ifRange IndexedHeader
    reqidx = IndexedHeader
    reqidx IndexedHeader -> Int -> Maybe Method
    forall i e. Ix i => Array i e -> i -> e
    ! RequestHeaderIndex -> Int
    forall a. Enum a => a -> Int
    fromEnum RequestHeaderIndex
    ReqIfRange 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 :: IndexedHeader -> HTTPDate -> H.Method -> Maybe RspFileInfo
    ifmodified :: IndexedHeader -> HTTPDate -> Method -> Maybe RspFileInfo
    ifmodified IndexedHeader
    reqidx HTTPDate
    mtime Method
    method = do
        HTTPDate
    date <- IndexedHeader -> Maybe HTTPDate
    ifModifiedSince IndexedHeader
    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
    $ IndexedHeader
    reqidx IndexedHeader -> Int -> Maybe Method
    forall i e. Ix i => Array i e -> i -> e
    ! RequestHeaderIndex -> Int
    forall a. Enum a => a -> Int
    fromEnum RequestHeaderIndex
    ReqIfNoneMatch
        -- "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 :: IndexedHeader -> HTTPDate -> Maybe RspFileInfo
    ifunmodified :: IndexedHeader -> HTTPDate -> Maybe RspFileInfo
    ifunmodified IndexedHeader
    reqidx HTTPDate
    mtime = do
        HTTPDate
    date <- IndexedHeader -> Maybe HTTPDate
    ifUnmodifiedSince IndexedHeader
    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
    $ IndexedHeader
    reqidx IndexedHeader -> Int -> Maybe Method
    forall i e. Ix i => Array i e -> i -> e
    ! RequestHeaderIndex -> Int
    forall a. Enum a => a -> Int
    fromEnum RequestHeaderIndex
    ReqIfMatch
        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 :: IndexedHeader -> HTTPDate -> H.Method -> Integer -> Maybe RspFileInfo
    ifrange :: IndexedHeader -> HTTPDate -> Method -> Integer -> Maybe RspFileInfo
    ifrange IndexedHeader
    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 <- IndexedHeader -> Maybe HTTPDate
    ifRange IndexedHeader
    reqidx
        Method
    rng  <- IndexedHeader
    reqidx IndexedHeader -> Int -> Maybe Method
    forall i e. Ix i => Array i e -> i -> e
    ! RequestHeaderIndex -> Int
    forall a. Enum a => a -> Int
    fromEnum RequestHeaderIndex
    ReqRange
        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 :: IndexedHeader -> Integer -> RspFileInfo
    unconditional :: IndexedHeader -> Integer -> RspFileInfo
    unconditional IndexedHeader
    reqidx =
        case IndexedHeader
    reqidx IndexedHeader -> Int -> Maybe Method
    forall i e. Ix i => Array i e -> i -> e
    ! RequestHeaderIndex -> Int
    forall a. Enum a => a -> Int
    fromEnum RequestHeaderIndex
    ReqRange 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
        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 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

    checkRange :: H.ByteRange -> Integer -> (Integer, Integer)
    checkRange :: ByteRange -> Integer -> (Integer, Integer)
    checkRange (H.ByteRangeFrom   Integer
    beg)     Integer
    size = (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 -> 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 -> 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
    H.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
    H.hContentLength, Method
    lengthBS) (HeaderName, Method) -> ResponseHeaders -> ResponseHeaders
    forall a. a -> [a] -> [a]
    : (HeaderName
    H.hAcceptRanges,Method
    "bytes") (HeaderName, Method) -> ResponseHeaders -> ResponseHeaders
    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