{-# 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)

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 :: [a] -> [a]
safeInit [] = []
safeInit xs :: [a]
xs = [a] -> [a]
forall a. [a] -> [a]
init [a]
xs

filterButLast :: (a -> Bool) -> [a] -> [a]
filterButLast :: (a -> Bool) -> [a] -> [a]
filterButLast _ [] = []
filterButLast _ [x :: a
x] = [a
x]
filterButLast f :: a -> Bool
f (x :: a
x:xs :: [a]
xs)
    | a -> Bool
f a
x = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filterButLast a -> Bool
f [a]
xs
    | Bool
otherwise = (a -> Bool) -> [a] -> [a]
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 {..} pieces :: Pieces
pieces req :: Request
req folder :: Folder
folder@Folder {..} =
    case Maybe Listing
ssListing of
        Just _ | Just path :: ByteString
path <- Request -> Maybe ByteString
addTrailingSlash Request
req, Bool
ssAddTrailingSlash ->
            StaticResponse -> IO StaticResponse
forall (m :: * -> *) a. Monad m => a -> m a
return (StaticResponse -> IO StaticResponse)
-> StaticResponse -> IO StaticResponse
forall a b. (a -> b) -> a -> b
$ ByteString -> StaticResponse
RawRedirect ByteString
path
        Just listing :: Listing
listing -> do
            -- directory listings turned on, display it
            Builder
builder <- Listing
listing Pieces
pieces Folder
folder
            StaticResponse -> IO StaticResponse
forall (m :: * -> *) a. Monad m => a -> m a
return (StaticResponse -> IO StaticResponse)
-> StaticResponse -> IO StaticResponse
forall a b. (a -> b) -> a -> b
$ Response -> StaticResponse
WaiResponse (Response -> StaticResponse) -> Response -> StaticResponse
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> Builder -> Response
W.responseBuilder Status
H.status200
                [ ("Content-Type", "text/html; charset=utf-8")
                ] Builder
builder
        Nothing -> StaticResponse -> IO StaticResponse
forall (m :: * -> *) a. Monad m => a -> m a
return (StaticResponse -> IO StaticResponse)
-> StaticResponse -> IO StaticResponse
forall a b. (a -> b) -> a -> b
$ Response -> StaticResponse
WaiResponse (Response -> StaticResponse) -> Response -> StaticResponse
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
W.responseLBS Status
H.status403
            [ ("Content-Type", "text/plain")
            ] "Directory listings disabled"

addTrailingSlash :: W.Request -> Maybe ByteString
addTrailingSlash :: Request -> Maybe ByteString
addTrailingSlash req :: Request
req
    | ByteString -> Bool
S8.null ByteString
rp = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just "/"
    | ByteString -> Char
S8.last ByteString
rp Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '/' = Maybe ByteString
forall a. Maybe a
Nothing
    | Bool
otherwise = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Char -> ByteString
S8.snoc ByteString
rp '/'
  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 _ pieces :: Pieces
pieces _ | (FolderName -> Bool) -> Pieces -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Bool
T.null (Text -> Bool) -> (FolderName -> Text) -> FolderName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FolderName -> Text
fromPiece) (Pieces -> Bool) -> Pieces -> Bool
forall a b. (a -> b) -> a -> b
$ Pieces -> Pieces
forall a. [a] -> [a]
safeInit Pieces
pieces =
    StaticResponse -> IO StaticResponse
forall (m :: * -> *) a. Monad m => a -> m a
return (StaticResponse -> IO StaticResponse)
-> StaticResponse -> IO StaticResponse
forall a b. (a -> b) -> a -> b
$ Pieces -> Maybe ByteString -> StaticResponse
Redirect ((FolderName -> Bool) -> Pieces -> Pieces
forall a. (a -> Bool) -> [a] -> [a]
filterButLast (Bool -> Bool
not (Bool -> Bool) -> (FolderName -> Bool) -> FolderName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null (Text -> Bool) -> (FolderName -> Text) -> FolderName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FolderName -> Text
fromPiece) Pieces
pieces) Maybe ByteString
forall a. Maybe a
Nothing

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

    lookupIndices :: [Pieces] -> IO (Either ByteString LookupResult)
    lookupIndices :: [Pieces] -> IO (Either ByteString LookupResult)
lookupIndices (x :: Pieces
x : xs :: [Pieces]
xs) = do
        LookupResult
res <- Pieces -> IO LookupResult
ssLookupFile Pieces
x
        case LookupResult
res of
            LRNotFound -> [Pieces] -> IO (Either ByteString LookupResult)
lookupIndices [Pieces]
xs
            _ -> Either ByteString LookupResult
-> IO (Either ByteString LookupResult)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ByteString LookupResult
 -> IO (Either ByteString LookupResult))
-> Either ByteString LookupResult
-> IO (Either ByteString LookupResult)
forall a b. (a -> b) -> a -> b
$ case (Bool
ssAddTrailingSlash, Request -> Maybe ByteString
addTrailingSlash Request
req) of
                (True, Just redirect :: ByteString
redirect) -> ByteString -> Either ByteString LookupResult
forall a b. a -> Either a b
Left ByteString
redirect
                _ -> LookupResult -> Either ByteString LookupResult
forall a b. b -> Either a b
Right LookupResult
res
    lookupIndices [] = Either ByteString LookupResult
-> IO (Either ByteString LookupResult)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ByteString LookupResult
 -> IO (Either ByteString LookupResult))
-> Either ByteString LookupResult
-> IO (Either ByteString LookupResult)
forall a b. (a -> b) -> a -> b
$ LookupResult -> Either ByteString LookupResult
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 {..} req :: Request
req file :: 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, HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "if-none-match" (ResponseHeaders -> Maybe ByteString)
-> ResponseHeaders -> Maybe ByteString
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 hash :: ByteString
hash, Just lastHash :: ByteString
lastHash) | ByteString
hash ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
lastHash -> StaticResponse -> IO StaticResponse
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.
            --
            -- Note: It would be arguably better to next check
            -- if-modified-since and return a 304 if that indicates a match as
            -- well. However, the circumstances under which such a situation
            -- could arise would be very anomalous, and should likely warrant a
            -- new file being sent anyway.
            (Just hash :: ByteString
hash, _) -> ResponseHeaders -> IO StaticResponse
forall (m :: * -> *).
Monad m =>
ResponseHeaders -> m StaticResponse
respond [("ETag", ByteString
hash)]

            -- No hash value available, fall back to last modified support.
            (Nothing, _) -> IO StaticResponse
lastMod
    -- etag turned off, so jump straight to last modified
    | Bool
otherwise = IO StaticResponse
lastMod
  where
    mLastSent :: Maybe HTTPDate
mLastSent = HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "if-modified-since" (Request -> ResponseHeaders
W.requestHeaders Request
req) Maybe ByteString
-> (ByteString -> Maybe HTTPDate) -> Maybe HTTPDate
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Maybe HTTPDate
parseHTTPDate
    lastMod :: IO StaticResponse
lastMod =
        case ((EpochTime -> HTTPDate) -> Maybe EpochTime -> Maybe HTTPDate
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap EpochTime -> HTTPDate
epochTimeToHTTPDate (Maybe EpochTime -> Maybe HTTPDate)
-> Maybe EpochTime -> Maybe HTTPDate
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 mdate :: HTTPDate
mdate, Just lastSent :: HTTPDate
lastSent)
                | HTTPDate
mdate HTTPDate -> HTTPDate -> Bool
forall a. Eq a => a -> a -> Bool
== HTTPDate
lastSent -> StaticResponse -> IO StaticResponse
forall (m :: * -> *) a. Monad m => a -> m a
return StaticResponse
NotModified

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

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

    -- Send a file response with the additional weak headers provided.
    respond :: ResponseHeaders -> m StaticResponse
respond headers :: ResponseHeaders
headers = StaticResponse -> m StaticResponse
forall (m :: * -> *) a. Monad m => a -> m a
return (StaticResponse -> m StaticResponse)
-> StaticResponse -> m StaticResponse
forall a b. (a -> b) -> a -> b
$ File -> ResponseHeaders -> StaticResponse
FileResponse File
file (ResponseHeaders -> StaticResponse)
-> ResponseHeaders -> StaticResponse
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
maxage =
    ResponseHeaders -> ResponseHeaders
headerCacheControl (ResponseHeaders -> ResponseHeaders)
-> (ResponseHeaders -> ResponseHeaders)
-> ResponseHeaders
-> ResponseHeaders
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResponseHeaders -> ResponseHeaders
headerExpires
  where
    ccInt :: Maybe Int
ccInt =
        case MaxAge
maxage of
            NoMaxAge -> Maybe Int
forall a. Maybe a
Nothing
            MaxAgeSeconds i :: Int
i -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i
            MaxAgeForever -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
oneYear
    oneYear :: Int
    oneYear :: Int
oneYear = 60 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 60 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 24 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 365

    headerCacheControl :: ResponseHeaders -> ResponseHeaders
headerCacheControl =
      case Maybe Int
ccInt of
        Nothing -> ResponseHeaders -> ResponseHeaders
forall a. a -> a
id
        Just i :: Int
i  -> (:) ("Cache-Control", ByteString -> ByteString -> ByteString
S8.append "public, max-age=" (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
S8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
i)
    headerExpires :: ResponseHeaders -> ResponseHeaders
headerExpires =
      case MaxAge
maxage of
        NoMaxAge        -> ResponseHeaders -> ResponseHeaders
forall a. a -> a
id
        MaxAgeSeconds _ -> ResponseHeaders -> ResponseHeaders
forall a. a -> a
id -- FIXME
        MaxAgeForever   -> (:) ("Expires", "Thu, 31 Dec 2037 23:55:55 GMT")

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

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

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

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

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

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

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

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