git.iko.soy/typeable/wai
on warp-3.3.4 help sign in
typeable/wai/time-manager/System/TimeManager.hs
152 lines 4.8 kB history raw
1{-# LANGUAGE DeriveDataTypeable #-}
3module 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
25import Control.Concurrent (myThreadId)
26import qualified Control.Exception as E
27import Control.Reaper
28import Data.Typeable (Typeable)
29import Data.IORef (IORef)
30import qualified Data.IORef as I
32----------------------------------------------------------------
34-- | A timeout manager
35type Manager = Reaper [Handle] Handle
37-- | An action to be performed on timeout.
38type TimeoutAction = IO ()
40-- | A handle used by 'Manager'
41data Handle = Handle !(IORef TimeoutAction) !(IORef State)
43data 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.
48----------------------------------------------------------------
50-- | Creating timeout manager which works every N micro seconds
51-- where N is the first argument.
52initialize :: Int -> IO Manager
53initialize 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
68 inactivate Active = Inactive
69 inactivate x = x
71----------------------------------------------------------------
73-- | Stopping timeout manager with onTimeout fired.
74stopManager :: Manager -> IO ()
75stopManager mgr = E.mask_ (reaperStop mgr >>= mapM_ fire)
76 where
77 fire (Handle actionRef _) = do
78 onTimeout <- I.readIORef actionRef
79 onTimeout `E.catch` ignoreAll
81ignoreAll :: E.SomeException -> IO ()
82ignoreAll _ = return ()
84-- | Killing timeout manager immediately without firing onTimeout.
85killManager :: Manager -> IO ()
86killManager = reaperKill
88----------------------------------------------------------------
90-- | Registering a timeout action.
91register :: Manager -> TimeoutAction -> IO Handle
92register 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
99-- | Registering a timeout action of killing this thread.
100registerKillThread :: Manager -> TimeoutAction -> IO Handle
101registerKillThread 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
111data TimeoutThread = TimeoutThread
112 deriving Typeable
113instance E.Exception TimeoutThread where
114 toException = E.asyncExceptionToException
115 fromException = E.asyncExceptionFromException
116instance Show TimeoutThread where
117 show TimeoutThread = "Thread killed by timeout manager"
119----------------------------------------------------------------
121-- | Setting the state to active.
122-- 'Manager' turns active to inactive repeatedly.
123tickle :: Handle -> IO ()
124tickle (Handle _ stateRef) = I.writeIORef stateRef Active
126-- | Setting the state to canceled.
127-- 'Manager' eventually removes this without timeout action.
128cancel :: Handle -> IO ()
129cancel (Handle actionRef stateRef) = do
130 I.writeIORef actionRef (return ()) -- ensuring to release ThreadId
131 I.writeIORef stateRef Canceled
133-- | Setting the state to paused.
134-- 'Manager' does not change the value.
135pause :: Handle -> IO ()
136pause (Handle _ stateRef) = I.writeIORef stateRef Paused
138-- | Setting the paused state to active.
139-- This is an alias to 'tickle'.
140resume :: Handle -> IO ()
141resume = tickle
143----------------------------------------------------------------
145-- | Call the inner function with a timeout manager.
146withManager :: Int -- ^ timeout in microseconds
147 -> (Manager -> IO a)
148 -> IO a
149withManager timeout f = do
150 -- FIXME when stopManager is available, use it
151 man <- initialize timeout
152 f man