module WaiAppStatic.Storage.Filesystem
(
ETagLookup
, 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, isRegularFile)
import Data.Maybe (catMaybes)
import qualified Crypto.Conduit
import Data.Serialize (encode)
import Crypto.Hash.CryptoAPI (MD5)
import qualified Data.ByteString.Base64 as B64
pathFromPieces :: FilePath -> Pieces -> FilePath
pathFromPieces = foldl' (\fp p -> fp </> F.fromText (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 $ F.encodeString 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 _ -> 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.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
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