@@ -1,5 +1,6 @@
11{-# LANGUAGE CPP #-}
22{-# LANGUAGE BangPatterns #-}
3+{-# LANGUAGE DeriveDataTypeable #-}
34{-# LANGUAGE UnboxedTuples, MagicHash #-}
45module Network.Wai.Handler.Warp.Timeout (
56 Manager
@@ -30,6 +31,7 @@ import qualified Control.Exception as E
3031import Control.Monad (forever, void)
3132import qualified Data.IORef as I
3233import System.IO.Unsafe (unsafePerformIO)
34+import Data.Typeable (Typeable)
3335
3436-- | A timeout manager
3537newtype Manager = Manager (I.IORef [Handle])
@@ -48,13 +50,15 @@ data State = Active | Inactive | Paused | Canceled
4850initialize :: Int -> IO Manager
4951initialize timeout = do
5052 ref <- I.newIORef []
51− void . forkIO $ forever $ do
53+ void . forkIO $ E.handle ignoreStop $ forever $ do
5254 threadDelay timeout
5355 ms <- I.atomicModifyIORef ref (\x -> ([], x))
5456 ms' <- go ms id
5557 I.atomicModifyIORef ref (\x -> (ms' x, ()))
5658 return $ Manager ref
5759 where
60+ ignoreStop TimeoutManagerStopped = return ()
61+
5862 go [] front = return front
5963 go (m@(Handle onTimeout iactive):rest) front = do
6064 state <- I.atomicModifyIORef iactive (\x -> (go' x, x))
@@ -67,11 +71,15 @@ initialize timeout = do
6771 go' Active = Inactive
6872 go' x = x
6973
74+data TimeoutManagerStopped = TimeoutManagerStopped
75+ deriving (Show, Typeable)
76+instance E.Exception TimeoutManagerStopped
77+
7078stopManager :: Manager -> IO ()
7179stopManager (Manager ihandles) = E.mask_ $ do
7280 -- Put an undefined value in the IORef to kill the worker thread (yes, it's
7381 -- a bit of a hack)
74− !handles <- I.atomicModifyIORef ihandles $ \h -> (error "Timeout manager stopped", h)
82+ !handles <- I.atomicModifyIORef ihandles $ \h -> (E.throw TimeoutManagerStopped, h)
7583 mapM_ go handles
7684 where
7785 go (Handle onTimeout _) = onTimeout `E.catch` ignoreAll