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