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