wai-app-static 3.1.8 → 3.1.9
raw patch · 15 files changed
+998/−799 lines, 15 filesdep ~warp
Dependency ranges changed: warp
Files
- ChangeLog.md +4/−0
- Network/Wai/Application/Static.hs +166/−123
- Util.hs +23/−17
- WaiAppStatic/CmdLine.hs +105/−69
- WaiAppStatic/Listing.hs +100/−87
- WaiAppStatic/Storage/Embedded.hs +6/−6
- WaiAppStatic/Storage/Embedded/Runtime.hs +36/−31
- WaiAppStatic/Storage/Embedded/TH.hs +136/−118
- WaiAppStatic/Storage/Filesystem.hs +102/−70
- WaiAppStatic/Types.hs +72/−71
- test/EmbeddedTestEntries.hs +48/−44
- test/WaiAppEmbeddedTest.hs +30/−22
- test/WaiAppStaticTest.hs +166/−137
- tests.hs +2/−2
- wai-app-static.cabal +2/−2
ChangeLog.md view
@@ -1,5 +1,9 @@ # wai-app-static changelog +## 3.1.9++* Added `NoCache` constructor to `MaxAge` [#977](https://github.com/yesodweb/wai/pull/977)+ ## 3.1.8 * Added `NoStore` constructor to `MaxAge` [#938](https://github.com/yesodweb/wai/pull/938)
Network/Wai/Application/Static.hs view
@@ -1,38 +1,42 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell, CPP #-}-{-# LANGUAGE RecordWildCards #-} {-# 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+module Network.Wai.Application.Static (+ -- * WAI application+ staticApp, -import Prelude hiding (FilePath)-import qualified Network.Wai as W-import qualified Network.HTTP.Types as H+ -- ** 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 Control.Monad.IO.Class (liftIO)+import qualified Network.HTTP.Types as H+import qualified Network.Wai as W+import Prelude hiding (FilePath) import Data.ByteString.Builder (toLazyByteString) @@ -42,51 +46,63 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as TE -import Network.HTTP.Date (parseHTTPDate, epochTimeToHTTPDate, formatHTTPDate)+import Network.HTTP.Date (epochTimeToHTTPDate, formatHTTPDate, parseHTTPDate) -import WaiAppStatic.Types+import Network.Mime (MimeType) import Util-import WaiAppStatic.Storage.Filesystem import WaiAppStatic.Storage.Embedded-import Network.Mime (MimeType)+import WaiAppStatic.Storage.Filesystem+import WaiAppStatic.Types -data StaticResponse =- -- | Just the etag hash or Nothing for no etag hash+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+ | -- TODO: add file size+ SendContent MimeType L.ByteString | WaiResponse W.Response -safeInit :: [a] -> [a]+safeInit :: [a] -> [a] safeInit [] = [] safeInit xs = init xs filterButLast :: (a -> Bool) -> [a] -> [a] filterButLast _ [] = [] filterButLast _ [x] = [x]-filterButLast f (x:xs)+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 =+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 _+ | 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"+ 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@@ -96,16 +112,18 @@ where rp = W.rawPathInfo req -checkPieces :: StaticSettings- -> Pieces -- ^ parsed request- -> W.Request- -> IO StaticResponse+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+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@@ -115,32 +133,35 @@ 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+ 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@@ -153,14 +174,14 @@ lookupIndices [] = return $ Right LRNotFound serveFile :: StaticSettings -> W.Request -> File -> IO StaticResponse-serveFile StaticSettings {..} req file+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. --@@ -172,7 +193,6 @@ -- > 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@@ -187,10 +207,8 @@ -- 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 [] @@ -215,12 +233,14 @@ 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+ 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@@ -228,61 +248,84 @@ 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)]+ | 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"+ 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 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 [] ""-+ sendResponse $ W.responseLBS H.status304 [] "" response (SendContent mt lbs) = do- -- TODO: set caching headers- sendResponse $ W.responseLBS H.status200+ -- TODO: set caching headers+ sendResponse $+ W.responseLBS+ H.status200 [ ("Content-Type", mt)- -- TODO: set Content-Length- ] lbs-+ -- 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)+ 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+ sendResponse $+ W.responseLBS+ H.status302 [ ("Content-Type", "text/plain") , ("Location", S8.append loc $ H.renderQuery True qString)- ] "Redirect"-+ ]+ "Redirect" response (RawRedirect path) =- sendResponse $ W.responseLBS H.status302+ sendResponse $+ W.responseLBS+ H.status302 [ ("Content-Type", "text/plain") , ("Location", path)- ] "Redirect"-+ ]+ "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"-+ Nothing ->+ sendResponse $+ W.responseLBS+ H.status404+ [ ("Content-Type", "text/plain")+ ]+ "File not found" response (WaiResponse r) = sendResponse r
Util.hs view
@@ -1,28 +1,32 @@-{-# LANGUAGE OverloadedStrings, ViewPatterns #-}-module Util- ( relativeDirFromPieces- , defaultMkRedirect- , replace- , remove- , dropLastIfNull- ) where+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-} -import WaiAppStatic.Types-import qualified Data.Text as T+module Util (+ relativeDirFromPieces,+ defaultMkRedirect,+ replace,+ remove,+ dropLastIfNull,+) where+ import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8+import qualified Data.Text as T import qualified Data.Text.Encoding as TE+import WaiAppStatic.Types -- alist helper functions replace :: Eq a => a -> b -> [(a, b)] -> [(a, b)]-replace k v [] = [(k,v)]-replace k v (x:xs) | fst x == k = (k,v):xs- | otherwise = x:replace k v xs+replace k v [] = [(k, v)]+replace k v (x : xs)+ | fst x == k = (k, v) : xs+ | otherwise = x : replace k v xs remove :: Eq a => a -> [(a, b)] -> [(a, b)] remove _ [] = []-remove k (x:xs) | fst x == k = xs- | otherwise = x:remove k xs+remove k (x : xs)+ | fst x == k = xs+ | otherwise = x : remove k xs -- | Turn a list of pieces into a relative path to the root folder. relativeDirFromPieces :: Pieces -> T.Text@@ -31,8 +35,10 @@ -- | Construct redirects with relative paths. defaultMkRedirect :: Pieces -> ByteString -> S8.ByteString defaultMkRedirect pieces newPath- | S8.null newPath || S8.null relDir ||- S8.last relDir /= '/' || S8.head newPath /= '/' =+ | S8.null newPath+ || S8.null relDir+ || S8.last relDir /= '/'+ || S8.head newPath /= '/' = relDir `S8.append` newPath | otherwise = relDir `S8.append` S8.tail newPath where
WaiAppStatic/CmdLine.hs view
@@ -1,29 +1,40 @@-{-# LANGUAGE CPP, RecordWildCards #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+ -- | Command line version of wai-app-static, used for the warp-static server.-module WaiAppStatic.CmdLine- ( runCommandLine- , Args (..)- ) where+module WaiAppStatic.CmdLine (+ runCommandLine,+ Args (..),+) where -import Network.Wai (Middleware)-import Network.Wai.Application.Static (staticApp, defaultFileServerSettings)-import Network.Wai.Handler.Warp- ( runSettings, defaultSettings, setHost, setPort- )-import Options.Applicative-import Text.Printf (printf)-import System.Directory (canonicalizePath)+import Control.Arrow (second, (***)) import Control.Monad (unless)-import Network.Wai.Middleware.RequestLogger (logStdout)-import Network.Wai.Middleware.Gzip-import qualified Data.Map as Map import qualified Data.ByteString.Char8 as S8-import Data.Text (pack)-import Data.String (fromString)-import Network.Mime (defaultMimeMap, mimeByExt, defaultMimeType)-import WaiAppStatic.Types (ssIndices, toPiece, ssGetMimeType, fileName, fromPiece)+import qualified Data.Map as Map import Data.Maybe (mapMaybe)-import Control.Arrow (second, (***))+import Data.String (fromString)+import Data.Text (pack)+import Network.Mime (defaultMimeMap, defaultMimeType, mimeByExt)+import Network.Wai (Middleware)+import Network.Wai.Application.Static (defaultFileServerSettings, staticApp)+import Network.Wai.Handler.Warp (+ defaultSettings,+ runSettings,+ setHost,+ setPort,+ )+import Network.Wai.Middleware.Gzip+import Network.Wai.Middleware.RequestLogger (logStdout)+import Options.Applicative+import System.Directory (canonicalizePath)+import Text.Printf (printf)+import WaiAppStatic.Types (+ fileName,+ fromPiece,+ ssGetMimeType,+ ssIndices,+ toPiece,+ ) #if __GLASGOW_HASKELL__ < 804 import Data.Monoid ((<>)) #endif@@ -47,44 +58,59 @@ #endif args :: Parser Args-args = Args- <$> strOption+args =+ Args+ <$> strOption ( long "docroot"- <> short 'd'- <> metavar "DOCROOT"- <> value "."- <> help "directory containing files to serve")- <*> (defIndex <$> many (strOption- ( long "index"- <> short 'i'- <> metavar "INDEX"- <> help "index files to serve when a directory is required"- )))- <*> option'+ <> short 'd'+ <> metavar "DOCROOT"+ <> value "."+ <> help "directory containing files to serve"+ )+ <*> ( defIndex+ <$> many+ ( strOption+ ( long "index"+ <> short 'i'+ <> metavar "INDEX"+ <> help "index files to serve when a directory is required"+ )+ )+ )+ <*> option' ( long "port"- <> short 'p'- <> metavar "PORT"- <> value 3000)- <*> switch+ <> short 'p'+ <> metavar "PORT"+ <> value 3000+ )+ <*> switch ( long "noindex"- <> short 'n')- <*> switch+ <> short 'n'+ )+ <*> switch ( long "quiet"- <> short 'q')- <*> switch+ <> short 'q'+ )+ <*> switch ( long "verbose"- <> short 'v')- <*> many (toPair <$> strOption- ( long "mime"- <> short 'm'- <> metavar "MIME"- <> help "extra file extension/mime type mappings"))- <*> strOption+ <> short 'v'+ )+ <*> many+ ( toPair+ <$> strOption+ ( long "mime"+ <> short 'm'+ <> metavar "MIME"+ <> help "extra file extension/mime type mappings"+ )+ )+ <*> strOption ( long "host"- <> short 'h'- <> metavar "HOST"- <> value "*"- <> help "interface to bind to, special values: *, *4, *6")+ <> short 'h'+ <> metavar "HOST"+ <> value "*"+ <> help "interface to bind to, special values: *, *4, *6"+ ) where toPair = second (drop 1) . break (== '=') defIndex [] = ["index.html", "index.htm"]@@ -95,29 +121,39 @@ -- Since 2.0.1 runCommandLine :: (Args -> Middleware) -> IO () runCommandLine middleware = do- clArgs@Args {..} <- execParser $ info (helperOption <*> args) fullDesc+ clArgs@Args{..} <- execParser $ info (helperOption <*> args) fullDesc let mime' = map (pack *** S8.pack) mime let mimeMap = Map.fromList mime' `Map.union` defaultMimeMap docroot' <- canonicalizePath docroot- unless quiet $ printf "Serving directory %s on port %d with %s index files.\n" docroot' port (if noindex then "no" else show index)- let middle = gzip def { gzipFiles = GzipCompress }- . (if verbose then logStdout else id)- . middleware clArgs+ unless quiet $+ printf+ "Serving directory %s on port %d with %s index files.\n"+ docroot'+ port+ (if noindex then "no" else show index)+ let middle =+ gzip def{gzipFiles = GzipCompress}+ . (if verbose then logStdout else id)+ . middleware clArgs runSettings- ( setPort port- $ setHost (fromString host)- defaultSettings+ ( setPort port $+ setHost+ (fromString host)+ defaultSettings )- $ middle $ staticApp (defaultFileServerSettings $ fromString docroot)- { ssIndices = if noindex then [] else mapMaybe (toPiece . pack) index- , ssGetMimeType = return . mimeByExt mimeMap defaultMimeType . fromPiece . fileName- }- where- helperOption :: Parser (a -> a)- helperOption =+ $ middle+ $ staticApp+ (defaultFileServerSettings $ fromString docroot)+ { ssIndices = if noindex then [] else mapMaybe (toPiece . pack) index+ , ssGetMimeType =+ return . mimeByExt mimeMap defaultMimeType . fromPiece . fileName+ }+ where+ helperOption :: Parser (a -> a)+ helperOption = #if MIN_VERSION_optparse_applicative(0,16,0) abortOption (ShowHelpText Nothing) $ #else abortOption ShowHelpText $ #endif- mconcat [long "help", help "Show this help text", hidden]+ mconcat [long "help", help "Show this help text", hidden]
WaiAppStatic/Listing.hs view
@@ -1,16 +1,17 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-}-module WaiAppStatic.Listing- ( defaultListing- ) where -import qualified Text.Blaze.Html5.Attributes as A-import qualified Text.Blaze.Html5 as H-import Text.Blaze ((!))+module WaiAppStatic.Listing (+ defaultListing,+) where+ import qualified Data.Text as T import Data.Time import Data.Time.Clock.POSIX+import Text.Blaze ((!))+import qualified Text.Blaze.Html5 as H+import qualified Text.Blaze.Html5.Attributes as A import WaiAppStatic.Types #if !MIN_VERSION_time(1,5,0) import System.Locale (defaultTimeLocale)@@ -28,33 +29,37 @@ let isTop = null pieces || map Just pieces == [toPiece ""] let fps'' :: [Either FolderName File] fps'' = (if isTop then id else (Left (unsafeToPiece "") :)) contents -- FIXME emptyParentFolder feels like a bit of a hack- return $ HU.renderHtmlBuilder- $ H.html $ do- H.head $ do- let title = T.intercalate "/" $ map fromPiece pieces- let title' = if T.null title then "root folder" else title- H.title $ H.toHtml title'- H.style $ H.toHtml $ unlines [ "table { margin: 0 auto; width: 760px; border-collapse: collapse; font-family: 'sans-serif'; }"- , "table, th, td { border: 1px solid #353948; }"- , "td.size { text-align: right; font-size: 0.7em; width: 50px }"- , "td.date { text-align: right; font-size: 0.7em; width: 130px }"- , "td { padding-right: 1em; padding-left: 1em; }"- , "th.first { background-color: white; width: 24px }"- , "td.first { padding-right: 0; padding-left: 0; text-align: center }"- , "tr { background-color: white; }"- , "tr.alt { background-color: #A3B5BA}"- , "th { background-color: #3C4569; color: white; font-size: 1.125em; }"- , "h1 { width: 760px; margin: 1em auto; font-size: 1em; font-family: sans-serif }"- , "img { width: 20px }"- , "a { text-decoration: none }"- ]- H.body $ do- let hasTrailingSlash =- case map fromPiece $ reverse pieces of- "":_ -> True- _ -> False- H.h1 $ showFolder' hasTrailingSlash $ filter (not . T.null . fromPiece) pieces- renderDirectoryContentsTable (map fromPiece pieces) haskellSrc folderSrc fps''+ return $+ HU.renderHtmlBuilder $+ H.html $ do+ H.head $ do+ let title = T.intercalate "/" $ map fromPiece pieces+ let title' = if T.null title then "root folder" else title+ H.title $ H.toHtml title'+ H.style $+ H.toHtml $+ unlines+ [ "table { margin: 0 auto; width: 760px; border-collapse: collapse; font-family: 'sans-serif'; }"+ , "table, th, td { border: 1px solid #353948; }"+ , "td.size { text-align: right; font-size: 0.7em; width: 50px }"+ , "td.date { text-align: right; font-size: 0.7em; width: 130px }"+ , "td { padding-right: 1em; padding-left: 1em; }"+ , "th.first { background-color: white; width: 24px }"+ , "td.first { padding-right: 0; padding-left: 0; text-align: center }"+ , "tr { background-color: white; }"+ , "tr.alt { background-color: #A3B5BA}"+ , "th { background-color: #3C4569; color: white; font-size: 1.125em; }"+ , "h1 { width: 760px; margin: 1em auto; font-size: 1em; font-family: sans-serif }"+ , "img { width: 20px }"+ , "a { text-decoration: none }"+ ]+ H.body $ do+ let hasTrailingSlash =+ case map fromPiece $ reverse pieces of+ "" : _ -> True+ _ -> False+ H.h1 $ showFolder' hasTrailingSlash $ filter (not . T.null . fromPiece) pieces+ renderDirectoryContentsTable (map fromPiece pieces) haskellSrc folderSrc fps'' where image x = T.unpack $ T.concat [relativeDirFromPieces pieces, ".hidden/", x, ".png"] folderSrc = image "folder"@@ -69,7 +74,7 @@ showFolder :: Bool -> Pieces -> H.Html showFolder _ [] = "/" -- won't happen showFolder _ [x] = H.toHtml $ showName $ fromPiece x- showFolder hasTrailingSlash (x:xs) = do+ showFolder hasTrailingSlash (x : xs) = do let len = length xs - (if hasTrailingSlash then 0 else 1) href | len == 0 = "."@@ -86,64 +91,72 @@ -- a new page template to wrap around this HTML. -- -- see also: 'getMetaData', 'renderDirectoryContents'-renderDirectoryContentsTable :: [T.Text] -- ^ requested path info- -> String- -> String- -> [Either FolderName File]- -> H.Html+renderDirectoryContentsTable+ :: [T.Text]+ -- ^ requested path info+ -> String+ -> String+ -> [Either FolderName File]+ -> H.Html renderDirectoryContentsTable pathInfo' haskellSrc folderSrc fps =- H.table $ do H.thead $ do H.th ! A.class_ "first" $ H.img ! A.src (H.toValue haskellSrc)- H.th "Name"- H.th "Modified"- H.th "Size"- H.tbody $ mapM_ mkRow (zip (sortBy sortMD fps) $ cycle [False, True])- where- sortMD :: Either FolderName File -> Either FolderName File -> Ordering- sortMD Left{} Right{} = LT- sortMD Right{} Left{} = GT- sortMD (Left a) (Left b) = compare a b- sortMD (Right a) (Right b) = compare (fileName a) (fileName b)+ H.table $ do+ H.thead $ do+ H.th ! A.class_ "first" $ H.img ! A.src (H.toValue haskellSrc)+ H.th "Name"+ H.th "Modified"+ H.th "Size"+ H.tbody $ mapM_ mkRow (zip (sortBy sortMD fps) $ cycle [False, True])+ where+ sortMD :: Either FolderName File -> Either FolderName File -> Ordering+ sortMD Left{} Right{} = LT+ sortMD Right{} Left{} = GT+ sortMD (Left a) (Left b) = compare a b+ sortMD (Right a) (Right b) = compare (fileName a) (fileName b) - mkRow :: (Either FolderName File, Bool) -> H.Html- mkRow (md, alt) =- (if alt then (! A.class_ "alt") else id) $- H.tr $ do- H.td ! A.class_ "first"- $ case md of- Left{} -> H.img ! A.src (H.toValue folderSrc)- ! A.alt "Folder"- Right{} -> return ()- let name =- case either id fileName md of- (fromPiece -> "") -> unsafeToPiece ".."- x -> x- let href = addCurrentDir $ fromPiece name- addCurrentDir x =- case reverse pathInfo' of- "":_ -> x -- has a trailing slash- [] -> x -- at the root- currentDir:_ -> T.concat [currentDir, "/", x]- H.td (H.a ! A.href (H.toValue href) $ H.toHtml $ fromPiece name)- H.td ! A.class_ "date" $ H.toHtml $- case md of- Right File { fileGetModified = Just t } ->- formatCalendarTime defaultTimeLocale "%d-%b-%Y %X" t- _ -> ""- H.td ! A.class_ "size" $ H.toHtml $- case md of- Right File { fileGetSize = s } -> prettyShow s- Left{} -> ""- formatCalendarTime a b c = formatTime a b $ posixSecondsToUTCTime (realToFrac c :: POSIXTime)- prettyShow x+ mkRow :: (Either FolderName File, Bool) -> H.Html+ mkRow (md, alt) =+ (if alt then (! A.class_ "alt") else id) $+ H.tr $ do+ H.td ! A.class_ "first" $+ case md of+ Left{} ->+ H.img+ ! A.src (H.toValue folderSrc)+ ! A.alt "Folder"+ Right{} -> return ()+ let name =+ case either id fileName md of+ (fromPiece -> "") -> unsafeToPiece ".."+ x -> x+ let href = addCurrentDir $ fromPiece name+ addCurrentDir x =+ case reverse pathInfo' of+ "" : _ -> x -- has a trailing slash+ [] -> x -- at the root+ currentDir : _ -> T.concat [currentDir, "/", x]+ H.td (H.a ! A.href (H.toValue href) $ H.toHtml $ fromPiece name)+ H.td ! A.class_ "date" $+ H.toHtml $+ case md of+ Right File{fileGetModified = Just t} ->+ formatCalendarTime defaultTimeLocale "%d-%b-%Y %X" t+ _ -> ""+ H.td ! A.class_ "size" $+ H.toHtml $+ case md of+ Right File{fileGetSize = s} -> prettyShow s+ Left{} -> ""+ formatCalendarTime a b c = formatTime a b $ posixSecondsToUTCTime (realToFrac c :: POSIXTime)+ prettyShow x | x > 1024 = prettyShowK $ x `div` 1024 | otherwise = addCommas "B" x- prettyShowK x+ prettyShowK x | x > 1024 = prettyShowM $ x `div` 1024 | otherwise = addCommas "KB" x- prettyShowM x+ prettyShowM x | x > 1024 = prettyShowG $ x `div` 1024 | otherwise = addCommas "MB" x- prettyShowG x = addCommas "GB" x- addCommas s = (++ (' ' : s)) . reverse . addCommas' . reverse . show- addCommas' (a:b:c:d:e) = a : b : c : ',' : addCommas' (d : e)- addCommas' x = x+ prettyShowG x = addCommas "GB" x+ addCommas s = (++ (' ' : s)) . reverse . addCommas' . reverse . show+ addCommas' (a : b : c : d : e) = a : b : c : ',' : addCommas' (d : e)+ addCommas' x = x
WaiAppStatic/Storage/Embedded.hs view
@@ -1,12 +1,12 @@-module WaiAppStatic.Storage.Embedded(+module WaiAppStatic.Storage.Embedded ( -- * Basic- embeddedSettings+ embeddedSettings, -- * Template Haskell- , Etag- , EmbeddableEntry(..)- , mkSettings- ) where+ Etag,+ EmbeddableEntry (..),+ mkSettings,+) where import WaiAppStatic.Storage.Embedded.Runtime import WaiAppStatic.Storage.Embedded.TH
WaiAppStatic/Storage/Embedded/Runtime.hs view
@@ -1,21 +1,22 @@ {-# LANGUAGE CPP #-}+ -- | Lookup files stored in memory instead of from the filesystem.-module WaiAppStatic.Storage.Embedded.Runtime- ( -- * Settings- embeddedSettings- ) where+module WaiAppStatic.Storage.Embedded.Runtime (+ -- * Settings+ embeddedSettings,+) where -import WaiAppStatic.Types+import Control.Arrow (second, (&&&)) import Data.ByteString (ByteString)-import Control.Arrow ((&&&), second)-import Data.List (groupBy, sortBy)+import qualified Data.ByteString as S import Data.ByteString.Builder (byteString)-import qualified Network.Wai as W-import qualified Data.Map as Map import Data.Function (on)-import qualified Data.Text as T+import Data.List (groupBy, sortBy)+import qualified Data.Map as Map import Data.Ord-import qualified Data.ByteString as S+import qualified Data.Text as T+import qualified Network.Wai as W+import WaiAppStatic.Types #ifdef MIN_VERSION_crypton import Crypto.Hash (hash, MD5, Digest) import Data.ByteArray.Encoding@@ -23,14 +24,15 @@ import Crypto.Hash.MD5 (hash) import Data.ByteString.Base64 (encode) #endif-import WaiAppStatic.Storage.Filesystem (defaultFileServerSettings) import System.FilePath (isPathSeparator)+import WaiAppStatic.Storage.Filesystem (defaultFileServerSettings) -- | Serve the list of path/content pairs directly from memory. embeddedSettings :: [(Prelude.FilePath, ByteString)] -> StaticSettings-embeddedSettings files = (defaultFileServerSettings $ error "unused")- { ssLookupFile = embeddedLookup $ toEmbedded files- }+embeddedSettings files =+ (defaultFileServerSettings $ error "unused")+ { ssLookupFile = embeddedLookup $ toEmbedded files+ } type Embedded = Map.Map Piece EmbeddedEntry @@ -40,10 +42,10 @@ embeddedLookup root pieces = return $ elookup pieces root where- elookup :: Pieces -> Embedded -> LookupResult+ elookup :: Pieces -> Embedded -> LookupResult elookup [] x = LRFolder $ Folder $ fmap toEntry $ Map.toList x elookup [p] x | T.null (fromPiece p) = elookup [] x- elookup (p:ps) x =+ elookup (p : ps) x = case Map.lookup p x of Nothing -> LRNotFound Just (EEFile f) ->@@ -54,13 +56,15 @@ toEntry :: (Piece, EmbeddedEntry) -> Either FolderName File toEntry (name, EEFolder{}) = Left name-toEntry (name, EEFile bs) = Right File- { fileGetSize = fromIntegral $ S.length bs- , fileToResponse = \s h -> W.responseBuilder s h $ byteString bs- , fileName = name- , fileGetHash = return $ Just $ runHash bs- , fileGetModified = Nothing- }+toEntry (name, EEFile bs) =+ Right+ File+ { fileGetSize = fromIntegral $ S.length bs+ , fileToResponse = \s h -> W.responseBuilder s h $ byteString bs+ , fileName = name+ , fileGetHash = return $ Just $ runHash bs+ , fileGetModified = Nothing+ } toEmbedded :: [(Prelude.FilePath, ByteString)] -> Embedded toEmbedded fps =@@ -91,13 +95,14 @@ go' x = EEFolder $ go $ filter (\y -> not $ null $ fst y) x bsToFile :: Piece -> ByteString -> File-bsToFile name bs = File- { fileGetSize = fromIntegral $ S.length bs- , fileToResponse = \s h -> W.responseBuilder s h $ byteString bs- , fileName = name- , fileGetHash = return $ Just $ runHash bs- , fileGetModified = Nothing- }+bsToFile name bs =+ File+ { fileGetSize = fromIntegral $ S.length bs+ , fileToResponse = \s h -> W.responseBuilder s h $ byteString bs+ , fileName = name+ , fileGetHash = return $ Just $ runHash bs+ , fileGetModified = Nothing+ } runHash :: ByteString -> ByteString #ifdef MIN_VERSION_crypton
WaiAppStatic/Storage/Embedded/TH.hs view
@@ -1,22 +1,27 @@-{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings, MagicHash, CPP #-}-module WaiAppStatic.Storage.Embedded.TH(- Etag- , EmbeddableEntry(..)- , mkSettings+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++module WaiAppStatic.Storage.Embedded.TH (+ Etag,+ EmbeddableEntry (..),+ mkSettings, ) where -import Data.ByteString.Builder.Extra (byteStringInsert) import Codec.Compression.GZip (compress)+import qualified Data.ByteString as B+import Data.ByteString.Builder.Extra (byteStringInsert)+import qualified Data.ByteString.Lazy as BL import Data.ByteString.Unsafe (unsafePackAddressLen) import Data.Either (lefts, rights)-import GHC.Exts (Int(..))+import GHC.Exts (Int (..)) import Language.Haskell.TH import Network.Mime (MimeType, defaultMimeLookup) import System.IO.Unsafe (unsafeDupablePerformIO)-import WaiAppStatic.Types import WaiAppStatic.Storage.Filesystem (defaultWebAppSettings)-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL+import WaiAppStatic.Types #if !MIN_VERSION_template_haskell(2, 8, 0) import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy.Char8 as BL8@@ -33,35 +38,37 @@ type Etag = T.Text -- | Used at compile time to hold data about an entry to embed into the compiled executable.-data EmbeddableEntry = EmbeddableEntry {- eLocation :: T.Text -- ^ The location where this resource should be served from. The- -- location can contain forward slashes (/) to simulate directories,- -- but must not end with a forward slash.- , eMimeType :: MimeType -- ^ The mime type.- , eContent :: Either (Etag, BL.ByteString) ExpQ- -- ^ The content itself. The content can be given as a tag and bytestring,- -- in which case the content will be embedded directly into the execuatble.- -- Alternatively, the content can be given as a template haskell expression- -- returning @IO ('Etag', 'BL.ByteString')@ in which case this action will- -- be executed on every request to reload the content (this is useful- -- for a debugging mode).-}+data EmbeddableEntry = EmbeddableEntry+ { eLocation :: T.Text+ -- ^ The location where this resource should be served from. The+ -- location can contain forward slashes (/) to simulate directories,+ -- but must not end with a forward slash.+ , eMimeType :: MimeType+ -- ^ The mime type.+ , eContent :: Either (Etag, BL.ByteString) ExpQ+ -- ^ The content itself. The content can be given as a tag and bytestring,+ -- in which case the content will be embedded directly into the execuatble.+ -- Alternatively, the content can be given as a template haskell expression+ -- returning @IO ('Etag', 'BL.ByteString')@ in which case this action will+ -- be executed on every request to reload the content (this is useful+ -- for a debugging mode).+ } -- | This structure is used at runtime to hold the entry.-data EmbeddedEntry = EmbeddedEntry {- embLocation :: !T.Text- , embMime :: !MimeType- , embEtag :: !B.ByteString- , embCompressed :: !Bool- , embContent :: !B.ByteString-}+data EmbeddedEntry = EmbeddedEntry+ { embLocation :: !T.Text+ , embMime :: !MimeType+ , embEtag :: !B.ByteString+ , embCompressed :: !Bool+ , embContent :: !B.ByteString+ } -- | This structure is used at runtime to hold the reload entries.-data ReloadEntry = ReloadEntry {- reloadLocation :: !T.Text- , reloadMime :: !MimeType- , reloadContent :: IO (T.Text, BL.ByteString)-}+data ReloadEntry = ReloadEntry+ { reloadLocation :: !T.Text+ , reloadMime :: !MimeType+ , reloadContent :: IO (T.Text, BL.ByteString)+ } -- The use of unsafePackAddressLen is safe here because the length -- is correct and we will only be reading from the bytestring, never@@ -102,90 +109,100 @@ -- | A template haskell expression which creates either an EmbeddedEntry or ReloadEntry. mkEntry :: EmbeddableEntry -> ExpQ mkEntry (EmbeddableEntry loc mime (Left (etag, ct))) =- [| Left $ EmbeddedEntry (T.pack $locE)- $(bytestringE mime)- $(bytestringE $ T.encodeUtf8 etag)- (1 == I# $compressedE)- $(bytestringLazyE ct')+ [|+ Left $+ EmbeddedEntry+ (T.pack $locE)+ $(bytestringE mime)+ $(bytestringE $ T.encodeUtf8 etag)+ (1 == I# $compressedE)+ $(bytestringLazyE ct') |]- where- locE = litE $ stringL $ T.unpack loc- (compressed, ct') = tryCompress mime ct- compressedE = litE $ intPrimL $ if compressed then 1 else 0-+ where+ locE = litE $ stringL $ T.unpack loc+ (compressed, ct') = tryCompress mime ct+ compressedE = litE $ intPrimL $ if compressed then 1 else 0 mkEntry (EmbeddableEntry loc mime (Right expr)) =- [| Right $ ReloadEntry (T.pack $locE)- $(bytestringE mime)- $expr+ [|+ Right $+ ReloadEntry+ (T.pack $locE)+ $(bytestringE mime)+ $expr |]- where- locE = litE $ stringL $ T.unpack loc+ where+ locE = litE $ stringL $ T.unpack loc -- | Converts an embedded entry to a file embeddedToFile :: EmbeddedEntry -> File-embeddedToFile entry = File- { fileGetSize = fromIntegral $ B.length $ embContent entry- , fileToResponse = \s h ->- let h' = if embCompressed entry- then h ++ [("Content-Encoding", "gzip")]- else h- in W.responseBuilder s h' $ byteStringInsert $ embContent entry-- -- Usually the fileName should just be the filename not the entire path,- -- but we need the whole path to make the lookup within lookupMime- -- possible. lookupMime is provided only with the File and from that- -- we must find the mime type. Putting the path here is OK since- -- within staticApp the fileName is used for directory listings which- -- we have disabled.- , fileName = unsafeToPiece $ embLocation entry- , fileGetHash = return $ if B.null (embEtag entry)- then Nothing- else Just $ embEtag entry- , fileGetModified = Nothing- }+embeddedToFile entry =+ File+ { fileGetSize = fromIntegral $ B.length $ embContent entry+ , fileToResponse = \s h ->+ let h' =+ if embCompressed entry+ then h ++ [("Content-Encoding", "gzip")]+ else h+ in W.responseBuilder s h' $ byteStringInsert $ embContent entry+ , -- Usually the fileName should just be the filename not the entire path,+ -- but we need the whole path to make the lookup within lookupMime+ -- possible. lookupMime is provided only with the File and from that+ -- we must find the mime type. Putting the path here is OK since+ -- within staticApp the fileName is used for directory listings which+ -- we have disabled.+ fileName = unsafeToPiece $ embLocation entry+ , fileGetHash =+ return $+ if B.null (embEtag entry)+ then Nothing+ else Just $ embEtag entry+ , fileGetModified = Nothing+ } -- | Converts a reload entry to a file reloadToFile :: ReloadEntry -> IO File reloadToFile entry = do (etag, ct) <- reloadContent entry let etag' = T.encodeUtf8 etag- return $ File- { fileGetSize = fromIntegral $ BL.length ct- , fileToResponse = \s h -> W.responseLBS s h ct- -- Similar to above the entire path needs to be in the fileName.- , fileName = unsafeToPiece $ reloadLocation entry- , fileGetHash = return $ if T.null etag then Nothing else Just etag'- , fileGetModified = Nothing- }-+ return $+ File+ { fileGetSize = fromIntegral $ BL.length ct+ , fileToResponse = \s h -> W.responseLBS s h ct+ , -- Similar to above the entire path needs to be in the fileName.+ fileName = unsafeToPiece $ reloadLocation entry+ , fileGetHash = return $ if T.null etag then Nothing else Just etag'+ , fileGetModified = Nothing+ } -- | Build a static settings based on a filemap. filemapToSettings :: M.HashMap T.Text (MimeType, IO File) -> StaticSettings-filemapToSettings mfiles = (defaultWebAppSettings "")- { ssLookupFile = lookupFile- , ssGetMimeType = lookupMime- }- where- piecesToFile p = T.intercalate "/" $ map fromPiece p+filemapToSettings mfiles =+ (defaultWebAppSettings "")+ { ssLookupFile = lookupFile+ , ssGetMimeType = lookupMime+ }+ where+ piecesToFile p = T.intercalate "/" $ map fromPiece p - lookupFile [] = return LRNotFound- lookupFile p =- case M.lookup (piecesToFile p) mfiles of- Nothing -> return LRNotFound- Just (_,act) -> LRFile <$> act+ lookupFile [] = return LRNotFound+ lookupFile p =+ case M.lookup (piecesToFile p) mfiles of+ Nothing -> return LRNotFound+ Just (_, act) -> LRFile <$> act - lookupMime (File { fileName = p }) =- case M.lookup (fromPiece p) mfiles of- Just (mime,_) -> return mime- Nothing -> return $ defaultMimeLookup $ fromPiece p+ lookupMime (File{fileName = p}) =+ case M.lookup (fromPiece p) mfiles of+ Just (mime, _) -> return mime+ Nothing -> return $ defaultMimeLookup $ fromPiece p -- | Create a 'StaticSettings' from a list of entries. Executed at run time. entriesToSt :: [Either EmbeddedEntry ReloadEntry] -> StaticSettings entriesToSt entries = hmap `seq` filemapToSettings hmap- where- embFiles = [ (embLocation e, (embMime e, return $ embeddedToFile e)) | e <- lefts entries]- reloadFiles = [ (reloadLocation r, (reloadMime r, reloadToFile r)) | r <- rights entries]- hmap = M.fromList $ embFiles ++ reloadFiles+ where+ embFiles =+ [(embLocation e, (embMime e, return $ embeddedToFile e)) | e <- lefts entries]+ reloadFiles = [(reloadLocation r, (reloadMime r, reloadToFile r)) | r <- rights entries]+ hmap = M.fromList $ embFiles ++ reloadFiles -- | Create a 'StaticSettings' at compile time that embeds resources directly into the compiled -- executable. The embedded resources are precompressed (depending on mime type)@@ -197,17 +214,17 @@ -- -- > {-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-} -- > module A (mkEmbedded) where--- > +-- > -- > import WaiAppStatic.Storage.Embedded -- > import Crypto.Hash.MD5 (hashlazy) -- > import qualified Data.ByteString.Lazy as BL -- > import qualified Data.ByteString.Base64 as B64 -- > import qualified Data.Text as T -- > import qualified Data.Text.Encoding as T--- > +-- > -- > hash :: BL.ByteString -> T.Text -- > hash = T.take 8 . T.decodeUtf8 . B64.encode . hashlazy--- > +-- > -- > mkEmbedded :: IO [EmbeddableEntry] -- > mkEmbedded = do -- > file <- BL.readFile "test.css"@@ -216,13 +233,13 @@ -- > , eMimeType = "text/css" -- > , eContent = Left (hash file, file) -- > }--- > +-- > -- > let reload = EmbeddableEntry { -- > eLocation = "anotherdir/test2.txt" -- > , eMimeType = "text/plain" -- > , eContent = Right [| BL.readFile "test2.txt" >>= \c -> return (hash c, c) |] -- > }--- > +-- > -- > return [emb, reload] -- -- The above @mkEmbedded@ will be executed at compile time. It loads the contents of test.css and@@ -241,37 +258,38 @@ -- -- > {-# LANGUAGE TemplateHaskell #-} -- > module B where--- > +-- > -- > import A -- > import Network.Wai (Application) -- > import Network.Wai.Application.Static (staticApp) -- > import WaiAppStatic.Storage.Embedded -- > import Network.Wai.Handler.Warp (run)--- > +-- > -- > myApp :: Application -- > myApp = staticApp $(mkSettings mkEmbedded)--- > +-- > -- > main :: IO () -- > main = run 3000 myApp mkSettings :: IO [EmbeddableEntry] -> ExpQ mkSettings action = do entries <- runIO action- [| entriesToSt $(listE $ map mkEntry entries) |]+ [|entriesToSt $(listE $ map mkEntry entries)|] shouldCompress :: MimeType -> Bool shouldCompress m = "text/" `B.isPrefixOf` m || m `elem` extra- where- extra = [ "application/json"- , "application/javascript"- , "application/ecmascript"- ]+ where+ extra =+ [ "application/json"+ , "application/javascript"+ , "application/ecmascript"+ ] -- | Only compress if the mime type is correct and the compressed text is actually shorter. tryCompress :: MimeType -> BL.ByteString -> (Bool, BL.ByteString) tryCompress mime ct- | shouldCompress mime = (c, ct')- | otherwise = (False, ct)- where- compressed = compress ct- c = BL.length compressed < BL.length ct- ct' = if c then compressed else ct+ | shouldCompress mime = (c, ct')+ | otherwise = (False, ct)+ where+ compressed = compress ct+ c = BL.length compressed < BL.length ct+ ct' = if c then compressed else ct
WaiAppStatic/Storage/Filesystem.hs view
@@ -1,31 +1,42 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}+ -- | Access files on the filesystem.-module WaiAppStatic.Storage.Filesystem- ( -- * Types- ETagLookup- -- * Settings- , defaultWebAppSettings- , defaultFileServerSettings- , webAppSettingsWithLookup- ) where+module WaiAppStatic.Storage.Filesystem (+ -- * Types+ ETagLookup, -import WaiAppStatic.Types-import System.FilePath ((</>))-import System.IO (withBinaryFile, IOMode(..))-import System.Directory (doesFileExist, doesDirectoryExist, getDirectoryContents)-import Data.List (foldl')+ -- * Settings+ defaultWebAppSettings,+ defaultFileServerSettings,+ webAppSettingsWithLookup,+) where++import Control.Exception (SomeException, try) import Control.Monad (forM)-import Util import Data.ByteString (ByteString)-import Control.Exception (SomeException, try)+import Data.List (foldl')+import Data.Maybe (catMaybes)+import Network.Mime import qualified Network.Wai as W+import System.Directory (+ doesDirectoryExist,+ doesFileExist,+ getDirectoryContents,+ )+import System.FilePath ((</>))+import System.IO (IOMode (..), withBinaryFile)+import System.PosixCompat.Files (+ fileSize,+ getFileStatus,+ isRegularFile,+ modificationTime,+ )+import Util import WaiAppStatic.Listing-import Network.Mime-import System.PosixCompat.Files (fileSize, getFileStatus, modificationTime, isRegularFile)-import Data.Maybe (catMaybes)+import WaiAppStatic.Types #ifdef MIN_VERSION_crypton import Data.ByteArray.Encoding import Crypto.Hash (hashlazy, MD5, Digest)@@ -42,70 +53,88 @@ -- | Settings optimized for a web application. Files will have aggressive -- caching applied and hashes calculated, and indices and listings are disabled.-defaultWebAppSettings :: FilePath -- ^ root folder to serve from- -> StaticSettings-defaultWebAppSettings root = StaticSettings- { ssLookupFile = webAppLookup hashFileIfExists root- , ssMkRedirect = defaultMkRedirect- , ssGetMimeType = return . defaultMimeLookup . fromPiece . fileName- , ssMaxAge = MaxAgeForever- , ssListing = Nothing- , ssIndices = []- , ssRedirectToIndex = False- , ssUseHash = True- , ssAddTrailingSlash = False- , ss404Handler = Nothing- }+defaultWebAppSettings+ :: FilePath+ -- ^ root folder to serve from+ -> StaticSettings+defaultWebAppSettings root =+ StaticSettings+ { ssLookupFile = webAppLookup hashFileIfExists root+ , ssMkRedirect = defaultMkRedirect+ , ssGetMimeType = return . defaultMimeLookup . fromPiece . fileName+ , ssMaxAge = MaxAgeForever+ , ssListing = Nothing+ , ssIndices = []+ , ssRedirectToIndex = False+ , ssUseHash = True+ , ssAddTrailingSlash = False+ , ss404Handler = Nothing+ } -- | Settings optimized for a file server. More conservative caching will be -- applied, and indices and listings are enabled.-defaultFileServerSettings :: FilePath -- ^ root folder to serve from- -> StaticSettings-defaultFileServerSettings root = StaticSettings- { ssLookupFile = fileSystemLookup (fmap Just . hashFile) root- , ssMkRedirect = defaultMkRedirect- , ssGetMimeType = return . defaultMimeLookup . fromPiece . fileName- , ssMaxAge = NoMaxAge- , ssListing = Just defaultListing- , ssIndices = map unsafeToPiece ["index.html", "index.htm"]- , ssRedirectToIndex = False- , ssUseHash = False- , ssAddTrailingSlash = False- , ss404Handler = Nothing- }+defaultFileServerSettings+ :: FilePath+ -- ^ root folder to serve from+ -> StaticSettings+defaultFileServerSettings root =+ StaticSettings+ { ssLookupFile = fileSystemLookup (fmap Just . hashFile) root+ , ssMkRedirect = defaultMkRedirect+ , ssGetMimeType = return . defaultMimeLookup . fromPiece . fileName+ , ssMaxAge = NoMaxAge+ , ssListing = Just defaultListing+ , ssIndices = map unsafeToPiece ["index.html", "index.htm"]+ , ssRedirectToIndex = False+ , ssUseHash = False+ , ssAddTrailingSlash = False+ , ss404Handler = Nothing+ } -- | Same as @defaultWebAppSettings@, but additionally uses a specialized -- @ETagLookup@ in place of the standard one. This can allow you to cache your -- hash values, or even precompute them.-webAppSettingsWithLookup :: FilePath -- ^ root folder to serve from- -> ETagLookup- -> StaticSettings+webAppSettingsWithLookup+ :: FilePath+ -- ^ root folder to serve from+ -> ETagLookup+ -> StaticSettings webAppSettingsWithLookup dir etagLookup =- (defaultWebAppSettings dir) { ssLookupFile = webAppLookup etagLookup dir}+ (defaultWebAppSettings dir){ssLookupFile = webAppLookup etagLookup dir} -- | Convenience wrapper for @fileHelper@.-fileHelperLR :: ETagLookup- -> FilePath -- ^ file location- -> Piece -- ^ file name- -> IO LookupResult+fileHelperLR+ :: ETagLookup+ -> FilePath+ -- ^ file location+ -> Piece+ -- ^ file name+ -> IO LookupResult fileHelperLR a b c = fmap (maybe LRNotFound LRFile) $ fileHelper a b c -- | Attempt to load up a @File@ from the given path.-fileHelper :: ETagLookup- -> FilePath -- ^ file location- -> Piece -- ^ file name- -> IO (Maybe File)+fileHelper+ :: ETagLookup+ -> FilePath+ -- ^ file location+ -> Piece+ -- ^ file name+ -> IO (Maybe File) fileHelper hashFunc fp name = do efs <- try $ getFileStatus fp case efs of Left (_ :: SomeException) -> return Nothing- Right fs | isRegularFile fs -> return $ Just File- { fileGetSize = fromIntegral $ fileSize fs- , fileToResponse = \s h -> W.responseFile s h fp Nothing- , fileName = name- , fileGetHash = hashFunc fp- , fileGetModified = Just $ modificationTime fs- }+ Right fs+ | isRegularFile fs ->+ return $+ Just+ File+ { fileGetSize = fromIntegral $ fileSize fs+ , fileToResponse = \s h -> W.responseFile s h fp Nothing+ , fileName = name+ , fileGetHash = hashFunc fp+ , fileGetModified = Just $ modificationTime fs+ } Right _ -> return Nothing -- | How to calculate etags. Can perform filesystem reads on each call, or use@@ -144,14 +173,17 @@ Right x -> Just x isVisible :: FilePath -> Bool-isVisible ('.':_) = False+isVisible ('.' : _) = False isVisible "" = False isVisible _ = True -- | Get a proper @LookupResult@, checking if the path is a file or folder. -- Compare with @webAppLookup@, which only deals with files.-fileSystemLookup :: ETagLookup- -> FilePath -> Pieces -> IO LookupResult+fileSystemLookup+ :: ETagLookup+ -> FilePath+ -> Pieces+ -> IO LookupResult fileSystemLookup hashFunc prefix pieces = do let fp = pathFromPieces prefix pieces fe <- doesFileExist fp
WaiAppStatic/Types.hs view
@@ -1,31 +1,34 @@-module WaiAppStatic.Types- ( -- * Pieces- Piece- , toPiece- , fromPiece- , unsafeToPiece- , Pieces- , toPieces- -- * Caching- , MaxAge (..)- -- * File\/folder serving- , FolderName- , Folder (..)- , File (..)- , LookupResult (..)- , Listing- -- * Settings- , StaticSettings (..)- ) where+module WaiAppStatic.Types (+ -- * Pieces+ Piece,+ toPiece,+ fromPiece,+ unsafeToPiece,+ Pieces,+ toPieces, + -- * Caching+ MaxAge (..),++ -- * File\/folder serving+ FolderName,+ Folder (..),+ File (..),+ LookupResult (..),+ Listing,++ -- * Settings+ StaticSettings (..),+) where++import Data.ByteString (ByteString)+import Data.ByteString.Builder (Builder) import Data.Text (Text)+import qualified Data.Text as T import qualified Network.HTTP.Types as H+import Network.Mime (MimeType) import qualified Network.Wai as W-import Data.ByteString (ByteString) import System.Posix.Types (EpochTime)-import qualified Data.Text as T-import Data.ByteString.Builder (Builder)-import Network.Mime (MimeType) -- | An individual component of a path, or of a filepath. --@@ -35,7 +38,7 @@ -- -- Individual file lookup backends must know how to convert from a @Piece@ to -- their storage system.-newtype Piece = Piece { fromPiece :: Text }+newtype Piece = Piece {fromPiece :: Text} deriving (Show, Eq, Ord) -- | Smart constructor for a @Piece@. Won\'t allow unsafe components, such as@@ -64,10 +67,17 @@ type Pieces = [Piece] -- | Values for the max-age component of the cache-control response header.-data MaxAge = NoMaxAge -- ^ no cache-control set- | MaxAgeSeconds Int -- ^ set to the given number of seconds- | MaxAgeForever -- ^ essentially infinite caching; in reality, probably one year- | NoStore -- ^ set cache-control to no-store @since 3.1.8+data MaxAge+ = -- | no cache-control set+ NoMaxAge+ | -- | set to the given number of seconds+ MaxAgeSeconds Int+ | -- | essentially infinite caching; in reality, probably one year+ MaxAgeForever+ | -- | set cache-control to no-store @since 3.1.8+ NoStore+ | -- | set cache-control to no-cache @since 3.1.9+ NoCache -- | Just the name of a folder. type FolderName = Piece@@ -80,26 +90,27 @@ -- | Information on an individual file. data File = File- { -- | Size of file in bytes- fileGetSize :: Integer- -- | How to construct a WAI response for this file. Some files are stored- -- on the filesystem and can use @ResponseFile@, while others are stored- -- in memory and should use @ResponseBuilder@.+ { fileGetSize :: Integer+ -- ^ Size of file in bytes , fileToResponse :: H.Status -> H.ResponseHeaders -> W.Response- -- | Last component of the filename.+ -- ^ How to construct a WAI response for this file. Some files are stored+ -- on the filesystem and can use @ResponseFile@, while others are stored+ -- in memory and should use @ResponseBuilder@. , fileName :: Piece- -- | Calculate a hash of the contents of this file, such as for etag.+ -- ^ Last component of the filename. , fileGetHash :: IO (Maybe ByteString)- -- | Last modified time, used for both display in listings and if-modified-since.+ -- ^ Calculate a hash of the contents of this file, such as for etag. , fileGetModified :: Maybe EpochTime+ -- ^ Last modified time, used for both display in listings and if-modified-since. } -- | Result of looking up a file in some storage backend. -- -- The lookup is either a file or folder, or does not exist.-data LookupResult = LRFile File- | LRFolder Folder- | LRNotFound+data LookupResult+ = LRFile File+ | LRFolder Folder+ | LRNotFound -- | How to construct a directory listing page for the given request path and -- the resulting folder.@@ -110,45 +121,35 @@ -- Note that you should use the settings type approach for modifying values. -- See <http://www.yesodweb.com/book/settings-types> for more information. data StaticSettings = StaticSettings- {- -- | Lookup a single file or folder. This is how you can control storage- -- backend (filesystem, embedded, etc) and where to lookup.- ssLookupFile :: Pieces -> IO LookupResult-- -- | Determine the mime type of the given file. Note that this function- -- lives in @IO@ in case you want to perform more complicated mimetype- -- analysis, such as via the @file@ utility.+ { ssLookupFile :: Pieces -> IO LookupResult+ -- ^ Lookup a single file or folder. This is how you can control storage+ -- backend (filesystem, embedded, etc) and where to lookup. , ssGetMimeType :: File -> IO MimeType-- -- | Ordered list of filenames to be used for indices. If the user- -- requests a folder, and a file with the given name is found in that- -- folder, that file is served. This supercedes any directory listing.+ -- ^ Determine the mime type of the given file. Note that this function+ -- lives in @IO@ in case you want to perform more complicated mimetype+ -- analysis, such as via the @file@ utility. , ssIndices :: [Piece]-- -- | How to perform a directory listing. Optional. Will be used when the- -- user requested a folder.+ -- ^ Ordered list of filenames to be used for indices. If the user+ -- requests a folder, and a file with the given name is found in that+ -- folder, that file is served. This supercedes any directory listing. , ssListing :: Maybe Listing-- -- | Value to provide for max age in the cache-control.+ -- ^ How to perform a directory listing. Optional. Will be used when the+ -- user requested a folder. , ssMaxAge :: MaxAge-- -- | Given a requested path and a new destination, construct a string- -- that will go there. Default implementation will use relative paths.+ -- ^ Value to provide for max age in the cache-control. , ssMkRedirect :: Pieces -> ByteString -> ByteString-- -- | If @True@, send a redirect to the user when a folder is requested- -- and an index page should be displayed. When @False@, display the- -- content immediately.+ -- ^ Given a requested path and a new destination, construct a string+ -- that will go there. Default implementation will use relative paths. , ssRedirectToIndex :: Bool-- -- | Prefer usage of etag caching to last-modified caching.+ -- ^ If @True@, send a redirect to the user when a folder is requested+ -- and an index page should be displayed. When @False@, display the+ -- content immediately. , ssUseHash :: Bool-- -- | Force a trailing slash at the end of directories+ -- ^ Prefer usage of etag caching to last-modified caching. , ssAddTrailingSlash :: Bool-- -- | Optional `W.Application` to be used in case of 404 errors- --- -- Since 3.1.3+ -- ^ Force a trailing slash at the end of directories , ss404Handler :: Maybe W.Application+ -- ^ Optional `W.Application` to be used in case of 404 errors+ --+ -- Since 3.1.3 }
test/EmbeddedTestEntries.hs view
@@ -1,55 +1,59 @@-{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-} module EmbeddedTestEntries where -import WaiAppStatic.Storage.Embedded+import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL-import qualified Data.ByteString.Lazy as BL+import WaiAppStatic.Storage.Embedded body :: Int -> Char -> BL.ByteString body i c = TL.encodeUtf8 $ TL.pack $ replicate i c mkEntries :: IO [EmbeddableEntry]-mkEntries = return- -- An entry that should be compressed- [ EmbeddableEntry "e1.txt" - "text/plain" - (Left ("Etag 1", body 1000 'A'))-- -- An entry so short that the compressed text is longer- , EmbeddableEntry "e2.txt"- "text/plain"- (Left ("Etag 2", "ABC"))-- -- An entry that is not compressed because of the mime- , EmbeddableEntry "somedir/e3.txt"- "xxx"- (Left ("Etag 3", body 1000 'A'))-- -- A reloadable entry- , EmbeddableEntry "e4.css"- "text/css"- (Right [| return ("Etag 4" :: T.Text, body 2000 'Q') |])-- -- An entry without etag- , EmbeddableEntry "e5.txt"- "text/plain"- (Left ("", body 1000 'Z'))-- -- A reloadable entry without etag- , EmbeddableEntry "e6.txt"- "text/plain"- (Right [| return ("" :: T.Text, body 1000 'W') |] )-- -- An index file- , EmbeddableEntry "index.html"- "text/html"- (Right [| return ("" :: T.Text, "index file") |] )-- -- An index file in a subdir- , EmbeddableEntry "foo/index.html"- "text/html"- (Right [| return ("" :: T.Text, "index file in subdir") |] )- ]+mkEntries =+ return+ -- An entry that should be compressed+ [ EmbeddableEntry+ "e1.txt"+ "text/plain"+ (Left ("Etag 1", body 1000 'A'))+ , -- An entry so short that the compressed text is longer+ EmbeddableEntry+ "e2.txt"+ "text/plain"+ (Left ("Etag 2", "ABC"))+ , -- An entry that is not compressed because of the mime+ EmbeddableEntry+ "somedir/e3.txt"+ "xxx"+ (Left ("Etag 3", body 1000 'A'))+ , -- A reloadable entry+ EmbeddableEntry+ "e4.css"+ "text/css"+ (Right [|return ("Etag 4" :: T.Text, body 2000 'Q')|])+ , -- An entry without etag+ EmbeddableEntry+ "e5.txt"+ "text/plain"+ (Left ("", body 1000 'Z'))+ , -- A reloadable entry without etag+ EmbeddableEntry+ "e6.txt"+ "text/plain"+ (Right [|return ("" :: T.Text, body 1000 'W')|])+ , -- An index file+ EmbeddableEntry+ "index.html"+ "text/html"+ (Right [|return ("" :: T.Text, "index file")|])+ , -- An index file in a subdir+ EmbeddableEntry+ "foo/index.html"+ "text/html"+ (Right [|return ("" :: T.Text, "index file in subdir")|])+ ]
test/WaiAppEmbeddedTest.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+ module WaiAppEmbeddedTest (embSpec) where import Codec.Compression.GZip (compress)@@ -28,27 +30,32 @@ assertBody (compress $ body 1000 'A') req it "304 when valid if-none-match sent" $ embed $ do- req <- request (setRawPathInfo defRequest "e1.txt")- { requestHeaders = [("If-None-Match", "Etag 1")] }+ req <-+ request+ (setRawPathInfo defRequest "e1.txt")+ { requestHeaders = [("If-None-Match", "Etag 1")]+ } assertStatus 304 req it "ssIndices works" $ do- let testSettings = $(mkSettings mkEntries){- ssIndices = [unsafeToPiece "index.html"]- }+ let testSettings =+ $(mkSettings mkEntries)+ { ssIndices = [unsafeToPiece "index.html"]+ } embedSettings testSettings $ do- req <- request defRequest- assertStatus 200 req- assertBody "index file" req+ req <- request defRequest+ assertStatus 200 req+ assertBody "index file" req it "ssIndices works with trailing slashes" $ do- let testSettings = $(mkSettings mkEntries){- ssIndices = [unsafeToPiece "index.html"]- }+ let testSettings =+ $(mkSettings mkEntries)+ { ssIndices = [unsafeToPiece "index.html"]+ } embedSettings testSettings $ do- req <- request (setRawPathInfo defRequest "/foo/")- assertStatus 200 req- assertBody "index file in subdir" req+ req <- request (setRawPathInfo defRequest "/foo/")+ assertStatus 200 req+ assertBody "index file in subdir" req describe "embedded, uncompressed entry" $ do it "too short" $ embed $ do@@ -68,13 +75,14 @@ assertBody (body 1000 'A') req describe "reloadable entry" $- it "served correctly" $ embed $ do- req <- request (setRawPathInfo defRequest "e4.css")- assertStatus 200 req- assertHeader "Content-Type" "text/css" req- assertNoHeader "Content-Encoding" req- assertHeader "ETag" "Etag 4" req- assertBody (body 2000 'Q') req+ it "served correctly" $+ embed $ do+ req <- request (setRawPathInfo defRequest "e4.css")+ assertStatus 200 req+ assertHeader "Content-Type" "text/css" req+ assertNoHeader "Content-Encoding" req+ assertHeader "ETag" "Etag 4" req+ assertBody (body 2000 'Q') req describe "entries without etags" $ do it "embedded entry" $ embed $ do
test/WaiAppStaticTest.hs view
@@ -1,19 +1,24 @@-{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+ module WaiAppStaticTest (spec) where import Network.Wai.Application.Static import WaiAppStatic.Types +import qualified Data.ByteString.Char8 as S8 import Test.Hspec import Test.Mockery.Directory-import qualified Data.ByteString.Char8 as S8+ -- import qualified Data.ByteString.Lazy.Char8 as L8-import System.PosixCompat.Files (getFileStatus, modificationTime)+ import System.FilePath import System.IO.Temp+import System.PosixCompat.Files (getFileStatus, modificationTime) import Network.HTTP.Date import Network.HTTP.Types (status500)+ {-import System.Locale (defaultTimeLocale)-} {-import Data.Time.Format (formatTime)-} @@ -29,157 +34,181 @@ spec :: Spec spec = do- let webApp = flip runSession $ staticApp $ defaultWebAppSettings "test"- let fileServerAppWithSettings settings = flip runSession $ staticApp settings- let fileServerApp = fileServerAppWithSettings (defaultFileServerSettings "test")- { ssAddTrailingSlash = True- }-- let etag = "1B2M2Y8AsgTpgAmY7PhCfg=="- let file = "a/b"- let statFile = setRawPathInfo defRequest file+ let webApp = flip runSession $ staticApp $ defaultWebAppSettings "test"+ let fileServerAppWithSettings settings = flip runSession $ staticApp settings+ let fileServerApp =+ fileServerAppWithSettings+ (defaultFileServerSettings "test")+ { ssAddTrailingSlash = True+ } - describe "mime types" $ do- it "fileNameExtensions" $- fileNameExtensions "foo.tar.gz" `shouldBe` ["tar.gz", "gz"]- it "handles multi-extensions" $- defaultMimeLookup "foo.tar.gz" `shouldBe` "application/x-tgz"- it "defaults correctly" $- defaultMimeLookup "foo.unknown" `shouldBe` "application/octet-stream"+ let etag = "1B2M2Y8AsgTpgAmY7PhCfg=="+ let file = "a/b"+ let statFile = setRawPathInfo defRequest file - describe "webApp" $ do- it "403 for unsafe paths" $ webApp $- forM_ ["..", "."] $ \path ->- assertStatus 403 =<<- request (setRawPathInfo defRequest path)+ describe "mime types" $ do+ it "fileNameExtensions" $+ fileNameExtensions "foo.tar.gz" `shouldBe` ["tar.gz", "gz"]+ it "handles multi-extensions" $+ defaultMimeLookup "foo.tar.gz" `shouldBe` "application/x-tgz"+ it "defaults correctly" $+ defaultMimeLookup "foo.unknown" `shouldBe` "application/octet-stream" - it "200 for hidden paths" $ webApp $- forM_ [".hidden/folder.png", ".hidden/haskell.png"] $ \path ->- assertStatus 200 =<<- request (setRawPathInfo defRequest path)+ describe "webApp" $ do+ it "403 for unsafe paths" $+ webApp $+ forM_ ["..", "."] $ \path ->+ assertStatus 403+ =<< request (setRawPathInfo defRequest path) - it "404 for non-existent files" $ webApp $- assertStatus 404 =<<- request (setRawPathInfo defRequest "doesNotExist")+ it "200 for hidden paths" $+ webApp $+ forM_ [".hidden/folder.png", ".hidden/haskell.png"] $ \path ->+ assertStatus 200+ =<< request (setRawPathInfo defRequest path) - it "302 redirect when multiple slashes" $ webApp $ do- req <- request (setRawPathInfo defRequest "a//b/c")- assertStatus 302 req- assertHeader "Location" "../../a/b/c" req+ it "404 for non-existent files" $+ webApp $+ assertStatus 404+ =<< request (setRawPathInfo defRequest "doesNotExist") - let absoluteApp = flip runSession $ staticApp $ (defaultWebAppSettings "test") {- ssMkRedirect = \_ u -> S8.append "http://www.example.com" u- }- it "302 redirect when multiple slashes" $ absoluteApp $- forM_ ["/a//b/c", "a//b/c"] $ \path -> do- req <- request (setRawPathInfo defRequest path)- assertStatus 302 req- assertHeader "Location" "http://www.example.com/a/b/c" req+ it "302 redirect when multiple slashes" $ webApp $ do+ req <- request (setRawPathInfo defRequest "a//b/c")+ assertStatus 302 req+ assertHeader "Location" "../../a/b/c" req - describe "webApp when requesting a static asset" $ do- it "200 and etag when no etag query parameters" $ webApp $ do- req <- request statFile- assertStatus 200 req- assertHeader "ETag" etag req- assertNoHeader "Last-Modified" req+ let absoluteApp =+ flip runSession $+ staticApp $+ (defaultWebAppSettings "test")+ { ssMkRedirect = \_ u -> S8.append "http://www.example.com" u+ }+ it "302 redirect when multiple slashes" $+ absoluteApp $+ forM_ ["/a//b/c", "a//b/c"] $ \path -> do+ req <- request (setRawPathInfo defRequest path)+ assertStatus 302 req+ assertHeader "Location" "http://www.example.com/a/b/c" req - it "Cache-Control set when etag parameter is correct" $ webApp $ do- req <- request statFile { queryString = [("etag", Just etag)] }- assertStatus 200 req- assertHeader "Cache-Control" "public, max-age=31536000" req- assertNoHeader "Last-Modified" req+ describe "webApp when requesting a static asset" $ do+ it "200 and etag when no etag query parameters" $ webApp $ do+ req <- request statFile+ assertStatus 200 req+ assertHeader "ETag" etag req+ assertNoHeader "Last-Modified" req - it "200 when invalid in-none-match sent" $ webApp $- forM_ ["cached", ""] $ \badETag -> do- req <- request statFile { requestHeaders = [("If-None-Match", badETag)] }- assertStatus 200 req- assertHeader "ETag" etag req- assertNoHeader "Last-Modified" req+ it "Cache-Control set when etag parameter is correct" $ webApp $ do+ req <- request statFile{queryString = [("etag", Just etag)]}+ assertStatus 200 req+ assertHeader "Cache-Control" "public, max-age=31536000" req+ assertNoHeader "Last-Modified" req - it "304 when valid if-none-match sent" $ webApp $ do- req <- request statFile { requestHeaders = [("If-None-Match", etag)] }- assertStatus 304 req- assertNoHeader "Etag" req- assertNoHeader "Last-Modified" req+ it "200 when invalid in-none-match sent" $+ webApp $+ forM_ ["cached", ""] $ \badETag -> do+ req <- request statFile{requestHeaders = [("If-None-Match", badETag)]}+ assertStatus 200 req+ assertHeader "ETag" etag req+ assertNoHeader "Last-Modified" req - describe "fileServerApp" $ do- let fileDate = do- stat <- liftIO $ getFileStatus $ "test/" ++ file- return $ formatHTTPDate . epochTimeToHTTPDate $ modificationTime stat+ it "304 when valid if-none-match sent" $ webApp $ do+ req <- request statFile{requestHeaders = [("If-None-Match", etag)]}+ assertStatus 304 req+ assertNoHeader "Etag" req+ assertNoHeader "Last-Modified" req - it "directory listing for index" $ fileServerApp $ do- resp <- request (setRawPathInfo defRequest "a/")- assertStatus 200 resp- -- note the unclosed img tags so both /> and > will pass- assertBodyContains "<img src=\"../.hidden/haskell.png\"" resp- assertBodyContains "<img src=\"../.hidden/folder.png\" alt=\"Folder\"" resp- assertBodyContains "<a href=\"b\">b</a>" resp+ describe "fileServerApp" $ do+ let fileDate = do+ stat <- liftIO $ getFileStatus $ "test/" ++ file+ return $ formatHTTPDate . epochTimeToHTTPDate $ modificationTime stat - it "200 when invalid if-modified-since header" $ fileServerApp $ do- forM_ ["123", ""] $ \badDate -> do- req <- request statFile {- requestHeaders = [("If-Modified-Since", badDate)]- }- assertStatus 200 req- fdate <- fileDate- assertHeader "Last-Modified" fdate req+ it "directory listing for index" $ fileServerApp $ do+ resp <- request (setRawPathInfo defRequest "a/")+ assertStatus 200 resp+ -- note the unclosed img tags so both /> and > will pass+ assertBodyContains "<img src=\"../.hidden/haskell.png\"" resp+ assertBodyContains "<img src=\"../.hidden/folder.png\" alt=\"Folder\"" resp+ assertBodyContains "<a href=\"b\">b</a>" resp - it "304 when if-modified-since matches" $ fileServerApp $ do- fdate <- fileDate- req <- request statFile {- requestHeaders = [("If-Modified-Since", fdate)]- }- assertStatus 304 req- assertNoHeader "Cache-Control" req+ it "200 when invalid if-modified-since header" $ fileServerApp $ do+ forM_ ["123", ""] $ \badDate -> do+ req <-+ request+ statFile+ { requestHeaders = [("If-Modified-Since", badDate)]+ }+ assertStatus 200 req+ fdate <- fileDate+ assertHeader "Last-Modified" fdate req - context "302 redirect to add a trailing slash on directories if missing" $ do- it "works at the root" $ fileServerApp $ do- req <- request (setRawPathInfo defRequest "/a")- assertStatus 302 req- assertHeader "Location" "/a/" req+ it "304 when if-modified-since matches" $ fileServerApp $ do+ fdate <- fileDate+ req <-+ request+ statFile+ { requestHeaders = [("If-Modified-Since", fdate)]+ }+ assertStatus 304 req+ assertNoHeader "Cache-Control" req - it "works when an index.html is delivered" $ do- let settings = (defaultFileServerSettings "."){- ssAddTrailingSlash = True- }- inTempDirectory $ fileServerAppWithSettings settings $ do- liftIO $ touch "foo/index.html"- req <- request (setRawPathInfo defRequest "/foo")- assertStatus 302 req- assertHeader "Location" "/foo/" req+ context "302 redirect to add a trailing slash on directories if missing" $ do+ it "works at the root" $ fileServerApp $ do+ req <- request (setRawPathInfo defRequest "/a")+ assertStatus 302 req+ assertHeader "Location" "/a/" req - let urlMapApp = flip runSession $ \req send ->- case pathInfo req of- "subPath":rest ->- let req' = req { pathInfo = rest }- in (staticApp (defaultFileServerSettings "test")+ it "works when an index.html is delivered" $ do+ let settings =+ (defaultFileServerSettings ".") { ssAddTrailingSlash = True- }) req' send- _ -> send $ responseLBS status500 []- "urlMapApp: only works at subPath"- it "works with subpath at the root of the file server" $ urlMapApp $ do- req <- request (setRawPathInfo defRequest "/subPath")- assertStatus 302 req- assertHeader "Location" "/subPath/" req+ }+ inTempDirectory $ fileServerAppWithSettings settings $ do+ liftIO $ touch "foo/index.html"+ req <- request (setRawPathInfo defRequest "/foo")+ assertStatus 302 req+ assertHeader "Location" "/foo/" req - context "with defaultWebAppSettings" $ do- it "ssIndices works" $ do- withSystemTempDirectory "wai-app-static-test" $ \ dir -> do- writeFile (dir </> "index.html") "foo"- let testSettings = (defaultWebAppSettings dir) {- ssIndices = [unsafeToPiece "index.html"]- }- fileServerAppWithSettings testSettings $ do- resp <- request (setRawPathInfo defRequest "/")- assertStatus 200 resp- assertBody "foo" resp+ let urlMapApp = flip runSession $ \req send ->+ case pathInfo req of+ "subPath" : rest ->+ let req' = req{pathInfo = rest}+ in ( staticApp+ (defaultFileServerSettings "test")+ { ssAddTrailingSlash = True+ }+ )+ req'+ send+ _ ->+ send $+ responseLBS+ status500+ []+ "urlMapApp: only works at subPath"+ it "works with subpath at the root of the file server" $ urlMapApp $ do+ req <- request (setRawPathInfo defRequest "/subPath")+ assertStatus 302 req+ assertHeader "Location" "/subPath/" req - context "with defaultFileServerSettings" $ do- it "prefers ssIndices over ssListing" $ do- withSystemTempDirectory "wai-app-static-test" $ \ dir -> do- writeFile (dir </> "index.html") "foo"- let testSettings = defaultFileServerSettings dir- fileServerAppWithSettings testSettings $ do- resp <- request (setRawPathInfo defRequest "/")- assertStatus 200 resp- assertBody "foo" resp+ context "with defaultWebAppSettings" $ do+ it "ssIndices works" $ do+ withSystemTempDirectory "wai-app-static-test" $ \dir -> do+ writeFile (dir </> "index.html") "foo"+ let testSettings =+ (defaultWebAppSettings dir)+ { ssIndices = [unsafeToPiece "index.html"]+ }+ fileServerAppWithSettings testSettings $ do+ resp <- request (setRawPathInfo defRequest "/")+ assertStatus 200 resp+ assertBody "foo" resp++ context "with defaultFileServerSettings" $ do+ it "prefers ssIndices over ssListing" $ do+ withSystemTempDirectory "wai-app-static-test" $ \dir -> do+ writeFile (dir </> "index.html") "foo"+ let testSettings = defaultFileServerSettings dir+ fileServerAppWithSettings testSettings $ do+ resp <- request (setRawPathInfo defRequest "/")+ assertStatus 200 resp+ assertBody "foo" resp
tests.hs view
@@ -1,6 +1,6 @@-import WaiAppStaticTest (spec)-import WaiAppEmbeddedTest (embSpec) import Test.Hspec+import WaiAppEmbeddedTest (embSpec)+import WaiAppStaticTest (spec) main :: IO () main = hspec $ spec >> embSpec
wai-app-static.cabal view
@@ -1,5 +1,5 @@ name: wai-app-static-version: 3.1.8+version: 3.1.9 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -52,7 +52,7 @@ , filepath , wai-extra >= 3.0 && < 3.2 , optparse-applicative >= 0.7- , warp >= 3.0.11 && < 3.4+ , warp >= 3.0.11 && < 3.5 if flag(crypton) build-depends: crypton >= 0.6 , memory >= 0.7