{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
module Network.Wai.Handler.Warp.FileInfoCache (
FileInfo (..),
withFileInfoCache,
getInfo,
) 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
data FileInfo = FileInfo
{ FileInfo -> FilePath
fileInfoName :: !FilePath
, FileInfo -> Integer
fileInfoSize :: !Integer
, FileInfo -> HTTPDate
fileInfoTime :: HTTPDate
, FileInfo -> ByteString
fileInfoDate :: ByteString
}
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)
getInfo :: FilePath -> IO FileInfo
getInfo :: FilePath -> IO FileInfo
getInfo FilePath
path = do
FileStatus
fs <- FilePath -> IO FileStatus
getFileStatus FilePath
path
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 reaper :: FileInfoCache
reaper@Reaper{IO ()
IO Cache
(FilePath, Entry) -> IO ()
reaperAdd :: (FilePath, Entry) -> IO ()
reaperRead :: IO Cache
reaperStop :: IO Cache
reaperKill :: IO ()
reaperAdd :: forall workload item. Reaper workload item -> item -> IO ()
reaperRead :: forall workload item. Reaper workload item -> IO workload
reaperStop :: forall workload item. Reaper workload item -> IO workload
reaperKill :: forall workload item. Reaper workload item -> IO ()
..} FilePath
path = do
Cache
cache <- IO Cache
reaperRead
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 Reaper{IO ()
IO Cache
(FilePath, Entry) -> IO ()
reaperAdd :: forall workload item. Reaper workload item -> item -> IO ()
reaperRead :: forall workload item. Reaper workload item -> IO workload
reaperStop :: forall workload item. Reaper workload item -> IO workload
reaperKill :: forall workload item. Reaper workload item -> IO ()
reaperAdd :: (FilePath, Entry) -> IO ()
reaperRead :: IO Cache
reaperStop :: IO Cache
reaperKill :: IO ()
..} FilePath
path = do
FileInfo
info <- FilePath -> IO FileInfo
getInfo FilePath
path
(FilePath, Entry) -> IO ()
reaperAdd (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 Reaper{IO ()
IO Cache
(FilePath, Entry) -> IO ()
reaperAdd :: forall workload item. Reaper workload item -> item -> IO ()
reaperRead :: forall workload item. Reaper workload item -> IO workload
reaperStop :: forall workload item. Reaper workload item -> IO workload
reaperKill :: forall workload item. Reaper workload item -> IO ()
reaperAdd :: (FilePath, Entry) -> IO ()
reaperRead :: IO Cache
reaperStop :: IO Cache
reaperKill :: IO ()
..} FilePath
path = do
(FilePath, Entry) -> IO ()
reaperAdd (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")
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