{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}

-- | File descriptor cache to avoid locks in kernel.
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)

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

-- | An action to activate a Fd cache entry.
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 ())

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

-- | Creating 'MutableFdCache' and executing the action in the second
--   argument. The first argument is a cache duration in second.
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

-- | Mutable Fd cacher.
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

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

-- The first argument is a cache duration in second.
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

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

-- | Getting 'Fd' and 'Refresh' from the mutable Fd cacher.
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