{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}

-- | 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 Control.Monad.IO.Class (liftIO)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import Data.ByteString.Lazy.Char8 ()
import qualified Network.HTTP.Types as H
import qualified Network.Wai as W
import Prelude hiding (FilePath)

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 (epochTimeToHTTPDate, formatHTTPDate, parseHTTPDate)

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

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 = [a] -> [a]
forall a. HasCallStack => [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 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{Bool
Pieces
Maybe Listing
Maybe Application
MaxAge
Pieces -> IO LookupResult
Pieces -> ByteString -> ByteString
File -> IO ByteString
ssLookupFile :: StaticSettings -> Pieces -> IO LookupResult
ssMkRedirect :: StaticSettings -> Pieces -> ByteString -> ByteString
ssGetMimeType :: StaticSettings -> File -> IO ByteString
ssListing :: StaticSettings -> Maybe Listing
ssIndices :: StaticSettings -> Pieces
ssMaxAge :: StaticSettings -> MaxAge
ssRedirectToIndex :: StaticSettings -> Bool
ssAddTrailingSlash :: StaticSettings -> Bool
ss404Handler :: StaticSettings -> Maybe Application
ssLookupFile :: Pieces -> IO LookupResult
ssGetMimeType :: File -> IO ByteString
ssIndices :: Pieces
ssListing :: Maybe Listing
ssMaxAge :: MaxAge
ssMkRedirect :: Pieces -> ByteString -> ByteString
ssRedirectToIndex :: Bool
ssUseHash :: Bool
ssAddTrailingSlash :: Bool
ss404Handler :: Maybe Application
ssUseHash :: StaticSettings -> Bool
..} Pieces
pieces Request
req Folder
folder =
    case Maybe Listing
ssListing of
        Just Listing
_
            | Just ByteString
path <- Request -> Maybe ByteString
addTrailingSlash Request
req
            , Bool
ssAddTrailingSlash ->
                StaticResponse -> IO StaticResponse
forall a. a -> IO a
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 -> do
            -- directory listings turned on, display it
            Builder
builder <- Listing
listing Pieces
pieces Folder
folder
            StaticResponse -> IO StaticResponse
forall a. a -> IO a
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
                        [ (HeaderName
"Content-Type", ByteString
"text/html; charset=utf-8")
                        ]
                        Builder
builder
        Maybe Listing
Nothing ->
            StaticResponse -> IO StaticResponse
forall a. a -> IO a
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
                        [ (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 = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"/"
    | ByteString -> Char
S8.last ByteString
rp Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/' = 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 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
_
    | (Piece -> Bool) -> Pieces -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Bool
T.null (Text -> Bool) -> (Piece -> Text) -> Piece -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Piece -> 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 a. a -> IO a
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 ((Piece -> Bool) -> Pieces -> Pieces
forall a. (a -> Bool) -> [a] -> [a]
filterButLast (Bool -> Bool
not (Bool -> Bool) -> (Piece -> Bool) -> Piece -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null (Text -> Bool) -> (Piece -> Text) -> Piece -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Piece -> Text
fromPiece) Pieces
pieces) Maybe ByteString
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
ssLookupFile :: StaticSettings -> Pieces -> IO LookupResult
ssMkRedirect :: StaticSettings -> Pieces -> ByteString -> ByteString
ssGetMimeType :: StaticSettings -> File -> IO ByteString
ssListing :: StaticSettings -> Maybe Listing
ssIndices :: StaticSettings -> Pieces
ssMaxAge :: StaticSettings -> MaxAge
ssRedirectToIndex :: StaticSettings -> Bool
ssAddTrailingSlash :: StaticSettings -> Bool
ss404Handler :: StaticSettings -> Maybe Application
ssUseHash :: StaticSettings -> Bool
ssLookupFile :: Pieces -> IO LookupResult
ssGetMimeType :: File -> IO ByteString
ssIndices :: Pieces
ssListing :: Maybe Listing
ssMaxAge :: MaxAge
ssMkRedirect :: Pieces -> ByteString -> ByteString
ssRedirectToIndex :: Bool
ssUseHash :: Bool
ssAddTrailingSlash :: Bool
ss404Handler :: Maybe Application
..} Pieces
pieces Request
req = do
    Either ByteString LookupResult
res <- IO (Either ByteString LookupResult)
lookupResult
    case Either ByteString LookupResult
res of
        Left ByteString
location -> StaticResponse -> IO StaticResponse
forall a. a -> IO a
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 LookupResult
LRNotFound -> StaticResponse -> IO StaticResponse
forall a. a -> IO a
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{} -> Either ByteString LookupResult
-> IO (Either ByteString LookupResult)
forall a. a -> IO a
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
            LookupResult
_ -> do
                Either ByteString LookupResult
eIndexResult <-
                    [Pieces] -> IO (Either ByteString LookupResult)
lookupIndices ((Piece -> Pieces) -> Pieces -> [Pieces]
forall a b. (a -> b) -> [a] -> [b]
map (\Piece
index -> Pieces -> Pieces
dropLastIfNull Pieces
pieces Pieces -> Pieces -> Pieces
forall a. [a] -> [a] -> [a]
++ [Piece
index]) Pieces
ssIndices)
                Either ByteString LookupResult
-> IO (Either ByteString LookupResult)
forall a. a -> IO a
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 ByteString
redirect -> ByteString -> Either ByteString LookupResult
forall a b. a -> Either a b
Left ByteString
redirect
                    Right LookupResult
indexResult -> case LookupResult
indexResult of
                        LookupResult
LRNotFound -> LookupResult -> Either ByteString LookupResult
forall a b. b -> Either a b
Right LookupResult
nonIndexResult
                        LRFile File
file
                            | Bool
ssRedirectToIndex ->
                                let relPath :: Text
relPath =
                                        case Pieces -> Pieces
forall a. [a] -> [a]
reverse Pieces
pieces of
                                            -- Served at root
                                            [] -> Piece -> Text
fromPiece (Piece -> Text) -> Piece -> Text
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 (Piece -> Text) -> Piece -> Text
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 (Piece -> Text) -> Piece -> Text
forall a b. (a -> b) -> a -> b
$ File -> Piece
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
_ -> 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 (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
_ -> Either ByteString LookupResult
-> IO (Either ByteString LookupResult)
forall a. a -> IO a
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
                (Bool
True, Just ByteString
redirect) -> ByteString -> Either ByteString LookupResult
forall a b. a -> Either a b
Left ByteString
redirect
                (Bool, Maybe ByteString)
_ -> LookupResult -> Either ByteString LookupResult
forall a b. b -> Either a b
Right LookupResult
res
    lookupIndices [] = Either ByteString LookupResult
-> IO (Either ByteString LookupResult)
forall a. a -> IO a
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{Bool
Pieces
Maybe Listing
Maybe Application
MaxAge
Pieces -> IO LookupResult
Pieces -> ByteString -> ByteString
File -> IO ByteString
ssLookupFile :: StaticSettings -> Pieces -> IO LookupResult
ssMkRedirect :: StaticSettings -> Pieces -> ByteString -> ByteString
ssGetMimeType :: StaticSettings -> File -> IO ByteString
ssListing :: StaticSettings -> Maybe Listing
ssIndices :: StaticSettings -> Pieces
ssMaxAge :: StaticSettings -> MaxAge
ssRedirectToIndex :: StaticSettings -> Bool
ssAddTrailingSlash :: StaticSettings -> Bool
ss404Handler :: StaticSettings -> Maybe Application
ssUseHash :: StaticSettings -> Bool
ssLookupFile :: Pieces -> IO LookupResult
ssGetMimeType :: File -> IO ByteString
ssIndices :: Pieces
ssListing :: Maybe Listing
ssMaxAge :: MaxAge
ssMkRedirect :: Pieces -> ByteString -> ByteString
ssRedirectToIndex :: Bool
ssUseHash :: Bool
ssAddTrailingSlash :: Bool
ss404Handler :: Maybe Application
..} Request
req File
file
    -- First check etag values, if turned on
    | Bool
ssUseHash = do
        Maybe ByteString
mHash <- File -> IO (Maybe ByteString)
fileGetHash File
file
        -- FIXME: Doesn't support multiple hashes in 'If-None-Match' header
        case (Maybe ByteString
mHash, HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"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 ByteString
hash, Just ByteString
lastHash) | ByteString
hash ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
lastHash -> StaticResponse -> IO StaticResponse
forall a. a -> IO a
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
_) -> ResponseHeaders -> IO StaticResponse
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 = HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"if-modified-since" (Request -> ResponseHeaders
W.requestHeaders Request
req) Maybe ByteString
-> (ByteString -> 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
>>= ByteString -> Maybe HTTPDate
parseHTTPDate
    lastMod :: IO StaticResponse
lastMod =
        case ((EpochTime -> HTTPDate) -> Maybe EpochTime -> Maybe HTTPDate
forall a b. (a -> b) -> Maybe a -> Maybe b
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 HTTPDate
mdate, Just HTTPDate
lastSent)
                | HTTPDate
mdate HTTPDate -> HTTPDate -> Bool
forall a. Eq a => a -> a -> Bool
== HTTPDate
lastSent -> StaticResponse -> IO StaticResponse
forall a. a -> IO a
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
_) -> ResponseHeaders -> IO StaticResponse
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
_) -> 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 ResponseHeaders
headers = StaticResponse -> m StaticResponse
forall a. a -> m a
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 =
    ResponseHeaders -> ResponseHeaders
headerCacheControl (ResponseHeaders -> ResponseHeaders)
-> (ResponseHeaders -> ResponseHeaders)
-> ResponseHeaders
-> ResponseHeaders
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResponseHeaders -> ResponseHeaders
headerExpires
  where
    oneYear :: Int
    oneYear :: Int
oneYear = Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
24 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
365

    maxAgeValue :: a -> ByteString
maxAgeValue a
i = ByteString -> ByteString -> ByteString
S8.append ByteString
"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
$ a -> String
forall a. Show a => a -> String
show a
i

    headerCacheControl :: ResponseHeaders -> ResponseHeaders
headerCacheControl = case MaxAge
maxage of
        MaxAge
NoMaxAge -> ResponseHeaders -> ResponseHeaders
forall a. a -> a
id
        MaxAgeSeconds Int
i -> (:) (HeaderName
"Cache-Control", Int -> ByteString
forall {a}. Show a => a -> ByteString
maxAgeValue Int
i)
        MaxAge
MaxAgeForever -> (:) (HeaderName
"Cache-Control", Int -> ByteString
forall {a}. Show a => a -> ByteString
maxAgeValue Int
oneYear)
        MaxAge
NoStore -> (:) (HeaderName
"Cache-Control", ByteString
"no-store")
        MaxAge
NoCache -> (:) (HeaderName
"Cache-Control", ByteString
"no-cache")
    headerExpires :: ResponseHeaders -> ResponseHeaders
headerExpires =
        case MaxAge
maxage of
            MaxAge
NoMaxAge -> ResponseHeaders -> ResponseHeaders
forall a. a -> a
id
            MaxAgeSeconds Int
_ -> ResponseHeaders -> ResponseHeaders
forall a. a -> a
id -- FIXME
            MaxAge
MaxAgeForever -> (:) (HeaderName
"Expires", ByteString
"Thu, 31 Dec 2037 23:55:55 GMT")
            MaxAge
NoStore -> ResponseHeaders -> ResponseHeaders
forall a. a -> a
id
            MaxAge
NoCache -> ResponseHeaders -> ResponseHeaders
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
    | ByteString -> [ByteString] -> Bool
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 (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
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 (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$
        Status -> ResponseHeaders -> ByteString -> Response
W.responseLBS Status
H.status200 [(HeaderName
"Content-Type", ByteString
"image/png")] (ByteString -> Response) -> ByteString -> Response
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 (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$
        Status -> ResponseHeaders -> ByteString -> Response
W.responseLBS Status
H.status200 [(HeaderName
"Content-Type", ByteString
"image/png")] (ByteString -> Response) -> ByteString -> Response
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 = IO ResponseReceived -> IO ResponseReceived
forall a. IO a -> IO a
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 -> StaticSettings -> Pieces -> Request -> IO StaticResponse
checkPieces StaticSettings
ss Pieces
pieces Request
req IO StaticResponse
-> (StaticResponse -> IO ResponseReceived) -> IO ResponseReceived
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StaticResponse -> IO ResponseReceived
response
        Maybe Pieces
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
                    [ (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)
                    (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 StaticResponse
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 [] ByteString
""
    response (SendContent ByteString
mt 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
                [ (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' (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
$ (Piece -> Text) -> Pieces -> [Text]
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 -> ByteString
-> Maybe ByteString
-> [(ByteString, Maybe ByteString)]
-> [(ByteString, Maybe ByteString)]
forall a b. Eq a => a -> b -> [(a, b)] -> [(a, b)]
replace ByteString
"etag" (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
hash) (Request -> [(ByteString, Maybe ByteString)]
W.queryString Request
req)
                Maybe ByteString
Nothing -> ByteString
-> [(ByteString, Maybe ByteString)]
-> [(ByteString, Maybe ByteString)]
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 (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
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 (ByteString -> ByteString) -> ByteString -> ByteString
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 (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
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 (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
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