@@ -1,153 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DeriveDataTypeable #-}
3−
4−module Network.Wai.Handler.Warp.Timeout (
5− -- ** Types
6− Manager
7− , TimeoutAction
8− , Handle
9− -- ** Manager
10− , initialize
11− , stopManager
12− , killManager
13− , withManager
14− -- ** Registration
15− , register
16− , registerKillThread
17− -- ** Control
18− , tickle
19− , cancel
20− , pause
21− , resume
22− -- ** Exceptions
23− , TimeoutThread (..)
24− ) where
25−
26−import Control.Concurrent (myThreadId)
27−import qualified Control.Exception as E
28−import Control.Reaper
29−import Data.Typeable (Typeable)
30−import Data.IORef (IORef)
31−import qualified Data.IORef as I
32−
33−----------------------------------------------------------------
34−
35−-- | A timeout manager
36−type Manager = Reaper [Handle] Handle
37−
38−-- | An action to be performed on timeout.
39−type TimeoutAction = IO ()
40−
41−-- | A handle used by 'Manager'
42−data Handle = Handle !(IORef TimeoutAction) !(IORef State)
43−
44−data State = Active -- Manager turns it to Inactive.
45− | Inactive -- Manager removes it with timeout action.
46− | Paused -- Manager does not change it.
47− | Canceled -- Manager removes it without timeout action.
48−
49−----------------------------------------------------------------
50−
51−-- | Creating timeout manager which works every N micro seconds
52−-- where N is the first argument.
53−initialize :: Int -> IO Manager
54−initialize timeout = mkReaper defaultReaperSettings
55− { reaperAction = mkListAction prune
56− , reaperDelay = timeout
57− }
58− where
59− prune m@(Handle actionRef stateRef) = do
60− state <- I.atomicModifyIORef' stateRef (\x -> (inactivate x, x))
61− case state of
62− Inactive -> do
63− onTimeout <- I.readIORef actionRef
64− onTimeout `E.catch` ignoreAll
65− return Nothing
66− Canceled -> return Nothing
67− _ -> return $ Just m
68−
69− inactivate Active = Inactive
70− inactivate x = x
71−
72−----------------------------------------------------------------
73−
74−-- | Stopping timeout manager with onTimeout fired.
75−stopManager :: Manager -> IO ()
76−stopManager mgr = E.mask_ (reaperStop mgr >>= mapM_ fire)
77− where
78− fire (Handle actionRef _) = do
79− onTimeout <- I.readIORef actionRef
80− onTimeout `E.catch` ignoreAll
81−
82−ignoreAll :: E.SomeException -> IO ()
83−ignoreAll _ = return ()
84−
85−-- | Killing timeout manager immediately without firing onTimeout.
86−killManager :: Manager -> IO ()
87−killManager = reaperKill
88−
89−----------------------------------------------------------------
90−
91−-- | Registering a timeout action.
92−register :: Manager -> TimeoutAction -> IO Handle
93−register mgr onTimeout = do
94− actionRef <- I.newIORef onTimeout
95− stateRef <- I.newIORef Active
96− let h = Handle actionRef stateRef
97− reaperAdd mgr h
98− return h
99−
100−-- | Registering a timeout action of killing this thread.
101−registerKillThread :: Manager -> TimeoutAction -> IO Handle
102−registerKillThread m onTimeout = do
103− -- If we hold ThreadId, the stack and data of the thread is leaked.
104− -- If we hold Weak ThreadId, the stack is released. However, its
105− -- data is still leaked probably because of a bug of GHC.
106− -- So, let's just use ThreadId and release ThreadId by
107− -- overriding the timeout action by "cancel".
108− tid <- myThreadId
109− -- First run the timeout action in case the child thread is masked.
110− register m $ onTimeout `E.finally` E.throwTo tid TimeoutThread
111−
112−data TimeoutThread = TimeoutThread
113− deriving Typeable
114−instance E.Exception TimeoutThread where
115− toException = E.asyncExceptionToException
116− fromException = E.asyncExceptionFromException
117−instance Show TimeoutThread where
118− show TimeoutThread = "Thread killed by Warp's timeout reaper"
119−
120−----------------------------------------------------------------
121−
122−-- | Setting the state to active.
123−-- 'Manager' turns active to inactive repeatedly.
124−tickle :: Handle -> IO ()
125−tickle (Handle _ stateRef) = I.writeIORef stateRef Active
126−
127−-- | Setting the state to canceled.
128−-- 'Manager' eventually removes this without timeout action.
129−cancel :: Handle -> IO ()
130−cancel (Handle actionRef stateRef) = do
131− I.writeIORef actionRef (return ()) -- ensuring to release ThreadId
132− I.writeIORef stateRef Canceled
133−
134−-- | Setting the state to paused.
135−-- 'Manager' does not change the value.
136−pause :: Handle -> IO ()
137−pause (Handle _ stateRef) = I.writeIORef stateRef Paused
138−
139−-- | Setting the paused state to active.
140−-- This is an alias to 'tickle'.
141−resume :: Handle -> IO ()
142−resume = tickle
143−
144−----------------------------------------------------------------
145−
146−-- | Call the inner function with a timeout manager.
147−withManager :: Int -- ^ timeout in microseconds
148− -> (Manager -> IO a)
149− -> IO a
150−withManager timeout f = do
151− -- FIXME when stopManager is available, use it
152− man <- initialize timeout
153− f man