wai-app-static-3.2.1: Network/Wai/Application/Static.hs
{-# 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 [] = []
safeInit xs = init xs
filterButLast :: (a -> Bool) -> [a] -> [a]
filterButLast _ [] = []
filterButLast _ [x] = [x]
filterButLast f (x : xs)
| f x = x : filterButLast f xs
| otherwise = filterButLast f xs
-- | Serve an appropriate response for a folder request.
serveFolder
:: StaticSettings -> Pieces -> W.Request -> Folder -> IO StaticResponse
serveFolder StaticSettings{..} pieces req folder =
case ssListing of
Just _
| Just path <- addTrailingSlash req
, ssAddTrailingSlash ->
return $ RawRedirect path
Just listing -> do
-- directory listings turned on, display it
builder <- listing pieces folder
return $
WaiResponse $
W.responseBuilder
H.status200
[ ("Content-Type", "text/html; charset=utf-8")
]
builder
Nothing ->
return $
WaiResponse $
W.responseLBS
H.status403
[ ("Content-Type", "text/plain")
]
"Directory listings disabled"
addTrailingSlash :: W.Request -> Maybe ByteString
addTrailingSlash req
| S8.null rp = Just "/"
| S8.last rp == '/' = Nothing
| otherwise = Just $ S8.snoc rp '/'
where
rp = W.rawPathInfo 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 _ pieces _
| any (T.null . fromPiece) $ safeInit pieces =
return $ Redirect (filterButLast (not . T.null . fromPiece) pieces) Nothing
checkPieces ss@StaticSettings{..} pieces req = do
res <- lookupResult
case res of
Left location -> return $ RawRedirect location
Right LRNotFound -> return NotFound
Right (LRFile file) -> serveFile ss req file
Right (LRFolder folder) -> serveFolder ss pieces req folder
where
lookupResult :: IO (Either ByteString LookupResult)
lookupResult = do
nonIndexResult <- ssLookupFile pieces
case nonIndexResult of
LRFile{} -> return $ Right nonIndexResult
_ -> do
eIndexResult <-
lookupIndices (map (\index -> dropLastIfNull pieces ++ [index]) ssIndices)
return $ case eIndexResult of
Left redirect -> Left redirect
Right indexResult -> case indexResult of
LRNotFound -> Right nonIndexResult
LRFile file
| ssRedirectToIndex ->
let relPath =
case reverse pieces of
-- Served at root
[] -> fromPiece $ fileName file
lastSegment : _ ->
case fromPiece lastSegment of
-- Ends with a trailing slash
"" -> fromPiece $ fileName file
-- Lacks a trailing slash
lastSegment' ->
T.concat
[ lastSegment'
, "/"
, fromPiece $ fileName file
]
in Left $ TE.encodeUtf8 relPath
_ -> Right indexResult
lookupIndices :: [Pieces] -> IO (Either ByteString LookupResult)
lookupIndices (x : xs) = do
res <- ssLookupFile x
case res of
LRNotFound -> lookupIndices xs
_ -> return $ case (ssAddTrailingSlash, addTrailingSlash req) of
(True, Just redirect) -> Left redirect
_ -> Right res
lookupIndices [] = return $ Right LRNotFound
serveFile :: StaticSettings -> W.Request -> File -> IO StaticResponse
serveFile StaticSettings{..} req file
-- First check etag values, if turned on
| ssUseHash = do
mHash <- fileGetHash file
-- FIXME: Doesn't support multiple hashes in 'If-None-Match' header
case (mHash, lookup "if-none-match" $ W.requestHeaders req) of
-- if-none-match matches the actual hash, return a 304
(Just hash, Just lastHash) | hash == lastHash -> return 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 hash, _) -> respond [("ETag", hash)]
-- No hash value available, fall back to last modified support.
(Nothing, _) -> lastMod
-- etag turned off, so jump straight to last modified
| otherwise = lastMod
where
mLastSent = lookup "if-modified-since" (W.requestHeaders req) >>= parseHTTPDate
lastMod =
case (fmap epochTimeToHTTPDate $ fileGetModified file, 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, Just lastSent)
| mdate == lastSent -> return NotModified
-- Did not match, but we have a new last-modified header
(Just mdate, _) -> respond [("last-modified", formatHTTPDate mdate)]
-- No modification time available
(Nothing, _) -> respond []
-- Send a file response with the additional weak headers provided.
respond headers = return $ FileResponse file $ cacheControl ssMaxAge 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 =
headerCacheControl . headerExpires
where
oneYear :: Int
oneYear = 60 * 60 * 24 * 365
maxAgeValue i = S8.append "public, max-age=" $ S8.pack $ show i
headerCacheControl = case maxage of
NoMaxAge -> id
MaxAgeSeconds i -> (:) ("Cache-Control", maxAgeValue i)
MaxAgeForever -> (:) ("Cache-Control", maxAgeValue oneYear)
NoStore -> (:) ("Cache-Control", "no-store")
NoCache -> (:) ("Cache-Control", "no-cache")
headerExpires =
case maxage of
NoMaxAge -> id
MaxAgeSeconds _ -> id -- FIXME
MaxAgeForever -> (:) ("Expires", "Thu, 31 Dec 2037 23:55:55 GMT")
NoStore -> id
NoCache -> id
-- | Turn a @StaticSettings@ into a WAI application.
staticApp :: StaticSettings -> W.Application
staticApp set req = staticAppPieces set (W.pathInfo req) req
staticAppPieces :: StaticSettings -> [Text] -> W.Application
staticAppPieces _ _ req sendResponse
| notElem (W.requestMethod req) ["GET", "HEAD"] =
sendResponse $
W.responseLBS
H.status405
[("Content-Type", "text/plain")]
"Only GET or HEAD is supported"
staticAppPieces _ [".hidden", "folder.png"] _ sendResponse =
sendResponse $
W.responseLBS H.status200 [("Content-Type", "image/png")] $
L.fromChunks [$(makeRelativeToProject "images/folder.png" >>= embedFile)]
staticAppPieces _ [".hidden", "haskell.png"] _ sendResponse =
sendResponse $
W.responseLBS H.status200 [("Content-Type", "image/png")] $
L.fromChunks [$(makeRelativeToProject "images/haskell.png" >>= embedFile)]
staticAppPieces ss rawPieces req sendResponse = liftIO $ do
case toPieces rawPieces of
Just pieces -> checkPieces ss pieces req >>= response
Nothing ->
sendResponse $
W.responseLBS
H.status403
[ ("Content-Type", "text/plain")
]
"Forbidden"
where
response :: StaticResponse -> IO W.ResponseReceived
response (FileResponse file ch) = do
mimetype <- ssGetMimeType ss file
-- let filesize = fileGetSize file
let headers =
("Content-Type", mimetype)
-- Let Warp provide the content-length, since it takes
-- range requests into account
-- : ("Content-Length", S8.pack $ show filesize)
: ch
sendResponse $ fileToResponse file H.status200 headers
response NotModified =
sendResponse $ W.responseLBS H.status304 [] ""
response (SendContent mt lbs) = do
-- TODO: set caching headers
sendResponse $
W.responseLBS
H.status200
[ ("Content-Type", mt)
-- TODO: set Content-Length
]
lbs
response (Redirect pieces' mHash) = do
let loc =
ssMkRedirect ss pieces' $
L.toStrict $
toLazyByteString (H.encodePathSegments $ map fromPiece pieces')
let qString = case mHash of
Just hash -> replace "etag" (Just hash) (W.queryString req)
Nothing -> remove "etag" (W.queryString req)
sendResponse $
W.responseLBS
H.status302
[ ("Content-Type", "text/plain")
, ("Location", S8.append loc $ H.renderQuery True qString)
]
"Redirect"
response (RawRedirect path) =
sendResponse $
W.responseLBS
H.status302
[ ("Content-Type", "text/plain")
, ("Location", path)
]
"Redirect"
response NotFound = case ss404Handler ss of
Just app -> app req sendResponse
Nothing ->
sendResponse $
W.responseLBS
H.status404
[ ("Content-Type", "text/plain")
]
"File not found"
response (WaiResponse r) = sendResponse r