{-# 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
_ = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, 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 = 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 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) = forall a. IORef a -> IO a
readIORef IORef Status
ref

newActiveStatus :: IO MutableStatus
newActiveStatus :: IO MutableStatus
newActiveStatus = IORef Status -> MutableStatus
MutableStatus forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (IORef a)
newIORef Status
Active

refresh :: MutableStatus -> Refresh
refresh :: MutableStatus -> Refresh
refresh (MutableStatus IORef Status
ref) = forall a. IORef a -> a -> Refresh
writeIORef IORef Status
ref Status
Active

inactive :: MutableStatus -> IO ()
inactive :: MutableStatus -> Refresh
inactive (MutableStatus IORef Status
ref) = 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 <- openFd path ReadOnly defaultFileFlags{nonBlock=False}
#else
    Fd
fd <- FilePath -> OpenMode -> Maybe FileMode -> OpenFileFlags -> IO Fd
openFd FilePath
path OpenMode
ReadOnly forall a. Maybe a
Nothing OpenFileFlags
defaultFileFlags{nonBlock :: Bool
nonBlock=Bool
False}
#endif
    Fd -> Refresh
setFileCloseOnExec Fd
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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Fd
openFile FilePath
path 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) = 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 = forall v. FilePath -> MultiMap v -> Maybe v
MM.lookup FilePath
path 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall workload item.
ReaperSettings workload item -> IO (Reaper workload item)
mkReaper ReaperSettings FdCache (FilePath, FdEntry)
settings
  where
    settings :: ReaperSettings FdCache (FilePath, FdEntry)
settings = 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 = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall v. FilePath -> v -> MultiMap v -> MultiMap v
insert
      , reaperNull :: FdCache -> Bool
reaperNull = forall v. MultiMap v -> Bool
isEmpty
      , reaperEmpty :: FdCache
reaperEmpty = forall v. MultiMap v
empty
      }

clean :: FdCache -> IO (FdCache -> FdCache)
clean :: FdCache -> IO (FdCache -> FdCache)
clean FdCache
old = do
    FdCache
new <- forall v.
MultiMap v -> ((FilePath, v) -> IO Bool) -> IO (MultiMap v)
pruneWith FdCache
old forall {a}. (a, FdEntry) -> IO Bool
prune
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        act Status
Inactive = Fd -> Refresh
closeFd Fd
fd   forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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 <- forall workload item. Reaper workload item -> IO workload
reaperStop Reaper FdCache (FilePath, FdEntry)
reaper
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (FdEntry -> Refresh
closeIt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ 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 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
        forall workload item. Reaper workload item -> item -> Refresh
reaperAdd Reaper FdCache (FilePath, FdEntry)
reaper (FilePath
path,FdEntry
ent)
        forall (m :: * -> *) a. Monad m => a -> m a
return (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
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Fd
fd, MutableStatus -> Refresh
refresh MutableStatus
mst)
#endif