    {-# 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 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 <- openFd path ReadOnly defaultFileFlags{nonBlock=False}
    #else
        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}
    #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 :: 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 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