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
    IORef [Handle]
ref <- forall a. a -> IO (IORef a)
I.newIORef []
    ThreadId
_ <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
        Int -> IO ()
threadDelay Int
timeout
        [Handle]
ms <- forall a b. IORef a -> (a -> (a, b)) -> IO b
I.atomicModifyIORef IORef [Handle]
ref (\[Handle]
x -> ([], [Handle]
x))
        [Handle] -> [Handle]
ms' <- forall {c}. [Handle] -> ([Handle] -> c) -> IO ([Handle] -> c)
go [Handle]
ms forall a. a -> a
id
        forall a b. IORef a -> (a -> (a, b)) -> IO b
I.atomicModifyIORef IORef [Handle]
ref (\[Handle]
x -> ([Handle] -> [Handle]
ms' [Handle]
x, ()))
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ IORef [Handle] -> Manager
Manager IORef [Handle]
ref
  where
    go :: [Handle] -> ([Handle] -> c) -> IO ([Handle] -> c)
go [] [Handle] -> c
front = 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
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
state of
            State
Inactive -> do
                IO ()
action <- forall a. IORef a -> IO a
I.readIORef IORef (IO ())
onTimeout
                IO ()
action forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` SomeException -> IO ()
ignoreAll
                [Handle] -> ([Handle] -> c) -> IO ([Handle] -> c)
go [Handle]
rest [Handle] -> c
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 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
_ = 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
    IORef State
iactive <- forall a. a -> IO (IORef a)
I.newIORef State
Active
    IORef (IO ())
action  <- forall a. a -> IO (IORef a)
I.newIORef IO ()
onTimeout
    let h :: Handle
h = IORef (IO ()) -> IORef State -> Handle
Handle IORef (IO ())
action IORef State
iactive
    forall a b. IORef a -> (a -> (a, b)) -> IO b
I.atomicModifyIORef IORef [Handle]
ref (\[Handle]
x -> (Handle
h forall a. a -> [a] -> [a]
: [Handle]
x, ()))
    forall (m :: * -> *) a. Monad m => a -> m a
return Handle
h

registerKillThread :: Manager -> IO Handle
registerKillThread :: Manager -> IO Handle
registerKillThread Manager
m = do
    ThreadId
tid <- IO ThreadId
myThreadId
    Manager -> IO () -> IO Handle
register Manager
m forall a b. (a -> b) -> a -> b
$ ThreadId -> IO ()
killThread ThreadId
tid

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

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

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