module Network.Wai.Handler.Warp.FdCache (
initialize
, getFd
, MutableFdCache
) where
import Control.Applicative ((<$>), (<*>))
import Control.Concurrent
import Control.Monad
import Data.Hashable
import Data.IORef
import Network.Wai.Handler.Warp.MultiMap
import System.Posix.IO
import System.Posix.Types
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
<*> newActiveStatus
type Hash = Int
type FdCache = MMap Hash FdEntry
newtype MutableFdCache = MutableFdCache (IORef FdCache)
newMutableFdCache :: IO MutableFdCache
newMutableFdCache = MutableFdCache <$> newIORef empty
fdCache :: MutableFdCache -> IO FdCache
fdCache (MutableFdCache ref) = readIORef ref
swapWithNew :: MutableFdCache -> IO FdCache
swapWithNew (MutableFdCache ref) = atomicModifyIORef ref (\t -> (empty, t))
update :: MutableFdCache -> (FdCache -> FdCache) -> IO ()
update (MutableFdCache ref) f = do
!_ <- atomicModifyIORef ref $ \t -> let !new = f t in (new, ())
return ()
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
initialize :: Int -> IO MutableFdCache
initialize duration = do
mfc <- newMutableFdCache
void . forkIO $ loop mfc
return mfc
where
loop mfc = do
old <- swapWithNew mfc
new <- pruneWith old prune
update mfc (merge new)
threadDelay duration
loop mfc
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
getFd :: MutableFdCache -> FilePath -> IO (Fd, Refresh)
getFd mfc path = look mfc path key >>= getFd'
where
key = hash path
getFd' Nothing = do
ent@(FdEntry _ fd mst) <- newFdEntry path
update mfc (insert key ent)
return (fd, refresh mst)
getFd' (Just (FdEntry _ fd mst)) = do
refresh mst
return (fd, refresh mst)