{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell, CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE PatternGuards #-}
-- | Static file serving for WAI.
module Network.Wai.Application.Static
    ( -- * WAI application
      staticApp
      -- ** Default Settings
    , defaultWebAppSettings
    , webAppSettingsWithLookup
    , defaultFileServerSettings
    , embeddedSettings
      -- ** Settings
    , StaticSettings
    , ssLookupFile
    , ssMkRedirect
    , ssGetMimeType
    , ssListing
    , ssIndices
    , ssMaxAge
    , ssRedirectToIndex
    , ssAddTrailingSlash
    , ss404Handler
    ) where

import Prelude hiding (FilePath)
import qualified Network.Wai as W
import qualified Network.HTTP.Types as H
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import Data.ByteString.Lazy.Char8 ()
import Control.Monad.IO.Class (liftIO)

import Data.ByteString.Builder (toLazyByteString)

import Data.FileEmbed (embedFile, makeRelativeToProject)

import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE

import Network.HTTP.Date (parseHTTPDate, epochTimeToHTTPDate, formatHTTPDate)

import WaiAppStatic.Types
import Util
import WaiAppStatic.Storage.Filesystem
import WaiAppStatic.Storage.Embedded
import Network.Mime (MimeType)

data StaticResponse =
      -- | Just the etag hash or Nothing for no etag hash
      Redirect Pieces (Maybe ByteString)
    | RawRedirect ByteString
    | NotFound
    | FileResponse File H.ResponseHeaders
    | NotModified
    -- TODO: add file size
    | SendContent MimeType L.ByteString
    | WaiResponse W.Response

safeInit  :: [a] -> [a]
safeInit :: forall a. [a] -> [a]
safeInit [] = []
safeInit [a]
xs = forall a. [a] -> [a]
init [a]
xs

filterButLast :: (a -> Bool) -> [a] -> [a]
filterButLast :: forall a. (a -> Bool) -> [a] -> [a]
filterButLast a -> Bool
_ [] = []
filterButLast a -> Bool
_ [a
x] = [a
x]
filterButLast a -> Bool
f (a
x:[a]
xs)
    | a -> Bool
f a
x = a
x forall a. a -> [a] -> [a]
: forall a. (a -> Bool) -> [a] -> [a]
filterButLast a -> Bool
f [a]
xs
    | Bool
otherwise = forall a. (a -> Bool) -> [a] -> [a]
filterButLast a -> Bool
f [a]
xs

-- | Serve an appropriate response for a folder request.
serveFolder :: StaticSettings -> Pieces -> W.Request -> Folder -> IO StaticResponse
serveFolder :: StaticSettings -> Pieces -> Request -> Folder -> IO StaticResponse
serveFolder StaticSettings {Bool
Pieces
Maybe Listing
Maybe Application
MaxAge
Pieces -> IO LookupResult
Pieces -> ByteString -> ByteString
File -> IO ByteString
ssUseHash :: StaticSettings -> Bool
ss404Handler :: Maybe Application
ssAddTrailingSlash :: Bool
ssUseHash :: Bool
ssRedirectToIndex :: Bool
ssMkRedirect :: Pieces -> ByteString -> ByteString
ssMaxAge :: MaxAge
ssListing :: Maybe Listing
ssIndices :: Pieces
ssGetMimeType :: File -> IO ByteString
ssLookupFile :: Pieces -> IO LookupResult
ss404Handler :: StaticSettings -> Maybe Application
ssAddTrailingSlash :: StaticSettings -> Bool
ssRedirectToIndex :: StaticSettings -> Bool
ssMaxAge :: StaticSettings -> MaxAge
ssIndices :: StaticSettings -> Pieces
ssListing :: StaticSettings -> Maybe Listing
ssGetMimeType :: StaticSettings -> File -> IO ByteString
ssMkRedirect :: StaticSettings -> Pieces -> ByteString -> ByteString
ssLookupFile :: StaticSettings -> Pieces -> IO LookupResult
..} Pieces
pieces Request
req Folder
folder =
    case Maybe Listing
ssListing of
        Just Listing
_ | Just ByteString
path <- Request -> Maybe ByteString
addTrailingSlash Request
req, Bool
ssAddTrailingSlash ->
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ByteString -> StaticResponse
RawRedirect ByteString
path
        Just Listing
listing -> do
            -- directory listings turned on, display it
            Builder
builder <- Listing
listing Pieces
pieces Folder
folder
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Response -> StaticResponse
WaiResponse forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> Builder -> Response
W.responseBuilder Status
H.status200
                [ (HeaderName
"Content-Type", ByteString
"text/html; charset=utf-8")
                ] Builder
builder
        Maybe Listing
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Response -> StaticResponse
WaiResponse forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
W.responseLBS Status
H.status403
            [ (HeaderName
"Content-Type", ByteString
"text/plain")
            ] ByteString
"Directory listings disabled"

addTrailingSlash :: W.Request -> Maybe ByteString
addTrailingSlash :: Request -> Maybe ByteString
addTrailingSlash Request
req
    | ByteString -> Bool
S8.null ByteString
rp = forall a. a -> Maybe a
Just ByteString
"/"
    | ByteString -> Char
S8.last ByteString
rp forall a. Eq a => a -> a -> Bool
== Char
'/' = forall a. Maybe a
Nothing
    | Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ByteString -> Char -> ByteString
S8.snoc ByteString
rp Char
'/'
  where
    rp :: ByteString
rp = Request -> ByteString
W.rawPathInfo Request
req

checkPieces :: StaticSettings
            -> Pieces                    -- ^ parsed request
            -> W.Request
            -> IO StaticResponse
-- If we have any empty pieces in the middle of the requested path, generate a
-- redirect to get rid of them.
checkPieces :: StaticSettings -> Pieces -> Request -> IO StaticResponse
checkPieces StaticSettings
_ Pieces
pieces Request
_ | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Bool
T.null forall b c a. (b -> c) -> (a -> b) -> a -> c
. Piece -> Text
fromPiece) forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
safeInit Pieces
pieces =
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Pieces -> Maybe ByteString -> StaticResponse
Redirect (forall a. (a -> Bool) -> [a] -> [a]
filterButLast (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null forall b c a. (b -> c) -> (a -> b) -> a -> c
. Piece -> Text
fromPiece) Pieces
pieces) forall a. Maybe a
Nothing

checkPieces ss :: StaticSettings
ss@StaticSettings {Bool
Pieces
Maybe Listing
Maybe Application
MaxAge
Pieces -> IO LookupResult
Pieces -> ByteString -> ByteString
File -> IO ByteString
ss404Handler :: Maybe Application
ssAddTrailingSlash :: Bool
ssUseHash :: Bool
ssRedirectToIndex :: Bool
ssMkRedirect :: Pieces -> ByteString -> ByteString
ssMaxAge :: MaxAge
ssListing :: Maybe Listing
ssIndices :: Pieces
ssGetMimeType :: File -> IO ByteString
ssLookupFile :: Pieces -> IO LookupResult
ssUseHash :: StaticSettings -> Bool
ss404Handler :: StaticSettings -> Maybe Application
ssAddTrailingSlash :: StaticSettings -> Bool
ssRedirectToIndex :: StaticSettings -> Bool
ssMaxAge :: StaticSettings -> MaxAge
ssIndices :: StaticSettings -> Pieces
ssListing :: StaticSettings -> Maybe Listing
ssGetMimeType :: StaticSettings -> File -> IO ByteString
ssMkRedirect :: StaticSettings -> Pieces -> ByteString -> ByteString
ssLookupFile :: StaticSettings -> Pieces -> IO LookupResult
..} Pieces
pieces Request
req = do
    Either ByteString LookupResult
res <- IO (Either ByteString LookupResult)
lookupResult
    case Either ByteString LookupResult
res of
        Left ByteString
location -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ByteString -> StaticResponse
RawRedirect ByteString
location
        Right LookupResult
LRNotFound -> forall (m :: * -> *) a. Monad m => a -> m a
return StaticResponse
NotFound
        Right (LRFile File
file) -> StaticSettings -> Request -> File -> IO StaticResponse
serveFile StaticSettings
ss Request
req File
file
        Right (LRFolder Folder
folder) -> StaticSettings -> Pieces -> Request -> Folder -> IO StaticResponse
serveFolder StaticSettings
ss Pieces
pieces Request
req Folder
folder
  where
    lookupResult :: IO (Either ByteString LookupResult)
    lookupResult :: IO (Either ByteString LookupResult)
lookupResult = do
      LookupResult
nonIndexResult <- Pieces -> IO LookupResult
ssLookupFile Pieces
pieces
      case LookupResult
nonIndexResult of
          LRFile{} -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right LookupResult
nonIndexResult
          LookupResult
_ -> do
              Either ByteString LookupResult
eIndexResult <- [Pieces] -> IO (Either ByteString LookupResult)
lookupIndices (forall a b. (a -> b) -> [a] -> [b]
map (\ Piece
index -> Pieces -> Pieces
dropLastIfNull Pieces
pieces forall a. [a] -> [a] -> [a]
++ [Piece
index]) Pieces
ssIndices)
              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Either ByteString LookupResult
eIndexResult of
                  Left ByteString
redirect -> forall a b. a -> Either a b
Left ByteString
redirect
                  Right LookupResult
indexResult -> case LookupResult
indexResult of
                      LookupResult
LRNotFound -> forall a b. b -> Either a b
Right LookupResult
nonIndexResult
                      LRFile File
file | Bool
ssRedirectToIndex ->
                          let relPath :: Text
relPath =
                                  case forall a. [a] -> [a]
reverse Pieces
pieces of
                                      -- Served at root
                                      [] -> Piece -> Text
fromPiece forall a b. (a -> b) -> a -> b
$ File -> Piece
fileName File
file
                                      Piece
lastSegment:Pieces
_ ->
                                          case Piece -> Text
fromPiece Piece
lastSegment of
                                              -- Ends with a trailing slash
                                              Text
"" -> Piece -> Text
fromPiece forall a b. (a -> b) -> a -> b
$ File -> Piece
fileName File
file
                                              -- Lacks a trailing slash
                                              Text
lastSegment' -> [Text] -> Text
T.concat
                                                  [ Text
lastSegment'
                                                  , Text
"/"
                                                  , Piece -> Text
fromPiece forall a b. (a -> b) -> a -> b
$ File -> Piece
fileName File
file
                                                  ]
                           in forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TE.encodeUtf8 Text
relPath
                      LookupResult
_ -> forall a b. b -> Either a b
Right LookupResult
indexResult

    lookupIndices :: [Pieces] -> IO (Either ByteString LookupResult)
    lookupIndices :: [Pieces] -> IO (Either ByteString LookupResult)
lookupIndices (Pieces
x : [Pieces]
xs) = do
        LookupResult
res <- Pieces -> IO LookupResult
ssLookupFile Pieces
x
        case LookupResult
res of
            LookupResult
LRNotFound -> [Pieces] -> IO (Either ByteString LookupResult)
lookupIndices [Pieces]
xs
            LookupResult
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case (Bool
ssAddTrailingSlash, Request -> Maybe ByteString
addTrailingSlash Request
req) of
                (Bool
True, Just ByteString
redirect) -> forall a b. a -> Either a b
Left ByteString
redirect
                (Bool, Maybe ByteString)
_ -> forall a b. b -> Either a b
Right LookupResult
res
    lookupIndices [] = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right LookupResult
LRNotFound

serveFile :: StaticSettings -> W.Request -> File -> IO StaticResponse
serveFile :: StaticSettings -> Request -> File -> IO StaticResponse
serveFile StaticSettings {Bool
Pieces
Maybe Listing
Maybe Application
MaxAge
Pieces -> IO LookupResult
Pieces -> ByteString -> ByteString
File -> IO ByteString
ss404Handler :: Maybe Application
ssAddTrailingSlash :: Bool
ssUseHash :: Bool
ssRedirectToIndex :: Bool
ssMkRedirect :: Pieces -> ByteString -> ByteString
ssMaxAge :: MaxAge
ssListing :: Maybe Listing
ssIndices :: Pieces
ssGetMimeType :: File -> IO ByteString
ssLookupFile :: Pieces -> IO LookupResult
ssUseHash :: StaticSettings -> Bool
ss404Handler :: StaticSettings -> Maybe Application
ssAddTrailingSlash :: StaticSettings -> Bool
ssRedirectToIndex :: StaticSettings -> Bool
ssMaxAge :: StaticSettings -> MaxAge
ssIndices :: StaticSettings -> Pieces
ssListing :: StaticSettings -> Maybe Listing
ssGetMimeType :: StaticSettings -> File -> IO ByteString
ssMkRedirect :: StaticSettings -> Pieces -> ByteString -> ByteString
ssLookupFile :: StaticSettings -> Pieces -> IO LookupResult
..} Request
req File
file
    -- First check etag values, if turned on
    | Bool
ssUseHash = do
        Maybe ByteString
mHash <- File -> IO (Maybe ByteString)
fileGetHash File
file
        case (Maybe ByteString
mHash, forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"if-none-match" forall a b. (a -> b) -> a -> b
$ Request -> ResponseHeaders
W.requestHeaders Request
req) of
            -- if-none-match matches the actual hash, return a 304
            (Just ByteString
hash, Just ByteString
lastHash) | ByteString
hash forall a. Eq a => a -> a -> Bool
== ByteString
lastHash -> forall (m :: * -> *) a. Monad m => a -> m a
return StaticResponse
NotModified

            -- Didn't match, but we have a hash value. Send the file contents
            -- with an ETag header.
            --
            -- RFC7232 (HTTP 1.1):
            -- > A recipient MUST ignore If-Modified-Since if the request contains an
            -- > If-None-Match header field; the condition in If-None-Match is
            -- > considered to be a more accurate replacement for the condition in
            -- > If-Modified-Since, and the two are only combined for the sake of
            -- > interoperating with older intermediaries that might not implement
            -- > If-None-Match.
            (Just ByteString
hash, Maybe ByteString
_) -> forall {m :: * -> *}.
Monad m =>
ResponseHeaders -> m StaticResponse
respond [(HeaderName
"ETag", ByteString
hash)]

            -- No hash value available, fall back to last modified support.
            (Maybe ByteString
Nothing, Maybe ByteString
_) -> IO StaticResponse
lastMod
    -- etag turned off, so jump straight to last modified
    | Bool
otherwise = IO StaticResponse
lastMod
  where
    mLastSent :: Maybe HTTPDate
mLastSent = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"if-modified-since" (Request -> ResponseHeaders
W.requestHeaders Request
req) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Maybe HTTPDate
parseHTTPDate
    lastMod :: IO StaticResponse
lastMod =
        case (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap EpochTime -> HTTPDate
epochTimeToHTTPDate forall a b. (a -> b) -> a -> b
$ File -> Maybe EpochTime
fileGetModified File
file, Maybe HTTPDate
mLastSent) of
            -- File modified time is equal to the if-modified-since header,
            -- return a 304.
            --
            -- Question: should the comparison be, date <= lastSent?
            (Just HTTPDate
mdate, Just HTTPDate
lastSent)
                | HTTPDate
mdate forall a. Eq a => a -> a -> Bool
== HTTPDate
lastSent -> forall (m :: * -> *) a. Monad m => a -> m a
return StaticResponse
NotModified

            -- Did not match, but we have a new last-modified header
            (Just HTTPDate
mdate, Maybe HTTPDate
_) -> forall {m :: * -> *}.
Monad m =>
ResponseHeaders -> m StaticResponse
respond [(HeaderName
"last-modified", HTTPDate -> ByteString
formatHTTPDate HTTPDate
mdate)]

            -- No modification time available
            (Maybe HTTPDate
Nothing, Maybe HTTPDate
_) -> forall {m :: * -> *}.
Monad m =>
ResponseHeaders -> m StaticResponse
respond []

    -- Send a file response with the additional weak headers provided.
    respond :: ResponseHeaders -> m StaticResponse
respond ResponseHeaders
headers = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ File -> ResponseHeaders -> StaticResponse
FileResponse File
file forall a b. (a -> b) -> a -> b
$ MaxAge -> ResponseHeaders -> ResponseHeaders
cacheControl MaxAge
ssMaxAge ResponseHeaders
headers

-- | Return a difference list of headers based on the specified MaxAge.
--
-- This function will return both Cache-Control and Expires headers, as
-- relevant.
cacheControl :: MaxAge -> (H.ResponseHeaders -> H.ResponseHeaders)
cacheControl :: MaxAge -> ResponseHeaders -> ResponseHeaders
cacheControl MaxAge
maxage =
    ResponseHeaders -> ResponseHeaders
headerCacheControl forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResponseHeaders -> ResponseHeaders
headerExpires
  where
    oneYear :: Int
    oneYear :: Int
oneYear = Int
60 forall a. Num a => a -> a -> a
* Int
60 forall a. Num a => a -> a -> a
* Int
24 forall a. Num a => a -> a -> a
* Int
365

    maxAgeValue :: a -> ByteString
maxAgeValue a
i = ByteString -> ByteString -> ByteString
S8.append ByteString
"public, max-age=" forall a b. (a -> b) -> a -> b
$ String -> ByteString
S8.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show a
i

    headerCacheControl :: ResponseHeaders -> ResponseHeaders
headerCacheControl = case MaxAge
maxage of
        MaxAge
NoMaxAge -> forall a. a -> a
id
        MaxAgeSeconds Int
i -> (:) (HeaderName
"Cache-Control", forall {a}. Show a => a -> ByteString
maxAgeValue Int
i)
        MaxAge
MaxAgeForever -> (:) (HeaderName
"Cache-Control", forall {a}. Show a => a -> ByteString
maxAgeValue Int
oneYear)
        MaxAge
NoStore -> (:) (HeaderName
"Cache-Control", ByteString
"no-store")
    headerExpires :: ResponseHeaders -> ResponseHeaders
headerExpires =
      case MaxAge
maxage of
        MaxAge
NoMaxAge        -> forall a. a -> a
id
        MaxAgeSeconds Int
_ -> forall a. a -> a
id -- FIXME
        MaxAge
MaxAgeForever   -> (:) (HeaderName
"Expires", ByteString
"Thu, 31 Dec 2037 23:55:55 GMT")
        MaxAge
NoStore -> forall a. a -> a
id

-- | Turn a @StaticSettings@ into a WAI application.
staticApp :: StaticSettings -> W.Application
staticApp :: StaticSettings -> Application
staticApp StaticSettings
set Request
req = StaticSettings -> [Text] -> Application
staticAppPieces StaticSettings
set (Request -> [Text]
W.pathInfo Request
req) Request
req

staticAppPieces :: StaticSettings -> [Text] -> W.Application
staticAppPieces :: StaticSettings -> [Text] -> Application
staticAppPieces StaticSettings
_ [Text]
_ Request
req Response -> IO ResponseReceived
sendResponse
    | forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem (Request -> ByteString
W.requestMethod Request
req) [ByteString
"GET", ByteString
"HEAD"] = Response -> IO ResponseReceived
sendResponse forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
W.responseLBS
        Status
H.status405
        [(HeaderName
"Content-Type", ByteString
"text/plain")]
        ByteString
"Only GET or HEAD is supported"
staticAppPieces StaticSettings
_ [Text
".hidden", Text
"folder.png"] Request
_ Response -> IO ResponseReceived
sendResponse = Response -> IO ResponseReceived
sendResponse forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
W.responseLBS Status
H.status200 [(HeaderName
"Content-Type", ByteString
"image/png")] forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
L.fromChunks [$(makeRelativeToProject "images/folder.png" >>= embedFile)]
staticAppPieces StaticSettings
_ [Text
".hidden", Text
"haskell.png"] Request
_ Response -> IO ResponseReceived
sendResponse = Response -> IO ResponseReceived
sendResponse forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
W.responseLBS Status
H.status200 [(HeaderName
"Content-Type", ByteString
"image/png")] forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
L.fromChunks [$(makeRelativeToProject "images/haskell.png" >>= embedFile)]
staticAppPieces StaticSettings
ss [Text]
rawPieces Request
req Response -> IO ResponseReceived
sendResponse = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    case [Text] -> Maybe Pieces
toPieces [Text]
rawPieces of
        Just Pieces
pieces -> StaticSettings -> Pieces -> Request -> IO StaticResponse
checkPieces StaticSettings
ss Pieces
pieces Request
req forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StaticResponse -> IO ResponseReceived
response
        Maybe Pieces
Nothing -> Response -> IO ResponseReceived
sendResponse forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
W.responseLBS Status
H.status403
            [ (HeaderName
"Content-Type", ByteString
"text/plain")
            ] ByteString
"Forbidden"
  where
    response :: StaticResponse -> IO W.ResponseReceived
    response :: StaticResponse -> IO ResponseReceived
response (FileResponse File
file ResponseHeaders
ch) = do
        ByteString
mimetype <- StaticSettings -> File -> IO ByteString
ssGetMimeType StaticSettings
ss File
file
        -- let filesize = fileGetSize file
        let headers :: ResponseHeaders
headers = (HeaderName
"Content-Type", ByteString
mimetype)
                    -- Let Warp provide the content-length, since it takes
                    -- range requests into account
                    -- : ("Content-Length", S8.pack $ show filesize)
                    forall a. a -> [a] -> [a]
: ResponseHeaders
ch
        Response -> IO ResponseReceived
sendResponse forall a b. (a -> b) -> a -> b
$ File -> Status -> ResponseHeaders -> Response
fileToResponse File
file Status
H.status200 ResponseHeaders
headers

    response StaticResponse
NotModified =
            Response -> IO ResponseReceived
sendResponse forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
W.responseLBS Status
H.status304 [] ByteString
""

    response (SendContent ByteString
mt ByteString
lbs) = do
            -- TODO: set caching headers
            Response -> IO ResponseReceived
sendResponse forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
W.responseLBS Status
H.status200
                [ (HeaderName
"Content-Type", ByteString
mt)
                  -- TODO: set Content-Length
                ] ByteString
lbs

    response (Redirect Pieces
pieces' Maybe ByteString
mHash) = do
            let loc :: ByteString
loc = StaticSettings -> Pieces -> ByteString -> ByteString
ssMkRedirect StaticSettings
ss Pieces
pieces' forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
L.toStrict forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString ([Text] -> Builder
H.encodePathSegments forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Piece -> Text
fromPiece Pieces
pieces')
            let qString :: [(ByteString, Maybe ByteString)]
qString = case Maybe ByteString
mHash of
                  Just ByteString
hash -> forall a b. Eq a => a -> b -> [(a, b)] -> [(a, b)]
replace ByteString
"etag" (forall a. a -> Maybe a
Just ByteString
hash) (Request -> [(ByteString, Maybe ByteString)]
W.queryString Request
req)
                  Maybe ByteString
Nothing   -> forall a b. Eq a => a -> [(a, b)] -> [(a, b)]
remove ByteString
"etag" (Request -> [(ByteString, Maybe ByteString)]
W.queryString Request
req)

            Response -> IO ResponseReceived
sendResponse forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
W.responseLBS Status
H.status302
                [ (HeaderName
"Content-Type", ByteString
"text/plain")
                , (HeaderName
"Location", ByteString -> ByteString -> ByteString
S8.append ByteString
loc forall a b. (a -> b) -> a -> b
$ Bool -> [(ByteString, Maybe ByteString)] -> ByteString
H.renderQuery Bool
True [(ByteString, Maybe ByteString)]
qString)
                ] ByteString
"Redirect"

    response (RawRedirect ByteString
path) =
            Response -> IO ResponseReceived
sendResponse forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
W.responseLBS Status
H.status302
                [ (HeaderName
"Content-Type", ByteString
"text/plain")
                , (HeaderName
"Location", ByteString
path)
                ] ByteString
"Redirect"

    response StaticResponse
NotFound = case StaticSettings -> Maybe Application
ss404Handler StaticSettings
ss of
        Just Application
app -> Application
app Request
req Response -> IO ResponseReceived
sendResponse
        Maybe Application
Nothing  -> Response -> IO ResponseReceived
sendResponse forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
W.responseLBS Status
H.status404
                        [ (HeaderName
"Content-Type", ByteString
"text/plain")
                        ] ByteString
"File not found"

    response (WaiResponse Response
r) = Response -> IO ResponseReceived
sendResponse Response
r