module Network.Wai.Application.Static
(
staticApp
, defaultWebAppSettings
, webAppSettingsWithLookup
, defaultFileServerSettings
, embeddedSettings
, StaticSettings
, ssLookupFile
, ssMkRedirect
, ssGetMimeType
, ssListing
, ssIndices
, ssMaxAge
, ssRedirectToIndex
) 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 Blaze.ByteString.Builder (toByteString)
import Data.FileEmbed (embedFile)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Either (rights)
import Network.HTTP.Date (parseHTTPDate, epochTimeToHTTPDate, formatHTTPDate)
import Data.Monoid (First (First, getFirst), mconcat)
import WaiAppStatic.Types
import Util
import WaiAppStatic.Storage.Filesystem
import WaiAppStatic.Storage.Embedded
import Network.Mime (MimeType)
data StaticResponse =
Redirect Pieces (Maybe ByteString)
| NotFound
| FileResponse File H.ResponseHeaders
| NotModified
| 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
serveFolder :: StaticSettings -> Pieces -> W.Request -> Folder -> IO StaticResponse
serveFolder ss@StaticSettings {..} pieces req folder@Folder {..} =
case getFirst $ mconcat $ map (findIndex $ rights folderContents) ssIndices of
Just index -> do
let pieces' = setLast pieces index
in if ssRedirectToIndex
then return $ Redirect pieces' Nothing
else checkPieces ss pieces' req
Nothing ->
case ssListing of
Just listing -> do
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"
where
setLast :: Pieces -> Piece -> Pieces
setLast [] x = [x]
setLast [t] x
| fromPiece t == "" = [x]
setLast (a:b) x = a : setLast b x
findIndex :: [File] -> Piece -> First Piece
findIndex files index
| index `elem` map fileName files = First $ Just index
| otherwise = First Nothing
checkPieces :: StaticSettings
-> Pieces
-> W.Request
-> IO StaticResponse
checkPieces _ pieces _ | any (T.null . fromPiece) $ safeInit pieces =
return $ Redirect (filterButLast (not . T.null . fromPiece) pieces) Nothing
checkPieces ss@StaticSettings {..} pieces req = do
res <- ssLookupFile pieces
case res of
LRNotFound -> return NotFound
LRFile file -> serveFile ss req file
LRFolder folder -> serveFolder ss pieces req folder
serveFile :: StaticSettings -> W.Request -> File -> IO StaticResponse
serveFile StaticSettings {..} req file
| ssUseHash = do
mHash <- fileGetHash file
case (mHash, lookup "if-none-match" $ W.requestHeaders req) of
(Just hash, Just lastHash) | hash == lastHash -> return NotModified
(Just hash, _) -> respond [("ETag", hash)]
(Nothing, _) -> lastMod
| otherwise = lastMod
where
mLastSent = lookup "if-modified-since" (W.requestHeaders req) >>= parseHTTPDate
lastMod =
case (fmap epochTimeToHTTPDate $ fileGetModified file, mLastSent) of
(Just mdate, Just lastSent)
| mdate == lastSent -> return NotModified
(Just mdate, _) -> respond [("last-modified", formatHTTPDate mdate)]
(Nothing, _) -> respond []
respond headers = return $ FileResponse file $ cacheControl ssMaxAge headers
cacheControl :: MaxAge -> (H.ResponseHeaders -> H.ResponseHeaders)
cacheControl maxage =
headerCacheControl . headerExpires
where
ccInt =
case maxage of
NoMaxAge -> Nothing
MaxAgeSeconds i -> Just i
MaxAgeForever -> Just oneYear
oneYear :: Int
oneYear = 60 * 60 * 24 * 365
headerCacheControl =
case ccInt of
Nothing -> id
Just i -> (:) ("Cache-Control", S8.append "public, max-age=" $ S8.pack $ show i)
headerExpires =
case maxage of
NoMaxAge -> id
MaxAgeSeconds _ -> id
MaxAgeForever -> (:) ("Expires", "Thu, 31 Dec 2037 23:55:55 GMT")
staticApp :: StaticSettings -> W.Application
staticApp set req = staticAppPieces set (W.pathInfo req) req
staticAppPieces :: StaticSettings -> [Text] -> W.Application
staticAppPieces _ _ req
| W.requestMethod req /= "GET" = return $ W.responseLBS
H.status405
[("Content-Type", "text/plain")]
"Only GET is supported"
staticAppPieces _ [".hidden", "folder.png"] _ = return $ W.responseLBS H.status200 [("Content-Type", "image/png")] $ L.fromChunks [$(embedFile "images/folder.png")]
staticAppPieces _ [".hidden", "haskell.png"] _ = return $ W.responseLBS H.status200 [("Content-Type", "image/png")] $ L.fromChunks [$(embedFile "images/haskell.png")]
staticAppPieces ss rawPieces req = liftIO $ do
case toPieces rawPieces of
Just pieces -> checkPieces ss pieces req >>= response
Nothing -> return $ W.responseLBS H.status403
[ ("Content-Type", "text/plain")
] "Forbidden"
where
response :: StaticResponse -> IO W.Response
response (FileResponse file ch) = do
mimetype <- ssGetMimeType ss file
let filesize = fileGetSize file
let headers = ("Content-Type", mimetype)
: ("Content-Length", S8.pack $ show filesize)
: ch
return $ fileToResponse file H.status200 headers
response NotModified =
return $ W.responseLBS H.status304 [] ""
response (SendContent mt lbs) = do
return $ W.responseLBS H.status200
[ ("Content-Type", mt)
] lbs
response (Redirect pieces' mHash) = do
let loc = (ssMkRedirect ss) pieces' $ toByteString (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)
return $ W.responseLBS H.status301
[ ("Content-Type", "text/plain")
, ("Location", S8.append loc $ H.renderQuery True qString)
] "Redirect"
response NotFound = return $ W.responseLBS H.status404
[ ("Content-Type", "text/plain")
] "File not found"
response (WaiResponse r) = return r