diff --git a/Network/Wai/Application/Static.hs b/Network/Wai/Application/Static.hs --- a/Network/Wai/Application/Static.hs +++ b/Network/Wai/Application/Static.hs @@ -1,663 +1,235 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell, CPP #-} +{-# LANGUAGE RecordWildCards #-} -- | Static file serving for WAI. module Network.Wai.Application.Static ( -- * WAI application staticApp - -- ** Settings + -- ** Default Settings , defaultWebAppSettings - , webAppSettingsWithLookup + , webAppSettingsWithLookup , defaultFileServerSettings + , embeddedSettings + -- ** Settings , StaticSettings - , ssFolder + , ssLookupFile , ssMkRedirect , ssGetMimeType , ssListing , ssIndices , ssMaxAge , ssRedirectToIndex - -- * Generic, non-WAI code - -- ** Mime types - , MimeType - , defaultMimeType - -- ** Mime type by file extension - , Extension - , MimeMap - , takeExtensions - , defaultMimeTypes - , mimeTypeByExt - , defaultMimeTypeByExt - -- ** Finding files - , Pieces - , pathFromPieces - -- ** Directory listings - , Listing - , defaultListing - -- ** Lookup functions - , fileSystemLookup - , fileSystemLookupHash - , embeddedLookup - -- ** Embedded - , Embedded - , EmbeddedEntry (..) - , toEmbedded - -- ** Redirecting - , defaultMkRedirect - -- * Other data types - , File (..) - , FilePath (..) - , toFilePath - , fromFilePath - , MaxAge (..) - , ETagLookup ) where import Prelude hiding (FilePath) -import qualified Prelude import qualified Network.Wai as W import qualified Network.HTTP.Types as H -import Data.Map (Map) -import qualified Data.Map as Map import Data.ByteString (ByteString) -import System.Directory (doesFileExist, doesDirectoryExist, getDirectoryContents) import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Data.ByteString.Lazy.Char8 () -import System.PosixCompat.Files (fileSize, getFileStatus, modificationTime) -import System.Posix.Types (EpochTime) import Control.Monad.IO.Class (liftIO) -import qualified Crypto.Hash.MD5 as MD5 -import Control.Monad (forM) -import Control.Exception (SomeException, try) -import Text.Blaze ((!)) -import qualified Text.Blaze.Html5 as H -#if MIN_VERSION_blaze_html(0,5,0) -import qualified Text.Blaze.Html.Renderer.Utf8 as HU -#else -import qualified Text.Blaze.Renderer.Utf8 as HU -#endif -import qualified Text.Blaze.Html5.Attributes as A - -import Blaze.ByteString.Builder (toByteString, fromByteString) - -import Data.Time -import Data.Time.Clock.POSIX -import System.Locale (defaultTimeLocale) +import Blaze.ByteString.Builder (toByteString) import Data.FileEmbed (embedFile) import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Encoding.Error as TEE -import Control.Arrow ((&&&), second) -import Data.List (groupBy, sortBy, find, foldl') -import Data.Function (on) -import Data.Ord (comparing) -import qualified Data.ByteString.Base64 as B64 import Data.Either (rights) -import Data.Maybe (isJust, fromJust, mapMaybe) import Network.HTTP.Date (parseHTTPDate, epochTimeToHTTPDate, formatHTTPDate) -import Data.String (IsString (..)) - -newtype FilePath = FilePath { unFilePath :: Text } - deriving (Ord, Eq, Show) -instance IsString FilePath where - fromString = toFilePath - -() :: FilePath -> FilePath -> FilePath -(FilePath a) (FilePath b) = FilePath $ T.concat [a, "/", b] - --- | A list of all possible extensions, starting from the largest. -takeExtensions :: FilePath -> [FilePath] -takeExtensions (FilePath s) = - case T.breakOn (".") s of - (_, "") -> [] - (_, x) -> FilePath (T.drop 1 x) : takeExtensions (FilePath $ T.drop 1 x) - -type MimeType = ByteString -type Extension = FilePath -type MimeMap = Map Extension MimeType - -defaultMimeType :: MimeType -defaultMimeType = "application/octet-stream" - --- taken from snap-core Snap.Util.FileServer -defaultMimeTypes :: MimeMap -defaultMimeTypes = Map.fromList [ - ( "apk" , "application/vnd.android.package-archive" ), - ( "asc" , "text/plain" ), - ( "asf" , "video/x-ms-asf" ), - ( "asx" , "video/x-ms-asf" ), - ( "avi" , "video/x-msvideo" ), - ( "bz2" , "application/x-bzip" ), - ( "c" , "text/plain" ), - ( "class" , "application/octet-stream" ), - ( "conf" , "text/plain" ), - ( "cpp" , "text/plain" ), - ( "css" , "text/css" ), - ( "cxx" , "text/plain" ), - ( "dtd" , "text/xml" ), - ( "dvi" , "application/x-dvi" ), - ( "epub" , "application/epub+zip" ), - ( "gif" , "image/gif" ), - ( "gz" , "application/x-gzip" ), - ( "hs" , "text/plain" ), - ( "htm" , "text/html" ), - ( "html" , "text/html" ), - ( "ico" , "image/vnd.microsoft.icon" ), - ( "jar" , "application/x-java-archive" ), - ( "jpeg" , "image/jpeg" ), - ( "jpg" , "image/jpeg" ), - ( "js" , "text/javascript" ), - ( "json" , "application/json" ), - ( "log" , "text/plain" ), - ( "manifest", "text/cache-manifest" ), - ( "m3u" , "audio/x-mpegurl" ), - ( "mov" , "video/quicktime" ), - ( "mp3" , "audio/mpeg" ), - ( "mpeg" , "video/mpeg" ), - ( "mpg" , "video/mpeg" ), - ( "ogg" , "application/ogg" ), - ( "pac" , "application/x-ns-proxy-autoconfig" ), - ( "pdf" , "application/pdf" ), - ( "png" , "image/png" ), - ( "bmp" , "image/bmp" ), - ( "ps" , "application/postscript" ), - ( "qt" , "video/quicktime" ), - ( "sig" , "application/pgp-signature" ), - ( "spl" , "application/futuresplash" ), - ( "svg" , "image/svg+xml" ), - ( "swf" , "application/x-shockwave-flash" ), - ( "tar" , "application/x-tar" ), - ( "tar.bz2" , "application/x-bzip-compressed-tar" ), - ( "tar.gz" , "application/x-tgz" ), - ( "tbz" , "application/x-bzip-compressed-tar" ), - ( "text" , "text/plain" ), - ( "tgz" , "application/x-tgz" ), - ( "torrent" , "application/x-bittorrent" ), - ( "ttf" , "application/x-font-truetype" ), - ( "txt" , "text/plain" ), - ( "wav" , "audio/x-wav" ), - ( "wax" , "audio/x-ms-wax" ), - ( "wma" , "audio/x-ms-wma" ), - ( "wmv" , "video/x-ms-wmv" ), - ( "xbm" , "image/x-xbitmap" ), - ( "xhtml" , "application/xhtml+xml" ), - ( "xml" , "text/xml" ), - ( "xpm" , "image/x-xpixmap" ), - ( "xwd" , "image/x-xwindowdump" ), - ( "zip" , "application/zip" )] - --- similar to Safe package -headDef :: a -> [a] -> a -headDef _ (x:_) = x -headDef def [] = def - --- similar to Safe package -initSafe :: [a] -> [a] -initSafe [] = [] -initSafe xs = init xs - -mimeTypeByExt :: MimeMap - -> MimeType -- ^ default mime type - -> FilePath - -> MimeType -mimeTypeByExt mm def = - headDef def . mapMaybe (flip Map.lookup mm) . takeExtensions - -defaultMimeTypeByExt :: FilePath -> MimeType -defaultMimeTypeByExt = mimeTypeByExt defaultMimeTypes defaultMimeType - -filterButLast :: (a -> Bool) -> [a] -> [a] -filterButLast _ [] = [] -filterButLast _ [x] = [x] -filterButLast f (x:xs) - | f x = x : filterButLast f xs - | otherwise = filterButLast f xs - - -unsafePiece :: FilePath -> Bool -unsafePiece (FilePath s) - | T.null s = False - | T.head s == '.' = True - | otherwise = T.any (== '/') s - -nullFilePath :: FilePath -> Bool -nullFilePath = T.null . unFilePath - -{- -stripTrailingSlash :: FilePath -> FilePath -stripTrailingSlash fp@(FilePath t) - | T.null t || T.last t /= '/' = fp - | otherwise = FilePath $ T.init t - -} - -type Pieces = [FilePath] - -relativeDirFromPieces :: Pieces -> T.Text -relativeDirFromPieces pieces = T.concat $ map (const "../") (drop 1 pieces) -- last piece is not a dir - -pathFromPieces :: FilePath -> Pieces -> FilePath -pathFromPieces = foldl' () +import Data.Monoid (First (First, getFirst), mconcat) -checkSpecialDirListing :: Pieces -> Maybe CheckPieces -checkSpecialDirListing [".hidden", "folder.png"] = - Just $ SendContent "image/png" $ L.fromChunks [$(embedFile "images/folder.png")] -checkSpecialDirListing [".hidden", "haskell.png"] = - Just $ SendContent "image/png" $ L.fromChunks [$(embedFile "images/haskell.png")] -checkSpecialDirListing _ = Nothing +import WaiAppStatic.Types +import Util +import WaiAppStatic.Storage.Filesystem +import WaiAppStatic.Storage.Embedded +import Network.Mime (MimeType) -data CheckPieces = +data StaticResponse = -- | Just the etag hash or Nothing for no etag hash Redirect Pieces (Maybe ByteString) - | Forbidden | NotFound | FileResponse File H.ResponseHeaders | NotModified - | DirectoryResponse Folder -- TODO: add file size | SendContent MimeType L.ByteString - -checkPieces :: (Pieces -> IO FileLookup) -- ^ file lookup function - -> [FilePath] -- ^ List of default index files. Cannot contain slashes. - -> Pieces -- ^ parsed request - -> W.Request - -> MaxAge - -> Bool -- ^ use hash? - -> Bool -- ^ Redirect to Index? - -> IO CheckPieces -checkPieces fileLookup indices pieces req maxAge useHash redirectToIndex - | any unsafePiece pieces = return Forbidden - | any nullFilePath $ initSafe pieces = - return $ Redirect (filterButLast (not . nullFilePath) pieces) Nothing - | otherwise = do - let (isFile, isFolder) = - if null pieces then (True, True) - else if nullFilePath (last pieces) then (False, True) - else (True, False) - - fl <- fileLookup pieces - case (fl, isFile) of - (Nothing, _) -> return NotFound - (Just (Right file), True) -> handleCache file - (Just Right{}, False) -> return $ Redirect (init pieces) Nothing - (Just (Left folder@(Folder _ contents)), _) -> do - case checkIndices $ map fileName $ rights contents of - Just index -> - if redirectToIndex then - return $ Redirect (setLast pieces index) Nothing - else - checkPieces fileLookup indices (setLast pieces index) req maxAge useHash redirectToIndex - Nothing -> - if isFolder - then return $ DirectoryResponse folder - else return $ Redirect (pieces ++ [""]) Nothing - where - headers = W.requestHeaders req - queryString = W.queryString req - - -- HTTP caching has a cache control header that you can set an expire time for a resource. - -- Max-Age is easiest because it is a simple number - -- a cache-control asset will only be downloaded once (if the browser maintains its cache) - -- and the server will never be contacted for the resource again (until it expires) - -- - -- A second caching mechanism is ETag and last-modified - -- this form of caching is not as good as the static- the browser can avoid downloading the file, but it always need to send a request with the etag value or the last-modified value to the server to see if its copy is up to date - -- - -- We should set a cache control and one of ETag or last-modifed whenever possible - -- - -- In a Yesod web application we can append an etag parameter to static assets. - -- This signals that both a max-age and ETag header should be set - -- if there is no etag parameter - -- * don't set the max-age - -- * set ETag or last-modified - -- * ETag must be calculated ahead of time. - -- * last-modified is just the file mtime. - handleCache file = - if not useHash then lastModifiedCache file - else do - let etagParam = lookup "etag" queryString - - case etagParam of - Nothing -> do -- no query parameter. Set appropriate ETag headers - mHash <- fileGetHash file - case mHash of - Nothing -> lastModifiedCache file - Just hash -> - case lookup "if-none-match" headers of - Just lastHash -> - if hash == lastHash - then return NotModified - else return $ FileResponse file $ [("ETag", hash)] - Nothing -> return $ FileResponse file $ [("ETag", hash)] - - Just mEtag -> do - mHash <- fileGetHash file - case mHash of - -- a file used to have an etag parameter, but no longer does - Nothing -> return $ Redirect pieces Nothing - Just hash -> - if isJust mEtag && hash == fromJust mEtag - then return $ FileResponse file $ ("ETag", hash):cacheControl - else return $ Redirect pieces (Just hash) + | WaiResponse W.Response +safeInit :: [a] -> [a] +safeInit [] = [] +safeInit xs = init xs - lastModifiedCache file = - case (lookup "if-modified-since" headers >>= parseHTTPDate, fileGetModified file) of - (mLastSent, Just modified) -> do - let mdate = epochTimeToHTTPDate modified in - case mLastSent of - Just lastSent -> - if lastSent == mdate - then return NotModified - else return $ FileResponse file $ [("last-modified", formatHTTPDate mdate)] - Nothing -> return $ FileResponse file $ [("last-modified", formatHTTPDate mdate)] - _ -> return $ FileResponse file [] +filterButLast :: (a -> Bool) -> [a] -> [a] +filterButLast _ [] = [] +filterButLast _ [x] = [x] +filterButLast f (x:xs) + | f x = x : filterButLast f xs + | otherwise = filterButLast f xs - setLast :: Pieces -> FilePath -> Pieces +-- | 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 + [ ("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 [""] x = [x] + setLast [t] x + | fromPiece t == "" = [x] setLast (a:b) x = a : setLast b x - checkIndices :: [FilePath] -> Maybe FilePath - checkIndices contents = find (flip elem indices) contents - - cacheControl = headerCacheControl $ headerExpires [] - where - ccInt = - case maxAge of - NoMaxAge -> Nothing - MaxAgeSeconds i -> Just i - MaxAgeForever -> Just oneYear - oneYear :: Int - oneYear = 60 * 60 * 24 * 365 - - headerCacheControl = - case ccInt of - Nothing -> id - Just i -> (:) ("Cache-Control", S8.append "public, max-age=" $ S8.pack $ show i) - headerExpires = - case maxAge of - NoMaxAge -> id - MaxAgeSeconds _ -> id -- FIXME - MaxAgeForever -> (:) ("Expires", "Thu, 31 Dec 2037 23:55:55 GMT") - -type Listing = (Pieces -> Folder -> IO L.ByteString) - - -type FileLookup = Maybe (Either Folder File) - -data Folder = Folder - { folderName :: FilePath - , folderContents :: [Either Folder File] - } - -data File = File - { fileGetSize :: Int - , fileToResponse :: H.Status -> H.ResponseHeaders -> W.Response - , fileName :: FilePath - , fileGetHash :: IO (Maybe ByteString) - , fileGetModified :: Maybe EpochTime - } - -data StaticSettings = StaticSettings - { ssFolder :: Pieces -> IO FileLookup -- TODO: not a folder, so rename - , ssMkRedirect :: Pieces -> ByteString -> ByteString - , ssGetMimeType :: File -> IO MimeType - , ssListing :: Maybe Listing - , ssIndices :: [T.Text] -- index.html - , ssRedirectToIndex :: Bool - , ssMaxAge :: MaxAge - , ssUseHash :: Bool - } - -data MaxAge = NoMaxAge | MaxAgeSeconds Int | MaxAgeForever - -defaultMkRedirect :: Pieces -> ByteString -> S8.ByteString -defaultMkRedirect pieces 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) - -webAppSettingsWithLookup :: FilePath -> ETagLookup -> StaticSettings -webAppSettingsWithLookup dir etagLookup = - defaultWebAppSettings { ssFolder = webAppLookup etagLookup dir} - + findIndex :: [File] -> Piece -> First Piece + findIndex files index + | index `elem` map fileName files = First $ Just index + | otherwise = First Nothing -defaultWebAppSettings :: StaticSettings -defaultWebAppSettings = StaticSettings - { ssFolder = webAppLookup hashFileIfExists "static" - , ssMkRedirect = defaultMkRedirect - , ssGetMimeType = return . defaultMimeTypeByExt . fileName - , ssMaxAge = MaxAgeForever - , ssListing = Nothing - , ssIndices = [] - , ssRedirectToIndex = False - , ssUseHash = True - } +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 -defaultFileServerSettings :: StaticSettings -defaultFileServerSettings = StaticSettings - { ssFolder = fileSystemLookup "static" - , ssMkRedirect = defaultMkRedirect - , ssGetMimeType = return . defaultMimeTypeByExt . fileName - , ssMaxAge = MaxAgeSeconds $ 60 * 60 - , ssListing = Just defaultListing - , ssIndices = ["index.html", "index.htm"] - , ssRedirectToIndex = False - , ssUseHash = False - } +checkPieces ss@StaticSettings {..} pieces req = do + res <- ssLookupFile pieces + case res of + LRNotFound -> return NotFound + LRFile file -> serveFile ss req file + LRFolder folder -> serveFolder ss pieces req folder -fileHelper :: ETagLookup - -> FilePath -> FilePath -> IO (Maybe File) -fileHelper hashFunc fp name = do - efs <- try $ getFileStatus $ fromFilePath fp - case efs of - Left (_ :: SomeException) -> return Nothing - Right fs -> return $ Just File - { fileGetSize = fromIntegral $ fileSize fs - , fileToResponse = \s h -> W.ResponseFile s h (fromFilePath fp) Nothing - , fileName = name - , fileGetHash = hashFunc fp - , fileGetModified = Just $ modificationTime fs - } +serveFile :: StaticSettings -> W.Request -> File -> IO StaticResponse +serveFile StaticSettings {..} req file + -- First check etag values, if turned on + | ssUseHash = do + mHash <- fileGetHash file + 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 -type ETagLookup = (FilePath -> IO (Maybe ByteString)) + -- 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. + (Just hash, _) -> respond [("ETag", hash)] -webAppLookup :: ETagLookup -> FilePath -> Pieces -> IO FileLookup -webAppLookup cachedLookupHash prefix pieces = do - mfile <- fileHelper cachedLookupHash fp (last pieces) - return $ fmap Right mfile + -- No hash value available, fall back to last modified support. + (Nothing, _) -> lastMod + -- etag turned off, so jump straight to last modified + | otherwise = lastMod where - fp = pathFromPieces prefix pieces - -defaultFileSystemHash :: ETagLookup -defaultFileSystemHash fp = fmap Just $ hashFile fp - --- FIXME replace lazy IO with enumerators --- FIXME let's use a dictionary to cache these values? -hashFile :: FilePath -> IO ByteString -hashFile fp = do - l <- L.readFile $ fromFilePath fp - return $ runHashL l - -hashFileIfExists :: ETagLookup -hashFileIfExists fp = do - fe <- doesFileExist $ fromFilePath fp - if fe - then return Nothing - else defaultFileSystemHash fp - -fileSystemLookup :: FilePath -> Pieces -> IO FileLookup -fileSystemLookup = fileSystemLookupHash defaultFileSystemHash - -fileSystemLookupHash :: ETagLookup - -> FilePath -> Pieces -> IO FileLookup -fileSystemLookupHash hashFunc prefix pieces = do - let fp = pathFromPieces prefix pieces - fe <- doesFileExist $ fromFilePath fp - if fe - then (fmap . fmap) Right $ fileHelper hashFunc fp $ last pieces - else do - de <- doesDirectoryExist $ fromFilePath fp - if de - then do - let isVisible ('.':_) = False - isVisible "" = False - isVisible _ = True - entries' <- fmap (filter isVisible) $ getDirectoryContents (fromFilePath fp) - entries <- forM entries' $ \nameRaw -> do - let name = toFilePath nameRaw - let fp' = fp name - mfile' <- fileHelper hashFunc fp' name - case mfile' of - Nothing -> return $ Left $ Folder name [] - Just file' -> return $ Right file' - return $ Just $ Left $ Folder (error "Network.Wai.Application.Static.fileSystemLookup") entries - else return Nothing - -type Embedded = Map.Map FilePath EmbeddedEntry + mLastSent = lookup "if-modified-since" (W.requestHeaders req) >>= parseHTTPDate + lastMod = + case (fmap epochTimeToHTTPDate $ fileGetModified file, mLastSent) of + -- File modified time is equal to the if-modified-since header, + -- return a 304. + -- + -- Question: should the comparison be, date <= lastSent? + (Just mdate, Just lastSent) + | mdate == lastSent -> return NotModified -data EmbeddedEntry = EEFile S8.ByteString | EEFolder Embedded + -- Did not match, but we have a new last-modified header + (Just mdate, _) -> respond [("last-modified", formatHTTPDate mdate)] -embeddedLookup :: Embedded -> Pieces -> IO FileLookup -embeddedLookup root pieces = - return $ elookup "" pieces root - where - elookup :: FilePath -> [FilePath] -> Embedded -> FileLookup - elookup p [] x = Just $ Left $ Folder p $ map toEntry $ Map.toList x - elookup p [""] x = elookup p [] x - elookup _ (p:ps) x = - case Map.lookup p x of - Nothing -> Nothing - Just (EEFile f) -> - case ps of - [] -> Just $ Right $ bsToFile p f - _ -> Nothing - Just (EEFolder y) -> elookup p ps y + -- No modification time available + (Nothing, _) -> respond [] -toEntry :: (FilePath, EmbeddedEntry) -> Either Folder File -toEntry (name, EEFolder{}) = Left $ Folder name [] -toEntry (name, EEFile bs) = Right $ File - { fileGetSize = S8.length bs - , fileToResponse = \s h -> W.ResponseBuilder s h $ fromByteString bs - , fileName = name - , fileGetHash = return $ Just $ runHash bs - , fileGetModified = Nothing - } + -- Send a file response with the additional weak headers provided. + respond headers = return $ FileResponse file $ cacheControl ssMaxAge headers -toEmbedded :: [(Prelude.FilePath, S8.ByteString)] -> Embedded -toEmbedded fps = - go texts +-- | Return a difference list of headers based on the specified MaxAge. +-- +-- This function will return both Cache-Control and Expires headers, as +-- relevant. +cacheControl :: MaxAge -> (H.ResponseHeaders -> H.ResponseHeaders) +cacheControl maxage = + headerCacheControl . headerExpires where - texts = map (\(x, y) -> (filter (not . T.null . unFilePath) $ toPieces x, y)) fps - toPieces "" = [] - toPieces x = - let (y, z) = break (== '/') x - in toFilePath y : toPieces (drop 1 z) - go :: [([FilePath], S8.ByteString)] -> Embedded - go orig = - Map.fromList $ map (second go') hoisted - where - next = map (\(x, y) -> (head x, (tail x, y))) orig - grouped :: [[(FilePath, ([FilePath], S8.ByteString))]] - grouped = groupBy ((==) `on` fst) $ sortBy (comparing fst) next - hoisted :: [(FilePath, [([FilePath], S8.ByteString)])] - hoisted = map (fst . head &&& map snd) grouped - go' :: [([FilePath], S8.ByteString)] -> EmbeddedEntry - go' [([], content)] = EEFile content - go' x = EEFolder $ go $ filter (\y -> not $ null $ fst y) x - -bsToFile :: FilePath -> S8.ByteString -> File -bsToFile name bs = File - { fileGetSize = S8.length bs - , fileToResponse = \s h -> W.ResponseBuilder s h $ fromByteString bs - , fileName = name - , fileGetHash = return $ Just $ runHash bs - , fileGetModified = Nothing - } - -runHash :: S8.ByteString -> S8.ByteString -runHash = B64.encode . MD5.hash + ccInt = + case maxage of + NoMaxAge -> Nothing + MaxAgeSeconds i -> Just i + MaxAgeForever -> Just oneYear + oneYear :: Int + oneYear = 60 * 60 * 24 * 365 -runHashL :: L.ByteString -> ByteString -runHashL = B64.encode . MD5.hashlazy + headerCacheControl = + case ccInt of + Nothing -> id + Just i -> (:) ("Cache-Control", S8.append "public, max-age=" $ S8.pack $ show i) + headerExpires = + case maxage of + NoMaxAge -> id + MaxAgeSeconds _ -> id -- FIXME + MaxAgeForever -> (:) ("Expires", "Thu, 31 Dec 2037 23:55:55 GMT") +-- | Turn a @StaticSettings@ into a WAI application. staticApp :: StaticSettings -> W.Application -staticApp set req = staticAppPieces set (map FilePath $ W.pathInfo req) req - -status304, statusNotModified :: H.Status -status304 = H.Status 304 "Not Modified" -statusNotModified = status304 - --- 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 - -remove :: Eq a => a -> [(a, b)] -> [(a, b)] -remove _ [] = [] -remove k (x:xs) | fst x == k = xs - | otherwise = x:remove k xs - +staticApp set req = staticAppPieces set (W.pathInfo req) req -staticAppPieces :: StaticSettings -> Pieces -> W.Application +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 ss pieces req = liftIO $ do - let indices = ssIndices ss - case checkSpecialDirListing pieces of - Just res -> response res - Nothing -> response =<< checkPieces (ssFolder ss) - (map FilePath indices) - pieces - req - (ssMaxAge ss) - (ssUseHash ss) - (ssRedirectToIndex ss) +staticAppPieces _ [".hidden", "folder.png"] _ = return $ W.responseLBS H.status200 [("Content-Type", "image/png")] $ L.fromChunks [$(embedFile "images/folder.png")] +staticAppPieces _ [".hidden", "haskell.png"] _ = return $ W.responseLBS H.status200 [("Content-Type", "image/png")] $ L.fromChunks [$(embedFile "images/haskell.png")] +staticAppPieces ss rawPieces req = liftIO $ do + case toPieces rawPieces of + Just pieces -> checkPieces ss pieces req >>= response + Nothing -> return $ W.responseLBS H.status403 + [ ("Content-Type", "text/plain") + ] "Forbidden" where - response cp = case cp of - FileResponse file ch -> do - mimetype <- ssGetMimeType ss file - let filesize = fileGetSize file - let headers = ("Content-Type", mimetype) - : ("Content-Length", S8.pack $ show filesize) - : ch - return $ fileToResponse file H.status200 headers - NotModified -> - return $ W.responseLBS statusNotModified + response :: StaticResponse -> IO W.Response + response (FileResponse file ch) = do + mimetype <- ssGetMimeType ss file + let filesize = fileGetSize file + let headers = ("Content-Type", mimetype) + : ("Content-Length", S8.pack $ show filesize) + : ch + return $ fileToResponse file H.status200 headers + + response NotModified = + return $ W.responseLBS H.status304 [ ("Content-Type", "text/plain") ] "Not Modified" - DirectoryResponse fp -> do - case ssListing ss of - (Just f) -> do - lbs <- f pieces fp - return $ W.responseLBS H.status200 - [ ("Content-Type", "text/html; charset=utf-8") - ] lbs - Nothing -> return $ W.responseLBS H.status403 - [ ("Content-Type", "text/plain") - ] "Directory listings disabled" - SendContent mt lbs -> do + + response (SendContent mt lbs) = do -- TODO: set caching headers return $ W.responseLBS H.status200 [ ("Content-Type", mt) -- TODO: set Content-Length ] lbs - Redirect pieces' mHash -> do - let loc = (ssMkRedirect ss) pieces' $ toByteString (H.encodePathSegments $ map unFilePath pieces') + 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) @@ -666,134 +238,9 @@ [ ("Content-Type", "text/plain") , ("Location", S8.append loc $ H.renderQuery True qString) ] "Redirect" - Forbidden -> return $ W.responseLBS H.status403 - [ ("Content-Type", "text/plain") - ] "Forbidden" - NotFound -> return $ W.responseLBS H.status404 + + response NotFound = return $ W.responseLBS H.status404 [ ("Content-Type", "text/plain") ] "File not found" --- | System.Directory functions are a lie: --- they claim to be using String, but it's really just a raw byte sequence. --- We're assuming that non-Windows systems use UTF-8 encoding (there was --- a discussion regarding this, it wasn't an arbitrary decision). So we --- need to encode/decode the byte sequence to/from UTF8. That's the use --- case for fixPathName/unfixPathName. I'm starting to use John --- Millikin's system-filepath package for some stuff with work, and might --- consider migrating over to it for this in the future. -toFilePath :: Prelude.FilePath -> FilePath -#if defined(mingw32_HOST_OS) -toFilePath = FilePath . T.pack -#else -toFilePath = FilePath . TE.decodeUtf8With TEE.lenientDecode . S8.pack -#endif - -fromFilePath :: FilePath -> Prelude.FilePath -#if defined(mingw32_HOST_OS) -fromFilePath = T.unpack . unFilePath -#else -fromFilePath = S8.unpack . TE.encodeUtf8 . unFilePath -#endif - --- Code below taken from Happstack: http://patch-tag.com/r/mae/happstack/snapshot/current/content/pretty/happstack-server/src/Happstack/Server/FileServe/BuildingBlocks.hs -defaultListing :: Listing -defaultListing pieces (Folder _ contents) = do - let isTop = null pieces || pieces == [""] - let fps'' :: [Either Folder File] - fps'' = (if isTop then id else (Left (Folder ".." []) :)) contents - return $ HU.renderHtml - $ H.html $ do - H.head $ do - let title = T.unpack $ T.intercalate "/" $ map unFilePath pieces - let title' = if 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 $ map unFilePath $ filter (not . nullFilePath) pieces - renderDirectoryContentsTable haskellSrc folderSrc fps'' - where - image x = T.unpack $ T.concat [(relativeDirFromPieces pieces), ".hidden/", x, ".png"] - folderSrc = image "folder" - haskellSrc = image "haskell" - showName "" = "root" - showName x = x - showFolder [] = "/" - showFolder [x] = H.toHtml $ showName x - showFolder (x:xs) = do - let href = concat $ replicate (length xs) "../" :: String - H.a ! A.href (H.toValue href) $ H.toHtml $ showName x - " / " :: H.Html - showFolder xs - --- | a function to generate an HTML table showing the contents of a directory on the disk --- --- This function generates most of the content of the --- 'renderDirectoryContents' page. If you want to style the page --- differently, or add google analytics code, etc, you can just create --- a new page template to wrap around this HTML. --- --- see also: 'getMetaData', 'renderDirectoryContents' -renderDirectoryContentsTable :: String - -> String - -> [Either Folder 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 Folder File -> Either Folder File -> Ordering - sortMD Left{} Right{} = LT - sortMD Right{} Left{} = GT - sortMD (Left a) (Left b) = compare (folderName a) (folderName b) - sortMD (Right a) (Right b) = compare (fileName a) (fileName b) - mkRow :: (Either Folder 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 folderName fileName md - let isFile = either (const False) (const True) md - H.td (H.a ! A.href (H.toValue $ unFilePath name `T.append` if isFile then "" else "/") $ H.toHtml $ unFilePath 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 - | x > 1024 = prettyShowM $ x `div` 1024 - | otherwise = addCommas "KB" 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 + response (WaiResponse r) = return r diff --git a/Util.hs b/Util.hs new file mode 100644 --- /dev/null +++ b/Util.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE OverloadedStrings #-} +module Util + ( relativeDirFromPieces + , defaultMkRedirect + , replace + , remove + ) where + +import WaiAppStatic.Types +import qualified Data.Text as T +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as S8 +import qualified Data.Text.Encoding as TE + +-- 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 + +remove :: Eq a => a -> [(a, b)] -> [(a, b)] +remove _ [] = [] +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 +relativeDirFromPieces pieces = T.concat $ map (const "../") (drop 1 pieces) -- last piece is not a dir + +-- | 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 /= '/' = + relDir `S8.append` newPath + | otherwise = relDir `S8.append` S8.tail newPath + where + relDir = TE.encodeUtf8 (relativeDirFromPieces pieces) diff --git a/WaiAppStatic/Listing.hs b/WaiAppStatic/Listing.hs new file mode 100644 --- /dev/null +++ b/WaiAppStatic/Listing.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +module WaiAppStatic.Listing + ( defaultListing + ) where + +import qualified Text.Blaze.Html5.Attributes as A +import qualified Text.Blaze.Html5 as H +import Text.Blaze ((!)) +import qualified Data.Text as T +import Data.Time +import Data.Time.Clock.POSIX +import WaiAppStatic.Types +import System.Locale (defaultTimeLocale) +import Data.List (sortBy) +import Util + +import qualified Text.Blaze.Html.Renderer.Utf8 as HU + +-- | Provides a default directory listing, suitable for most apps. +-- +-- Code below taken from Happstack: +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'' + where + 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 + H.a ! A.href (H.toValue href) $ H.toHtml $ showName $ fromPiece x + " / " :: H.Html + showFolder xs + +-- | a function to generate an HTML table showing the contents of a directory on the disk +-- +-- This function generates most of the content of the +-- 'renderDirectoryContents' page. If you want to style the page +-- differently, or add google analytics code, etc, you can just create +-- 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) + + 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 + | x > 1024 = prettyShowK $ x `div` 1024 + | otherwise = addCommas "B" x + prettyShowK x + | x > 1024 = prettyShowM $ x `div` 1024 + | otherwise = addCommas "KB" 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 diff --git a/WaiAppStatic/Storage/Embedded.hs b/WaiAppStatic/Storage/Embedded.hs new file mode 100644 --- /dev/null +++ b/WaiAppStatic/Storage/Embedded.hs @@ -0,0 +1,92 @@ +-- | Lookup files stored in memory instead of from the filesystem. +module WaiAppStatic.Storage.Embedded + ( -- * Settings + embeddedSettings + ) where + +import WaiAppStatic.Types +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 Data.Function (on) +import qualified Data.Text as T +import Data.Ord +import qualified Data.ByteString as S +import qualified Crypto.Hash.MD5 as MD5 +import qualified Data.ByteString.Base64 as B64 +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 + } + +type Embedded = Map.Map Piece EmbeddedEntry + +data EmbeddedEntry = EEFile ByteString | EEFolder Embedded + +embeddedLookup :: Embedded -> Pieces -> IO LookupResult +embeddedLookup root pieces = + return $ elookup pieces root + where + elookup :: Pieces -> Embedded -> LookupResult + elookup [] x = LRFolder $ Folder $ map toEntry $ Map.toList x + elookup [p] x | T.null (fromPiece p) = elookup [] x + elookup (p:ps) x = + case Map.lookup p x of + Nothing -> LRNotFound + Just (EEFile f) -> + case ps of + [] -> LRFile $ bsToFile p f + _ -> LRNotFound + Just (EEFolder y) -> elookup ps y + +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 + } + +toEmbedded :: [(Prelude.FilePath, ByteString)] -> Embedded +toEmbedded fps = + go texts + where + texts = map (\(x, y) -> (filter (not . T.null . fromPiece) $ toPieces' x, y)) fps + toPieces' "" = [] + toPieces' x = + let (y, z) = break (== '/') x + in unsafeToPiece (T.pack y) : toPieces' (drop 1 z) + + go :: [(Pieces, ByteString)] -> Embedded + go orig = + Map.fromList $ map (second go') hoisted + where + next = map (\(x, y) -> (head x, (tail x, y))) orig + grouped :: [[(Piece, ([Piece], ByteString))]] + grouped = groupBy ((==) `on` fst) $ sortBy (comparing fst) next + hoisted :: [(Piece, [([Piece], ByteString)])] + hoisted = map (fst . head &&& map snd) grouped + + go' :: [(Pieces, ByteString)] -> EmbeddedEntry + go' [([], content)] = EEFile content + 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 + } + +runHash :: ByteString -> ByteString +runHash = B64.encode . MD5.hash diff --git a/WaiAppStatic/Storage/Filesystem.hs b/WaiAppStatic/Storage/Filesystem.hs new file mode 100644 --- /dev/null +++ b/WaiAppStatic/Storage/Filesystem.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Access files on the filesystem. +module WaiAppStatic.Storage.Filesystem + ( -- * Types + ETagLookup + -- * Settings + , defaultWebAppSettings + , defaultFileServerSettings + , webAppSettingsWithLookup + ) where + +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') +import Control.Monad (forM) +import Util +import Data.ByteString (ByteString) +import Control.Exception (SomeException, try) +import qualified Network.Wai as W +import WaiAppStatic.Listing +import Network.Mime +import System.PosixCompat.Files (fileSize, getFileStatus, modificationTime) +import Data.Maybe (catMaybes) +import qualified Crypto.Conduit +import Data.Serialize (encode) +import Crypto.Hash.MD5 (MD5) +import qualified Data.ByteString.Base64 as B64 + +-- | Construct a new path from a root and some @Pieces@. +pathFromPieces :: FilePath -> Pieces -> FilePath +pathFromPieces = foldl' (\fp p -> fp F.fromText (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 + } + +-- | 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 = MaxAgeSeconds $ 60 * 60 + , ssListing = Just defaultListing + , ssIndices = map unsafeToPiece ["index.html", "index.htm"] + , ssRedirectToIndex = False + , ssUseHash = False + } + +-- | 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 dir etagLookup = + (defaultWebAppSettings dir) { ssLookupFile = webAppLookup etagLookup dir} + +-- | Convenience wrapper for @fileHelper@. +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 hashFunc fp name = do + efs <- try $ getFileStatus $ F.encodeString fp + case efs of + Left (_ :: SomeException) -> return Nothing + Right 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 + } + +-- | How to calculate etags. Can perform filesystem reads on each call, or use +-- some caching mechanism. +type ETagLookup = FilePath -> IO (Maybe ByteString) + +-- | More efficient than @fileSystemLookup@ as it only concerns itself with +-- finding files, not folders. +webAppLookup :: ETagLookup -> FilePath -> Pieces -> IO LookupResult +webAppLookup hashFunc prefix pieces = + fileHelperLR hashFunc fp lastPiece + where + fp = pathFromPieces prefix pieces + lastPiece + | null pieces = unsafeToPiece "" + | otherwise = last pieces + +-- | MD5 hash and base64-encode the file contents. Does not check if the file +-- exists. +hashFile :: FilePath -> IO ByteString +hashFile fp = do + h <- Crypto.Conduit.hashFile (F.encodeString fp) + return $ B64.encode $ encode (h :: MD5) + +hashFileIfExists :: ETagLookup +hashFileIfExists fp = do + res <- try $ hashFile fp + return $ case res of + Left (_ :: SomeException) -> Nothing + Right x -> Just x + +isVisible :: FilePath -> Bool +isVisible = + go . F.encodeString . F.filename + where + go ('.':_) = False + go "" = False + go _ = 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 hashFunc prefix pieces = do + let fp = pathFromPieces prefix pieces + fe <- F.isFile fp + if fe + then fileHelperLR hashFunc fp lastPiece + else do + de <- F.isDirectory 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' + if de' + then return $ Just $ Left name + else do + mfile <- fileHelper hashFunc fp' name + case mfile of + Nothing -> return Nothing + Just file -> return $ Just $ Right file + return $ LRFolder $ Folder $ catMaybes entries + else return LRNotFound + where + lastPiece + | null pieces = unsafeToPiece "" + | otherwise = last pieces diff --git a/WaiAppStatic/Types.hs b/WaiAppStatic/Types.hs new file mode 100644 --- /dev/null +++ b/WaiAppStatic/Types.hs @@ -0,0 +1,144 @@ +{-# 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 + +import Data.Text (Text) +import qualified Network.HTTP.Types as H +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. +-- +-- This is the core type used by wai-app-static for doing lookups. It provides +-- a smart constructor to avoid the possibility of constructing unsafe path +-- segments (though @unsafeToPiece@ can get around that as necessary). +-- +-- Individual file lookup backends must know how to convert from a @Piece@ to +-- their storage system. +newtype Piece = Piece { fromPiece :: Text } + deriving (Show, Eq, Ord) + +-- | Smart constructor for a @Piece@. Won\'t allow unsafe components, such as +-- pieces beginning with a period or containing a slash. This /will/, however, +-- allow null pieces. +toPiece :: Text -> Maybe Piece +toPiece t + | T.null t = Just $ Piece t + | T.head t == '.' = Nothing + | T.any (== '/') t = Nothing + | otherwise = Just $ Piece t + +-- | Construct a @Piece@ without input validation. +unsafeToPiece :: Text -> Piece +unsafeToPiece = Piece + +-- | Call @toPiece@ on a list. +-- +-- > toPieces = mapM toPiece +toPieces :: [Text] -> Maybe Pieces +toPieces = mapM toPiece + +-- | Request coming from a user. Corresponds to @pathInfo@. +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 + +-- | Just the name of a folder. +type FolderName = Piece + +-- | Represent contents of a single folder, which can be itself either a file +-- or a folder. +data Folder = Folder + { folderContents :: [Either FolderName File] + } + +-- | 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@. + , fileToResponse :: H.Status -> H.ResponseHeaders -> W.Response + -- | Last component of the filename. + , fileName :: Piece + -- | Calculate a hash of the contents of this file, such as for etag. + , fileGetHash :: IO (Maybe ByteString) + -- | Last modified time, used for both display in listings and if-modified-since. + , fileGetModified :: Maybe EpochTime + } + +-- | 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 + +-- | How to construct a directory listing page for the given request path and +-- the resulting folder. +type Listing = Pieces -> Folder -> IO Builder + +-- | All of the settings available to users for tweaking wai-app-static. +-- +-- Note that you should use the settings type approach for modifying values. +-- See 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. + , 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. + , ssIndices :: [Piece] + + -- | How to perform a directory listing. Optional. Will be used when the + -- user requested a folder. + , ssListing :: Maybe Listing + + -- | Value to provide for max age in the cache-control. + , ssMaxAge :: MaxAge + + -- | Given a requested path and a new destination, construct a string + -- that will go there. Default implementation will use relative paths. + , 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. + , ssRedirectToIndex :: Bool + + -- | Prefer usage of etag caching to last-modified caching. + , ssUseHash :: Bool + } diff --git a/test/WaiAppStaticTest.hs b/test/WaiAppStaticTest.hs --- a/test/WaiAppStaticTest.hs +++ b/test/WaiAppStaticTest.hs @@ -4,13 +4,10 @@ import Network.Wai.Application.Static import Test.Hspec.Monadic -import Test.Hspec.QuickCheck import Test.Hspec.HUnit () import Test.HUnit ((@?=)) -import Data.List (isInfixOf) import qualified Data.ByteString.Char8 as S8 -- import qualified Data.ByteString.Lazy.Char8 as L8 -import qualified Data.Text as T import System.PosixCompat.Files (getFileStatus, modificationTime) import Network.HTTP.Date @@ -21,26 +18,27 @@ import Network.Wai.Test import Control.Monad.IO.Class (liftIO) +import Network.Mime defRequest :: Request defRequest = defaultRequest specs :: Specs specs = do - let webApp = flip runSession $ staticApp defaultWebAppSettings {ssFolder = fileSystemLookup "test"} - let fileServerApp = flip runSession $ staticApp defaultFileServerSettings {ssFolder = fileSystemLookup "test"} + let webApp = flip runSession $ staticApp $ defaultWebAppSettings "test" + let fileServerApp = flip runSession $ staticApp $ defaultFileServerSettings "test" let etag = "1B2M2Y8AsgTpgAmY7PhCfg==" let file = "a/b" let statFile = setRawPathInfo defRequest file - describe "Pieces: pathFromPieces" $ do - it "converts to a file path" $ - (pathFromPieces "prefix" ["a", "bc"]) @?= "prefix/a/bc" - - prop "each piece is in file path" $ \piecesS -> - let pieces = map (FilePath . T.pack) piecesS - in all (\p -> ("/" ++ p) `isInfixOf` (T.unpack $ unFilePath $ pathFromPieces "root" $ pieces)) piecesS + describe "mime types" $ do + it "fileNameExtensions" $ + fileNameExtensions "foo.tar.gz" @?= ["tar.gz", "gz"] + it "handles multi-extensions" $ + defaultMimeLookup "foo.tar.gz" @?= "application/x-tgz" + it "defaults correctly" $ + defaultMimeLookup "foo.unknown" @?= "application/octet-stream" describe "webApp" $ do it "403 for unsafe paths" $ webApp $ @@ -62,8 +60,8 @@ assertStatus 301 req assertHeader "Location" "../../a/b/c" req - let absoluteApp = flip runSession $ staticApp $ defaultWebAppSettings { - ssFolder = fileSystemLookup "test", ssMkRedirect = \_ u -> S8.append "http://www.example.com" u + 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 @@ -75,18 +73,9 @@ it "200 and etag when no etag query parameters" $ webApp $ do req <- request statFile assertStatus 200 req - assertNoHeader "Cache-Control" req assertHeader "ETag" etag req assertNoHeader "Last-Modified" req - it "200 when no cache headers and bad cache query string" $ webApp $ do - flip mapM_ [Just "cached", Nothing] $ \badETag -> do - req <- request statFile { queryString = [("etag", badETag)] } - assertStatus 301 req - assertHeader "Location" "../a/b?etag=1B2M2Y8AsgTpgAmY7PhCfg%3D%3D" req - assertNoHeader "Cache-Control" 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 @@ -125,7 +114,6 @@ requestHeaders = [("If-Modified-Since", badDate)] } assertStatus 200 req - assertNoHeader "Cache-Control" req fdate <- fileDate assertHeader "Last-Modified" fdate req diff --git a/wai-app-static.cabal b/wai-app-static.cabal --- a/wai-app-static.cabal +++ b/wai-app-static.cabal @@ -1,5 +1,5 @@ name: wai-app-static -version: 1.2.0.4 +version: 1.3.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -22,15 +22,11 @@ Description: print debug info Default: False -flag blaze_html_0_5 - Description: use blaze-html 0.5 and blaze-markup 0.5 - Default: False - library build-depends: base >= 4 && < 5 - , wai >= 1.2 && < 1.3 + , wai >= 1.3 && < 1.4 , bytestring >= 0.9.1.4 - , http-types >= 0.6 && < 0.7 + , http-types >= 0.7 && < 0.8 , transformers >= 0.2.2 && < 0.4 , unix-compat >= 0.2 , directory >= 1.0.1 && < 1.2 @@ -42,17 +38,21 @@ , blaze-builder >= 0.2.1.4 && < 0.4 , base64-bytestring >= 0.1 && < 0.2 , cryptohash >= 0.7 && < 0.8 + , system-filepath >= 0.4 && < 0.5 + , system-fileio >= 0.3 && < 0.4 , http-date - - if flag(blaze_html_0_5) - build-depends: - blaze-html >= 0.5 && < 0.6 + , blaze-html >= 0.5 && < 0.6 , blaze-markup >= 0.5.1 && < 0.6 - else - build-depends: - blaze-html >= 0.4 && < 0.5 + , crypto-conduit >= 0.4 && < 0.5 + , cereal >= 0.3.5 && < 0.4 + , mime-types >= 0.1 && < 0.2 exposed-modules: Network.Wai.Application.Static + WaiAppStatic.Storage.Filesystem + WaiAppStatic.Storage.Embedded + WaiAppStatic.Listing + WaiAppStatic.Types + other-modules: Util ghc-options: -Wall extensions: CPP @@ -79,6 +79,7 @@ , bytestring , text , transformers + , mime-types -- , containers ghc-options: -Wall