1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
|
{-# LANGUAGE BangPatterns, FlexibleInstances, CPP #-}
-- | File descriptor cache to avoid locks in kernel.
#ifndef SENDFILEFD
module Network.Wai.Handler.Warp.FdCache (
withFdCache
, MutableFdCache
, Refresh
) where
type Refresh = IO ()
data MutableFdCache = MutableFdCache
withFdCache :: Int -> (Maybe MutableFdCache -> IO a) -> IO a
withFdCache _ f = f Nothing
#else
module Network.Wai.Handler.Warp.FdCache (
withFdCache
, getFd
, MutableFdCache
, Refresh
) where
import Control.Applicative ((<$>), (<*>))
import Control.Concurrent (threadDelay)
import Control.Exception (bracket, mask_)
import Data.Hashable (hash)
import Network.Wai.Handler.Warp.IORef
import Network.Wai.Handler.Warp.MultiMap
import Network.Wai.Handler.Warp.Thread
import System.Posix.IO (openFd, OpenFileFlags(..), defaultFileFlags, OpenMode(ReadOnly), closeFd)
import System.Posix.Types (Fd)
----------------------------------------------------------------
data Status = Active | Inactive
newtype MutableStatus = MutableStatus (IORef Status)
-- | An action to activate a Fd cache entry.
type Refresh = IO ()
status :: MutableStatus -> IO Status
status (MutableStatus ref) = readIORef ref
newActiveStatus :: IO MutableStatus
newActiveStatus = MutableStatus <$> newIORef Active
refresh :: MutableStatus -> Refresh
refresh (MutableStatus ref) = writeIORef ref Active
inactive :: MutableStatus -> IO ()
inactive (MutableStatus ref) = writeIORef ref Inactive
----------------------------------------------------------------
data FdEntry = FdEntry !FilePath !Fd !MutableStatus
newFdEntry :: FilePath -> IO FdEntry
newFdEntry path = FdEntry path
<$> openFd path ReadOnly Nothing defaultFileFlags{nonBlock=True}
<*> newActiveStatus
----------------------------------------------------------------
type Hash = Int
type FdCache = MMap Hash FdEntry
-- | Mutable Fd cacher.
newtype MutableFdCache = MutableFdCache (IORef FdCache)
fdCache :: MutableFdCache -> IO FdCache
fdCache (MutableFdCache ref) = readIORef ref
swapWithNew :: IORef FdCache -> IO FdCache
swapWithNew ref = atomicModifyIORef' ref $ \t -> (empty, t)
update :: MutableFdCache -> (FdCache -> FdCache) -> IO ()
update (MutableFdCache ref) = update' ref
update' :: IORef FdCache -> (FdCache -> FdCache) -> IO ()
update' ref f = atomicModifyIORef' ref $ \t -> (f t, ())
look :: MutableFdCache -> FilePath -> Hash -> IO (Maybe FdEntry)
look mfc path key = searchWith key check <$> fdCache mfc
where
check (One ent@(FdEntry path' _ _))
| path == path' = Just ent
| otherwise = Nothing
check (Tom ent@(FdEntry path' _ _) vs)
| path == path' = Just ent
| otherwise = check vs
----------------------------------------------------------------
-- | Creating 'MutableFdCache' and executing the action in the second
-- argument. The first argument is a cache duration in second.
withFdCache :: Int -> (Maybe MutableFdCache -> IO a) -> IO a
withFdCache duration action = bracket (initialize duration)
terminate
action
----------------------------------------------------------------
-- The first argument is a cache duration in second.
initialize :: Int -> IO (Maybe MutableFdCache)
initialize 0 = return Nothing
initialize duration = do
ref' <- forkIOwithBreakableForever empty $ \ref -> do
threadDelay duration
clean ref
return (Just (MutableFdCache ref'))
clean :: IORef FdCache -> IO ()
clean ref = do
old <- swapWithNew ref
new <- pruneWith old prune
update' ref (merge new)
prune :: t -> Some FdEntry -> IO [(t, Some FdEntry)]
prune k v@(One (FdEntry _ fd mst)) = status mst >>= prune'
where
prune' Active = inactive mst >> return [(k,v)]
prune' Inactive = closeFd fd >> return []
prune k (Tom ent@(FdEntry _ fd mst) vs) = status mst >>= prune'
where
prune' Active = do
inactive mst
zs <- prune k vs
case zs of
[] -> return [(k,One ent)]
[(_,zvs)] -> return [(k,Tom ent zvs)]
_ -> error "prune"
prune' Inactive = closeFd fd >> prune k vs
----------------------------------------------------------------
terminate :: Maybe MutableFdCache -> IO ()
terminate Nothing = return ()
terminate (Just (MutableFdCache ref)) = mask_ $ do
!t <- breakForever ref
mapM_ closeIt $ toList t
where
closeIt (_, FdEntry _ fd _) = closeFd fd
----------------------------------------------------------------
-- | Getting 'Fd' and 'Refresh' from the mutable Fd cacher.
getFd :: MutableFdCache -> FilePath -> IO (Fd, Refresh)
getFd mfc path = look mfc path key >>= getFd'
where
key = hash path
getFd' Nothing = do
ent@(FdEntry _ fd mst) <- newFdEntry path
update mfc (insert key ent)
return (fd, refresh mst)
getFd' (Just (FdEntry _ fd mst)) = do
refresh mst
return (fd, refresh mst)
#endif
|
