@@ -23,14 +23,14 @@ module Network.Wai.Handler.Warp.FdCache (
2323 ) where
2424
2525import Control.Applicative ((<$>), (<*>))
26−import Control.Concurrent (threadDelay)
27−import Control.Exception (bracket, mask_)
26+import Control.Exception (bracket)
2827import Data.Hashable (hash)
2928import Network.Wai.Handler.Warp.IORef
3029import Network.Wai.Handler.Warp.MultiMap
31−import Network.Wai.Handler.Warp.Thread
3230import System.Posix.IO (openFd, OpenFileFlags(..), defaultFileFlags, OpenMode(ReadOnly), closeFd)
3331import System.Posix.Types (Fd)
32+import Control.Reaper
33+import Data.Maybe (fromMaybe)
3434
3535----------------------------------------------------------------
3636
@@ -68,19 +68,12 @@ type Hash = Int
6868type FdCache = MMap Hash FdEntry
6969
7070-- | Mutable Fd cacher.
71−newtype MutableFdCache = MutableFdCache (IORef FdCache)
71+data MutableFdCache = MutableFdCache
72+ ((Hash, FdEntry) -> IO ())
73+ (IORef (Maybe FdCache))
7274
7375fdCache :: MutableFdCache -> IO FdCache
74−fdCache (MutableFdCache ref) = readIORef ref
75−
76−swapWithNew :: IORef FdCache -> IO FdCache
77−swapWithNew ref = atomicModifyIORef' ref $ \t -> (empty, t)
78−
79−update :: MutableFdCache -> (FdCache -> FdCache) -> IO ()
80−update (MutableFdCache ref) = update' ref
81−
82−update' :: IORef FdCache -> (FdCache -> FdCache) -> IO ()
83−update' ref f = atomicModifyIORef' ref $ \t -> (f t, ())
76+fdCache (MutableFdCache _ ref) = fromMaybe empty <$> readIORef ref
8477
8578look :: MutableFdCache -> FilePath -> Hash -> IO (Maybe FdEntry)
8679look mfc path key = searchWith key check <$> fdCache mfc
@@ -106,17 +99,19 @@ withFdCache duration action = bracket (initialize duration)
10699-- The first argument is a cache duration in second.
107100initialize :: Int -> IO (Maybe MutableFdCache)
108101initialize 0 = return Nothing
109−initialize duration = do
110− ref' <- forkIOwithBreakableForever empty $ \ref -> do
111− threadDelay duration
112− clean ref
113− return (Just (MutableFdCache ref'))
114−
115−clean :: IORef FdCache -> IO ()
116−clean ref = do
117− old <- swapWithNew ref
102+initialize duration = fmap (Just . uncurry MutableFdCache)
103+ $ reaper defaultReaperSettings
104+ { reaperAction = clean
105+ , reaperDelay = duration
106+ , reaperCons = uncurry insert
107+ , reaperNull = isEmpty
108+ , reaperEmpty = empty
109+ }
110+
111+clean :: FdCache -> IO (FdCache -> FdCache)
112+clean old = do
118113 new <- pruneWith old prune
119− update' ref (merge new)
114+ return $ merge new
120115
121116prune :: t -> Some FdEntry -> IO [(t, Some FdEntry)]
122117prune k v@(One (FdEntry _ fd mst)) = status mst >>= prune'
@@ -138,8 +133,11 @@ prune k (Tom ent@(FdEntry _ fd mst) vs) = status mst >>= prune'
138133
139134terminate :: Maybe MutableFdCache -> IO ()
140135terminate Nothing = return ()
141−terminate (Just (MutableFdCache ref)) = mask_ $ do
142− !t <- breakForever ref
136+terminate (Just (MutableFdCache _ ref)) = do
137+ !t <- atomicModifyIORef ref $ \mm ->
138+ case mm of
139+ Nothing -> (Nothing, empty)
140+ Just m -> (Just empty, m)
143141 mapM_ closeIt $ toList t
144142 where
145143 closeIt (_, FdEntry _ fd _) = closeFd fd
@@ -148,12 +146,12 @@ terminate (Just (MutableFdCache ref)) = mask_ $ do
148146
149147-- | Getting 'Fd' and 'Refresh' from the mutable Fd cacher.
150148getFd :: MutableFdCache -> FilePath -> IO (Fd, Refresh)
151−getFd mfc path = look mfc path key >>= getFd'
149+getFd mfc@(MutableFdCache add _) path = look mfc path key >>= getFd'
152150 where
153151 key = hash path
154152 getFd' Nothing = do
155153 ent@(FdEntry _ fd mst) <- newFdEntry path
156− update mfc (insert key ent)
154+ add (key, ent)
157155 return (fd, refresh mst)
158156 getFd' (Just (FdEntry _ fd mst)) = do
159157 refresh mst