module WaiAppStatic.Storage.Filesystem
(
ETagLookup
, defaultWebAppSettings
, defaultFileServerSettings
, webAppSettingsWithLookup
) where
import WaiAppStatic.Types
import System.FilePath ((</>))
import System.Directory (doesFileExist, doesDirectoryExist, getDirectoryContents)
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, 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 qualified Data.Text as T
pathFromPieces :: FilePath -> Pieces -> FilePath
pathFromPieces = foldl' (\fp p -> fp </> T.unpack (fromPiece p))
defaultWebAppSettings :: FilePath
-> StaticSettings
defaultWebAppSettings root = StaticSettings
{ ssLookupFile = webAppLookup hashFileIfExists root
, ssMkRedirect = defaultMkRedirect
, ssGetMimeType = return . defaultMimeLookup . fromPiece . fileName
, ssMaxAge = MaxAgeForever
, ssListing = Nothing
, ssIndices = []
, ssRedirectToIndex = False
, ssUseHash = True
}
defaultFileServerSettings :: FilePath
-> 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
}
webAppSettingsWithLookup :: FilePath
-> ETagLookup
-> StaticSettings
webAppSettingsWithLookup dir etagLookup =
(defaultWebAppSettings dir) { ssLookupFile = webAppLookup etagLookup dir}
fileHelperLR :: ETagLookup
-> FilePath
-> Piece
-> IO LookupResult
fileHelperLR a b c = fmap (maybe LRNotFound LRFile) $ fileHelper a b c
fileHelper :: ETagLookup
-> FilePath
-> Piece
-> IO (Maybe File)
fileHelper hashFunc fp name = do
efs <- try $ getFileStatus fp
case efs of
Left (_ :: SomeException) -> return Nothing
Right fs | isRegularFile fs -> return $ Just File
{ fileGetSize = fromIntegral $ fileSize fs
, fileToResponse = \s h -> W.responseFile s h fp Nothing
, fileName = name
, fileGetHash = hashFunc fp
, fileGetModified = Just $ modificationTime fs
}
Right _ -> return Nothing
type ETagLookup = FilePath -> IO (Maybe ByteString)
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
hashFile :: FilePath -> IO ByteString
hashFile fp = do
h <- Crypto.Hash.Conduit.hashFile fp
return $ B64.encode $ toBytes (h :: Digest 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 ('.':_) = False
isVisible "" = False
isVisible _ = True
fileSystemLookup :: ETagLookup
-> FilePath -> Pieces -> IO LookupResult
fileSystemLookup hashFunc prefix pieces = do
let fp = pathFromPieces prefix pieces
fe <- doesFileExist fp
if fe
then fileHelperLR hashFunc fp lastPiece
else do
de <- doesDirectoryExist fp
if de
then do
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
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