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 <- [Handle] -> IO (IORef [Handle])
forall a. a -> IO (IORef a)
I.newIORef []
    ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Int -> IO ()
threadDelay Int
timeout
        [Handle]
ms <- IORef [Handle] -> ([Handle] -> ([Handle], [Handle])) -> IO [Handle]
forall a b. IORef a -> (a -> (a, b)) -> IO b
I.atomicModifyIORef IORef [Handle]
ref (\[Handle]
x -> ([], [Handle]
x))
        [Handle] -> [Handle]
ms' <- [Handle] -> ([Handle] -> [Handle]) -> IO ([Handle] -> [Handle])
forall c. [Handle] -> ([Handle] -> c) -> IO ([Handle] -> c)
go [Handle]
ms [Handle] -> [Handle]
forall a. a -> a
id
        IORef [Handle] -> ([Handle] -> ([Handle], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
I.atomicModifyIORef IORef [Handle]
ref (\[Handle]
x -> ([Handle] -> [Handle]
ms' [Handle]
x, ()))
    Manager -> IO Manager
forall (m :: * -> *) a. Monad m => a -> m a
return (Manager -> IO Manager) -> Manager -> IO Manager
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 = ([Handle] -> c) -> IO ([Handle] -> c)
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 <- 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
state of
            State
Inactive -> do
                IO ()
action <- IORef (IO ()) -> IO (IO ())
forall a. IORef a -> IO a
I.readIORef IORef (IO ())
onTimeout
                IO ()
action IO () -> (SomeException -> IO ()) -> IO ()
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 ([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 (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 <- State -> IO (IORef State)
forall a. a -> IO (IORef a)
I.newIORef State
Active
    IORef (IO ())
action  <- IO () -> IO (IORef (IO ()))
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
    IORef [Handle] -> ([Handle] -> ([Handle], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
I.atomicModifyIORef IORef [Handle]
ref (\[Handle]
x -> (Handle
h Handle -> [Handle] -> [Handle]
forall a. a -> [a] -> [a]
: [Handle]
x, ()))
    Handle -> IO Handle
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 (IO () -> IO Handle) -> IO () -> IO Handle
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) = 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 (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 ()
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 (m :: * -> *) a. Monad m => a -> m a
return (), IO ()
io))
     IO ()
io IO () -> (SomeException -> 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 <- 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))
     (Handle -> IO ()) -> [Handle] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Handle -> IO ()
forceTimeout [Handle]
hs