{-# 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_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 = 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 = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
defaultMimeLookup forall b c a. (b -> c) -> (a -> b) -> a -> c
. Piece -> Text
fromPiece forall b c a. (b -> c) -> (a -> b) -> a -> c
. File -> Piece
fileName
    , ssMaxAge :: MaxAge
ssMaxAge  = MaxAge
MaxAgeForever
    , ssListing :: Maybe Listing
ssListing = 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 = 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 (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just 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 = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
defaultMimeLookup forall b c a. (b -> c) -> (a -> b) -> a -> c
. Piece -> Text
fromPiece forall b c a. (b -> c) -> (a -> b) -> a -> c
. File -> Piece
fileName
    , ssMaxAge :: MaxAge
ssMaxAge = MaxAge
NoMaxAge
    , ssListing :: Maybe Listing
ssListing = forall a. a -> Maybe a
Just Listing
defaultListing
    , ssIndices :: Pieces
ssIndices = 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 = 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b a. b -> (a -> b) -> Maybe a -> b
maybe LookupResult
LRNotFound File -> LookupResult
LRFile) 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 <- forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$ FilePath -> IO FileStatus
getFileStatus FilePath
fp
    case Either SomeException FileStatus
efs of
        Left (SomeException
_ :: SomeException) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        Right FileStatus
fs | FileStatus -> Bool
isRegularFile FileStatus
fs -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just File
            { fileGetSize :: Integer
fileGetSize = forall a b. (Integral a, Num b) => a -> b
fromIntegral 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 forall a. Maybe a
Nothing
            , fileName :: Piece
fileName = Piece
name
            , fileGetHash :: IO (Maybe ByteString)
fileGetHash = ETagLookup
hashFunc FilePath
fp
            , fileGetModified :: Maybe EpochTime
fileGetModified = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ FileStatus -> EpochTime
modificationTime FileStatus
fs
            }
        Right FileStatus
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return 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
        | forall (t :: * -> *) a. Foldable t => t a -> Bool
null Pieces
pieces = Text -> Piece
unsafeToPiece Text
""
        | Bool
otherwise = 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 ByteString
hashFile FilePath
fp = forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile FilePath
fp IOMode
ReadMode 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 = forall a. HashAlgorithm a => ByteString -> Digest a
hashlazy ByteString
f :: Digest MD5
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 <- forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$ FilePath -> IO ByteString
hashFile FilePath
fp
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Either SomeException ByteString
res of
        Left (SomeException
_ :: SomeException) -> forall a. Maybe a
Nothing
        Right ByteString
x -> 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' <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
isVisible) forall a b. (a -> b) -> a -> b
$ FilePath -> IO [FilePath]
getDirectoryContents FilePath
fp
                    [Maybe (Either Piece File)]
entries <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FilePath]
entries' forall a b. (a -> b) -> a -> b
$ \FilePath
fpRel' -> do
                        let name :: Piece
name = Text -> Piece
unsafeToPiece 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 forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                                    Just File
file -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right File
file
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Folder -> LookupResult
LRFolder forall a b. (a -> b) -> a -> b
$ [Either Piece File] -> Folder
Folder forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes [Maybe (Either Piece File)]
entries
                else forall (m :: * -> *) a. Monad m => a -> m a
return LookupResult
LRNotFound
  where
    lastPiece :: Piece
lastPiece
        | forall (t :: * -> *) a. Foldable t => t a -> Bool
null Pieces
pieces = Text -> Piece
unsafeToPiece Text
""
        | Bool
otherwise = forall a. [a] -> a
last Pieces
pieces