@@ -2,27 +2,28 @@
22
33#ifndef SENDFILEFD
44module Network.Wai.Handler.Warp.FdCache (
5− initialize
6− , MutableFdCache
5+ withFdCache
6+ , MutableFdCacheSet
77 ) where
88
9−data MutableFdCache = MutableFdCache
10−
11−initialize :: Int -> IO (Maybe MutableFdCache)
12−initialize _ = return Nothing
9+data MutableFdCacheSet = MutableFdCacheSet
1310
11+withFdCache :: Int -> (Maybe MutableFdCacheSet -> IO a) -> IO a
12+withFdCache _ f = f Nothing
1413#else
1514module Network.Wai.Handler.Warp.FdCache (
16− initialize
15+ withFdCache
1716 , getFd
18− , MutableFdCache
17+ , MutableFdCacheSet
1918 ) where
2019
2120import Control.Applicative ((<$>), (<*>))
22−import Control.Concurrent (forkIO, threadDelay, ThreadId, killThread)
23−import Control.Exception (mask_)
21+import Control.Concurrent (forkIO, threadDelay, myThreadId, threadCapability, getNumCapabilities)
22+import Control.Exception (bracket)
23+import Control.Monad (replicateM, void)
24+import Data.Array (Array, (!), listArray, elems)
2425import Data.Hashable (hash)
25−import Data.IORef (IORef, newIORef, readIORef, writeIORef, atomicModifyIORef, mkWeakIORef)
26+import Data.IORef (IORef, newIORef, readIORef, writeIORef, atomicModifyIORef)
2627import Network.Wai.Handler.Warp.MultiMap
2728import System.Posix.IO (openFd, defaultFileFlags, OpenMode(ReadOnly), closeFd)
2829import System.Posix.Types (Fd)
@@ -60,7 +61,8 @@ newFdEntry path = FdEntry path
6061
6162type Hash = Int
6263type FdCache = MMap Hash FdEntry
63−newtype MutableFdCache = MutableFdCache { unMutableFdCache :: IORef FdCache }
64+newtype MutableFdCache = MutableFdCache (IORef FdCache)
65+newtype MutableFdCacheSet = MutableFdCacheSet (Array Int MutableFdCache)
6466
6567newMutableFdCache :: IO MutableFdCache
6668newMutableFdCache = MutableFdCache <$> newIORef empty
@@ -88,31 +90,41 @@ look mfc path key = searchWith key check <$> fdCache mfc
8890
8991----------------------------------------------------------------
9092
91−initialize :: Int -> IO (Maybe MutableFdCache)
93+withFdCache :: Int -> (Maybe MutableFdCacheSet -> IO a) -> IO a
94+withFdCache duration action = bracket (initialize duration)
95+ terminate
96+ action
97+
98+----------------------------------------------------------------
99+
100+initialize :: Int -> IO (Maybe MutableFdCacheSet)
92101initialize 0 = return Nothing
93102initialize duration = do
94− mfc <- newMutableFdCache
95− tid <- forkIO $ loop mfc
96− -- Registering finalizer to this IORef.
97− -- When Warp is finished in GHCi, this IORef is GCed.
98− -- At that time, we should close all opened file descriptors.
99− _ <- mkWeakIORef (unMutableFdCache mfc) $ terminate mfc tid
100− return (Just mfc)
101− where
102− loop mfc = do
103− mask_ $ do
104− old <- swapWithNew mfc
105− new <- pruneWith old prune
106− update mfc (merge new)
107− threadDelay duration
108− loop mfc
109−
110−terminate :: MutableFdCache -> ThreadId -> IO ()
111−terminate (MutableFdCache icache) tid = do
112− killThread tid
113− readIORef icache >>= mapM_ go . toList
114− where
115− go (_, FdEntry _ fd _) = closeFd fd
103+ mfcset <- create
104+ -- FIXME: how to stop this thread?
105+ void . forkIO $ cleanLoop duration mfcset
106+ return (Just mfcset)
107+
108+create :: IO MutableFdCacheSet
109+create = do
110+ n <- getNumCapabilities
111+ mfcs <- replicateM n newMutableFdCache
112+ let mfcset = listArray (0,n-1) mfcs
113+ return $ MutableFdCacheSet mfcset
114+
115+cleanLoop :: Int -> MutableFdCacheSet -> IO ()
116+cleanLoop duration (MutableFdCacheSet mfcs) = loop
117+ where
118+ loop = do
119+ mapM_ clean $ elems mfcs
120+ threadDelay duration
121+ loop
122+
123+clean :: MutableFdCache -> IO ()
124+clean mfc = do
125+ old <- swapWithNew mfc
126+ new <- pruneWith old prune
127+ update mfc (merge new)
116128
117129prune :: t -> Some FdEntry -> IO [(t, Some FdEntry)]
118130prune k v@(One (FdEntry _ fd mst)) = status mst >>= prune'
@@ -132,15 +144,34 @@ prune k (Tom ent@(FdEntry _ fd mst) vs) = status mst >>= prune'
132144
133145----------------------------------------------------------------
134146
135−getFd :: MutableFdCache -> FilePath -> IO (Fd, Refresh)
136−getFd mfc path = look mfc path key >>= getFd'
147+terminate :: Maybe MutableFdCacheSet -> IO ()
148+terminate Nothing = return ()
149+terminate (Just (MutableFdCacheSet mfcs)) = mapM_ cleanup $ elems mfcs
150+
151+cleanup :: MutableFdCache -> IO ()
152+cleanup (MutableFdCache mfc) = readIORef mfc >>= mapM_ closeIt . toList
153+ where
154+ closeIt (_, FdEntry _ fd _) = closeFd fd
155+
156+----------------------------------------------------------------
157+
158+getFd :: MutableFdCacheSet -> FilePath -> IO (Fd, Refresh)
159+getFd mfcs path = do
160+ mfc <- myMutableFdCache mfcs
161+ look mfc path key >>= getFd' mfc
137162 where
138163 key = hash path
139− getFd' Nothing = do
164+ getFd' mfc Nothing = do
140165 ent@(FdEntry _ fd mst) <- newFdEntry path
141166 update mfc (insert key ent)
142167 return (fd, refresh mst)
143− getFd' (Just (FdEntry _ fd mst)) = do
168+ getFd' _ (Just (FdEntry _ fd mst)) = do
144169 refresh mst
145170 return (fd, refresh mst)
171+----------------------------------------------------------------
172+
173+myMutableFdCache :: MutableFdCacheSet -> IO MutableFdCache
174+myMutableFdCache (MutableFdCacheSet mfcs) = do
175+ (i, _) <- myThreadId >>= threadCapability
176+ return $ mfcs ! i
146177#endif