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