{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Access files on the filesystem.
module WaiAppStatic.Storage.Filesystem (
    -- * Types
    ETagLookup,

    -- * Settings
    defaultWebAppSettings,
    defaultFileServerSettings,
    webAppSettingsWithLookup,
) where

import Control.Exception (SomeException, try)
import Control.Monad (forM)
import Data.ByteString (ByteString)
import Data.List (foldl')
import Data.Maybe (catMaybes)
import Network.Mime
import qualified Network.Wai as W
import System.Directory (
    doesDirectoryExist,
    doesFileExist,
    getDirectoryContents,
 )
import System.FilePath ((</>))
import System.IO (IOMode (..), withBinaryFile)
import System.PosixCompat.Files (
    fileSize,
    getFileStatus,
    isRegularFile,
    modificationTime,
 )
import Util
import WaiAppStatic.Listing
import WaiAppStatic.Types
#ifdef MIN_VERSION_crypton
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 b a. (b -> a -> b) -> b -> [a] -> b
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
        { ssLookupFile :: Pieces -> IO LookupResult
ssLookupFile = ETagLookup -> FilePath -> Pieces -> IO LookupResult
webAppLookup ETagLookup
hashFileIfExists FilePath
root
        , ssMkRedirect :: Pieces -> ByteString -> ByteString
ssMkRedirect = Pieces -> ByteString -> ByteString
defaultMkRedirect
        , ssGetMimeType :: File -> IO ByteString
ssGetMimeType = ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString)
-> (File -> ByteString) -> File -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
defaultMimeLookup (Text -> ByteString) -> (File -> Text) -> File -> ByteString
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
        { ssLookupFile :: Pieces -> IO LookupResult
ssLookupFile = ETagLookup -> FilePath -> Pieces -> IO LookupResult
fileSystemLookup ((ByteString -> Maybe ByteString)
-> IO ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (IO ByteString -> IO (Maybe ByteString))
-> (FilePath -> IO ByteString) -> ETagLookup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO ByteString
hashFile) FilePath
root
        , ssMkRedirect :: Pieces -> ByteString -> ByteString
ssMkRedirect = Pieces -> ByteString -> ByteString
defaultMkRedirect
        , ssGetMimeType :: File -> IO ByteString
ssGetMimeType = ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString)
-> (File -> ByteString) -> File -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
defaultMimeLookup (Text -> ByteString) -> (File -> Text) -> File -> ByteString
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 = webAppLookup etagLookup 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 a b. (a -> b) -> IO a -> IO b
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 a. a -> IO a
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 a. a -> IO a
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
                            { 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 ByteString)
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 a. a -> IO a
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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Pieces
pieces = Text -> Piece
unsafeToPiece Text
""
        | Bool
otherwise = Pieces -> Piece
forall a. HasCallStack => [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 ByteString
hashFile FilePath
fp = FilePath -> IOMode -> (Handle -> IO ByteString) -> IO ByteString
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile FilePath
fp IOMode
ReadMode ((Handle -> IO ByteString) -> IO ByteString)
-> (Handle -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
    ByteString
f <- Handle -> IO ByteString
BL.hGetContents Handle
h
#ifdef MIN_VERSION_crypton
    let !hash :: Digest MD5
hash = ByteString -> Digest MD5
forall a. HashAlgorithm a => ByteString -> Digest a
hashlazy ByteString
f :: Digest MD5
    ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Base -> Digest MD5 -> ByteString
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 ByteString
res <- IO ByteString -> IO (Either SomeException ByteString)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO ByteString -> IO (Either SomeException ByteString))
-> IO ByteString -> IO (Either SomeException ByteString)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ByteString
hashFile FilePath
fp
    Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> IO (Maybe ByteString))
-> Maybe ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ case Either SomeException ByteString
res of
        Left (SomeException
_ :: SomeException) -> Maybe ByteString
forall a. Maybe a
Nothing
        Right ByteString
x -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
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 a b. (a -> b) -> IO a -> IO b
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 a. a -> IO a
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 a. a -> IO a
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 a. a -> IO a
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 a. a -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return LookupResult
LRNotFound
  where
    lastPiece :: Piece
lastPiece
        | Pieces -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Pieces
pieces = Text -> Piece
unsafeToPiece Text
""
        | Bool
otherwise = Pieces -> Piece
forall a. HasCallStack => [a] -> a
last Pieces
pieces