@@ -0,0 +1,123 @@
1+{-# LANGUAGE BangPatterns, FlexibleInstances #-}
2+
3+module Network.Wai.Handler.Warp.FdCache (
4+ initialize
5+ , getFd
6+ ) where
7+
8+import Control.Applicative ((<$>), (<*>))
9+import Control.Concurrent
10+import Control.Monad
11+import Data.Hashable
12+import Data.IORef
13+import Network.Wai.Handler.Warp.MultiMap
14+import System.Posix.IO
15+import System.Posix.Types
16+import System.IO.Unsafe
17+
18+----------------------------------------------------------------
19+
20+data Status = Active | Inactive deriving Show
21+
22+newtype MutableStatus = MutableStatus (IORef Status) deriving Show
23+
24+instance Show (IORef Status) where
25+ show ref = show (unsafePerformIO (readIORef ref))
26+
27+type Refresh = IO ()
28+
29+status :: MutableStatus -> IO Status
30+status (MutableStatus ref) = readIORef ref
31+
32+newActiveStatus :: IO MutableStatus
33+newActiveStatus = MutableStatus <$> newIORef Active
34+
35+refresh :: MutableStatus -> Refresh
36+refresh (MutableStatus ref) = writeIORef ref Active
37+
38+inactive :: MutableStatus -> IO ()
39+inactive (MutableStatus ref) = writeIORef ref Inactive
40+
41+----------------------------------------------------------------
42+
43+data FdEntry = FdEntry FilePath Fd MutableStatus deriving Show
44+
45+newFdEntry :: FilePath -> IO FdEntry
46+newFdEntry path = FdEntry path
47+ <$> openFd path ReadOnly Nothing defaultFileFlags
48+ <*> newActiveStatus
49+
50+----------------------------------------------------------------
51+
52+type Hash = Int
53+type FdCache = MMap Hash FdEntry
54+newtype MutableFdCache = MutableFdCache (IORef FdCache)
55+
56+newMutableFdCache :: IO MutableFdCache
57+newMutableFdCache = MutableFdCache <$> newIORef empty
58+
59+fdCache :: MutableFdCache -> IO FdCache
60+fdCache (MutableFdCache ref) = readIORef ref
61+
62+swapWithNew :: MutableFdCache -> IO FdCache
63+swapWithNew (MutableFdCache ref) = atomicModifyIORef ref (\t -> (empty, t))
64+
65+update :: MutableFdCache -> (FdCache -> FdCache) -> IO ()
66+update (MutableFdCache ref) f = do
67+ !_ <- atomicModifyIORef ref $ \t -> let !new = f t in (new, ())
68+ return ()
69+
70+look :: MutableFdCache -> FilePath -> Hash -> IO (Maybe FdEntry)
71+look mfc path key = searchWith key check <$> fdCache mfc
72+ where
73+ check (One ent@(FdEntry path' _ _))
74+ | path == path' = Just ent
75+ | otherwise = Nothing
76+ check (Tom ent@(FdEntry path' _ _) vs)
77+ | path == path' = Just ent
78+ | otherwise = check vs
79+
80+----------------------------------------------------------------
81+
82+initialize :: IO MutableFdCache
83+initialize = do
84+ mfc <- newMutableFdCache
85+ void . forkIO $ loop mfc
86+ return mfc
87+ where
88+ loop mfc = do
89+ old <- swapWithNew mfc
90+ new <- pruneWith old prune
91+ update mfc (merge new)
92+ threadDelay 30000000 -- FIXME
93+ loop mfc
94+
95+prune :: t -> Some FdEntry -> IO [(t, Some FdEntry)]
96+prune k v@(One (FdEntry _ fd mst)) = status mst >>= prune'
97+ where
98+ prune' Active = inactive mst >> return [(k,v)]
99+ prune' Inactive = closeFd fd >> return []
100+prune k (Tom ent@(FdEntry _ fd mst) vs) = status mst >>= prune'
101+ where
102+ prune' Active = do
103+ inactive mst
104+ zs <- prune k vs
105+ case zs of
106+ [] -> return [(k,One ent)]
107+ [(_,zvs)] -> return [(k,Tom ent zvs)]
108+ _ -> error "prune"
109+ prune' Inactive = closeFd fd >> prune k vs
110+
111+----------------------------------------------------------------
112+
113+getFd :: MutableFdCache -> FilePath -> IO (Fd, Refresh)
114+getFd mfc path = look mfc path key >>= getFd'
115+ where
116+ key = hash path
117+ getFd' Nothing = do
118+ ent@(FdEntry _ fd mst) <- newFdEntry path
119+ update mfc (insert key ent)
120+ return $ (fd, refresh mst)
121+ getFd' (Just (FdEntry _ fd mst)) = do
122+ refresh mst
123+ return $ (fd, refresh mst)