{-# LANGUAGE CPP #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE RecordWildCards #-}

-- | Timeout manager. Since @v0.3.0@, timeout manager is a wrapper of
-- GHC System TimerManager, except on Windows, where it has a timer of
-- its own: the one in @GHC.Event.Windows@ belongs to WinIO and never
-- runs under the I\/O manager which is still the default there.
--
-- Some caveats of using this package:
--
--   * Only works for GHC
--   * Only works with a threaded runtime
--   * Users of older versions should check the current semantics.
--   * Using 32-bit systems means the max timeout is @'maxBound' :: Int@
--     (2147483647) microseconds, which is less than 36 minutes.
--   * Using the same 'Handle' in different threads might cause issues in some
--     edge cases. (i.e. using 'cancel'/'pause' in one thread, and 'resume' in another)
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,
    cancel,

    -- ** Low level
    register,
    registerKillThread,

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

import Control.Concurrent (forkIO, mkWeakThreadId, myThreadId, newMVar)
import qualified Control.Exception as E
import Control.Monad (void, when)
import Data.Bits (shiftR)
import qualified Data.IORef as I
import Data.Word (Word64)
import GHC.Clock (getMonotonicTimeNSec)
import System.IO.Unsafe (unsafePerformIO)
import System.Mem.Weak (deRefWeak)
import System.TimeManager.Internal

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

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

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

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

-- | Dummy 'Handle'.
emptyHandle :: Handle
emptyHandle :: Handle
emptyHandle =
    Handle
        { handleTimeout :: Int
handleTimeout = Int
0
        , handleAction :: TimeoutAction
handleAction = () -> TimeoutAction
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        , handleTimerManager :: TimerManager
handleTimerManager = [Char] -> TimerManager
forall {a}. [Char] -> a
mutError [Char]
"handleTimerManager"
        , handleState :: IORef HandleState
handleState = [Char] -> IORef HandleState
forall {a}. [Char] -> a
mutError [Char]
"handleState"
        , handleLastRenewed :: IORef Word64
handleLastRenewed = [Char] -> IORef Word64
forall {a}. [Char] -> a
mutError [Char]
"handleLastRenewed"
        , handleMinRenewGap :: Word64
handleMinRenewGap = Word64
0
        , handleLock :: Lock
handleLock = Lock
emptyLock
        }
  where
    mutError :: [Char] -> a
mutError [Char]
s = [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char] -> a) -> [Char] -> a
forall a b. (a -> b) -> a -> b
$ [Char]
"time-manager: Handle." [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
s [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" not set"

emptyLock :: Lock
emptyLock :: Lock
emptyLock = IO Lock -> Lock
forall a. IO a -> a
unsafePerformIO (IO Lock -> Lock) -> IO Lock -> Lock
forall a b. (a -> b) -> a -> b
$ () -> IO Lock
forall a. a -> IO (MVar a)
newMVar ()
{-# NOINLINE emptyLock #-}

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

-- | 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 (f :: * -> *) a. Applicative f => a -> f a
pure ()
{-# 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 (f :: * -> *) a. Applicative f => a -> f a
pure ()
{-# 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 {f :: * -> *}. Applicative f => TimeoutThread -> f ()
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 -> f ()
ignore TimeoutThread
TimeoutThread = () -> f ()
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

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

-- ============== NOTE ABOUT THREAD SAFETY ==============
--
-- The use of 'IORef's are fine in the current situation where
-- the 'TimeManager' is supposed to be used in a single thread.
--
-- The triggered action, though, is run by the Timer Manager
-- outside of the thread it was registered in.
-- This will potentially cause race conditions if we implement
-- anything that depends on the 'Handle's state.
--
-- Given the following:
--   - If run in one thread: 'register/tickle/pause/resume/cancel' never
--     overlap, making them devoid of race conditions in the general sense.
--   - We want to hit the Timer Manager as little as possible.
--   - We want to keep the 'resume/pause' surface functionality intact, while
--     not hitting the Timer Manager when we don't have to. This means not
--     cancelling the timeout on a pause, but rather mark the timeout paused.
--   - Not actually stopping the timeout on 'pause' introduces race
--     conditions, because the registered action will need to check the 'Handle'
--     state to see whether it should actually run (Active) or if it should
--     drop the action (Paused/Stopped).
--   - Not hitting the Timer Manager on a 'pause' will increase performance on
--     hot 'resume/pause' loops, like 'warp' has when using a streaming response.
--   - 'tickle' gets a sort of debounce to avoid repeated updates in hot loops.
--     - The debounce is 1/4 of the timeout, but we cap it to a maximum of 1 second.
--     - This means the registered action might run earlier than the timeout
--       would indicate; that difference going up to a maximum of 'handleMinRenewGap'.
--   - The following can happen:
--     - == The "Surprise Active" issue ==
--        A 'resume' might get called right after a 'Paused' registered action
--        starts running, and sets the state to 'Active' __before__ the action
--        inspects the 'Handle' state.
--     - == The "Dropped Active" issue ==
--        A 'resume' might get called right after a 'Paused' registered action
--        starts running, but inspects the state __before__ the action sets the
--        state to 'Stopped', and the registered action inspects the state
--        __before__ the 'resume' has set it to 'Active'. Essentially missing
--        the 'resume' completely.
--     - == The "Dropped Cancel" issue ==
--       A 'cancel' getting called right after a 'Paused' registered action
--       starts running, and cancelling __after__ the action reads the state
--       will have the registered action overwrite the state to 'Stopped',
--       when it shouldn't register a new action, but stop everything.
--     - A 'pause' should technically not be an issue, as it will only run when
--       the state is 'Active', but it is a function that changes the state, so
--       just to be cautious, we let it grab the lock.
--     - A 'tickle' in the same situation doesn't matter, as a 'tickle'
--       shouldn't activate a 'Paused' state. (and doesn't change any state)
--   - The "Surprise Active" issue can be mitigated by checking the
--     'handleLastRenewed' time and reregistering the timeout action with the
--     remaining amount of microseconds in the case where it has not yet been
--     'handleTimeout' amount of time.
--     - A 'tickle' could also cause this if the state was 'Active' all along,
--       but we'll accept the 'tickle' as being on time to extend the timeout.
--   - The "Dropped Active" issue is a bit more difficult to mitigate. We'll
--     need a lock to guarantee that either the activation of 'resume' is seen
--     by the registered action, or that the termination of the registered
--     action is seen by the 'resume'.
--   - The "Dropped Cancel" issue will also be avoided when using a lock.
--   - The lock will generally never be contested. It is there only for the
--     off-chance that a state-changing function runs JUST after the registered
--     action triggers. So in general, we don't expect the lock to reduce
--     performance noticeably.

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

-- | 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 (f :: * -> *) a. Applicative f => a -> f a
pure Handle
emptyHandle
    | Bool
otherwise = do
        -- The system timer manager is stable for the lifetime of the
        -- process (and even if it were replaced, e.g. around a fork,
        -- the key registered below would only be meaningful to the
        -- manager it was registered with). So fetch it once here and
        -- cache it in the 'Handle' instead of re-reading the global
        -- IORef on every tickle/pause/resume.
        TimerManager
sysmgr <- IO TimerManager
getTimerManager
        IORef HandleState
stateRef <- HandleState -> IO (IORef HandleState)
forall a. a -> IO (IORef a)
I.newIORef HandleState
Stopped
        Lock
lock <- IO Lock
newLock
        IORef Word64
lastRenewedRef <- Word64 -> IO (IORef Word64)
forall a. a -> IO (IORef a)
I.newIORef (Word64 -> IO (IORef Word64)) -> IO Word64 -> IO (IORef Word64)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Word64
getMonotonicTimeNSec
        let h :: Handle
h =
                Handle
                    { handleTimeout :: Int
handleTimeout = Int
timeout
                    , handleAction :: TimeoutAction
handleAction = TimeoutAction
onTimeout
                    , handleTimerManager :: TimerManager
handleTimerManager = TimerManager
sysmgr
                    , handleState :: IORef HandleState
handleState = IORef HandleState
stateRef
                    , handleLastRenewed :: IORef Word64
handleLastRenewed = IORef Word64
lastRenewedRef
                    , handleMinRenewGap :: Word64
handleMinRenewGap = Int -> Word64
minRenewGap Int
timeout
                    , handleLock :: Lock
handleLock = Lock
lock
                    }
        -- Just in case the timeout is only 1 microsecond and because of thread
        -- scheduling it runs before we can change the state to 'Active'
        Lock -> TimeoutAction -> TimeoutAction
forall a. Lock -> IO a -> IO a
withLock Lock
lock (TimeoutAction -> TimeoutAction) -> TimeoutAction -> TimeoutAction
forall a b. (a -> b) -> a -> b
$ do
            TimeoutKey
key <- Handle -> Int -> IO TimeoutKey
registerAdjustedTimeout Handle
h Int
timeout
            Word64
now <- IO Word64
getMonotonicTimeNSec
            IORef Word64 -> Word64 -> TimeoutAction
forall a. IORef a -> a -> TimeoutAction
I.writeIORef IORef Word64
lastRenewedRef Word64
now
            IORef HandleState -> HandleState -> TimeoutAction
forall a. IORef a -> a -> TimeoutAction
I.writeIORef IORef HandleState
stateRef (HandleState -> TimeoutAction) -> HandleState -> TimeoutAction
forall a b. (a -> b) -> a -> b
$ TimeoutKey -> HandleState
Active TimeoutKey
key
        Handle -> IO Handle
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Handle
h

-- | This function needs a separate 'timeout' argument, because we might not
-- register the full amount of time when continuing a timeout that was started
-- a bit earlier. (cf. "Surprise Active" situation)
registerAdjustedTimeout :: Handle -> Int -> IO EV.TimeoutKey
registerAdjustedTimeout :: Handle -> Int -> IO TimeoutKey
registerAdjustedTimeout h :: Handle
h@Handle{Int
TimeoutAction
Word64
Lock
IORef Word64
IORef HandleState
TimerManager
handleTimeout :: Handle -> Int
handleAction :: Handle -> TimeoutAction
handleTimerManager :: Handle -> TimerManager
handleState :: Handle -> IORef HandleState
handleLastRenewed :: Handle -> IORef Word64
handleMinRenewGap :: Handle -> Word64
handleLock :: Handle -> Lock
handleTimeout :: Int
handleAction :: TimeoutAction
handleTimerManager :: TimerManager
handleLock :: Lock
handleState :: IORef HandleState
handleLastRenewed :: IORef Word64
handleMinRenewGap :: Word64
..} Int
timeout = do
    IORef TimeoutKey
originalKeyRef <-
        TimeoutKey -> IO (IORef TimeoutKey)
forall a. a -> IO (IORef a)
I.newIORef (TimeoutKey -> IO (IORef TimeoutKey))
-> TimeoutKey -> IO (IORef TimeoutKey)
forall a b. (a -> b) -> a -> b
$
            [Char] -> TimeoutKey
forall a. HasCallStack => [Char] -> a
error [Char]
"System.TimeManager.registerAdjustedTimeout: originalKeyRef not filled"
    TimeoutKey
key <-
        TimerManager -> Int -> TimeoutAction -> IO TimeoutKey
EV.registerTimeout TimerManager
handleTimerManager Int
timeout (TimeoutAction -> IO TimeoutKey) -> TimeoutAction -> IO TimeoutKey
forall a b. (a -> b) -> a -> b
$
            IORef TimeoutKey -> Handle -> TimeoutAction
adjustOnTimeout IORef TimeoutKey
originalKeyRef Handle
h
    IORef TimeoutKey -> TimeoutKey -> TimeoutAction
forall a. IORef a -> a -> TimeoutAction
I.writeIORef IORef TimeoutKey
originalKeyRef TimeoutKey
key
    TimeoutKey -> IO TimeoutKey
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TimeoutKey
key

-- | Wrapper around a registered action to ensure correct handling.
--
-- We basically need the 'Handle', but this is used before making the handle, so
adjustOnTimeout :: I.IORef EV.TimeoutKey -> Handle -> TimeoutAction
adjustOnTimeout :: IORef TimeoutKey -> Handle -> TimeoutAction
adjustOnTimeout IORef TimeoutKey
originalKeyRef h :: Handle
h@Handle{Int
TimeoutAction
Word64
Lock
IORef Word64
IORef HandleState
TimerManager
handleTimeout :: Handle -> Int
handleAction :: Handle -> TimeoutAction
handleTimerManager :: Handle -> TimerManager
handleState :: Handle -> IORef HandleState
handleLastRenewed :: Handle -> IORef Word64
handleMinRenewGap :: Handle -> Word64
handleLock :: Handle -> Lock
handleTimeout :: Int
handleAction :: TimeoutAction
handleTimerManager :: TimerManager
handleLock :: Lock
handleState :: IORef HandleState
handleLastRenewed :: IORef Word64
handleMinRenewGap :: Word64
..} = do
    let writeState :: HandleState -> TimeoutAction
writeState = IORef HandleState -> HandleState -> TimeoutAction
forall a. IORef a -> a -> TimeoutAction
I.atomicWriteIORef IORef HandleState
handleState
    -- Lock ensures we don't get race conditions.
    -- We return a boolean so that we don't run the (potentially long) action
    -- while holding on to the lock.
    Bool
shouldRun <- Lock -> IO Bool -> IO Bool
forall a. Lock -> IO a -> IO a
withLock Lock
handleLock (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
        HandleState
st <- IORef HandleState -> IO HandleState
forall a. IORef a -> IO a
I.readIORef IORef HandleState
handleState
        case HandleState
st of
            -- We can check the @now - handleLastRenewed@ diff
            -- and 'threadDelay' the diff to make the timing better?
            -- @if diff > 'handleTimeout - 'handleMinRenewGap' then runTimeout@
            Active TimeoutKey
key -> do
                -- set state ref to 'Active'?
                TimeoutKey -> IO Bool -> IO Bool
ifSameKey TimeoutKey
key (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
                    Word64
lastRenewed <- IORef Word64 -> IO Word64
forall a. IORef a -> IO a
I.readIORef IORef Word64
handleLastRenewed
                    Word64
now <- IO Word64
getMonotonicTimeNSec
                    let diff :: Int
diff = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> Word64 -> Int
forall a b. (a -> b) -> a -> b
$ (Word64
now Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
lastRenewed) Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`div` Word64
1_000
                    if Int
diff Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
handleTimeout
                        -- Valid expiration of the timeout, we run the action
                        then do
                            -- We're going to run the action, so set the state
                            -- so that it won't be resumed.
                            HandleState -> TimeoutAction
writeState HandleState
Terminated
                            Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
                        -- "Surprise Active" situation
                        else do
                            -- We reschedule, but with only the remaining time
                            let remainingTimeout :: Int
remainingTimeout = Int
handleTimeout Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
diff
                            TimeoutKey
k <- Handle -> Int -> IO TimeoutKey
registerAdjustedTimeout Handle
h Int
remainingTimeout
                            HandleState -> TimeoutAction
writeState (HandleState -> TimeoutAction) -> HandleState -> TimeoutAction
forall a b. (a -> b) -> a -> b
$ TimeoutKey -> HandleState
Active TimeoutKey
k
                            Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
            -- We find this action being run after it's been paused. We write
            -- the state to 'Stopped' so that 'resume' knows to reregister the
            -- timeout action.
            Paused TimeoutKey
key ->
                TimeoutKey -> IO Bool -> IO Bool
ifSameKey TimeoutKey
key (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
                    HandleState -> TimeoutAction
writeState HandleState
Stopped
                    Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
            -- 'Stopped' and 'Terminated' mean the action shouldn't run.
            HandleState
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Bool -> TimeoutAction -> TimeoutAction
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldRun TimeoutAction
handleAction
  where
    -- If the key in the state isn't the same as the one this action
    -- was registered with, then this action shouldn't run.
    -- (Technically, this situation shouldn't happen. but since the registered
    -- action only ever runs once, we can afford to be redundant)
    ifSameKey :: TimeoutKey -> IO Bool -> IO Bool
ifSameKey TimeoutKey
key IO Bool
f = do
        TimeoutKey
originalKey <- IORef TimeoutKey -> IO TimeoutKey
forall a. IORef a -> IO a
I.readIORef IORef TimeoutKey
originalKeyRef
        if TimeoutKey
key TimeoutKey -> TimeoutKey -> Bool
forall a. Eq a => a -> a -> Bool
== TimeoutKey
originalKey
            then IO Bool
f
            else Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

-- | How long 'tickle' waits before actually renewing the timeout:
--   a quarter of the timeout, capped at one second. Skipping a renewal
--   inside this window only shortens the effective timeout by up to
--   this gap, but turns hot 'tickle' loops (one per chunk sent or
--   received) into a clock read and a comparison.
minRenewGap :: Int -> Word64
minRenewGap :: Int -> Word64
minRenewGap Int
timeout =
    -- @shiftR 2 === divide by 4@
    Word64 -> Word64 -> Word64
forall a. Ord a => a -> a -> a
min Word64
maxRenewDebounce (Int -> Word64
microToNano Int
timeout Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
2)
  where
    microToNano :: Int -> Word64
microToNano = (Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
1_000) (Word64 -> Word64) -> (Int -> Word64) -> Int -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- | One second in nanoseconds
maxRenewDebounce :: Word64
maxRenewDebounce :: Word64
maxRenewDebounce = Word64
1_000_000_000

-- | Run 'f' if the minimum renew gap has been crossed.
whenRenew :: Handle -> IO () -> IO ()
whenRenew :: Handle -> TimeoutAction -> TimeoutAction
whenRenew Handle
h TimeoutAction
f = do
    Word64
now <- IO Word64
getMonotonicTimeNSec
    Word64
lastRenewed <- IORef Word64 -> IO Word64
forall a. IORef a -> IO a
I.readIORef (IORef Word64 -> IO Word64) -> IORef Word64 -> IO Word64
forall a b. (a -> b) -> a -> b
$ Handle -> IORef Word64
handleLastRenewed Handle
h
    Bool -> TimeoutAction -> TimeoutAction
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word64
now Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
lastRenewed Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Handle -> Word64
handleMinRenewGap Handle
h) TimeoutAction
f

-- | Unregistering the timeout.
--
-- The timeout can not be 'resume'd. To "resume" the timeout, you need to
-- 'register' again.
cancel :: Handle -> IO ()
cancel :: Handle -> TimeoutAction
cancel h :: Handle
h@Handle{Int
TimeoutAction
Word64
Lock
IORef Word64
IORef HandleState
TimerManager
handleTimeout :: Handle -> Int
handleAction :: Handle -> TimeoutAction
handleTimerManager :: Handle -> TimerManager
handleState :: Handle -> IORef HandleState
handleLastRenewed :: Handle -> IORef Word64
handleMinRenewGap :: Handle -> Word64
handleLock :: Handle -> Lock
handleTimeout :: Int
handleAction :: TimeoutAction
handleTimerManager :: TimerManager
handleLock :: Lock
handleState :: IORef HandleState
handleLastRenewed :: IORef Word64
handleMinRenewGap :: Word64
..} =
    Handle -> TimeoutAction -> TimeoutAction
withNonEmptyHandle Handle
h (TimeoutAction -> TimeoutAction) -> TimeoutAction -> TimeoutAction
forall a b. (a -> b) -> a -> b
$
        -- "Dropped Cancel" remedy
        --
        -- We can eat a potential mutex pause here to avoid race conditions,
        -- because we don't expect 'cancel' to be called in hot loops.
        --
        -- (The race condition being: the 'Terminated' state being overwritten
        -- because the 'cancel' runs JUST after the registered action starts
        -- running, sets the state to 'Terminated', and then the registered
        -- action finishes and overwrites it to 'Stopped')
        Lock -> TimeoutAction -> TimeoutAction
forall a. Lock -> IO a -> IO a
withLock Lock
handleLock (TimeoutAction -> TimeoutAction) -> TimeoutAction -> TimeoutAction
forall a b. (a -> b) -> a -> b
$ do
            Handle -> (TimeoutKey -> TimeoutAction) -> TimeoutAction
withTimeoutKey Handle
h ((TimeoutKey -> TimeoutAction) -> TimeoutAction)
-> (TimeoutKey -> TimeoutAction) -> TimeoutAction
forall a b. (a -> b) -> a -> b
$ TimerManager -> TimeoutKey -> TimeoutAction
EV.unregisterTimeout TimerManager
handleTimerManager
            IORef HandleState -> HandleState -> TimeoutAction
forall a. IORef a -> a -> TimeoutAction
I.atomicWriteIORef IORef HandleState
handleState HandleState
Terminated

-- | Extending the timeout.
--
-- To keep frequent callers cheap, the renewal is rate-limited: it is
-- skipped unless at least a quarter of the timeout (capped at one
-- second) has passed since the timeout was last registered or updated.
--
-- Careful: this does NOT reactivate an already 'pause'd 'Handle'!
--
tickle :: Handle -> IO ()
tickle :: Handle -> TimeoutAction
tickle h :: Handle
h@Handle{Int
TimeoutAction
Word64
Lock
IORef Word64
IORef HandleState
TimerManager
handleTimeout :: Handle -> Int
handleAction :: Handle -> TimeoutAction
handleTimerManager :: Handle -> TimerManager
handleState :: Handle -> IORef HandleState
handleLastRenewed :: Handle -> IORef Word64
handleMinRenewGap :: Handle -> Word64
handleLock :: Handle -> Lock
handleTimeout :: Int
handleAction :: TimeoutAction
handleTimerManager :: TimerManager
handleLock :: Lock
handleState :: IORef HandleState
handleLastRenewed :: IORef Word64
handleMinRenewGap :: Word64
..} =
    Handle -> TimeoutAction -> TimeoutAction
withNonEmptyHandle Handle
h (TimeoutAction -> TimeoutAction) -> TimeoutAction -> TimeoutAction
forall a b. (a -> b) -> a -> b
$
        Handle -> TimeoutAction -> TimeoutAction
whenRenew Handle
h (TimeoutAction -> TimeoutAction) -> TimeoutAction -> TimeoutAction
forall a b. (a -> b) -> a -> b
$
            Handle -> (TimeoutKey -> TimeoutAction) -> TimeoutAction
withActiveTimeoutKey Handle
h ((TimeoutKey -> TimeoutAction) -> TimeoutAction)
-> (TimeoutKey -> TimeoutAction) -> TimeoutAction
forall a b. (a -> b) -> a -> b
$ \TimeoutKey
key -> do
                TimeoutKey -> TimeoutAction
updateTheTimeout TimeoutKey
key
                Word64
now <- IO Word64
getMonotonicTimeNSec
                IORef Word64 -> Word64 -> TimeoutAction
forall a. IORef a -> a -> TimeoutAction
I.atomicWriteIORef IORef Word64
handleLastRenewed Word64
now
  where
    updateTheTimeout :: TimeoutKey -> TimeoutAction
updateTheTimeout TimeoutKey
key =
        TimerManager -> TimeoutKey -> Int -> TimeoutAction
EV.updateTimeout TimerManager
handleTimerManager TimeoutKey
key Int
handleTimeout

-- | Pauses the timeout so you can 'resume' it later. Does not stop it entirely.
-- Use 'cancel' if you want to make sure the action will not be resumed.
--
-- To resume a timeout with the same 'Handle', 'resume' MUST be called.
-- Don't call 'tickle' for resumption.
pause :: Handle -> IO ()
pause :: Handle -> TimeoutAction
pause h :: Handle
h@Handle{Int
TimeoutAction
Word64
Lock
IORef Word64
IORef HandleState
TimerManager
handleTimeout :: Handle -> Int
handleAction :: Handle -> TimeoutAction
handleTimerManager :: Handle -> TimerManager
handleState :: Handle -> IORef HandleState
handleLastRenewed :: Handle -> IORef Word64
handleMinRenewGap :: Handle -> Word64
handleLock :: Handle -> Lock
handleTimeout :: Int
handleAction :: TimeoutAction
handleTimerManager :: TimerManager
handleLock :: Lock
handleState :: IORef HandleState
handleLastRenewed :: IORef Word64
handleMinRenewGap :: Word64
..} =
    Handle -> TimeoutAction -> TimeoutAction
withNonEmptyHandle Handle
h (TimeoutAction -> TimeoutAction) -> TimeoutAction -> TimeoutAction
forall a b. (a -> b) -> a -> b
$
        Lock -> TimeoutAction -> TimeoutAction
forall a. Lock -> IO a -> IO a
withLock Lock
handleLock (TimeoutAction -> TimeoutAction)
-> ((TimeoutKey -> TimeoutAction) -> TimeoutAction)
-> (TimeoutKey -> TimeoutAction)
-> TimeoutAction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> (TimeoutKey -> TimeoutAction) -> TimeoutAction
withActiveTimeoutKey Handle
h ((TimeoutKey -> TimeoutAction) -> TimeoutAction)
-> (TimeoutKey -> TimeoutAction) -> TimeoutAction
forall a b. (a -> b) -> a -> b
$
            IORef HandleState -> HandleState -> TimeoutAction
forall a. IORef a -> a -> TimeoutAction
I.atomicWriteIORef IORef HandleState
handleState (HandleState -> TimeoutAction)
-> (TimeoutKey -> HandleState) -> TimeoutKey -> TimeoutAction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeoutKey -> HandleState
Paused

-- | Resuming the timeout.
--
-- Works like 'tickle' if the 'Handle' wasn't 'pause'd or 'cancel'ed.
resume :: Handle -> IO ()
resume :: Handle -> TimeoutAction
resume h :: Handle
h@Handle{Int
TimeoutAction
Word64
Lock
IORef Word64
IORef HandleState
TimerManager
handleTimeout :: Handle -> Int
handleAction :: Handle -> TimeoutAction
handleTimerManager :: Handle -> TimerManager
handleState :: Handle -> IORef HandleState
handleLastRenewed :: Handle -> IORef Word64
handleMinRenewGap :: Handle -> Word64
handleLock :: Handle -> Lock
handleTimeout :: Int
handleAction :: TimeoutAction
handleTimerManager :: TimerManager
handleLock :: Lock
handleState :: IORef HandleState
handleLastRenewed :: IORef Word64
handleMinRenewGap :: Word64
..} =
    Handle -> TimeoutAction -> TimeoutAction
withNonEmptyHandle Handle
h (TimeoutAction -> TimeoutAction) -> TimeoutAction -> TimeoutAction
forall a b. (a -> b) -> a -> b
$
        -- we ignore the key when paused, because we recheck the state after
        -- grabbing the lock.
        (TimeoutKey -> TimeoutAction) -> TimeoutAction -> TimeoutAction
checkStateWith (\TimeoutKey
_ -> TimeoutAction
onPausedOrStopped) TimeoutAction
onPausedOrStopped
  where
    -- "Dropped Active" remedy
    --
    -- Grabbing the lock ensures 'resume' runs either before or after the
    -- registered action changes the state.
    onPausedOrStopped :: TimeoutAction
onPausedOrStopped =
        Lock -> TimeoutAction -> TimeoutAction
forall a. Lock -> IO a -> IO a
withLock Lock
handleLock (TimeoutAction -> TimeoutAction) -> TimeoutAction -> TimeoutAction
forall a b. (a -> b) -> a -> b
$ (TimeoutKey -> TimeoutAction) -> TimeoutAction -> TimeoutAction
checkStateWith TimeoutKey -> TimeoutAction
pausedF TimeoutAction
stoppedF
    checkStateWith :: (TimeoutKey -> TimeoutAction) -> TimeoutAction -> TimeoutAction
checkStateWith TimeoutKey -> TimeoutAction
onPaused TimeoutAction
onStopped = do
        HandleState
state <- IORef HandleState -> IO HandleState
forall a. IORef a -> IO a
I.readIORef IORef HandleState
handleState
        case HandleState
state of
            -- 'tickle' doesn't introduce race conditions, so can always be run.
            Active{} -> Handle -> TimeoutAction
tickle Handle
h
            -- Abort when terminated.
            HandleState
Terminated -> () -> TimeoutAction
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Paused TimeoutKey
k -> TimeoutKey -> TimeoutAction
onPaused TimeoutKey
k
            HandleState
Stopped -> TimeoutAction
onStopped
    pausedF :: TimeoutKey -> TimeoutAction
pausedF TimeoutKey
k = do
        -- Set state to 'Active' before 'tickle'ing, because
        -- 'tickle' only runs when the state is 'Active'.
        TimeoutKey -> TimeoutAction
activateTimeout TimeoutKey
k
        Handle -> TimeoutAction
tickle Handle
h
    stoppedF :: TimeoutAction
stoppedF = do
        TimeoutKey
key <- Handle -> Int -> IO TimeoutKey
registerAdjustedTimeout Handle
h Int
handleTimeout
        Word64
now <- IO Word64
getMonotonicTimeNSec
        IORef Word64 -> Word64 -> TimeoutAction
forall a. IORef a -> a -> TimeoutAction
I.atomicWriteIORef IORef Word64
handleLastRenewed Word64
now
        TimeoutKey -> TimeoutAction
activateTimeout TimeoutKey
key
    activateTimeout :: TimeoutKey -> TimeoutAction
activateTimeout =
        IORef HandleState -> HandleState -> TimeoutAction
forall a. IORef a -> a -> TimeoutAction
I.atomicWriteIORef IORef HandleState
handleState (HandleState -> TimeoutAction)
-> (TimeoutKey -> HandleState) -> TimeoutKey -> TimeoutAction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeoutKey -> HandleState
Active

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

-- | 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
    Weak ThreadId
wtid <- IO ThreadId
myThreadId IO ThreadId
-> (ThreadId -> IO (Weak ThreadId)) -> IO (Weak ThreadId)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ThreadId -> IO (Weak ThreadId)
mkWeakThreadId
    -- 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 (f :: * -> *) a. Applicative f => a -> f a
pure ()
                Just ThreadId
tid' -> IO ThreadId -> TimeoutAction
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> TimeoutAction)
-> (TimeoutAction -> IO ThreadId) -> TimeoutAction -> TimeoutAction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeoutAction -> IO ThreadId
forkIO (TimeoutAction -> TimeoutAction) -> TimeoutAction -> TimeoutAction
forall a b. (a -> b) -> a -> b
$ 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" #-}