{-# LANGUAGE RecordWildCards, CPP #-}

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

import qualified UnliftIO (onException, bracket, throwIO)
import Control.Reaper
import Network.HTTP.Date
import System.PosixCompat.Files

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
/= :: FileInfo -> FileInfo -> Bool
$c/= :: FileInfo -> FileInfo -> Bool
== :: FileInfo -> FileInfo -> Bool
$c== :: 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
showList :: [FileInfo] -> ShowS
$cshowList :: [FileInfo] -> ShowS
show :: FileInfo -> FilePath
$cshow :: FileInfo -> FilePath
showsPrec :: Int -> FileInfo -> ShowS
$cshowsPrec :: Int -> 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 :: FilePath -> Integer -> HTTPDate -> ByteString -> FileInfo
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 (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 :: 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 ()
reaperKill :: IO ()
reaperStop :: IO Cache
reaperRead :: IO Cache
reaperAdd :: (FilePath, Entry) -> 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 (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 ()
reaperKill :: IO ()
reaperStop :: IO Cache
reaperRead :: IO Cache
reaperAdd :: (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 ()
..} 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 (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 ()
reaperKill :: IO ()
reaperStop :: IO Cache
reaperRead :: IO Cache
reaperAdd :: (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 ()
..} 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")

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

-- | 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 :: 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 :: Cache -> IO (Cache -> Cache)
reaperAction = Cache -> IO (Cache -> Cache)
override
      , reaperDelay :: Int
reaperDelay  = Int
duration
      , reaperCons :: (FilePath, Entry) -> Cache -> Cache
reaperCons   = \(FilePath
path,Entry
v) -> FilePath -> Entry -> Cache -> Cache
forall v. FilePath -> v -> HashMap v -> HashMap v
M.insert FilePath
path Entry
v
      , reaperNull :: Cache -> Bool
reaperNull   = Cache -> Bool
forall v. HashMap v -> Bool
M.isEmpty
      , reaperEmpty :: Cache
reaperEmpty  = Cache
forall v. HashMap v
M.empty
      }

override :: Cache -> IO (Cache -> Cache)
override :: Cache -> IO (Cache -> Cache)
override Cache
_ = (Cache -> Cache) -> IO (Cache -> Cache)
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