#ifdef WINDOWS
module Network.Wai.Handler.Warp.FdCache (
withFdCache
, MutableFdCache
, Refresh
) where
type Refresh = IO ()
type MutableFdCache = ()
withFdCache :: Int -> (Maybe MutableFdCache -> IO a) -> IO a
withFdCache _ f = f Nothing
#else
module Network.Wai.Handler.Warp.FdCache (
withFdCache
, getFd
, getFd'
, MutableFdCache
, Refresh
) where
#if __GLASGOW_HASKELL__ < 709
import Control.Applicative ((<$>), (<*>))
#endif
import Control.Exception (bracket)
import Data.Hashable (hash)
import Network.Wai.Handler.Warp.IORef
import Network.Wai.Handler.Warp.MultiMap
import System.Posix.IO (openFd, OpenFileFlags(..), defaultFileFlags, OpenMode(ReadOnly), closeFd)
import System.Posix.Types (Fd)
import Control.Reaper
data Status = Active | Inactive
newtype MutableStatus = MutableStatus (IORef Status)
type Refresh = IO ()
status :: MutableStatus -> IO Status
status (MutableStatus ref) = readIORef ref
newActiveStatus :: IO MutableStatus
newActiveStatus = MutableStatus <$> newIORef Active
refresh :: MutableStatus -> Refresh
refresh (MutableStatus ref) = writeIORef ref Active
inactive :: MutableStatus -> IO ()
inactive (MutableStatus ref) = writeIORef ref Inactive
data FdEntry = FdEntry !FilePath !Fd !MutableStatus
newFdEntry :: FilePath -> IO FdEntry
newFdEntry path = FdEntry path
<$> openFd path ReadOnly Nothing defaultFileFlags{nonBlock=True}
<*> newActiveStatus
type Hash = Int
type FdCache = MMap Hash FdEntry
newtype MutableFdCache = MutableFdCache (Reaper FdCache (Hash, FdEntry))
fdCache :: MutableFdCache -> IO FdCache
fdCache (MutableFdCache reaper) = reaperRead reaper
look :: MutableFdCache -> FilePath -> Hash -> IO (Maybe FdEntry)
look mfc path key = searchWith key check <$> fdCache mfc
where
check (One ent@(FdEntry path' _ _))
| path == path' = Just ent
| otherwise = Nothing
check (Tom ent@(FdEntry path' _ _) vs)
| path == path' = Just ent
| otherwise = check vs
withFdCache :: Int -> (Maybe MutableFdCache -> IO a) -> IO a
withFdCache duration action = bracket (initialize duration)
terminate
action
initialize :: Int -> IO (Maybe MutableFdCache)
initialize 0 = return Nothing
initialize duration = Just . MutableFdCache <$> mkReaper defaultReaperSettings
{ reaperAction = clean
, reaperDelay = duration
, reaperCons = uncurry insert
, reaperNull = isEmpty
, reaperEmpty = empty
}
clean :: FdCache -> IO (FdCache -> FdCache)
clean old = do
new <- pruneWith old prune
return $ merge new
prune :: t -> Some FdEntry -> IO [(t, Some FdEntry)]
prune k v@(One (FdEntry _ fd mst)) = status mst >>= prune'
where
prune' Active = inactive mst >> return [(k,v)]
prune' Inactive = closeFd fd >> return []
prune k (Tom ent@(FdEntry _ fd mst) vs) = status mst >>= prune'
where
prune' Active = do
inactive mst
zs <- prune k vs
case zs of
[] -> return [(k,One ent)]
[(_,zvs)] -> return [(k,Tom ent zvs)]
_ -> error "prune"
prune' Inactive = closeFd fd >> prune k vs
terminate :: Maybe MutableFdCache -> IO ()
terminate Nothing = return ()
terminate (Just (MutableFdCache reaper)) = do
!t <- reaperStop reaper
mapM_ closeIt $ toList t
where
closeIt (_, FdEntry _ fd _) = closeFd fd
getFd :: MutableFdCache -> FilePath -> IO (Fd, Refresh)
getFd mfc path = getFd' mfc (hash path) path
getFd' :: MutableFdCache -> Hash -> FilePath -> IO (Fd, Refresh)
getFd' mfc@(MutableFdCache reaper) h path = look mfc path h >>= get
where
get Nothing = do
ent@(FdEntry _ fd mst) <- newFdEntry path
reaperAdd reaper (h, ent)
return (fd, refresh mst)
get (Just (FdEntry _ fd mst)) = do
refresh mst
return (fd, refresh mst)
#endif