{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}
-- | Access files on the filesystem.
module WaiAppStatic.Storage.Filesystem
    ( -- * Types
      ETagLookup
      -- * Settings
    , defaultWebAppSettings
    , defaultFileServerSettings
    , webAppSettingsWithLookup
    ) where

import WaiAppStatic.Types
import System.FilePath ((</>))
import System.IO (withBinaryFile, IOMode(..))
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)
#ifdef MIN_VERSION_cryptonite
import Data.ByteArray.Encoding
import Crypto.Hash (hashlazy, MD5, Digest)
#else
import Data.ByteString.Base64 (encode)
import Crypto.Hash.MD5 (hashlazy)
#endif
import qualified Data.ByteString.Lazy as BL (hGetContents)
import qualified Data.Text as T

-- | Construct a new path from a root and some @Pieces@.
pathFromPieces :: FilePath -> Pieces -> FilePath
pathFromPieces :: FilePath -> Pieces -> FilePath
pathFromPieces = (FilePath -> Piece -> FilePath) -> FilePath -> Pieces -> FilePath
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\FilePath
fp Piece
p -> FilePath
fp FilePath -> FilePath -> FilePath
</> Text -> FilePath
T.unpack (Piece -> Text
fromPiece Piece
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 :: FilePath -> StaticSettings
defaultWebAppSettings FilePath
root = StaticSettings :: (Pieces -> IO LookupResult)
-> (File -> IO MimeType)
-> Pieces
-> Maybe Listing
-> MaxAge
-> (Pieces -> MimeType -> MimeType)
-> Bool
-> Bool
-> Bool
-> Maybe Application
-> StaticSettings
StaticSettings
    { ssLookupFile :: Pieces -> IO LookupResult
ssLookupFile = ETagLookup -> FilePath -> Pieces -> IO LookupResult
webAppLookup ETagLookup
hashFileIfExists FilePath
root
    , ssMkRedirect :: Pieces -> MimeType -> MimeType
ssMkRedirect  = Pieces -> MimeType -> MimeType
defaultMkRedirect
    , ssGetMimeType :: File -> IO MimeType
ssGetMimeType = MimeType -> IO MimeType
forall (m :: * -> *) a. Monad m => a -> m a
return (MimeType -> IO MimeType)
-> (File -> MimeType) -> File -> IO MimeType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> MimeType
defaultMimeLookup (Text -> MimeType) -> (File -> Text) -> File -> MimeType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Piece -> Text
fromPiece (Piece -> Text) -> (File -> Piece) -> File -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. File -> Piece
fileName
    , ssMaxAge :: MaxAge
ssMaxAge  = MaxAge
MaxAgeForever
    , ssListing :: Maybe Listing
ssListing = Maybe Listing
forall a. Maybe a
Nothing
    , ssIndices :: Pieces
ssIndices = []
    , ssRedirectToIndex :: Bool
ssRedirectToIndex = Bool
False
    , ssUseHash :: Bool
ssUseHash = Bool
True
    , ssAddTrailingSlash :: Bool
ssAddTrailingSlash = Bool
False
    , ss404Handler :: Maybe Application
ss404Handler = Maybe Application
forall a. Maybe a
Nothing
    }

-- | 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 :: FilePath -> StaticSettings
defaultFileServerSettings FilePath
root = StaticSettings :: (Pieces -> IO LookupResult)
-> (File -> IO MimeType)
-> Pieces
-> Maybe Listing
-> MaxAge
-> (Pieces -> MimeType -> MimeType)
-> Bool
-> Bool
-> Bool
-> Maybe Application
-> StaticSettings
StaticSettings
    { ssLookupFile :: Pieces -> IO LookupResult
ssLookupFile = ETagLookup -> FilePath -> Pieces -> IO LookupResult
fileSystemLookup ((MimeType -> Maybe MimeType) -> IO MimeType -> IO (Maybe MimeType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MimeType -> Maybe MimeType
forall a. a -> Maybe a
Just (IO MimeType -> IO (Maybe MimeType))
-> (FilePath -> IO MimeType) -> ETagLookup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO MimeType
hashFile) FilePath
root
    , ssMkRedirect :: Pieces -> MimeType -> MimeType
ssMkRedirect = Pieces -> MimeType -> MimeType
defaultMkRedirect
    , ssGetMimeType :: File -> IO MimeType
ssGetMimeType = MimeType -> IO MimeType
forall (m :: * -> *) a. Monad m => a -> m a
return (MimeType -> IO MimeType)
-> (File -> MimeType) -> File -> IO MimeType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> MimeType
defaultMimeLookup (Text -> MimeType) -> (File -> Text) -> File -> MimeType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Piece -> Text
fromPiece (Piece -> Text) -> (File -> Piece) -> File -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. File -> Piece
fileName
    , ssMaxAge :: MaxAge
ssMaxAge = MaxAge
NoMaxAge
    , ssListing :: Maybe Listing
ssListing = Listing -> Maybe Listing
forall a. a -> Maybe a
Just Listing
defaultListing
    , ssIndices :: Pieces
ssIndices = (Text -> Piece) -> [Text] -> Pieces
forall a b. (a -> b) -> [a] -> [b]
map Text -> Piece
unsafeToPiece [Text
"index.html", Text
"index.htm"]
    , ssRedirectToIndex :: Bool
ssRedirectToIndex = Bool
False
    , ssUseHash :: Bool
ssUseHash = Bool
False
    , ssAddTrailingSlash :: Bool
ssAddTrailingSlash = Bool
False
    , ss404Handler :: Maybe Application
ss404Handler = Maybe Application
forall a. Maybe a
Nothing
    }

-- | 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 :: FilePath -> ETagLookup -> StaticSettings
webAppSettingsWithLookup FilePath
dir ETagLookup
etagLookup =
  (FilePath -> StaticSettings
defaultWebAppSettings FilePath
dir) { ssLookupFile :: Pieces -> IO LookupResult
ssLookupFile = ETagLookup -> FilePath -> Pieces -> IO LookupResult
webAppLookup ETagLookup
etagLookup FilePath
dir}

-- | Convenience wrapper for @fileHelper@.
fileHelperLR :: ETagLookup
             -> FilePath -- ^ file location
             -> Piece -- ^ file name
             -> IO LookupResult
fileHelperLR :: ETagLookup -> FilePath -> Piece -> IO LookupResult
fileHelperLR ETagLookup
a FilePath
b Piece
c = (Maybe File -> LookupResult) -> IO (Maybe File) -> IO LookupResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (LookupResult
-> (File -> LookupResult) -> Maybe File -> LookupResult
forall b a. b -> (a -> b) -> Maybe a -> b
maybe LookupResult
LRNotFound File -> LookupResult
LRFile) (IO (Maybe File) -> IO LookupResult)
-> IO (Maybe File) -> IO LookupResult
forall a b. (a -> b) -> a -> b
$ ETagLookup -> FilePath -> Piece -> IO (Maybe File)
fileHelper ETagLookup
a FilePath
b Piece
c

-- | Attempt to load up a @File@ from the given path.
fileHelper :: ETagLookup
           -> FilePath -- ^ file location
           -> Piece -- ^ file name
           -> IO (Maybe File)
fileHelper :: ETagLookup -> FilePath -> Piece -> IO (Maybe File)
fileHelper ETagLookup
hashFunc FilePath
fp Piece
name = do
    Either SomeException FileStatus
efs <- IO FileStatus -> IO (Either SomeException FileStatus)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO FileStatus -> IO (Either SomeException FileStatus))
-> IO FileStatus -> IO (Either SomeException FileStatus)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FileStatus
getFileStatus FilePath
fp
    case Either SomeException FileStatus
efs of
        Left (SomeException
_ :: SomeException) -> Maybe File -> IO (Maybe File)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe File
forall a. Maybe a
Nothing
        Right FileStatus
fs | FileStatus -> Bool
isRegularFile FileStatus
fs -> Maybe File -> IO (Maybe File)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe File -> IO (Maybe File)) -> Maybe File -> IO (Maybe File)
forall a b. (a -> b) -> a -> b
$ File -> Maybe File
forall a. a -> Maybe a
Just File :: Integer
-> (Status -> ResponseHeaders -> Response)
-> Piece
-> IO (Maybe MimeType)
-> Maybe EpochTime
-> File
File
            { fileGetSize :: Integer
fileGetSize = FileOffset -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (FileOffset -> Integer) -> FileOffset -> Integer
forall a b. (a -> b) -> a -> b
$ FileStatus -> FileOffset
fileSize FileStatus
fs
            , fileToResponse :: Status -> ResponseHeaders -> Response
fileToResponse = \Status
s ResponseHeaders
h -> Status -> ResponseHeaders -> FilePath -> Maybe FilePart -> Response
W.responseFile Status
s ResponseHeaders
h FilePath
fp Maybe FilePart
forall a. Maybe a
Nothing
            , fileName :: Piece
fileName = Piece
name
            , fileGetHash :: IO (Maybe MimeType)
fileGetHash = ETagLookup
hashFunc FilePath
fp
            , fileGetModified :: Maybe EpochTime
fileGetModified = EpochTime -> Maybe EpochTime
forall a. a -> Maybe a
Just (EpochTime -> Maybe EpochTime) -> EpochTime -> Maybe EpochTime
forall a b. (a -> b) -> a -> b
$ FileStatus -> EpochTime
modificationTime FileStatus
fs
            }
        Right FileStatus
_ -> Maybe File -> IO (Maybe File)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe File
forall a. Maybe a
Nothing

-- | 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 :: ETagLookup -> FilePath -> Pieces -> IO LookupResult
webAppLookup ETagLookup
hashFunc FilePath
prefix Pieces
pieces =
    ETagLookup -> FilePath -> Piece -> IO LookupResult
fileHelperLR ETagLookup
hashFunc FilePath
fp Piece
lastPiece
  where
    fp :: FilePath
fp = FilePath -> Pieces -> FilePath
pathFromPieces FilePath
prefix Pieces
pieces
    lastPiece :: Piece
lastPiece
        | Pieces -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Pieces
pieces = Text -> Piece
unsafeToPiece Text
""
        | Bool
otherwise = Pieces -> Piece
forall a. [a] -> a
last Pieces
pieces

-- | MD5 hash and base64-encode the file contents. Does not check if the file
-- exists.
hashFile :: FilePath -> IO ByteString
hashFile :: FilePath -> IO MimeType
hashFile FilePath
fp = FilePath -> IOMode -> (Handle -> IO MimeType) -> IO MimeType
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile FilePath
fp IOMode
ReadMode ((Handle -> IO MimeType) -> IO MimeType)
-> (Handle -> IO MimeType) -> IO MimeType
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
    ByteString
f <- Handle -> IO ByteString
BL.hGetContents Handle
h
#ifdef MIN_VERSION_cryptonite
    let !hash :: Digest MD5
hash = ByteString -> Digest MD5
forall a. HashAlgorithm a => ByteString -> Digest a
hashlazy ByteString
f :: Digest MD5
    MimeType -> IO MimeType
forall (m :: * -> *) a. Monad m => a -> m a
return (MimeType -> IO MimeType) -> MimeType -> IO MimeType
forall a b. (a -> b) -> a -> b
$ Base -> Digest MD5 -> MimeType
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase Base
Base64 Digest MD5
hash
#else
    let !hash = hashlazy f
    return . encode $ hash
#endif

hashFileIfExists :: ETagLookup
hashFileIfExists :: ETagLookup
hashFileIfExists FilePath
fp = do
    Either SomeException MimeType
res <- IO MimeType -> IO (Either SomeException MimeType)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO MimeType -> IO (Either SomeException MimeType))
-> IO MimeType -> IO (Either SomeException MimeType)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO MimeType
hashFile FilePath
fp
    Maybe MimeType -> IO (Maybe MimeType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe MimeType -> IO (Maybe MimeType))
-> Maybe MimeType -> IO (Maybe MimeType)
forall a b. (a -> b) -> a -> b
$ case Either SomeException MimeType
res of
        Left (SomeException
_ :: SomeException) -> Maybe MimeType
forall a. Maybe a
Nothing
        Right MimeType
x -> MimeType -> Maybe MimeType
forall a. a -> Maybe a
Just MimeType
x

isVisible :: FilePath -> Bool
isVisible :: FilePath -> Bool
isVisible (Char
'.':FilePath
_) = Bool
False
isVisible FilePath
"" = Bool
False
isVisible FilePath
_ = Bool
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 :: ETagLookup -> FilePath -> Pieces -> IO LookupResult
fileSystemLookup ETagLookup
hashFunc FilePath
prefix Pieces
pieces = do
    let fp :: FilePath
fp = FilePath -> Pieces -> FilePath
pathFromPieces FilePath
prefix Pieces
pieces
    Bool
fe <- FilePath -> IO Bool
doesFileExist FilePath
fp
    if Bool
fe
        then ETagLookup -> FilePath -> Piece -> IO LookupResult
fileHelperLR ETagLookup
hashFunc FilePath
fp Piece
lastPiece
        else do
            Bool
de <- FilePath -> IO Bool
doesDirectoryExist FilePath
fp
            if Bool
de
                then do
                    [FilePath]
entries' <- ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
isVisible) (IO [FilePath] -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath -> IO [FilePath]
getDirectoryContents FilePath
fp
                    [Maybe (Either Piece File)]
entries <- [FilePath]
-> (FilePath -> IO (Maybe (Either Piece File)))
-> IO [Maybe (Either Piece File)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FilePath]
entries' ((FilePath -> IO (Maybe (Either Piece File)))
 -> IO [Maybe (Either Piece File)])
-> (FilePath -> IO (Maybe (Either Piece File)))
-> IO [Maybe (Either Piece File)]
forall a b. (a -> b) -> a -> b
$ \FilePath
fpRel' -> do
                        let name :: Piece
name = Text -> Piece
unsafeToPiece (Text -> Piece) -> Text -> Piece
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
fpRel'
                            fp' :: FilePath
fp' = FilePath
fp FilePath -> FilePath -> FilePath
</> FilePath
fpRel'
                        Bool
de' <- FilePath -> IO Bool
doesDirectoryExist FilePath
fp'
                        if Bool
de'
                            then Maybe (Either Piece File) -> IO (Maybe (Either Piece File))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Either Piece File) -> IO (Maybe (Either Piece File)))
-> Maybe (Either Piece File) -> IO (Maybe (Either Piece File))
forall a b. (a -> b) -> a -> b
$ Either Piece File -> Maybe (Either Piece File)
forall a. a -> Maybe a
Just (Either Piece File -> Maybe (Either Piece File))
-> Either Piece File -> Maybe (Either Piece File)
forall a b. (a -> b) -> a -> b
$ Piece -> Either Piece File
forall a b. a -> Either a b
Left Piece
name
                            else do
                                Maybe File
mfile <- ETagLookup -> FilePath -> Piece -> IO (Maybe File)
fileHelper ETagLookup
hashFunc FilePath
fp' Piece
name
                                case Maybe File
mfile of
                                    Maybe File
Nothing -> Maybe (Either Piece File) -> IO (Maybe (Either Piece File))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Either Piece File)
forall a. Maybe a
Nothing
                                    Just File
file -> Maybe (Either Piece File) -> IO (Maybe (Either Piece File))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Either Piece File) -> IO (Maybe (Either Piece File)))
-> Maybe (Either Piece File) -> IO (Maybe (Either Piece File))
forall a b. (a -> b) -> a -> b
$ Either Piece File -> Maybe (Either Piece File)
forall a. a -> Maybe a
Just (Either Piece File -> Maybe (Either Piece File))
-> Either Piece File -> Maybe (Either Piece File)
forall a b. (a -> b) -> a -> b
$ File -> Either Piece File
forall a b. b -> Either a b
Right File
file
                    LookupResult -> IO LookupResult
forall (m :: * -> *) a. Monad m => a -> m a
return (LookupResult -> IO LookupResult)
-> LookupResult -> IO LookupResult
forall a b. (a -> b) -> a -> b
$ Folder -> LookupResult
LRFolder (Folder -> LookupResult) -> Folder -> LookupResult
forall a b. (a -> b) -> a -> b
$ [Either Piece File] -> Folder
Folder ([Either Piece File] -> Folder) -> [Either Piece File] -> Folder
forall a b. (a -> b) -> a -> b
$ [Maybe (Either Piece File)] -> [Either Piece File]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (Either Piece File)]
entries
                else LookupResult -> IO LookupResult
forall (m :: * -> *) a. Monad m => a -> m a
return LookupResult
LRNotFound
  where
    lastPiece :: Piece
lastPiece
        | Pieces -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Pieces
pieces = Text -> Piece
unsafeToPiece Text
""
        | Bool
otherwise = Pieces -> Piece
forall a. [a] -> a
last Pieces
pieces