wai-app-static 2.0.1.1 → 3.2.1
raw patch · 18 files changed
Files
- ChangeLog.md +108/−0
- Network/Wai/Application/Static.hs +226/−139
- README.md +5/−0
- Util.hs +28/−15
- WaiAppStatic/CmdLine.hs +116/−68
- WaiAppStatic/Listing.hs +118/−82
- WaiAppStatic/Storage/Embedded.hs +6/−6
- WaiAppStatic/Storage/Embedded/Runtime.hs +51/−37
- WaiAppStatic/Storage/Embedded/TH.hs +136/−119
- WaiAppStatic/Storage/Filesystem.hs +132/−86
- WaiAppStatic/Types.hs +76/−65
- app/warp-static.hs +0/−1
- test/EmbeddedTestEntries.hs +49/−35
- test/WaiAppEmbeddedTest.hs +39/−15
- test/WaiAppStaticTest.hs +175/−86
- test/tests.hs +6/−0
- tests.hs +0/−6
- wai-app-static.cabal +29/−34
+ ChangeLog.md view
@@ -0,0 +1,108 @@+# wai-app-static changelog++## 3.2.1++* Removing the dependency to "crypton".++## 3.2.0++* Using "ram" instead of "memory".++## 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)++## 3.1.7.5++* Removed dependency of `time`, `old-locale` and `network` [#902](https://github.com/yesodweb/wai/pull/902)++## 3.1.7.4++* Fix a bug when the cryptonite flag is disabled. [#874](https://github.com/yesodweb/wai/pull/874)++## 3.1.7.3++* Introduce a flag to avoid the cryptonite dependency. [#871](https://github.com/yesodweb/wai/pull/871)++## 3.1.7.2++* `optparse-applicative-0.16.0.0` support++## 3.1.7.1++* Update the test suite too++## 3.1.7++* Use 302 instead of 301 redirect, to avoid caching the presence of an index.html file++## 3.1.6.3++* The executable warp obeys `-h` option properly for host+now. Previously this used to invoke the help option. That can be+reached via `--help` as before.++## 3.1.6.2++* Drop dependency on `blaze-builder`++## 3.1.6.1++* Add `<>` import++## 3.1.6++* Make ssAddTrailingSlash work in combination with ssIndices [#569](https://github.com/yesodweb/wai/pull/569)+* Make ssIndices work with ssLookupFile and trailing slashes [#570](https://github.com/yesodweb/wai/pull/570)++## 3.1.5++* Switch to cryponite++## 3.1.4.1++* Support wai/warp 3.2++## 3.1.4++* Reinstate redirectToIndex++## 3.1.3++* Add 404 handler [#467](https://github.com/yesodweb/wai/pull/467)++## 3.1.2++* Honor ssIndices when used with defaultWebAppSettings [#460](https://github.com/yesodweb/wai/pull/460)++## 3.1.1++* Make adding a trailing slash optional [#327](https://github.com/yesodweb/wai/issues/327) [yesod#988](https://github.com/yesodweb/yesod/issues/988)++## 3.1.0++* Drop system-filepath++## 3.0.1.1++* Fix root links++## 3.0.1++* Better HEAD support [#354](https://github.com/yesodweb/wai/issues/354)++## 3.0.0.6++Fix trailing slashes for `UrlMap` and other non-root setups [#325](https://github.com/yesodweb/wai/issues/325)++## 3.0.0.4++Add missing trailing slashes [#312](https://github.com/yesodweb/wai/issues/312)++## 3.0.0.3++Support for time 1.5
Network/Wai/Application/Static.hs view
@@ -1,143 +1,198 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell, CPP #-}+{-# 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- ) 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 Blaze.ByteString.Builder (toByteString)+import Data.ByteString.Builder (toLazyByteString) -import Data.FileEmbed (embedFile)+import Data.FileEmbed (embedFile, makeRelativeToProject) import Data.Text (Text) import qualified Data.Text as T+import qualified Data.Text.Encoding as TE -import Data.Either (rights)-import Network.HTTP.Date (parseHTTPDate, epochTimeToHTTPDate, formatHTTPDate)-import Data.Monoid (First (First, getFirst), mconcat)+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 ss@StaticSettings {..} pieces req folder@Folder {..} =- -- first check if there is an index file in this 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- -- start the checking process over, with a new set- else checkPieces ss pieces' req- Nothing ->- case ssListing of- Just listing -> do- -- directory listings turned on, display it- builder <- listing pieces folder- return $ WaiResponse $ W.responseBuilder H.status200+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"- where- setLast :: Pieces -> Piece -> Pieces- setLast [] x = [x]- setLast [t] x- | fromPiece t == "" = [x]- setLast (a:b) x = a : setLast b x+ ]+ builder+ Nothing ->+ return $+ WaiResponse $+ W.responseLBS+ H.status403+ [ ("Content-Type", "text/plain")+ ]+ "Directory listings disabled" - findIndex :: [File] -> Piece -> First Piece- findIndex files index- | index `elem` map fileName files = First $ Just index- | otherwise = First Nothing+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+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 <- ssLookupFile pieces+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- LRNotFound -> return NotFound- LRFile file -> serveFile ss req file- LRFolder folder -> serveFolder ss pieces req folder+ 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+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. --- -- Note: It would be arguably better to next check- -- if-modified-since and return a 304 if that indicates a match as- -- well. However, the circumstances under which such a situation- -- could arise would be very anomolous, and should likely warrant a- -- new file being sent anyway.+ -- 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@@ -152,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 [] @@ -170,75 +223,109 @@ 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)+ 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")+ 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- | 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+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 -> return $ 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.Response+ response :: StaticResponse -> IO W.ResponseReceived response (FileResponse file ch) = do mimetype <- ssGetMimeType ss file- let filesize = fileGetSize file- let headers = ("Content-Type", mimetype)- : ("Content-Length", S8.pack $ show filesize)+ -- 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- return $ fileToResponse file H.status200 headers-+ sendResponse $ fileToResponse file H.status200 headers response NotModified =- return $ W.responseLBS H.status304 [] ""-+ sendResponse $ W.responseLBS H.status304 [] "" response (SendContent mt lbs) = do- -- TODO: set caching headers- return $ 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' $ 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)+ 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) - return $ W.responseLBS H.status301+ sendResponse $+ W.responseLBS+ H.status302 [ ("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+ ]+ "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
+ README.md view
@@ -0,0 +1,5 @@+## wai-app-static++WAI application for static serving++Also provides some helper functions and datatypes for use outside of WAI.
Util.hs view
@@ -1,27 +1,32 @@ {-# LANGUAGE OverloadedStrings #-}-module Util- ( relativeDirFromPieces- , defaultMkRedirect- , replace- , remove- ) where+{-# 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@@ -30,9 +35,17 @@ -- | 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 relDir = TE.encodeUtf8 (relativeDirFromPieces pieces)++dropLastIfNull :: [Piece] -> [Piece]+dropLastIfNull pieces = case pieces of+ [fromPiece -> ""] -> []+ (a : r) -> a : dropLastIfNull r+ [] -> []
WaiAppStatic/CmdLine.hs view
@@ -1,31 +1,43 @@-{-# LANGUAGE DeriveDataTypeable, 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, settingsHost, settingsPort- )-import Options.Applicative-import Text.Printf (printf)-import System.Directory (canonicalizePath)+import Control.Arrow (second, (***)) import Control.Monad (unless)-import Network.Wai.Middleware.Autohead-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 Control.Arrow ((***))-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 data Args = Args { docroot :: FilePath@@ -39,50 +51,66 @@ } #if MIN_VERSION_optparse_applicative(0, 10, 0)+option' :: Mod OptionFields Int -> Parser Int option' = option auto #else option' = option #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"]@@ -93,19 +121,39 @@ -- Since 2.0.1 runCommandLine :: (Args -> Middleware) -> IO () runCommandLine middleware = do- args@Args {..} <- execParser $ info (helper <*> 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)- . autohead- . (middleware args)- runSettings defaultSettings- { settingsPort = port- , settingsHost = fromString host- } $ middle $ staticApp (defaultFileServerSettings $ fromString docroot)- { ssIndices = if noindex then [] else mapMaybe (toPiece . pack) index- , ssGetMimeType = return . mimeByExt mimeMap defaultMimeType . fromPiece . fileName- }+ 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 defaultGzipSettings{gzipFiles = GzipCompress}+ . (if verbose then logStdout else id)+ . middleware clArgs+ runSettings+ ( 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 =+#if MIN_VERSION_optparse_applicative(0,16,0)+ abortOption (ShowHelpText Nothing) $+#else+ abortOption ShowHelpText $+#endif+ mconcat [long "help", help "Show this help text", hidden]
WaiAppStatic/Listing.hs view
@@ -1,17 +1,21 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}-module WaiAppStatic.Listing- ( defaultListing- ) where+{-# LANGUAGE ViewPatterns #-} -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)+#endif import Data.List (sortBy) import Util @@ -19,50 +23,65 @@ -- | Provides a default directory listing, suitable for most apps. ----- Code below taken from Happstack: <http://patch-tag.com/r/mae/happstack/snapshot/current/content/pretty/happstack-server/src/Happstack/Server/FileServe/BuildingBlocks.hs>+-- Code below taken from Happstack: <https://github.com/Happstack/happstack-server/blob/87e6c01a65c687d06c61345430a112fc9a444a95/src/Happstack/Server/FileServe/BuildingBlocks.hs> defaultListing :: Listing defaultListing pieces (Folder contents) = do 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- H.h1 $ showFolder $ filter (not . T.null . fromPiece) pieces- renderDirectoryContentsTable 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"]+ image x = T.unpack $ T.concat [relativeDirFromPieces pieces, ".hidden/", x, ".png"] folderSrc = image "folder" haskellSrc = image "haskell" showName "" = "root" showName x = x - showFolder :: Pieces -> H.Html- showFolder [] = "/"- showFolder [x] = H.toHtml $ showName $ fromPiece x- showFolder (x:xs) = do- let href = concat $ replicate (length xs) "../" :: String+ -- Add a link to the root of the tree+ showFolder' :: Bool -> Pieces -> H.Html+ showFolder' hasTrailingSlash pieces' = showFolder hasTrailingSlash (unsafeToPiece "root" : pieces')++ showFolder :: Bool -> Pieces -> H.Html+ showFolder _ [] = "/" -- won't happen+ showFolder _ [x] = H.toHtml $ showName $ fromPiece x+ showFolder hasTrailingSlash (x : xs) = do+ let len = length xs - (if hasTrailingSlash then 0 else 1)+ href+ | len == 0 = "."+ | otherwise = concat $ replicate len "../" :: String H.a ! A.href (H.toValue href) $ H.toHtml $ showName $ fromPiece x " / " :: H.Html- showFolder xs+ showFolder hasTrailingSlash xs -- | a function to generate an HTML table showing the contents of a directory on the disk --@@ -72,55 +91,72 @@ -- a new page template to wrap around this HTML. -- -- see also: 'getMetaData', 'renderDirectoryContents'-renderDirectoryContentsTable :: String- -> String- -> [Either FolderName File]- -> H.Html-renderDirectoryContentsTable 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)+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) - 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 = either id fileName md- let isFile = either (const False) (const True) md- H.td (H.a ! A.href (H.toValue $ fromPiece name `T.append` if isFile then "" else "/") $ 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,31 +1,38 @@+{-# 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-import Blaze.ByteString.Builder (fromByteString)-import qualified Network.Wai as W-import qualified Data.Map as Map+import qualified Data.ByteString as S+import Data.ByteString.Builder (byteString) 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.Byteable (toBytes)-import qualified Data.ByteString.Base64 as B64-import WaiAppStatic.Storage.Filesystem (defaultFileServerSettings)+import Data.ByteArray.Encoding+#else+import Crypto.Hash.MD5 (hash)+import Data.ByteString.Base64 (encode)+#endif 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 @@ -35,10 +42,10 @@ embeddedLookup root pieces = return $ elookup pieces root where- elookup :: Pieces -> Embedded -> LookupResult- elookup [] x = LRFolder $ Folder $ map toEntry $ Map.toList x+ 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) ->@@ -49,19 +56,21 @@ toEntry :: (Piece, EmbeddedEntry) -> Either FolderName File toEntry (name, EEFolder{}) = Left name-toEntry (name, EEFile bs) = Right File- { fileGetSize = S.length bs- , fileToResponse = \s h -> W.responseBuilder s h $ fromByteString 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 = go texts where- texts = map (\(x, y) -> (filter (not . T.null . fromPiece) $ toPieces' x, y)) fps+ texts = fmap (\(x, y) -> (filter (not . T.null . fromPiece) $ toPieces' x, y)) fps toPieces' "" = [] toPieces' x = -- See https://github.com/yesodweb/yesod/issues/626@@ -86,13 +95,18 @@ go' x = EEFolder $ go $ filter (\y -> not $ null $ fst y) x bsToFile :: Piece -> ByteString -> File-bsToFile name bs = File- { fileGetSize = S.length bs- , fileToResponse = \s h -> W.responseBuilder s h $ fromByteString 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-runHash = B64.encode . toBytes . (hash :: S.ByteString -> Digest MD5)+#ifdef MIN_VERSION_crypton+runHash = convertToBase Base64 . (hash :: S.ByteString -> Digest MD5)+#else+runHash = encode . hash+#endif
WaiAppStatic/Storage/Embedded/TH.hs view
@@ -1,23 +1,27 @@-{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings, MagicHash #-}-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 Blaze.ByteString.Builder.ByteString (insertByteString) import Codec.Compression.GZip (compress)-import Control.Applicative+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@@ -34,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@@ -103,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' $ insertByteString $ 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)@@ -198,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"@@ -217,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@@ -242,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,101 +1,140 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}+{-# 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 Prelude hiding (FilePath)-import Filesystem.Path.CurrentOS (FilePath, (</>))-import qualified Filesystem.Path.CurrentOS as F-import qualified Filesystem as F-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 qualified Crypto.Hash.Conduit (hashFile)-import Data.Byteable (toBytes)-import Crypto.Hash (MD5, Digest)-import qualified Data.ByteString.Base64 as B64+import WaiAppStatic.Types+#ifdef MIN_VERSION_crypton+import Data.ByteArray.Encoding+import Crypto.Hash (hashlazy, MD5, Digest)+#else+import Data.ByteString.Base64 (encode)+import Crypto.Hash.MD5 (hashlazy)+#endif+import qualified Data.ByteString.Lazy as BL (hGetContents)+import qualified Data.Text as T -- | Construct a new path from a root and some @Pieces@. pathFromPieces :: FilePath -> Pieces -> FilePath-pathFromPieces = foldl' (\fp p -> fp </> F.fromText (fromPiece p))+pathFromPieces = foldl' (\fp p -> fp </> T.unpack (fromPiece p)) -- | 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- }+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- }+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 $ F.encodeString fp+ 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 (F.encodeString 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@@ -116,9 +155,15 @@ -- | MD5 hash and base64-encode the file contents. Does not check if the file -- exists. hashFile :: FilePath -> IO ByteString-hashFile fp = do- h <- Crypto.Hash.Conduit.hashFile (F.encodeString fp)- return $ B64.encode $ toBytes (h :: Digest MD5)+hashFile fp = withBinaryFile fp ReadMode $ \h -> do+ f <- BL.hGetContents h+#ifdef MIN_VERSION_crypton+ let !hash = hashlazy f :: Digest MD5+ return $ convertToBase Base64 hash+#else+ let !hash = hashlazy f+ return . encode $ hash+#endif hashFileIfExists :: ETagLookup hashFileIfExists fp = do@@ -128,30 +173,31 @@ Right x -> Just x isVisible :: FilePath -> Bool-isVisible =- go . F.encodeString . F.filename- where- go ('.':_) = False- go "" = False- go _ = True+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 <- F.isFile fp+ fe <- doesFileExist fp if fe then fileHelperLR hashFunc fp lastPiece else do- de <- F.isDirectory fp+ de <- doesDirectoryExist fp if de then do- entries' <- fmap (filter isVisible) $ F.listDirectory fp- entries <- forM entries' $ \fp' -> do- let name = unsafeToPiece $ either id id $ F.toText $ F.filename fp'- de' <- F.isDirectory fp'+ entries' <- fmap (filter isVisible) $ getDirectoryContents fp+ entries <- forM entries' $ \fpRel' -> do+ let name = unsafeToPiece $ T.pack fpRel'+ fp' = fp </> fpRel'+ de' <- doesDirectoryExist fp' if de' then return $ Just $ Left name else do
WaiAppStatic/Types.hs view
@@ -1,32 +1,34 @@-{-# LANGUAGE OverloadedStrings #-}-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 Blaze.ByteString.Builder (Builder)-import Network.Mime (MimeType) -- | An individual component of a path, or of a filepath. --@@ -36,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@@ -60,12 +62,22 @@ toPieces = mapM toPiece -- | Request coming from a user. Corresponds to @pathInfo@.+--+-- The root path is the empty list. 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+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@@ -78,26 +90,27 @@ -- | Information on an individual file. data File = File- { -- | Size of file in bytes- fileGetSize :: Int- -- | 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.@@ -108,37 +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+ -- ^ Prefer usage of etag caching to last-modified caching.+ , ssAddTrailingSlash :: Bool+ -- ^ 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 }
app/warp-static.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-} module Main (main) where import WaiAppStatic.CmdLine (runCommandLine)
test/EmbeddedTestEntries.hs view
@@ -1,45 +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 $ take i $ repeat c+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') |] )- ]+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)@@ -8,16 +10,15 @@ import Network.Wai.Test import Test.Hspec import WaiAppStatic.Storage.Embedded--embApp :: Application-embApp = staticApp $(mkSettings mkEntries)+import WaiAppStatic.Types defRequest :: Request defRequest = defaultRequest embSpec :: Spec embSpec = do- let embed = flip runSession embApp+ let embedSettings settings = flip runSession (staticApp settings)+ let embed = embedSettings $(mkSettings mkEntries) describe "embedded, compressed entry" $ do it "served correctly" $ embed $ do req <- request (setRawPathInfo defRequest "e1.txt")@@ -29,10 +30,33 @@ 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"]+ }+ embedSettings testSettings $ do+ 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"]+ }+ embedSettings testSettings $ do+ req <- request (setRawPathInfo defRequest "/foo/")+ assertStatus 200 req+ assertBody "index file in subdir" req+ describe "embedded, uncompressed entry" $ do it "too short" $ embed $ do req <- request (setRawPathInfo defRequest "e2.txt")@@ -51,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@@ -75,4 +100,3 @@ assertNoHeader "Content-Encoding" req assertNoHeader "ETag" req assertBody (body 1000 'W') req-
test/WaiAppStaticTest.hs view
@@ -1,20 +1,31 @@-{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+ module WaiAppStaticTest (spec) where import Network.Wai.Application.Static+import WaiAppStatic.Types -import Test.Hspec import qualified Data.ByteString.Char8 as S8+import Test.Hspec+import Test.Mockery.Directory+ -- import qualified Data.ByteString.Lazy.Char8 as L8++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)-} import Network.Wai import Network.Wai.Test +import Control.Monad (forM_) import Control.Monad.IO.Class (liftIO) import Network.Mime @@ -23,103 +34,181 @@ spec :: Spec spec = do- let webApp = flip runSession $ staticApp $ defaultWebAppSettings "test"- let fileServerApp = flip runSession $ staticApp $ defaultFileServerSettings "test"+ 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 etag = "1B2M2Y8AsgTpgAmY7PhCfg=="+ let file = "a/b"+ let statFile = setRawPathInfo defRequest file - 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"+ 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" - describe "webApp" $ do- it "403 for unsafe paths" $ webApp $- flip mapM_ ["..", "."] $ \path ->- assertStatus 403 =<<- request (setRawPathInfo defRequest path)+ describe "webApp" $ do+ it "403 for unsafe paths" $+ webApp $+ forM_ ["..", "."] $ \path ->+ assertStatus 403+ =<< request (setRawPathInfo defRequest path) - it "200 for hidden paths" $ webApp $- flip mapM_ [".hidden/folder.png", ".hidden/haskell.png"] $ \path ->- assertStatus 200 =<<- request (setRawPathInfo defRequest path)+ it "200 for hidden paths" $+ webApp $+ forM_ [".hidden/folder.png", ".hidden/haskell.png"] $ \path ->+ assertStatus 200+ =<< request (setRawPathInfo defRequest path) - it "404 for non-existant files" $ webApp $- assertStatus 404 =<<- request (setRawPathInfo defRequest "doesNotExist")+ it "404 for non-existent files" $+ webApp $+ assertStatus 404+ =<< request (setRawPathInfo defRequest "doesNotExist") - it "301 redirect when multiple slashes" $ webApp $ do- req <- request (setRawPathInfo defRequest "a//b/c")- assertStatus 301 req- assertHeader "Location" "../../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 - let absoluteApp = flip runSession $ staticApp $ (defaultWebAppSettings "test") {- ssMkRedirect = \_ u -> S8.append "http://www.example.com" u- }- it "301 redirect when multiple slashes" $ absoluteApp $- flip mapM_ ["/a//b/c", "a//b/c"] $ \path -> do- req <- request (setRawPathInfo defRequest path)- assertStatus 301 req- assertHeader "Location" "http://www.example.com/a/b/c" 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 - 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+ 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 "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 "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 "200 when invalid in-none-match sent" $ webApp $- flip mapM_ ["cached", ""] $ \badETag -> do- req <- request statFile { requestHeaders = [("If-None-Match", badETag)] }- 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 "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 "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 - describe "fileServerApp" $ do- let fileDate = do- stat <- liftIO $ getFileStatus $ "test/" ++ file- return $ formatHTTPDate . epochTimeToHTTPDate $ modificationTime stat+ describe "fileServerApp" $ do+ let fileDate = do+ stat <- liftIO $ getFileStatus $ "test/" ++ file+ return $ formatHTTPDate . epochTimeToHTTPDate $ modificationTime stat - 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 "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 "200 when invalid if-modified-since header" $ fileServerApp $ do- flip mapM_ ["123", ""] $ \badDate -> do- req <- request statFile {- requestHeaders = [("If-Modified-Since", badDate)]- }- assertStatus 200 req- fdate <- fileDate- assertHeader "Last-Modified" fdate 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 - 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 "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 + 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 "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++ 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 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
+ test/tests.hs view
@@ -0,0 +1,6 @@+import Test.Hspec+import WaiAppEmbeddedTest (embSpec)+import WaiAppStaticTest (spec)++main :: IO ()+main = hspec $ spec >> embSpec
− tests.hs
@@ -1,6 +0,0 @@-import WaiAppStaticTest (spec)-import WaiAppEmbeddedTest (embSpec)-import Test.Hspec--main :: IO ()-main = hspec $ spec >> embSpec
wai-app-static.cabal view
@@ -1,31 +1,32 @@ name: wai-app-static-version: 2.0.1.1+version: 3.2.1 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>-maintainer: Michael Snoyman <michael@snoyman.com>+maintainer: Michael Snoyman <michael@snoyman.com>, Greg Weber <greg@gregweber.info> synopsis: WAI application for static serving-description: Also provides some helper functions and datatypes for use outside of WAI.+description: API docs and the README are available at <http://www.stackage.org/package/wai-app-static>. category: Web, Yesod stability: Stable-cabal-version: >= 1.8+cabal-version: >= 1.10 build-type: Simple homepage: http://www.yesodweb.com/book/web-application-interface Extra-source-files: images/folder.png images/haskell.png- test/*.hs test/a/b- tests.hs+ README.md+ ChangeLog.md Flag print Description: print debug info Default: False library- build-depends: base >= 4 && < 5- , wai >= 2.0 && < 2.2- , bytestring >= 0.9.1.4+ default-language: Haskell2010+ build-depends: base >= 4.12 && < 5+ , wai >= 3.0 && < 3.3+ , bytestring >= 0.10.4 , http-types >= 0.7 , transformers >= 0.2.2 , unix-compat >= 0.2@@ -35,13 +36,6 @@ , old-locale >= 1.0.0.2 , file-embed >= 0.0.3.1 , text >= 0.7- , blaze-builder >= 0.2.1.4- , base64-bytestring >= 0.1- , byteable- , cryptohash >= 0.11- , cryptohash-conduit >= 0.1.0- , system-filepath >= 0.4- , system-fileio >= 0.3 , http-date , blaze-html >= 0.5 , blaze-markup >= 0.5.1@@ -50,9 +44,11 @@ , template-haskell >= 2.7 , zlib >= 0.5 , filepath- , wai-extra >= 2.0 && < 2.2+ , wai-extra >= 3.0 && < 3.2 , optparse-applicative >= 0.7- , warp >= 2.0 && < 2.2+ , warp >= 3.0.11 && < 3.5+ , base64-bytestring >= 0.1+ , cryptohash-md5 >= 0.11.101 exposed-modules: Network.Wai.Application.Static WaiAppStatic.Storage.Filesystem@@ -64,46 +60,45 @@ WaiAppStatic.Storage.Embedded.Runtime WaiAppStatic.Storage.Embedded.TH ghc-options: -Wall- extensions: CPP if flag(print) cpp-options: -DPRINT Executable warp+ default-language: Haskell2010 Main-is: warp-static.hs hs-source-dirs: app Build-depends: base >= 4 && < 5- , wai-app-static >= 2.0 && < 2.1- , directory >= 1.0- , containers >= 0.2- , bytestring >= 0.9.1.4- , text >= 0.7- , mime-types >= 0.1 && < 0.2+ , wai-app-static test-suite runtests+ default-language: Haskell2010 hs-source-dirs: test- main-is: ../tests.hs+ other-modules: EmbeddedTestEntries+ , WaiAppEmbeddedTest+ , WaiAppStaticTest+ main-is: tests.hs type: exitcode-stdio-1.0 build-depends: base >= 4 && < 5 , hspec >= 1.3 , unix-compat- , time- , old-locale , http-date- , wai-app-static >= 1.3- , wai-test+ , wai-app-static+ , wai-extra , wai , http-types- , network , bytestring , text , transformers , mime-types , zlib- -- , containers- ghc-options: -Wall+ , filepath+ , temporary+ , mockery+ ghc-options: -Wall source-repository head type: git- location: git://github.com/yesodweb/wai.git+ location: https://github.com/yesodweb/wai.git+ subdir: wai-app-static