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
|
module Timeout
( Manager
, Handle
, initialize
, register
, registerKillThread
, tickle
, pause
, resume
, cancel
) where
import qualified Data.IORef as I
import Control.Concurrent (forkIO, threadDelay, myThreadId, killThread)
import Control.Monad (forever)
import qualified Control.Exception as E
-- FIXME implement stopManager
-- | A timeout manager
newtype Manager = Manager (I.IORef [Handle])
data Handle = Handle (IO ()) (I.IORef State)
data State = Active | Inactive | Paused | Canceled
initialize :: Int -> IO Manager
initialize timeout = do
ref <- I.newIORef []
_ <- forkIO $ forever $ do
threadDelay timeout
ms <- I.atomicModifyIORef ref (\x -> ([], x))
ms' <- go ms id
I.atomicModifyIORef ref (\x -> (ms' x, ()))
return $ Manager ref
where
go [] front = return front
go (m@(Handle onTimeout iactive):rest) front = do
state <- I.atomicModifyIORef iactive (\x -> (go' x, x))
case state of
Inactive -> do
onTimeout `E.catch` ignoreAll
go rest front
Canceled -> go rest front
_ -> go rest (front . (:) m)
go' Active = Inactive
go' x = x
ignoreAll :: E.SomeException -> IO ()
ignoreAll _ = return ()
register :: Manager -> IO () -> IO Handle
register (Manager ref) onTimeout = do
iactive <- I.newIORef Active
let h = Handle onTimeout iactive
I.atomicModifyIORef ref (\x -> (h : x, ()))
return h
registerKillThread :: Manager -> IO Handle
registerKillThread m = do
tid <- myThreadId
register m $ killThread tid
tickle, pause, resume, cancel :: Handle -> IO ()
tickle (Handle _ iactive) = I.writeIORef iactive Active
pause (Handle _ iactive) = I.writeIORef iactive Paused
resume = tickle
cancel (Handle _ iactive) = I.writeIORef iactive Canceled
|
