git.iko.soy/typeable/wai
on wai-app-static/1.2.0.3 help sign in
typeable/wai/warp/Timeout.hs
66 lines 1.9 kB history raw
1module Timeout
2 ( Manager
3 , Handle
4 , initialize
5 , register
6 , registerKillThread
7 , tickle
8 , pause
9 , resume
10 , cancel
11 ) where
13import qualified Data.IORef as I
14import Control.Concurrent (forkIO, threadDelay, myThreadId, killThread)
15import Control.Monad (forever)
16import qualified Control.Exception as E
18-- FIXME implement stopManager
20-- | A timeout manager
21newtype Manager = Manager (I.IORef [Handle])
22data Handle = Handle (IO ()) (I.IORef State)
23data State = Active | Inactive | Paused | Canceled
25initialize :: Int -> IO Manager
26initialize timeout = do
27 ref <- I.newIORef []
28 _ <- forkIO $ forever $ do
29 threadDelay timeout
30 ms <- I.atomicModifyIORef ref (\x -> ([], x))
31 ms' <- go ms id
32 I.atomicModifyIORef ref (\x -> (ms' x, ()))
33 return $ Manager ref
34 where
35 go [] front = return front
36 go (m@(Handle onTimeout iactive):rest) front = do
37 state <- I.atomicModifyIORef iactive (\x -> (go' x, x))
38 case state of
39 Inactive -> do
40 onTimeout `E.catch` ignoreAll
41 go rest front
42 Canceled -> go rest front
43 _ -> go rest (front . (:) m)
44 go' Active = Inactive
45 go' x = x
47ignoreAll :: E.SomeException -> IO ()
48ignoreAll _ = return ()
50register :: Manager -> IO () -> IO Handle
51register (Manager ref) onTimeout = do
52 iactive <- I.newIORef Active
53 let h = Handle onTimeout iactive
54 I.atomicModifyIORef ref (\x -> (h : x, ()))
55 return h
57registerKillThread :: Manager -> IO Handle
58registerKillThread m = do
59 tid <- myThreadId
60 register m $ killThread tid
62tickle, pause, resume, cancel :: Handle -> IO ()
63tickle (Handle _ iactive) = I.writeIORef iactive Active
64pause (Handle _ iactive) = I.writeIORef iactive Paused
65resume = tickle
66cancel (Handle _ iactive) = I.writeIORef iactive Canceled