    {-# 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)
    import Data.ByteArray.Encoding
    import Crypto.Hash (hashlazy, MD5, Digest)
    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' (\fp :: FilePath
    fp p :: 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 root :: 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 root :: 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 ["index.html", "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 dir :: FilePath
    dir etagLookup :: 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 a :: ETagLookup
    a b :: FilePath
    b c :: 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 hashFunc :: ETagLookup
    hashFunc fp :: FilePath
    fp name :: 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 fs :: 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 = \s :: Status
    s h :: 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 _ -> 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 hashFunc :: ETagLookup
    hashFunc prefix :: FilePath
    prefix pieces :: 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 ""
            | 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 fp :: 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
    $ \h :: Handle
    h -> do
        ByteString
    f <- Handle -> IO ByteString
    BL.hGetContents Handle
    h
        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

    hashFileIfExists :: ETagLookup
    hashFileIfExists :: ETagLookup
    hashFileIfExists fp :: 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 x :: MimeType
    x -> MimeType -> Maybe MimeType
    forall a. a -> Maybe a
    Just MimeType
    x

    isVisible :: FilePath -> Bool
    isVisible :: FilePath -> Bool
    isVisible ('.':_) = Bool
    False
    isVisible "" = Bool
    False
    isVisible _ = 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 hashFunc :: ETagLookup
    hashFunc prefix :: FilePath
    prefix pieces :: 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
    $ \fpRel' :: 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
                                        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
    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 ""
            | Bool
    otherwise = Pieces -> Piece
    forall a. [a] -> a
    last Pieces
    pieces