{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}

module Network.Wai.Handler.Warp.FileInfoCache (
    FileInfo (..),
    withFileInfoCache,
    getInfo, -- test purpose only
) where

import Control.Reaper
import Network.HTTP.Date
#if WINDOWS
import System.PosixCompat.Files
#else
import System.Posix.Files
#endif
import qualified UnliftIO (bracket, onException, throwIO)

import Network.Wai.Handler.Warp.HashMap (HashMap)
import qualified Network.Wai.Handler.Warp.HashMap as M
import Network.Wai.Handler.Warp.Imports

----------------------------------------------------------------

-- | File information.
data FileInfo = FileInfo
    { FileInfo -> FilePath
fileInfoName :: !FilePath
    , FileInfo -> Integer
fileInfoSize :: !Integer
    , FileInfo -> HTTPDate
fileInfoTime :: HTTPDate
    -- ^ Modification time
    , FileInfo -> ByteString
fileInfoDate :: ByteString
    -- ^ Modification time in the GMT format
    }
    deriving (FileInfo -> FileInfo -> Bool
(FileInfo -> FileInfo -> Bool)
-> (FileInfo -> FileInfo -> Bool) -> Eq FileInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FileInfo -> FileInfo -> Bool
== :: FileInfo -> FileInfo -> Bool
$c/= :: FileInfo -> FileInfo -> Bool
/= :: FileInfo -> FileInfo -> Bool
Eq, Int -> FileInfo -> ShowS
[FileInfo] -> ShowS
FileInfo -> FilePath
(Int -> FileInfo -> ShowS)
-> (FileInfo -> FilePath) -> ([FileInfo] -> ShowS) -> Show FileInfo
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FileInfo -> ShowS
showsPrec :: Int -> FileInfo -> ShowS
$cshow :: FileInfo -> FilePath
show :: FileInfo -> FilePath
$cshowList :: [FileInfo] -> ShowS
showList :: [FileInfo] -> ShowS
Show)

data Entry = Negative | Positive FileInfo
type Cache = HashMap Entry
type FileInfoCache = Reaper Cache (FilePath, Entry)

----------------------------------------------------------------

-- | Getting the file information corresponding to the file.
getInfo :: FilePath -> IO FileInfo
getInfo :: FilePath -> IO FileInfo
getInfo FilePath
path = do
    FileStatus
fs <- FilePath -> IO FileStatus
getFileStatus FilePath
path -- file access
    let regular :: Bool
regular = Bool -> Bool
not (FileStatus -> Bool
isDirectory FileStatus
fs)
        readable :: Bool
readable = FileStatus -> FileMode
fileMode FileStatus
fs FileMode -> FileMode -> FileMode
`intersectFileModes` FileMode
ownerReadMode FileMode -> FileMode -> Bool
forall a. Eq a => a -> a -> Bool
/= FileMode
0
    if Bool
regular Bool -> Bool -> Bool
&& Bool
readable
        then do
            let time :: HTTPDate
time = EpochTime -> HTTPDate
epochTimeToHTTPDate (EpochTime -> HTTPDate) -> EpochTime -> HTTPDate
forall a b. (a -> b) -> a -> b
$ FileStatus -> EpochTime
modificationTime FileStatus
fs
                date :: ByteString
date = HTTPDate -> ByteString
formatHTTPDate HTTPDate
time
                size :: Integer
size = 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
                info :: FileInfo
info =
                    FileInfo
                        { fileInfoName :: FilePath
fileInfoName = FilePath
path
                        , fileInfoSize :: Integer
fileInfoSize = Integer
size
                        , fileInfoTime :: HTTPDate
fileInfoTime = HTTPDate
time
                        , fileInfoDate :: ByteString
fileInfoDate = ByteString
date
                        }
            FileInfo -> IO FileInfo
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FileInfo
info
        else IOError -> IO FileInfo
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
UnliftIO.throwIO (FilePath -> IOError
userError FilePath
"FileInfoCache:getInfo")

getInfoNaive :: FilePath -> IO FileInfo
getInfoNaive :: FilePath -> IO FileInfo
getInfoNaive = FilePath -> IO FileInfo
getInfo

----------------------------------------------------------------

getAndRegisterInfo :: FileInfoCache -> FilePath -> IO FileInfo
getAndRegisterInfo :: FileInfoCache -> FilePath -> IO FileInfo
getAndRegisterInfo FileInfoCache
reaper FilePath
path = do
    Cache
cache <- FileInfoCache -> IO Cache
forall workload item. Reaper workload item -> IO workload
reaperRead FileInfoCache
reaper
    case FilePath -> Cache -> Maybe Entry
forall v. FilePath -> HashMap v -> Maybe v
M.lookup FilePath
path Cache
cache of
        Just Entry
Negative -> IOError -> IO FileInfo
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
UnliftIO.throwIO (FilePath -> IOError
userError FilePath
"FileInfoCache:getAndRegisterInfo")
        Just (Positive FileInfo
x) -> FileInfo -> IO FileInfo
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FileInfo
x
        Maybe Entry
Nothing ->
            FileInfoCache -> FilePath -> IO FileInfo
positive FileInfoCache
reaper FilePath
path
                IO FileInfo -> IO FileInfo -> IO FileInfo
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`UnliftIO.onException` FileInfoCache -> FilePath -> IO FileInfo
negative FileInfoCache
reaper FilePath
path

positive :: FileInfoCache -> FilePath -> IO FileInfo
positive :: FileInfoCache -> FilePath -> IO FileInfo
positive FileInfoCache
reaper FilePath
path = do
    FileInfo
info <- FilePath -> IO FileInfo
getInfo FilePath
path
    FileInfoCache -> (FilePath, Entry) -> IO ()
forall workload item. Reaper workload item -> item -> IO ()
reaperAdd FileInfoCache
reaper (FilePath
path, FileInfo -> Entry
Positive FileInfo
info)
    FileInfo -> IO FileInfo
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FileInfo
info

negative :: FileInfoCache -> FilePath -> IO FileInfo
negative :: FileInfoCache -> FilePath -> IO FileInfo
negative FileInfoCache
reaper FilePath
path = do
    FileInfoCache -> (FilePath, Entry) -> IO ()
forall workload item. Reaper workload item -> item -> IO ()
reaperAdd FileInfoCache
reaper (FilePath
path, Entry
Negative)
    IOError -> IO FileInfo
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
UnliftIO.throwIO (FilePath -> IOError
userError FilePath
"FileInfoCache:negative")

----------------------------------------------------------------

-- | Creating a file information cache
--   and executing the action in the second argument.
--   The first argument is a cache duration in second.
withFileInfoCache
    :: Int
    -> ((FilePath -> IO FileInfo) -> IO a)
    -> IO a
withFileInfoCache :: forall a. Int -> ((FilePath -> IO FileInfo) -> IO a) -> IO a
withFileInfoCache Int
0 (FilePath -> IO FileInfo) -> IO a
action = (FilePath -> IO FileInfo) -> IO a
action FilePath -> IO FileInfo
getInfoNaive
withFileInfoCache Int
duration (FilePath -> IO FileInfo) -> IO a
action =
    IO FileInfoCache
-> (FileInfoCache -> IO ()) -> (FileInfoCache -> IO a) -> IO a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
UnliftIO.bracket
        (Int -> IO FileInfoCache
initialize Int
duration)
        FileInfoCache -> IO ()
terminate
        ((FilePath -> IO FileInfo) -> IO a
action ((FilePath -> IO FileInfo) -> IO a)
-> (FileInfoCache -> FilePath -> IO FileInfo)
-> FileInfoCache
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileInfoCache -> FilePath -> IO FileInfo
getAndRegisterInfo)

initialize :: Int -> IO FileInfoCache
initialize :: Int -> IO FileInfoCache
initialize Int
duration = ReaperSettings Cache (FilePath, Entry) -> IO FileInfoCache
forall workload item.
ReaperSettings workload item -> IO (Reaper workload item)
mkReaper ReaperSettings Cache (FilePath, Entry)
settings
  where
    settings :: ReaperSettings Cache (FilePath, Entry)
settings =
        ReaperSettings [Any] Any
forall item. ReaperSettings [item] item
defaultReaperSettings
            { reaperAction = override
            , reaperDelay = duration
            , reaperCons = \(FilePath
path, Entry
v) -> FilePath -> Entry -> Cache -> Cache
forall v. FilePath -> v -> HashMap v -> HashMap v
M.insert FilePath
path Entry
v
            , reaperNull = M.isEmpty
            , reaperEmpty = M.empty
            }

override :: Cache -> IO (Cache -> Cache)
override :: Cache -> IO (Cache -> Cache)
override Cache
_ = (Cache -> Cache) -> IO (Cache -> Cache)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Cache -> Cache) -> IO (Cache -> Cache))
-> (Cache -> Cache) -> IO (Cache -> Cache)
forall a b. (a -> b) -> a -> b
$ Cache -> Cache -> Cache
forall a b. a -> b -> a
const Cache
forall v. HashMap v
M.empty

terminate :: FileInfoCache -> IO ()
terminate :: FileInfoCache -> IO ()
terminate FileInfoCache
x = IO Cache -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Cache -> IO ()) -> IO Cache -> IO ()
forall a b. (a -> b) -> a -> b
$ FileInfoCache -> IO Cache
forall workload item. Reaper workload item -> IO workload
reaperStop FileInfoCache
x