1{-# LANGUAGE ScopedTypeVariables #-} 2{-# LANGUAGE OverloadedStrings #-} 3{-# LANGUAGE BangPatterns #-} 4-- | Access files on the filesystem. 5module WaiAppStatic.Storage.Filesystem 6 ( -- * Types 7 ETagLookup 8 -- * Settings 9 , defaultWebAppSettings 10 , defaultFileServerSettings 11 , webAppSettingsWithLookup 12 ) where 13 14import WaiAppStatic.Types 15import System.FilePath ((</>)) 16import System.IO (withBinaryFile, IOMode(..)) 17import System.Directory (doesFileExist, doesDirectoryExist, getDirectoryContents) 18import Data.List (foldl') 19import Control.Monad (forM) 20import Util 21import Data.ByteString (ByteString) 22import Control.Exception (SomeException, try) 23import qualified Network.Wai as W 24import WaiAppStatic.Listing 25import Network.Mime 26import System.PosixCompat.Files (fileSize, getFileStatus, modificationTime, isRegularFile) 27import Data.Maybe (catMaybes) 28import Data.ByteArray.Encoding 29import Crypto.Hash (hashlazy, MD5, Digest) 30import qualified Data.ByteString.Lazy as BL (hGetContents) 31import qualified Data.Text as T 32 33-- | Construct a new path from a root and some @Pieces@. 34pathFromPieces :: FilePath -> Pieces -> FilePath 35pathFromPieces = foldl' (\fp p -> fp </> T.unpack (fromPiece p)) 36 37-- | Settings optimized for a web application. Files will have aggressive 38-- caching applied and hashes calculated, and indices and listings are disabled. 39defaultWebAppSettings :: FilePath -- ^ root folder to serve from 40 -> StaticSettings 41defaultWebAppSettings root = StaticSettings 42 { ssLookupFile = webAppLookup hashFileIfExists root 43 , ssMkRedirect = defaultMkRedirect 44 , ssGetMimeType = return . defaultMimeLookup . fromPiece . fileName 45 , ssMaxAge = MaxAgeForever 46 , ssListing = Nothing 47 , ssIndices = [] 48 , ssRedirectToIndex = False 49 , ssUseHash = True 50 , ssAddTrailingSlash = False 51 , ss404Handler = Nothing 52 } 53 54-- | Settings optimized for a file server. More conservative caching will be 55-- applied, and indices and listings are enabled. 56defaultFileServerSettings :: FilePath -- ^ root folder to serve from 57 -> StaticSettings 58defaultFileServerSettings root = StaticSettings 59 { ssLookupFile = fileSystemLookup (fmap Just . hashFile) root 60 , ssMkRedirect = defaultMkRedirect 61 , ssGetMimeType = return . defaultMimeLookup . fromPiece . fileName 62 , ssMaxAge = NoMaxAge 63 , ssListing = Just defaultListing 64 , ssIndices = map unsafeToPiece ["index.html", "index.htm"] 65 , ssRedirectToIndex = False 66 , ssUseHash = False 67 , ssAddTrailingSlash = False 68 , ss404Handler = Nothing 69 } 70 71-- | Same as @defaultWebAppSettings@, but additionally uses a specialized 72-- @ETagLookup@ in place of the standard one. This can allow you to cache your 73-- hash values, or even precompute them. 74webAppSettingsWithLookup :: FilePath -- ^ root folder to serve from 75 -> ETagLookup 76 -> StaticSettings 77webAppSettingsWithLookup dir etagLookup = 78 (defaultWebAppSettings dir) { ssLookupFile = webAppLookup etagLookup dir} 79 80-- | Convenience wrapper for @fileHelper@. 81fileHelperLR :: ETagLookup 82 -> FilePath -- ^ file location 83 -> Piece -- ^ file name 84 -> IO LookupResult 85fileHelperLR a b c = fmap (maybe LRNotFound LRFile) $ fileHelper a b c 86 87-- | Attempt to load up a @File@ from the given path. 88fileHelper :: ETagLookup 89 -> FilePath -- ^ file location 90 -> Piece -- ^ file name 91 -> IO (Maybe File) 92fileHelper hashFunc fp name = do 93 efs <- try $ getFileStatus fp 94 case efs of 95 Left (_ :: SomeException) -> return Nothing 96 Right fs | isRegularFile fs -> return $ Just File 97 { fileGetSize = fromIntegral $ fileSize fs 98 , fileToResponse = \s h -> W.responseFile s h fp Nothing 99 , fileName = name 100 , fileGetHash = hashFunc fp 101 , fileGetModified = Just $ modificationTime fs 102 } 103 Right _ -> return Nothing 104 105-- | How to calculate etags. Can perform filesystem reads on each call, or use 106-- some caching mechanism. 107type ETagLookup = FilePath -> IO (Maybe ByteString) 108 109-- | More efficient than @fileSystemLookup@ as it only concerns itself with 110-- finding files, not folders. 111webAppLookup :: ETagLookup -> FilePath -> Pieces -> IO LookupResult 112webAppLookup hashFunc prefix pieces = 113 fileHelperLR hashFunc fp lastPiece 114 where 115 fp = pathFromPieces prefix pieces 116 lastPiece 117 | null pieces = unsafeToPiece "" 118 | otherwise = last pieces 119 120-- | MD5 hash and base64-encode the file contents. Does not check if the file 121-- exists. 122hashFile :: FilePath -> IO ByteString 123hashFile fp = withBinaryFile fp ReadMode $ \h -> do 124 f <- BL.hGetContents h 125 let !hash = hashlazy f :: Digest MD5 126 return $ convertToBase Base64 hash 127 128hashFileIfExists :: ETagLookup 129hashFileIfExists fp = do 130 res <- try $ hashFile fp 131 return $ case res of 132 Left (_ :: SomeException) -> Nothing 133 Right x -> Just x 134 135isVisible :: FilePath -> Bool 136isVisible ('.':_) = False 137isVisible "" = False 138isVisible _ = True 139 140-- | Get a proper @LookupResult@, checking if the path is a file or folder. 141-- Compare with @webAppLookup@, which only deals with files. 142fileSystemLookup :: ETagLookup 143 -> FilePath -> Pieces -> IO LookupResult 144fileSystemLookup hashFunc prefix pieces = do 145 let fp = pathFromPieces prefix pieces 146 fe <- doesFileExist fp 147 if fe 148 then fileHelperLR hashFunc fp lastPiece 149 else do 150 de <- doesDirectoryExist fp 151 if de 152 then do 153 entries' <- fmap (filter isVisible) $ getDirectoryContents fp 154 entries <- forM entries' $ \fpRel' -> do 155 let name = unsafeToPiece $ T.pack fpRel' 156 fp' = fp </> fpRel' 157 de' <- doesDirectoryExist fp' 158 if de' 159 then return $ Just $ Left name 160 else do 161 mfile <- fileHelper hashFunc fp' name 162 case mfile of 163 Nothing -> return Nothing 164 Just file -> return $ Just $ Right file 165 return $ LRFolder $ Folder $ catMaybes entries 166 else return LRNotFound 167 where 168 lastPiece 169 | null pieces = unsafeToPiece "" 170 | otherwise = last pieces 171