module Network.Wai.Handler.Warp.Timeout (
Manager
, Handle
, TimeoutAction
, initialize
, stopManager
, register
, registerKillThread
, tickle
, pause
, resume
, cancel
, withManager
, dummyHandle
) where
#if MIN_VERSION_base(4,6,0)
import Control.Concurrent (mkWeakThreadId, ThreadId)
#else
import Control.Concurrent (ThreadId(..))
import GHC.Exts (mkWeak#)
import GHC.IO (IO (IO))
#endif
import GHC.Weak (Weak (..))
import Control.Concurrent (forkIO, threadDelay, myThreadId, killThread)
import qualified Control.Exception as E
import Control.Monad (forever, void)
import Data.IORef (IORef)
import qualified Data.IORef as I
import Data.Typeable (Typeable)
import System.IO.Unsafe (unsafePerformIO)
import System.Mem.Weak (deRefWeak)
newtype Manager = Manager (IORef [Handle])
type TimeoutAction = IO ()
data Handle = Handle TimeoutAction (IORef State)
data State = Active
| Inactive
| Paused
| Canceled
dummyHandle :: Handle
dummyHandle = Handle (return ()) (unsafePerformIO $ I.newIORef Active)
data TimeoutManagerStopped = TimeoutManagerStopped
deriving (Show, Typeable)
instance E.Exception TimeoutManagerStopped
initialize :: Int -> IO Manager
initialize timeout = do
ref <- I.newIORef []
void . forkIO $ E.handle ignoreStop $ forever $ do
threadDelay timeout
old <- I.atomicModifyIORef ref (\x -> ([], x))
merge <- prune old id
I.atomicModifyIORef ref (\new -> (merge new, ()))
return $ Manager ref
where
ignoreStop TimeoutManagerStopped = return ()
prune [] front = return front
prune (m@(Handle onTimeout iactive):rest) front = do
state <- I.atomicModifyIORef iactive (\x -> (inactivate x, x))
case state of
Inactive -> do
onTimeout `E.catch` ignoreAll
prune rest front
Canceled -> prune rest front
_ -> prune rest (front . (:) m)
inactivate Active = Inactive
inactivate x = x
stopManager :: Manager -> IO ()
stopManager (Manager ihandles) = E.mask_ $ do
!handles <- I.atomicModifyIORef ihandles $ \h -> (E.throw TimeoutManagerStopped, h)
mapM_ fire handles
where
fire (Handle onTimeout _) = onTimeout `E.catch` ignoreAll
ignoreAll :: E.SomeException -> IO ()
ignoreAll _ = return ()
register :: Manager -> TimeoutAction -> 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
wtid <- myThreadId >>= mkWeakThreadId
register m $ killIfExist wtid
killIfExist :: Weak ThreadId -> TimeoutAction
killIfExist wtid = deRefWeak wtid >>= maybe (return ()) killThread
#if !MIN_VERSION_base(4,6,0)
mkWeakThreadId :: ThreadId -> IO (Weak ThreadId)
mkWeakThreadId t@(ThreadId t#) = IO $ \s ->
case mkWeak# t# t Nothing s of
(# s1, w #) -> (# s1, Weak w #)
#endif
tickle :: Handle -> IO ()
tickle (Handle _ iactive) = I.writeIORef iactive Active
cancel :: Handle -> IO ()
cancel (Handle _ iactive) = I.writeIORef iactive Canceled
pause :: Handle -> IO ()
pause (Handle _ iactive) = I.writeIORef iactive Paused
resume :: Handle -> IO ()
resume = tickle
withManager :: Int
-> (Manager -> IO a)
-> IO a
withManager timeout f = do
man <- initialize timeout
f man