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

filterButLast :: (a -> Bool) -> [a] -> [a]
filterButLast :: (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
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
folder@Folder {[Either FolderName File]
folderContents :: Folder -> [Either FolderName File]
folderContents :: [Either FolderName File]
..} =
    case Maybe Listing
ssListing of
        Just Listing
_ | Just 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 -> 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
                [ (HeaderName
"Content-Type", ByteString
"text/html; charset=utf-8")
                ] Builder
builder
        Maybe Listing
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
            [ (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
_ | (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 {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 -> 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 LookupResult
LRNotFound -> StaticResponse -> IO StaticResponse
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 (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 ((FolderName -> Pieces) -> Pieces -> [Pieces]
forall a b. (a -> b) -> [a] -> [b]
map (\ 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 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
                                      [] -> FolderName -> Text
fromPiece (FolderName -> Text) -> FolderName -> Text
forall a b. (a -> b) -> a -> b
$ File -> FolderName
fileName File
file
                                      FolderName
lastSegment:Pieces
_ ->
                                          case FolderName -> Text
fromPiece FolderName
lastSegment of
                                              -- Ends with a trailing slash
                                              Text
"" -> FolderName -> Text
fromPiece (FolderName -> Text) -> FolderName -> Text
forall a b. (a -> b) -> a -> b
$ File -> FolderName
fileName File
file
                                              -- Lacks a trailing slash
                                              Text
lastSegment' -> [Text] -> Text
T.concat
                                                  [ Text
lastSegment'
                                                  , Text
"/"
                                                  , 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
_ -> 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 (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 (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
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, 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 (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 (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 HTTPDate
mdate, Just 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 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 (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
    ccInt :: Maybe Int
ccInt =
        case MaxAge
maxage of
            MaxAge
NoMaxAge -> Maybe Int
forall a. Maybe a
Nothing
            MaxAgeSeconds Int
i -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i
            MaxAge
MaxAgeForever -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
oneYear
    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

    headerCacheControl :: ResponseHeaders -> ResponseHeaders
headerCacheControl =
      case Maybe Int
ccInt of
        Maybe Int
Nothing -> ResponseHeaders -> ResponseHeaders
forall a. a -> a
id
        Just Int
i  -> (:) (HeaderName
"Cache-Control", 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
$ Int -> String
forall a. Show a => a -> String
show Int
i)
    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")

-- | 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 [$(embedFile "images/folder.png")]
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 [$(embedFile "images/haskell.png")]
staticAppPieces StaticSettings
ss [Text]
rawPieces Request
req 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 -> 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
        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
$ (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 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