{-# 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
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
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 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 forall a b. (a -> b) -> a -> b
$ FileStatus -> EpochTime
modificationTime FileStatus
fs
            date :: ByteString
date = HTTPDate -> ByteString
formatHTTPDate HTTPDate
time
            size :: Integer
size = forall a b. (Integral a, Num b) => a -> b
fromIntegral 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
              }
        forall (m :: * -> *) a. Monad m => a -> m a
return FileInfo
info
      else
        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 forall v. FilePath -> HashMap v -> Maybe v
M.lookup FilePath
path Cache
cache of
        Just Entry
Negative     -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
UnliftIO.throwIO (FilePath -> IOError
userError FilePath
"FileInfoCache:getAndRegisterInfo")
        Just (Positive FileInfo
x) -> forall (m :: * -> *) a. Monad m => a -> m a
return FileInfo
x
        Maybe Entry
Nothing           -> FileInfoCache -> FilePath -> IO FileInfo
positive FileInfoCache
reaper FilePath
path
                               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)
    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)
    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 =
    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 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 = forall workload item.
ReaperSettings workload item -> IO (Reaper workload item)
mkReaper ReaperSettings Cache (FilePath, Entry)
settings
  where
    settings :: ReaperSettings Cache (FilePath, Entry)
settings = 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) -> forall v. FilePath -> v -> HashMap v -> HashMap v
M.insert FilePath
path Entry
v
      , reaperNull :: Cache -> Bool
reaperNull   = forall v. HashMap v -> Bool
M.isEmpty
      , reaperEmpty :: Cache
reaperEmpty  = forall v. HashMap v
M.empty
      }

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

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