{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
module Network.Wai.Handler.Warp.FdCache (
withFdCache,
Fd,
Refresh,
#ifndef WINDOWS
closeFile,
openFile,
setFileCloseOnExec,
#endif
) where
#ifndef WINDOWS
import Control.Reaper
import Data.IORef
import Network.Wai.Handler.Warp.MultiMap as MM
import System.Posix.IO (
FdOption (CloseOnExec),
OpenFileFlags (..),
OpenMode (ReadOnly),
closeFd,
defaultFileFlags,
openFd,
setFdOption,
)
import UnliftIO.Exception (bracket)
#endif
import System.Posix.Types (Fd)
type Refresh = IO ()
getFdNothing :: FilePath -> IO (Maybe Fd, Refresh)
getFdNothing :: FilePath -> IO (Maybe Fd, Refresh)
getFdNothing FilePath
_ = (Maybe Fd, Refresh) -> IO (Maybe Fd, Refresh)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Fd
forall a. Maybe a
Nothing, () -> Refresh
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
withFdCache :: Int -> ((FilePath -> IO (Maybe Fd, Refresh)) -> IO a) -> IO a
#ifdef WINDOWS
withFdCache _ action = action getFdNothing
#else
withFdCache :: forall a.
Int -> ((FilePath -> IO (Maybe Fd, Refresh)) -> IO a) -> IO a
withFdCache Int
0 (FilePath -> IO (Maybe Fd, Refresh)) -> IO a
action = (FilePath -> IO (Maybe Fd, Refresh)) -> IO a
action FilePath -> IO (Maybe Fd, Refresh)
getFdNothing
withFdCache Int
duration (FilePath -> IO (Maybe Fd, Refresh)) -> IO a
action =
IO MutableFdCache
-> (MutableFdCache -> Refresh) -> (MutableFdCache -> IO a) -> IO a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
(Int -> IO MutableFdCache
initialize Int
duration)
MutableFdCache -> Refresh
terminate
((FilePath -> IO (Maybe Fd, Refresh)) -> IO a
action ((FilePath -> IO (Maybe Fd, Refresh)) -> IO a)
-> (MutableFdCache -> FilePath -> IO (Maybe Fd, Refresh))
-> MutableFdCache
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MutableFdCache -> FilePath -> IO (Maybe Fd, Refresh)
getFd)
data Status = Active | Inactive
newtype MutableStatus = MutableStatus (IORef Status)
status :: MutableStatus -> IO Status
status :: MutableStatus -> IO Status
status (MutableStatus IORef Status
ref) = IORef Status -> IO Status
forall a. IORef a -> IO a
readIORef IORef Status
ref
newActiveStatus :: IO MutableStatus
newActiveStatus :: IO MutableStatus
newActiveStatus = IORef Status -> MutableStatus
MutableStatus (IORef Status -> MutableStatus)
-> IO (IORef Status) -> IO MutableStatus
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Status -> IO (IORef Status)
forall a. a -> IO (IORef a)
newIORef Status
Active
refresh :: MutableStatus -> Refresh
refresh :: MutableStatus -> Refresh
refresh (MutableStatus IORef Status
ref) = IORef Status -> Status -> Refresh
forall a. IORef a -> a -> Refresh
writeIORef IORef Status
ref Status
Active
inactive :: MutableStatus -> IO ()
inactive :: MutableStatus -> Refresh
inactive (MutableStatus IORef Status
ref) = IORef Status -> Status -> Refresh
forall a. IORef a -> a -> Refresh
writeIORef IORef Status
ref Status
Inactive
data FdEntry = FdEntry !Fd !MutableStatus
openFile :: FilePath -> IO Fd
openFile :: FilePath -> IO Fd
openFile FilePath
path = do
#if MIN_VERSION_unix(2,8,0)
Fd
fd <- FilePath -> OpenMode -> OpenFileFlags -> IO Fd
openFd FilePath
path OpenMode
ReadOnly OpenFileFlags
defaultFileFlags{nonBlock = False}
#else
fd <- openFd path ReadOnly Nothing defaultFileFlags{nonBlock = False}
#endif
Fd -> Refresh
setFileCloseOnExec Fd
fd
Fd -> IO Fd
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Fd
fd
closeFile :: Fd -> IO ()
closeFile :: Fd -> Refresh
closeFile = Fd -> Refresh
closeFd
newFdEntry :: FilePath -> IO FdEntry
newFdEntry :: FilePath -> IO FdEntry
newFdEntry FilePath
path = Fd -> MutableStatus -> FdEntry
FdEntry (Fd -> MutableStatus -> FdEntry)
-> IO Fd -> IO (MutableStatus -> FdEntry)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Fd
openFile FilePath
path IO (MutableStatus -> FdEntry) -> IO MutableStatus -> IO FdEntry
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO MutableStatus
newActiveStatus
setFileCloseOnExec :: Fd -> IO ()
setFileCloseOnExec :: Fd -> Refresh
setFileCloseOnExec Fd
fd = Fd -> FdOption -> Bool -> Refresh
setFdOption Fd
fd FdOption
CloseOnExec Bool
True
type FdCache = MultiMap FdEntry
newtype MutableFdCache = MutableFdCache (Reaper FdCache (FilePath, FdEntry))
fdCache :: MutableFdCache -> IO FdCache
fdCache :: MutableFdCache -> IO FdCache
fdCache (MutableFdCache Reaper FdCache (FilePath, FdEntry)
reaper) = Reaper FdCache (FilePath, FdEntry) -> IO FdCache
forall workload item. Reaper workload item -> IO workload
reaperRead Reaper FdCache (FilePath, FdEntry)
reaper
look :: MutableFdCache -> FilePath -> IO (Maybe FdEntry)
look :: MutableFdCache -> FilePath -> IO (Maybe FdEntry)
look MutableFdCache
mfc FilePath
path = FilePath -> FdCache -> Maybe FdEntry
forall v. FilePath -> MultiMap v -> Maybe v
MM.lookup FilePath
path (FdCache -> Maybe FdEntry) -> IO FdCache -> IO (Maybe FdEntry)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MutableFdCache -> IO FdCache
fdCache MutableFdCache
mfc
initialize :: Int -> IO MutableFdCache
initialize :: Int -> IO MutableFdCache
initialize Int
duration = Reaper FdCache (FilePath, FdEntry) -> MutableFdCache
MutableFdCache (Reaper FdCache (FilePath, FdEntry) -> MutableFdCache)
-> IO (Reaper FdCache (FilePath, FdEntry)) -> IO MutableFdCache
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaperSettings FdCache (FilePath, FdEntry)
-> IO (Reaper FdCache (FilePath, FdEntry))
forall workload item.
ReaperSettings workload item -> IO (Reaper workload item)
mkReaper ReaperSettings FdCache (FilePath, FdEntry)
settings
where
settings :: ReaperSettings FdCache (FilePath, FdEntry)
settings =
ReaperSettings [Any] Any
forall item. ReaperSettings [item] item
defaultReaperSettings
{ reaperAction = clean
, reaperDelay = duration
, reaperCons = uncurry insert
, reaperNull = isEmpty
, reaperEmpty = empty
}
clean :: FdCache -> IO (FdCache -> FdCache)
clean :: FdCache -> IO (FdCache -> FdCache)
clean FdCache
old = do
FdCache
new <- FdCache -> ((FilePath, FdEntry) -> IO Bool) -> IO FdCache
forall v.
MultiMap v -> ((FilePath, v) -> IO Bool) -> IO (MultiMap v)
pruneWith FdCache
old (FilePath, FdEntry) -> IO Bool
forall {a}. (a, FdEntry) -> IO Bool
prune
(FdCache -> FdCache) -> IO (FdCache -> FdCache)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((FdCache -> FdCache) -> IO (FdCache -> FdCache))
-> (FdCache -> FdCache) -> IO (FdCache -> FdCache)
forall a b. (a -> b) -> a -> b
$ FdCache -> FdCache -> FdCache
forall v. MultiMap v -> MultiMap v -> MultiMap v
merge FdCache
new
where
prune :: (a, FdEntry) -> IO Bool
prune (a
_, FdEntry Fd
fd MutableStatus
mst) = MutableStatus -> IO Status
status MutableStatus
mst IO Status -> (Status -> IO Bool) -> IO Bool
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Status -> IO Bool
act
where
act :: Status -> IO Bool
act Status
Active = MutableStatus -> Refresh
inactive MutableStatus
mst Refresh -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
act Status
Inactive = Fd -> Refresh
closeFd Fd
fd Refresh -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
terminate :: MutableFdCache -> IO ()
terminate :: MutableFdCache -> Refresh
terminate (MutableFdCache Reaper FdCache (FilePath, FdEntry)
reaper) = do
!FdCache
t <- Reaper FdCache (FilePath, FdEntry) -> IO FdCache
forall workload item. Reaper workload item -> IO workload
reaperStop Reaper FdCache (FilePath, FdEntry)
reaper
((FilePath, FdEntry) -> Refresh)
-> [(FilePath, FdEntry)] -> Refresh
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (FdEntry -> Refresh
closeIt (FdEntry -> Refresh)
-> ((FilePath, FdEntry) -> FdEntry)
-> (FilePath, FdEntry)
-> Refresh
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath, FdEntry) -> FdEntry
forall a b. (a, b) -> b
snd) ([(FilePath, FdEntry)] -> Refresh)
-> [(FilePath, FdEntry)] -> Refresh
forall a b. (a -> b) -> a -> b
$ FdCache -> [(FilePath, FdEntry)]
forall v. MultiMap v -> [(FilePath, v)]
toList FdCache
t
where
closeIt :: FdEntry -> Refresh
closeIt (FdEntry Fd
fd MutableStatus
_) = Fd -> Refresh
closeFd Fd
fd
getFd :: MutableFdCache -> FilePath -> IO (Maybe Fd, Refresh)
getFd :: MutableFdCache -> FilePath -> IO (Maybe Fd, Refresh)
getFd mfc :: MutableFdCache
mfc@(MutableFdCache Reaper FdCache (FilePath, FdEntry)
reaper) FilePath
path = MutableFdCache -> FilePath -> IO (Maybe FdEntry)
look MutableFdCache
mfc FilePath
path IO (Maybe FdEntry)
-> (Maybe FdEntry -> IO (Maybe Fd, Refresh))
-> IO (Maybe Fd, Refresh)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe FdEntry -> IO (Maybe Fd, Refresh)
get
where
get :: Maybe FdEntry -> IO (Maybe Fd, Refresh)
get Maybe FdEntry
Nothing = do
ent :: FdEntry
ent@(FdEntry Fd
fd MutableStatus
mst) <- FilePath -> IO FdEntry
newFdEntry FilePath
path
Reaper FdCache (FilePath, FdEntry)
-> (FilePath, FdEntry) -> Refresh
forall workload item. Reaper workload item -> item -> Refresh
reaperAdd Reaper FdCache (FilePath, FdEntry)
reaper (FilePath
path, FdEntry
ent)
(Maybe Fd, Refresh) -> IO (Maybe Fd, Refresh)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Fd -> Maybe Fd
forall a. a -> Maybe a
Just Fd
fd, MutableStatus -> Refresh
refresh MutableStatus
mst)
get (Just (FdEntry Fd
fd MutableStatus
mst)) = do
MutableStatus -> Refresh
refresh MutableStatus
mst
(Maybe Fd, Refresh) -> IO (Maybe Fd, Refresh)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Fd -> Maybe Fd
forall a. a -> Maybe a
Just Fd
fd, MutableStatus -> Refresh
refresh MutableStatus
mst)
#endif