{-# LANGUAGE BangPatterns, CPP #-}

-- | File descriptor cache to avoid locks in kernel.

module Network.Wai.Handler.Warp.FdCache (
    withFdCache
  , Fd
  , Refresh
#ifndef WINDOWS
  , openFile
  , closeFile
  , setFileCloseOnExec
#endif
  ) where

#ifndef WINDOWS
import UnliftIO.Exception (bracket)
import Control.Reaper
import Data.IORef
import Network.Wai.Handler.Warp.MultiMap as MM
import System.Posix.IO (openFd, OpenFileFlags(..), defaultFileFlags, OpenMode(ReadOnly), closeFd, FdOption(CloseOnExec), setFdOption)
#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 (m :: * -> *) a. Monad m => a -> m a
return (Maybe Fd
forall a. Maybe a
Nothing, () -> Refresh
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 :: 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
    Fd
fd <- FilePath -> OpenMode -> Maybe FileMode -> OpenFileFlags -> IO Fd
openFd FilePath
path OpenMode
ReadOnly Maybe FileMode
forall a. Maybe a
Nothing OpenFileFlags
defaultFileFlags{nonBlock :: Bool
nonBlock=Bool
False}
    Fd -> Refresh
setFileCloseOnExec Fd
fd
    Fd -> IO Fd
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 (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 :: FdCache -> IO (FdCache -> FdCache)
reaperAction = FdCache -> IO (FdCache -> FdCache)
clean
      , reaperDelay :: Int
reaperDelay = Int
duration
      , reaperCons :: (FilePath, FdEntry) -> FdCache -> FdCache
reaperCons = (FilePath -> FdEntry -> FdCache -> FdCache)
-> (FilePath, FdEntry) -> FdCache -> FdCache
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry FilePath -> FdEntry -> FdCache -> FdCache
forall v. FilePath -> v -> MultiMap v -> MultiMap v
insert
      , reaperNull :: FdCache -> Bool
reaperNull = FdCache -> Bool
forall v. MultiMap v -> Bool
isEmpty
      , reaperEmpty :: FdCache
reaperEmpty = FdCache
forall v. MultiMap v
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 (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 (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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
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 (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 (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 (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