    module Happstack.Server.Internal.TimeoutManager
        ( Manager
        , Handle
        , initialize
        , register
        , registerKillThread
        , tickle
        , pause
        , resume
        , cancel
        , forceTimeout
        , forceTimeoutAll
        ) 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 (I.IORef (IO ())) (I.IORef State)
    data State = Active | Inactive | Paused | Canceled

    initialize :: Int -> IO Manager
    initialize :: Int -> IO Manager
    initialize Int
    timeout = do
        ref <- [Handle] -> IO (IORef [Handle])
    forall a. a -> IO (IORef a)
    I.newIORef []
        _ <- forkIO $ forever $ do
            threadDelay timeout
            ms <- I.atomicModifyIORef ref (\[Handle]
    x -> ([], [Handle]
    x))
            ms' <- go ms id
            I.atomicModifyIORef ref (\[Handle]
    x -> ([Handle] -> [Handle]
    ms' [Handle]
    x, ()))
        return $ Manager ref
      where
        go :: [Handle] -> ([Handle] -> c) -> IO ([Handle] -> c)
    go [] [Handle] -> c
    front = ([Handle] -> c) -> IO ([Handle] -> c)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [Handle] -> c
    front
        go (m :: Handle
    m@(Handle IORef (IO ())
    onTimeout IORef State
    iactive):[Handle]
    rest) [Handle] -> c
    front = do
            state <- IORef State -> (State -> (State, State)) -> IO State
    forall a b. IORef a -> (a -> (a, b)) -> IO b
    I.atomicModifyIORef IORef State
    iactive (\State
    x -> (State -> State
    go' State
    x, State
    x))
            case state of
                State
    Inactive -> do
                    action <- IORef (IO ()) -> IO (IO ())
    forall a. IORef a -> IO a
    I.readIORef IORef (IO ())
    onTimeout
                    action `E.catch` ignoreAll
                    go rest front
                State
    Canceled -> [Handle] -> ([Handle] -> c) -> IO ([Handle] -> c)
    go [Handle]
    rest [Handle] -> c
    front
                State
    _ -> [Handle] -> ([Handle] -> c) -> IO ([Handle] -> c)
    go [Handle]
    rest ([Handle] -> c
    front ([Handle] -> c) -> ([Handle] -> [Handle]) -> [Handle] -> c
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (:) Handle
    m)
        go' :: State -> State
    go' State
    Active = State
    Inactive
        go' State
    x = State
    x

    ignoreAll :: E.SomeException -> IO ()
    ignoreAll :: SomeException -> IO ()
    ignoreAll SomeException
    _ = () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

    register :: Manager -> IO () -> IO Handle
    register :: Manager -> IO () -> IO Handle
    register (Manager IORef [Handle]
    ref) IO ()
    onTimeout = do
        iactive <- State -> IO (IORef State)
    forall a. a -> IO (IORef a)
    I.newIORef State
    Active
        action  <- I.newIORef onTimeout
        let h = IORef (IO ()) -> IORef State -> Handle
    Handle IORef (IO ())
    action IORef State
    iactive
        I.atomicModifyIORef ref (\[Handle]
    x -> (Handle
    h Handle -> [Handle] -> [Handle]
    forall a. a -> [a] -> [a]
    : [Handle]
    x, ()))
        return h

    registerKillThread :: Manager -> IO Handle
    registerKillThread :: Manager -> IO Handle
    registerKillThread Manager
    m = do
        tid <- IO ThreadId
    myThreadId
        register m $ killThread tid

    tickle, pause, resume, cancel :: Handle -> IO ()
    tickle :: Handle -> IO ()
    tickle (Handle IORef (IO ())
    _ IORef State
    iactive) = IORef State -> State -> IO ()
    forall a. IORef a -> a -> IO ()
    I.writeIORef IORef State
    iactive (State -> IO ()) -> State -> IO ()
    forall a b. (a -> b) -> a -> b
    $! State
    Active
    pause :: Handle -> IO ()
    pause (Handle IORef (IO ())
    _ IORef State
    iactive) = IORef State -> State -> IO ()
    forall a. IORef a -> a -> IO ()
    I.writeIORef IORef State
    iactive (State -> IO ()) -> State -> IO ()
    forall a b. (a -> b) -> a -> b
    $! State
    Paused
    resume :: Handle -> IO ()
    resume = Handle -> IO ()
    tickle
    cancel :: Handle -> IO ()
    cancel (Handle IORef (IO ())
    action IORef State
    iactive) =
        do IORef State -> State -> IO ()
    forall a. IORef a -> a -> IO ()
    I.writeIORef IORef State
    iactive (State -> IO ()) -> State -> IO ()
    forall a b. (a -> b) -> a -> b
    $! State
    Canceled
           IORef (IO ()) -> IO () -> IO ()
    forall a. IORef a -> a -> IO ()
    I.writeIORef IORef (IO ())
    action (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $! (() -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ())

    forceTimeout :: Handle -> IO ()
    forceTimeout :: Handle -> IO ()
    forceTimeout (Handle IORef (IO ())
    action IORef State
    iactive) =
      do IORef State -> State -> IO ()
    forall a. IORef a -> a -> IO ()
    I.writeIORef IORef State
    iactive (State -> IO ()) -> State -> IO ()
    forall a b. (a -> b) -> a -> b
    $! State
    Canceled
         io <- IORef (IO ()) -> (IO () -> (IO (), IO ())) -> IO (IO ())
    forall a b. IORef a -> (a -> (a, b)) -> IO b
    I.atomicModifyIORef IORef (IO ())
    action (\IO ()
    io -> (() -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (), IO ()
    io))
         io `E.catch` ignoreAll

    -- | terminate all threads immediately
    forceTimeoutAll :: Manager -> IO ()
    forceTimeoutAll :: Manager -> IO ()
    forceTimeoutAll (Manager IORef [Handle]
    ref) =
      do hs <- IORef [Handle] -> ([Handle] -> ([Handle], [Handle])) -> IO [Handle]
    forall a b. IORef a -> (a -> (a, b)) -> IO b
    I.atomicModifyIORef IORef [Handle]
    ref (\[Handle]
    hs -> ([], [Handle]
    hs))
         mapM_ forceTimeout hs