@@ -1,27 +1,31 @@
11{-# LANGUAGE BangPatterns, FlexibleInstances, CPP #-}
22
3+-- | File descriptor cache to avoid locks in kernel.
4+
35#ifndef SENDFILEFD
46module Network.Wai.Handler.Warp.FdCache (
57 withFdCache
6− , MutableFdCacheSet
8+ , MutableFdCache
9+ , Refresh
710 ) where
811
9−data MutableFdCacheSet = MutableFdCacheSet
12+type Refresh = IO ()
13+data MutableFdCache = MutableFdCache
1014
11−withFdCache :: Int -> (Maybe MutableFdCacheSet -> IO a) -> IO a
15+withFdCache :: Int -> (Maybe MutableFdCache -> IO a) -> IO a
1216withFdCache _ f = f Nothing
1317#else
1418module Network.Wai.Handler.Warp.FdCache (
1519 withFdCache
1620 , getFd
17− , MutableFdCacheSet
21+ , MutableFdCache
22+ , Refresh
1823 ) where
1924
2025import Control.Applicative ((<$>), (<*>))
21−import Control.Concurrent (forkIO, threadDelay, myThreadId, threadCapability, getNumCapabilities)
26+import Control.Concurrent (forkIO, threadDelay)
2227import Control.Exception (bracket)
23−import Control.Monad (replicateM, void)
24−import Data.Array (Array, (!), listArray, elems)
28+import Control.Monad (void)
2529import Data.Hashable (hash)
2630import Data.IORef (IORef, newIORef, readIORef, writeIORef, atomicModifyIORef)
2731import Network.Wai.Handler.Warp.MultiMap
@@ -62,7 +66,6 @@ newFdEntry path = FdEntry path
6266type Hash = Int
6367type FdCache = MMap Hash FdEntry
6468newtype MutableFdCache = MutableFdCache (IORef FdCache)
65−newtype MutableFdCacheSet = MutableFdCacheSet (Array Int MutableFdCache)
6669
6770newMutableFdCache :: IO MutableFdCache
6871newMutableFdCache = MutableFdCache <$> newIORef empty
@@ -90,33 +93,26 @@ look mfc path key = searchWith key check <$> fdCache mfc
9093
9194----------------------------------------------------------------
9295
93−withFdCache :: Int -> (Maybe MutableFdCacheSet -> IO a) -> IO a
96+withFdCache :: Int -> (Maybe MutableFdCache -> IO a) -> IO a
9497withFdCache duration action = bracket (initialize duration)
9598 terminate
9699 action
97100
98101----------------------------------------------------------------
99102
100−initialize :: Int -> IO (Maybe MutableFdCacheSet)
103+initialize :: Int -> IO (Maybe MutableFdCache)
101104initialize 0 = return Nothing
102105initialize duration = do
103− mfcset <- create
106+ mfc <- newMutableFdCache
104107 -- 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
108+ void . forkIO $ cleanLoop duration mfc
109+ return (Just mfc)
110+
111+cleanLoop :: Int -> MutableFdCache -> IO ()
112+cleanLoop duration mfc = loop
117113 where
118114 loop = do
119− mapM_ clean $ elems mfcs
115+ clean mfc
120116 threadDelay duration
121117 loop
122118
@@ -144,34 +140,23 @@ prune k (Tom ent@(FdEntry _ fd mst) vs) = status mst >>= prune'
144140
145141----------------------------------------------------------------
146142
147−terminate :: Maybe MutableFdCacheSet -> IO ()
143+terminate :: Maybe MutableFdCache -> IO ()
148144terminate 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
145+terminate (Just (MutableFdCache mfc)) = readIORef mfc >>= mapM_ closeIt . toList
153146 where
154147 closeIt (_, FdEntry _ fd _) = closeFd fd
155148
156149----------------------------------------------------------------
157150
158−getFd :: MutableFdCacheSet -> FilePath -> IO (Fd, Refresh)
159−getFd mfcs path = do
160− mfc <- myMutableFdCache mfcs
161− look mfc path key >>= getFd' mfc
151+getFd :: MutableFdCache -> FilePath -> IO (Fd, Refresh)
152+getFd mfc path = look mfc path key >>= getFd'
162153 where
163154 key = hash path
164− getFd' mfc Nothing = do
155+ getFd' Nothing = do
165156 ent@(FdEntry _ fd mst) <- newFdEntry path
166157 update mfc (insert key ent)
167158 return (fd, refresh mst)
168− getFd' _ (Just (FdEntry _ fd mst)) = do
159+ getFd' (Just (FdEntry _ fd mst)) = do
169160 refresh mst
170161 return (fd, refresh mst)
171−----------------------------------------------------------------
172−
173−myMutableFdCache :: MutableFdCacheSet -> IO MutableFdCache
174−myMutableFdCache (MutableFdCacheSet mfcs) = do
175− (i, _) <- myThreadId >>= threadCapability
176− return $ mfcs ! i
177162#endif