@@ -2,47 +2,59 @@
22
33-- | File descriptor cache to avoid locks in kernel.
44
5−#ifdef WINDOWS
65module Network.Wai.Handler.Warp.FdCache (
76 withFdCache
8− , MutableFdCache
7+ , Fd
98 , Refresh
9+#ifndef WINDOWS
10+ , openFile
11+ , closeFile
12+#endif
1013 ) where
1114
12−type Refresh = IO ()
13−type MutableFdCache = ()
14−
15−withFdCache :: Int -> (Maybe MutableFdCache -> IO a) -> IO a
16−withFdCache _ f = f Nothing
15+#ifdef WINDOWS
16+type Fd = ()
1717#else
18−module Network.Wai.Handler.Warp.FdCache (
19− withFdCache
20− , getFd
21− , getFd'
22− , MutableFdCache
23− , Refresh
24− ) where
25−
2618#if __GLASGOW_HASKELL__ < 709
2719import Control.Applicative ((<$>), (<*>))
2820#endif
2921import Control.Exception (bracket)
30−import Data.Hashable (hash)
3122import Network.Wai.Handler.Warp.IORef
3223import Network.Wai.Handler.Warp.MultiMap
24+import Control.Reaper
3325import System.Posix.IO (openFd, OpenFileFlags(..), defaultFileFlags, OpenMode(ReadOnly), closeFd)
3426import System.Posix.Types (Fd)
35−import Control.Reaper
27+#endif
3628
3729----------------------------------------------------------------
3830
39−data Status = Active | Inactive
40−
41−newtype MutableStatus = MutableStatus (IORef Status)
31+type Hash = Int
4232
4333-- | An action to activate a Fd cache entry.
4434type Refresh = IO ()
4535
36+getFdNothing :: Hash -> FilePath -> IO (Maybe Fd, Refresh)
37+getFdNothing _ _ = return (Nothing, return ())
38+
39+----------------------------------------------------------------
40+
41+-- | Creating 'MutableFdCache' and executing the action in the second
42+-- argument. The first argument is a cache duration in second.
43+withFdCache :: Int -> ((Hash -> FilePath -> IO (Maybe Fd, Refresh)) -> IO a) -> IO a
44+#ifdef WINDOWS
45+withFdCache _ action = action getFdNothing
46+#else
47+withFdCache 0 action = action getFdNothing
48+withFdCache duration action = bracket (initialize duration)
49+ terminate
50+ (\mfc -> action (getFd mfc))
51+
52+----------------------------------------------------------------
53+
54+data Status = Active | Inactive
55+
56+newtype MutableStatus = MutableStatus (IORef Status)
57+
4658status :: MutableStatus -> IO Status
4759status (MutableStatus ref) = readIORef ref
4860
@@ -59,14 +71,17 @@ inactive (MutableStatus ref) = writeIORef ref Inactive
5971
6072data FdEntry = FdEntry !FilePath !Fd !MutableStatus
6173
74+openFile :: FilePath -> IO Fd
75+openFile path = openFd path ReadOnly Nothing defaultFileFlags{nonBlock=True}
76+
77+closeFile :: Fd -> IO ()
78+closeFile = closeFd
79+
6280newFdEntry :: FilePath -> IO FdEntry
63−newFdEntry path = FdEntry path
64− <$> openFd path ReadOnly Nothing defaultFileFlags{nonBlock=True}
65− <*> newActiveStatus
81+newFdEntry path = FdEntry path <$> openFile path <*> newActiveStatus
6682
6783----------------------------------------------------------------
6884
69−type Hash = Int
7085type FdCache = MMap Hash FdEntry
7186
7287-- | Mutable Fd cacher.
@@ -87,25 +102,17 @@ look mfc path key = searchWith key check <$> fdCache mfc
87102
88103----------------------------------------------------------------
89104
90−-- | Creating 'MutableFdCache' and executing the action in the second
91−-- argument. The first argument is a cache duration in second.
92−withFdCache :: Int -> (Maybe MutableFdCache -> IO a) -> IO a
93−withFdCache duration action = bracket (initialize duration)
94− terminate
95− action
96−
97−----------------------------------------------------------------
98−
99105-- The first argument is a cache duration in second.
100−initialize :: Int -> IO (Maybe MutableFdCache)
101−initialize 0 = return Nothing
102−initialize duration = Just . MutableFdCache <$> mkReaper defaultReaperSettings
103− { reaperAction = clean
104− , reaperDelay = duration
105− , reaperCons = uncurry insert
106− , reaperNull = isEmpty
107− , reaperEmpty = empty
108− }
106+initialize :: Int -> IO MutableFdCache
107+initialize duration = MutableFdCache <$> mkReaper settings
108+ where
109+ settings = defaultReaperSettings {
110+ reaperAction = clean
111+ , reaperDelay = duration
112+ , reaperCons = uncurry insert
113+ , reaperNull = isEmpty
114+ , reaperEmpty = empty
115+ }
109116
110117clean :: FdCache -> IO (FdCache -> FdCache)
111118clean old = do
@@ -130,9 +137,8 @@ prune k (Tom ent@(FdEntry _ fd mst) vs) = status mst >>= prune'
130137
131138----------------------------------------------------------------
132139
133−terminate :: Maybe MutableFdCache -> IO ()
134−terminate Nothing = return ()
135−terminate (Just (MutableFdCache reaper)) = do
140+terminate :: MutableFdCache -> IO ()
141+terminate (MutableFdCache reaper) = do
136142 !t <- reaperStop reaper
137143 mapM_ closeIt $ toList t
138144 where
@@ -140,18 +146,15 @@ terminate (Just (MutableFdCache reaper)) = do
140146
141147----------------------------------------------------------------
142148
143−getFd :: MutableFdCache -> FilePath -> IO (Fd, Refresh)
144−getFd mfc path = getFd' mfc (hash path) path
145−
146149-- | Getting 'Fd' and 'Refresh' from the mutable Fd cacher.
147−getFd' :: MutableFdCache -> Hash -> FilePath -> IO (Fd, Refresh)
148−getFd' mfc@(MutableFdCache reaper) h path = look mfc path h >>= get
150+getFd :: MutableFdCache -> Hash -> FilePath -> IO (Maybe Fd, Refresh)
151+getFd mfc@(MutableFdCache reaper) h path = look mfc path h >>= get
149152 where
150153 get Nothing = do
151154 ent@(FdEntry _ fd mst) <- newFdEntry path
152155 reaperAdd reaper (h, ent)
153− return (fd, refresh mst)
156+ return (Just fd, refresh mst)
154157 get (Just (FdEntry _ fd mst)) = do
155158 refresh mst
156− return (fd, refresh mst)
159+ return (Just fd, refresh mst)
157160#endif