{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StrictData #-}

-- | Timeout manager. Since v0.3.0, timeout manager is a wrapper of
-- GHC System TimerManager.
--
-- Users of old version should check the current semantics.
module System.TimeManager (
    -- ** Types
    Manager,
    defaultManager,
    TimeoutAction,
    Handle,
    emptyHandle,

    -- ** Manager
    initialize,
    stopManager,
    killManager,
    withManager,
    withManager',

    -- ** Registering a timeout action
    withHandle,
    withHandleKillThread,

    -- ** Control timeout
    tickle,
    pause,
    resume,

    -- ** Low level
    register,
    registerKillThread,
    cancel,

    -- ** Exceptions
    TimeoutThread (..),
) where

import Control.Concurrent (mkWeakThreadId, myThreadId)
import qualified Control.Exception as E
import Data.IORef (IORef)
import qualified Data.IORef as I
import System.Mem.Weak (deRefWeak)

#if defined(mingw32_HOST_OS)
import qualified GHC.Event.Windows as EV
#else
import qualified GHC.Event as EV
#endif

----------------------------------------------------------------

-- | A timeout manager
newtype Manager = Manager Int

-- | A manager whose timeout value is 0 (no callbacks are fired).
defaultManager :: Manager
defaultManager :: Manager
defaultManager = Int -> Manager
Manager Int
0

isNoManager :: Manager -> Bool
isNoManager :: Manager -> Bool
isNoManager (Manager Int
0) = Bool
True
isNoManager Manager
_ = Bool
False

----------------------------------------------------------------

-- | An action (callback) to be performed on timeout.
type TimeoutAction = IO ()

----------------------------------------------------------------

-- | A handle used by a timeout manager.
data Handle = Handle
    { Handle -> Int
handleTimeout :: Int
    , Handle -> TimeoutAction
handleAction :: TimeoutAction
    , Handle -> IORef TimeoutKey
handleKeyRef :: ~(IORef EV.TimeoutKey)
    }

-- | Dummy 'Handle'.
emptyHandle :: Handle
emptyHandle :: Handle
emptyHandle =
    Handle
        { handleTimeout :: Int
handleTimeout = Int
0
        , handleAction :: TimeoutAction
handleAction = () -> TimeoutAction
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        , handleKeyRef :: IORef TimeoutKey
handleKeyRef = [Char] -> IORef TimeoutKey
forall a. HasCallStack => [Char] -> a
error [Char]
"time-manager: Handle.handleKeyRef not set"
        }

isEmptyHandle :: Handle -> Bool
isEmptyHandle :: Handle -> Bool
isEmptyHandle Handle{Int
TimeoutAction
IORef TimeoutKey
handleTimeout :: Handle -> Int
handleAction :: Handle -> TimeoutAction
handleKeyRef :: Handle -> IORef TimeoutKey
handleTimeout :: Int
handleAction :: TimeoutAction
handleKeyRef :: IORef TimeoutKey
..} = Int
handleTimeout Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0

----------------------------------------------------------------

-- | Creating timeout manager with a timeout value in microseconds.
--
--   Setting the timeout to zero or lower (<= 0) will produce a
--   `defaultManager`.
initialize :: Int -> IO Manager
initialize :: Int -> IO Manager
initialize = Manager -> IO Manager
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Manager -> IO Manager) -> (Int -> Manager) -> Int -> IO Manager
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Manager
Manager (Int -> Manager) -> (Int -> Int) -> Int -> Manager
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0

----------------------------------------------------------------

-- | Obsoleted since version 0.3.0
--   Is now equivalent to @pure ()@.
stopManager :: Manager -> IO ()
stopManager :: Manager -> TimeoutAction
stopManager Manager
_ = () -> TimeoutAction
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
{-# DEPRECATED stopManager "This function does nothing since version 0.3.0" #-}

-- | Obsoleted since version 0.3.0
--   Is now equivalent to @pure ()@.
killManager :: Manager -> IO ()
killManager :: Manager -> TimeoutAction
killManager Manager
_ = () -> TimeoutAction
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
{-# DEPRECATED killManager "This function does nothing since version 0.3.0" #-}

----------------------------------------------------------------

-- | Registering a timeout action and unregister its handle
--   when the body action is finished.
withHandle :: Manager -> TimeoutAction -> (Handle -> IO a) -> IO a
withHandle :: forall a. Manager -> TimeoutAction -> (Handle -> IO a) -> IO a
withHandle Manager
mgr TimeoutAction
onTimeout Handle -> IO a
action
    | Manager -> Bool
isNoManager Manager
mgr = Handle -> IO a
action Handle
emptyHandle
    | Bool
otherwise = IO Handle -> (Handle -> TimeoutAction) -> (Handle -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket (Manager -> TimeoutAction -> IO Handle
register Manager
mgr TimeoutAction
onTimeout) Handle -> TimeoutAction
cancel Handle -> IO a
action

-- | Registering a timeout action of killing this thread and
--   unregister its handle when the body action is killed or finished.
withHandleKillThread :: Manager -> TimeoutAction -> (Handle -> IO ()) -> IO ()
withHandleKillThread :: Manager
-> TimeoutAction -> (Handle -> TimeoutAction) -> TimeoutAction
withHandleKillThread Manager
mgr TimeoutAction
onTimeout Handle -> TimeoutAction
action
    | Manager -> Bool
isNoManager Manager
mgr = Handle -> TimeoutAction
action Handle
emptyHandle
    | Bool
otherwise =
        (TimeoutThread -> TimeoutAction) -> TimeoutAction -> TimeoutAction
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
E.handle TimeoutThread -> TimeoutAction
forall {m :: * -> *}. Monad m => TimeoutThread -> m ()
ignore (TimeoutAction -> TimeoutAction) -> TimeoutAction -> TimeoutAction
forall a b. (a -> b) -> a -> b
$ IO Handle
-> (Handle -> TimeoutAction)
-> (Handle -> TimeoutAction)
-> TimeoutAction
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket (Manager -> TimeoutAction -> IO Handle
registerKillThread Manager
mgr TimeoutAction
onTimeout) Handle -> TimeoutAction
cancel Handle -> TimeoutAction
action
  where
    ignore :: TimeoutThread -> m ()
ignore TimeoutThread
TimeoutThread = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

----------------------------------------------------------------

-- | Registering a timeout action.
register :: Manager -> TimeoutAction -> IO Handle
register :: Manager -> TimeoutAction -> IO Handle
register mgr :: Manager
mgr@(Manager Int
timeout) TimeoutAction
onTimeout
    | Manager -> Bool
isNoManager Manager
mgr = Handle -> IO Handle
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
emptyHandle
    | Bool
otherwise = do
        TimerManager
sysmgr <- IO TimerManager
getTimerManager
        TimeoutKey
key <- TimerManager -> Int -> TimeoutAction -> IO TimeoutKey
EV.registerTimeout TimerManager
sysmgr Int
timeout TimeoutAction
onTimeout
        IORef TimeoutKey
keyref <- TimeoutKey -> IO (IORef TimeoutKey)
forall a. a -> IO (IORef a)
I.newIORef TimeoutKey
key
        let h :: Handle
h =
                Handle
                    { handleTimeout :: Int
handleTimeout = Int
timeout
                    , handleAction :: TimeoutAction
handleAction = TimeoutAction
onTimeout
                    , handleKeyRef :: IORef TimeoutKey
handleKeyRef = IORef TimeoutKey
keyref
                    }
        Handle -> IO Handle
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
h

-- | Unregistering the timeout.
cancel :: Handle -> IO ()
cancel :: Handle -> TimeoutAction
cancel Handle
hd | Handle -> Bool
isEmptyHandle Handle
hd = () -> TimeoutAction
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
cancel Handle{Int
TimeoutAction
IORef TimeoutKey
handleTimeout :: Handle -> Int
handleAction :: Handle -> TimeoutAction
handleKeyRef :: Handle -> IORef TimeoutKey
handleTimeout :: Int
handleAction :: TimeoutAction
handleKeyRef :: IORef TimeoutKey
..} = do
    TimerManager
mgr <- IO TimerManager
getTimerManager
    TimeoutKey
key <- IORef TimeoutKey -> IO TimeoutKey
forall a. IORef a -> IO a
I.readIORef IORef TimeoutKey
handleKeyRef
    TimerManager -> TimeoutKey -> TimeoutAction
EV.unregisterTimeout TimerManager
mgr TimeoutKey
key

-- | Extending the timeout.
tickle :: Handle -> IO ()
tickle :: Handle -> TimeoutAction
tickle Handle
h | Handle -> Bool
isEmptyHandle Handle
h = () -> TimeoutAction
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
tickle Handle{Int
TimeoutAction
IORef TimeoutKey
handleTimeout :: Handle -> Int
handleAction :: Handle -> TimeoutAction
handleKeyRef :: Handle -> IORef TimeoutKey
handleTimeout :: Int
handleAction :: TimeoutAction
handleKeyRef :: IORef TimeoutKey
..} = do
    TimerManager
mgr <- IO TimerManager
getTimerManager
    TimeoutKey
key <- IORef TimeoutKey -> IO TimeoutKey
forall a. IORef a -> IO a
I.readIORef IORef TimeoutKey
handleKeyRef
#if defined(mingw32_HOST_OS)
    EV.updateTimeout mgr key $ fromIntegral (handleTimeout `div` 1000000)
#else
    TimerManager -> TimeoutKey -> Int -> TimeoutAction
EV.updateTimeout TimerManager
mgr TimeoutKey
key Int
handleTimeout
#endif

-- | This is identical to 'cancel'.
--   To resume timeout with the same 'Handle', 'resume' MUST be called.
--   Don't call 'tickle' for resumption.
pause :: Handle -> IO ()
pause :: Handle -> TimeoutAction
pause = Handle -> TimeoutAction
cancel

-- | Resuming the timeout.
resume :: Handle -> IO ()
resume :: Handle -> TimeoutAction
resume Handle
h | Handle -> Bool
isEmptyHandle Handle
h = () -> TimeoutAction
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
resume Handle{Int
TimeoutAction
IORef TimeoutKey
handleTimeout :: Handle -> Int
handleAction :: Handle -> TimeoutAction
handleKeyRef :: Handle -> IORef TimeoutKey
handleTimeout :: Int
handleAction :: TimeoutAction
handleKeyRef :: IORef TimeoutKey
..} = do
    TimerManager
mgr <- IO TimerManager
getTimerManager
    TimeoutKey
key <- TimerManager -> Int -> TimeoutAction -> IO TimeoutKey
EV.registerTimeout TimerManager
mgr Int
handleTimeout TimeoutAction
handleAction
    IORef TimeoutKey -> TimeoutKey -> TimeoutAction
forall a. IORef a -> a -> TimeoutAction
I.writeIORef IORef TimeoutKey
handleKeyRef TimeoutKey
key

----------------------------------------------------------------

-- | The asynchronous exception thrown if a thread is registered via
-- 'registerKillThread'.
data TimeoutThread = TimeoutThread

instance E.Exception TimeoutThread where
    toException :: TimeoutThread -> SomeException
toException = TimeoutThread -> SomeException
forall e. Exception e => e -> SomeException
E.asyncExceptionToException
    fromException :: SomeException -> Maybe TimeoutThread
fromException = SomeException -> Maybe TimeoutThread
forall e. Exception e => SomeException -> Maybe e
E.asyncExceptionFromException

instance Show TimeoutThread where
    show :: TimeoutThread -> [Char]
show TimeoutThread
TimeoutThread = [Char]
"Thread killed by timeout manager"

-- | Registering a timeout action of killing this thread.
--   'TimeoutThread' is thrown to the thread which called this
--   function on timeout. Catch 'TimeoutThread' if you don't
--   want to leak the asynchronous exception to GHC RTS.
registerKillThread :: Manager -> TimeoutAction -> IO Handle
registerKillThread :: Manager -> TimeoutAction -> IO Handle
registerKillThread Manager
m TimeoutAction
onTimeout = do
    ThreadId
tid <- IO ThreadId
myThreadId
    Weak ThreadId
wtid <- ThreadId -> IO (Weak ThreadId)
mkWeakThreadId ThreadId
tid
    -- First run the timeout action in case the child thread is masked.
    Manager -> TimeoutAction -> IO Handle
register Manager
m (TimeoutAction -> IO Handle) -> TimeoutAction -> IO Handle
forall a b. (a -> b) -> a -> b
$
        TimeoutAction
onTimeout TimeoutAction -> TimeoutAction -> TimeoutAction
forall a b. IO a -> IO b -> IO a
`E.finally` do
            Maybe ThreadId
mtid <- Weak ThreadId -> IO (Maybe ThreadId)
forall v. Weak v -> IO (Maybe v)
deRefWeak Weak ThreadId
wtid
            case Maybe ThreadId
mtid of
                Maybe ThreadId
Nothing -> () -> TimeoutAction
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                -- FIXME: forkIO to prevent blocking TimerManger
                Just ThreadId
tid' -> ThreadId -> TimeoutThread -> TimeoutAction
forall e. Exception e => ThreadId -> e -> TimeoutAction
E.throwTo ThreadId
tid' TimeoutThread
TimeoutThread

----------------------------------------------------------------

-- | Call the inner function with a timeout manager.
withManager
    :: Int
    -- ^ timeout in microseconds
    -> (Manager -> IO a)
    -> IO a
withManager :: forall a. Int -> (Manager -> IO a) -> IO a
withManager Int
timeout Manager -> IO a
f = Int -> IO Manager
initialize Int
timeout IO Manager -> (Manager -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Manager -> IO a
f

-- | Call the inner function with a timeout manager.
--   This is identical to 'withManager'.
withManager'
    :: Int
    -- ^ timeout in microseconds
    -> (Manager -> IO a)
    -> IO a
withManager' :: forall a. Int -> (Manager -> IO a) -> IO a
withManager' = Int -> (Manager -> IO a) -> IO a
forall a. Int -> (Manager -> IO a) -> IO a
withManager
{-# DEPRECATED withManager' "This function is the same as 'withManager' since version 0.3.0" #-}

#if defined(mingw32_HOST_OS)
getTimerManager :: IO EV.Manager
getTimerManager = EV.getSystemManager
#else
getTimerManager :: IO EV.TimerManager
getTimerManager :: IO TimerManager
getTimerManager = IO TimerManager
EV.getSystemTimerManager
#endif