{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}

{-# OPTIONS_GHC -Wno-redundant-constraints #-}

-- | An alternative implementation of 'System.Timeout.timeout' for platforms
-- (i.e. Windows) where the standard implementation is too expensive.
--
-- The implementation provided here is for the special case where only one
-- timeout is active at once. A concurrent implementation would be possible
-- but is not currently needed.
--
module Network.Mux.Timeout
  ( TimeoutFn
  , withTimeoutSerial
  , withTimeoutSerialNative
  , withTimeoutSerialAlternative
  ) where

import           Control.Exception (asyncExceptionFromException,
                     asyncExceptionToException)
import           Control.Monad
import           Control.Monad.Class.MonadAsync
import           Control.Monad.Class.MonadFork
import           Control.Monad.Class.MonadSTM
import           Control.Monad.Class.MonadThrow
import           Control.Monad.Class.MonadTime
import           Control.Monad.Class.MonadTimer (MonadTimer, registerDelay)
import qualified Control.Monad.Class.MonadTimer as MonadTimer


-- | The type of the 'System.Timeout.timeout' function.
--
type TimeoutFn m = forall a. DiffTime -> m a -> m (Maybe a)

-- | A 'System.Timeout.timeout' that is reasonably efficient for all platforms.
--
-- On Unix it uses exactly 'System.Timeout.timeout' and on Windows it uses
-- 'withTimeoutSerialAlternative'.
--
-- > withTimeoutSerial $ \timeout ->
-- >   -- now use timeout as one would use System.Timeout.timeout
-- >   -- but not concurrently!
--
-- The implementation has a serial constraint: the body action that calls
-- @timeout@ can /only do so from one thread at once/.
--
withTimeoutSerial, withTimeoutSerialNative
  :: forall m b. (MonadAsync m, MonadFork m,
                  MonadMonotonicTime m, MonadTimer m,
                  MonadMask m, MonadThrow (STM m))
  => (TimeoutFn m -> m b) -> m b

#if defined(mingw32_HOST_OS)
withTimeoutSerial = withTimeoutSerialAlternative
#else
withTimeoutSerial :: (TimeoutFn m -> m b) -> m b
withTimeoutSerial = (TimeoutFn m -> m b) -> m b
forall (m :: * -> *) b.
(MonadAsync m, MonadFork m, MonadMonotonicTime m, MonadTimer m,
 MonadMask m, MonadThrow (STM m)) =>
(TimeoutFn m -> m b) -> m b
withTimeoutSerialNative
#endif

-- | This version simply passes the native platform's 'MonadTimer.timeout'.
--
withTimeoutSerialNative :: (TimeoutFn m -> m b) -> m b
withTimeoutSerialNative TimeoutFn m -> m b
body = TimeoutFn m -> m b
body TimeoutFn m
forall (m :: * -> *) a.
MonadTimer m =>
DiffTime -> m a -> m (Maybe a)
MonadTimer.timeout


-- | An alternative implementation of 'System.Timeout.timeout' for platforms
-- where the standard implementation is too expensive.
--
-- > withTimeoutSerial $ \timeout ->
-- >   -- now use timeout as one would use System.Timeout.timeout
-- >   -- but not concurrently!
--
-- This implementation has a serial constraint: the body action that calls
-- @timeout@ can /only do so from one thread at once/.
--
-- Further details for the curious:
--
-- the problem with @System.Timeout.timeout@ is that (as of base 4.12) it has
-- two implementations, one for Unix with the threaded RTS, and one for all
-- other configurations.
--
-- The Unix threaded RTS implementation is rather clever and very fast. In the
-- normal case of no timeout, it only has to allocate a timer entry. Only in
-- the case the timeout occurs does it allocate a 'forkIO' thread to do the
-- potentially-blocking operation of sending the asynchronous exception to
-- interrupt the action under timeout.
--
-- The implementation for all other configurations has to allocate a 'forkIO'
-- thread up front, whether or not the timeout fires. This is fine for many
-- applications but not for network timers which have to be created and
-- altered\/cancelled with very high frequency.
--
-- The implementation here only relies upon 'threadDelay' which has an
-- efficient implementation on all platforms. It uses a separate monitoring
-- thread which will throw an exception to terminate the action if the
-- timeout expires. This is why it uses the \"with\" style: because it keeps
-- a monitoring thread over a region of execution that may use many timeouts.
-- The cost of allocating this thread is amortised over all the timeouts used.
--
-- This implementation is simplified by the constraint that the timeouts only
-- be used serially. In addition, it has the limitation that timeouts may not
-- always be detected promptly: e.g. a 10s timeout on an action that finishes
-- immediately, followed by a 5s timeout on an action will only actually be
-- interrupted after 10s. So it's possible that action with the 5s timeout runs
-- for up to 10s. This is ok for many applications provided that the variance
-- in timeouts is not too large and the timeouts don't need to be too tight.
--
withTimeoutSerialAlternative
  :: forall m b. (MonadAsync m, MonadFork m,
                  MonadMonotonicTime m, MonadTimer m,
                  MonadMask m, MonadThrow (STM m))
  => (TimeoutFn m -> m b) -> m b
withTimeoutSerialAlternative :: (TimeoutFn m -> m b) -> m b
withTimeoutSerialAlternative TimeoutFn m -> m b
body = do

    -- State shared between the timeouts and the monitoring thread.
    MonitorState m
monitorState <- m (MonitorState m)
forall (m :: * -> *). MonadSTM m => m (MonitorState m)
newMonitorState

    -- Run the monitoring thread but ensure it terminates when the body is done.
    m () -> (Async m () -> m b) -> m b
forall (m :: * -> *) a b.
MonadAsync m =>
m a -> (Async m a -> m b) -> m b
withAsync (MonitorState m -> m ()
forall (m :: * -> *).
(MonadFork m, MonadSTM m, MonadMonotonicTime m, MonadTimer m,
 MonadThrow (STM m)) =>
MonitorState m -> m ()
monitoringThread MonitorState m
monitorState) ((Async m () -> m b) -> m b) -> (Async m () -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ \Async m ()
_ ->

      -- Run the body and pass it the @timeout@ function.
      TimeoutFn m -> m b
body (MonitorState m -> DiffTime -> m a -> m (Maybe a)
forall (m :: * -> *) a.
(MonadFork m, MonadMonotonicTime m, MonadTimer m, MonadMask m,
 MonadThrow (STM m)) =>
MonitorState m -> DiffTime -> m a -> m (Maybe a)
timeout MonitorState m
monitorState)


-- | The state shared between the timeouts and the monitoring thread.
--
data MonitorState m =
     MonitorState {
       -- written by timeout combinator, read and reset by monitoring thread
       MonitorState m -> TVar m (NextTimeout m)
nextTimeoutVar   :: !(TVar m (NextTimeout m)),

       -- written by monitoring thread, read by timeout combinator
       MonitorState m -> TVar m Time
curDeadlineVar   :: !(TVar m Time),

       -- written by timeout combinator, read and reset by monitoring thread
       MonitorState m -> TVar m Bool
deadlineResetVar :: !(TVar m Bool)
     }

data NextTimeout m = NoNextTimeout
                   | NextTimeout
                       !(ThreadId m)           -- Which thread to interrupt
                       !Time                   -- When to interrupt it
                       !(TVar m TimeoutState)  -- Synchronisation state


newMonitorState :: MonadSTM m => m (MonitorState m)
newMonitorState :: m (MonitorState m)
newMonitorState = do
    TVar m (NextTimeout m)
nextTimeoutVar   <- NextTimeout m -> m (TVar m (NextTimeout m))
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO NextTimeout m
forall (m :: * -> *). NextTimeout m
NoNextTimeout
    TVar m Time
curDeadlineVar   <- Time -> m (TVar m Time)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO (DiffTime -> Time
Time DiffTime
0)
    TVar m Bool
deadlineResetVar <- Bool -> m (TVar m Bool)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO Bool
False
    MonitorState m -> m (MonitorState m)
forall (m :: * -> *) a. Monad m => a -> m a
return MonitorState :: forall (m :: * -> *).
TVar m (NextTimeout m)
-> TVar m Time -> TVar m Bool -> MonitorState m
MonitorState{TVar m Bool
TVar m Time
TVar m (NextTimeout m)
deadlineResetVar :: TVar m Bool
curDeadlineVar :: TVar m Time
nextTimeoutVar :: TVar m (NextTimeout m)
deadlineResetVar :: TVar m Bool
curDeadlineVar :: TVar m Time
nextTimeoutVar :: TVar m (NextTimeout m)
..}


-- | An update to the shared monitor state to set a new timer.
--
setNewTimer :: MonadSTM m
            => MonitorState m
            -> ThreadId m
            -> Time
            -> TVar m TimeoutState
            -> m ()
setNewTimer :: MonitorState m -> ThreadId m -> Time -> TVar m TimeoutState -> m ()
setNewTimer MonitorState{TVar m (NextTimeout m)
nextTimeoutVar :: TVar m (NextTimeout m)
nextTimeoutVar :: forall (m :: * -> *). MonitorState m -> TVar m (NextTimeout m)
nextTimeoutVar, TVar m Time
curDeadlineVar :: TVar m Time
curDeadlineVar :: forall (m :: * -> *). MonitorState m -> TVar m Time
curDeadlineVar, TVar m Bool
deadlineResetVar :: TVar m Bool
deadlineResetVar :: forall (m :: * -> *). MonitorState m -> TVar m Bool
deadlineResetVar}
            !ThreadId m
tid !Time
deadline !TVar m TimeoutState
stateVar =
    STM m () -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      TVar m (NextTimeout m) -> NextTimeout m -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (NextTimeout m)
nextTimeoutVar (ThreadId m -> Time -> TVar m TimeoutState -> NextTimeout m
forall (m :: * -> *).
ThreadId m -> Time -> TVar m TimeoutState -> NextTimeout m
NextTimeout ThreadId m
tid Time
deadline TVar m TimeoutState
stateVar)
      Time
curDeadline <- TVar m Time -> STM m Time
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m Time
curDeadlineVar
      -- If the timer deadline has moved backwards, notify the monitor thread
      -- so it can wake up and grab the next timeout
      Bool -> STM m () -> STM m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Time
deadline Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
< Time
curDeadline) (STM m () -> STM m ()) -> STM m () -> STM m ()
forall a b. (a -> b) -> a -> b
$
        TVar m Bool -> Bool -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m Bool
deadlineResetVar Bool
True


-- | A potentially blocking wait read side, so can block.
--
readNextTimeout :: MonadSTM m
                => MonitorState m
                -> m (ThreadId m, Time, TVar m TimeoutState)
readNextTimeout :: MonitorState m -> m (ThreadId m, Time, TVar m TimeoutState)
readNextTimeout MonitorState{TVar m (NextTimeout m)
nextTimeoutVar :: TVar m (NextTimeout m)
nextTimeoutVar :: forall (m :: * -> *). MonitorState m -> TVar m (NextTimeout m)
nextTimeoutVar, TVar m Time
curDeadlineVar :: TVar m Time
curDeadlineVar :: forall (m :: * -> *). MonitorState m -> TVar m Time
curDeadlineVar, TVar m Bool
deadlineResetVar :: TVar m Bool
deadlineResetVar :: forall (m :: * -> *). MonitorState m -> TVar m Bool
deadlineResetVar} = do
    STM m (ThreadId m, Time, TVar m TimeoutState)
-> m (ThreadId m, Time, TVar m TimeoutState)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (ThreadId m, Time, TVar m TimeoutState)
 -> m (ThreadId m, Time, TVar m TimeoutState))
-> STM m (ThreadId m, Time, TVar m TimeoutState)
-> m (ThreadId m, Time, TVar m TimeoutState)
forall a b. (a -> b) -> a -> b
$ do
      NextTimeout m
nextTimeout <- TVar m (NextTimeout m) -> STM m (NextTimeout m)
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m (NextTimeout m)
nextTimeoutVar
      case NextTimeout m
nextTimeout of
        NextTimeout m
NoNextTimeout -> STM m (ThreadId m, Time, TVar m TimeoutState)
forall (m :: * -> *) a. MonadSTM m => STM m a
retry
        NextTimeout ThreadId m
tid Time
deadline TVar m TimeoutState
stateVar -> do
          -- We've picked up the next timeout so reset to empty
          TVar m (NextTimeout m) -> NextTimeout m -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (NextTimeout m)
nextTimeoutVar NextTimeout m
forall (m :: * -> *). NextTimeout m
NoNextTimeout
          -- Update the current deadline var so the 'setNewTimer' can see what
          -- the current deadline we're waiting on is, so it can see if it
          -- ever needs to wake us up if it sets up a new timer with an earlier
          -- deadline.
          TVar m Time -> Time -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m Time
curDeadlineVar Time
deadline
          TVar m Bool -> Bool -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m Bool
deadlineResetVar Bool
False
          (ThreadId m, Time, TVar m TimeoutState)
-> STM m (ThreadId m, Time, TVar m TimeoutState)
forall (m :: * -> *) a. Monad m => a -> m a
return (ThreadId m
tid, Time
deadline, TVar m TimeoutState
stateVar)


-- | Three normal states of the timeout, plus one pseudo state. We use these
-- states to provide proper communication between the action thread and the
-- monitoring thread.
--
-- The valid transitions are from 'TimeoutPending' to 'TimeoutCancelled', and
-- from 'TimeoutPending' to 'TimeoutFired'. Additionally there is a transition
-- from 'TimeoutFired' to 'TimeoutTerminated'.
--
data TimeoutState = TimeoutPending
                  | TimeoutCancelled
                  | TimeoutFired
                  | TimeoutTerminated


-- | Exception used by 'withTimeoutSerial' to terminate the action when the
-- timeout occurs.
--
data TimeoutException = TimeoutException deriving Int -> TimeoutException -> ShowS
[TimeoutException] -> ShowS
TimeoutException -> String
(Int -> TimeoutException -> ShowS)
-> (TimeoutException -> String)
-> ([TimeoutException] -> ShowS)
-> Show TimeoutException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TimeoutException] -> ShowS
$cshowList :: [TimeoutException] -> ShowS
show :: TimeoutException -> String
$cshow :: TimeoutException -> String
showsPrec :: Int -> TimeoutException -> ShowS
$cshowsPrec :: Int -> TimeoutException -> ShowS
Show

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


-- | The @timeout@ action we pass to the body in 'withTimeoutSerial'.
--
timeout :: forall m a.
           (MonadFork m, MonadMonotonicTime m, MonadTimer m,
            MonadMask m, MonadThrow (STM m))
        => MonitorState m
        -> DiffTime -> m a -> m (Maybe a)
timeout :: MonitorState m -> DiffTime -> m a -> m (Maybe a)
timeout MonitorState m
_            DiffTime
delay m a
action | DiffTime
delay DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
<  DiffTime
0 = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> m a -> m (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
action
timeout MonitorState m
_            DiffTime
delay m a
_      | DiffTime
delay DiffTime -> DiffTime -> Bool
forall a. Eq a => a -> a -> Bool
== DiffTime
0 = Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
timeout MonitorState m
monitorState DiffTime
delay m a
action =

    -- We have to be very careful with async exceptions of course.
    ((forall a. m a -> m a) -> m (Maybe a)) -> m (Maybe a)
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. m a -> m a) -> m (Maybe a)) -> m (Maybe a))
-> ((forall a. m a -> m a) -> m (Maybe a)) -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
restore -> do

      -- Set up the timeout and pass it over to the monitoring thread.
      -- This overwrites any previous timeout.
      ThreadId m
tid <- m (ThreadId m)
forall (m :: * -> *). MonadThread m => m (ThreadId m)
myThreadId
      TVar m TimeoutState
timeoutStateVar <- TimeoutState -> m (TVar m TimeoutState)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO TimeoutState
TimeoutPending
      Time
now <- m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
      let deadline :: Time
deadline = DiffTime -> Time -> Time
addTime DiffTime
delay Time
now
      MonitorState m -> ThreadId m -> Time -> TVar m TimeoutState -> m ()
forall (m :: * -> *).
MonadSTM m =>
MonitorState m -> ThreadId m -> Time -> TVar m TimeoutState -> m ()
setNewTimer MonitorState m
monitorState ThreadId m
tid Time
deadline TVar m TimeoutState
timeoutStateVar

      -- Now we unmask exceptions to run the action. If we get the timeout
      -- exception then we drop straight down to the outer 'catch' handler.
      a
result <- m a -> m a
forall a. m a -> m a
restore m a
action

      -- The action completed without us getting an exception, but there's
      -- a race condition with the monitoringThread to resolve. It could be
      -- just about to send us an async exception when we drop out of the
      -- masked region, or worse, outside of the scope of the 'catch' handler.
      --
      -- So we must synchronise with the monitoringThread to ensure that we
      -- know positively one way or the other whether the timeout exception is
      -- or is not going to be sent.
      --
      -- We do that by having both this thread and the monitoringThread do
      -- an STM tx on the timeoutStateVar, to atomically move it into the
      -- cancelled or fired state, depending on which thread gets there first.
      -- So this is a race, but it's a race where we can positively establish
      -- the outcome. If this thread gets there first we move it to the
      -- cancelled state. If the monitoringThread gets there first it moves it
      -- to the fired state.
      --
      -- This STM tx is not blocking, so we're guaranteed not to be interrupted
      -- while we have async exceptions masked.
      --
      Bool
timeoutFired <- STM m Bool -> m Bool
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m Bool -> m Bool) -> STM m Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ do
        TimeoutState
st <- TVar m TimeoutState -> STM m TimeoutState
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m TimeoutState
timeoutStateVar
        case TimeoutState
st of
          TimeoutState
TimeoutFired   -> Bool -> STM m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
          TimeoutState
TimeoutPending -> TVar m TimeoutState -> TimeoutState -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m TimeoutState
timeoutStateVar TimeoutState
TimeoutCancelled
                         STM m () -> STM m Bool -> STM m Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> STM m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
          TimeoutState
_              -> TimeoutAssertion -> STM m Bool
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM TimeoutAssertion
TimeoutImpossibleTimeoutState

      -- If we established that the monitoring thread is definitely not firing
      -- the timeout exception then we're done.
      --
      -- If on the other hand we lost the race and the monitoring thread is
      -- about to come for us then it's crucial that we block and wait for
      -- our own demise, otherwise we could escape the scope of the outer
      -- 'catch' handler.
      --
      -- We do that blocking wait with another STM tx on the timeoutStateVar,
      -- this time waiting for the monitoring thread to set it to the
      -- TimeoutTerminated state. But the monitoring thread only sets it to
      -- that state /after/ raising the async exception in this thread. So
      -- we will never actually rach that terminated state.
      --
      -- Note also that blocking STM txs are points where async exceptions that
      -- are pending (due to our masked state) can be raised. Hence there is no
      -- need for us to unmask for this bit.
      --
      if Bool -> Bool
not Bool
timeoutFired
        then Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
result)
        else STM m (Maybe a) -> m (Maybe a)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Maybe a) -> m (Maybe a)) -> STM m (Maybe a) -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ do
               TimeoutState
st <- TVar m TimeoutState -> STM m TimeoutState
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m TimeoutState
timeoutStateVar
               case TimeoutState
st of
                 TimeoutState
TimeoutFired      -> STM m (Maybe a)
forall (m :: * -> *) a. MonadSTM m => STM m a
retry
                 TimeoutState
TimeoutTerminated -> TimeoutAssertion -> STM m (Maybe a)
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM TimeoutAssertion
TimeoutImpossibleReachedTerminated
                 TimeoutState
_                 -> TimeoutAssertion -> STM m (Maybe a)
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM TimeoutAssertion
TimeoutImpossibleTimeoutState

    m (Maybe a) -> (TimeoutException -> m (Maybe a)) -> m (Maybe a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \TimeoutException
TimeoutException -> Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing


monitoringThread :: (MonadFork m, MonadSTM m,
                     MonadMonotonicTime m, MonadTimer m,
                     MonadThrow (STM m))
                 => MonitorState m -> m ()
monitoringThread :: MonitorState m -> m ()
monitoringThread monitorState :: MonitorState m
monitorState@MonitorState{TVar m Bool
deadlineResetVar :: TVar m Bool
deadlineResetVar :: forall (m :: * -> *). MonitorState m -> TVar m Bool
deadlineResetVar} = do
  ThreadId m
threadId <- m (ThreadId m)
forall (m :: * -> *). MonadThread m => m (ThreadId m)
myThreadId
  ThreadId m -> String -> m ()
forall (m :: * -> *). MonadThread m => ThreadId m -> String -> m ()
labelThread ThreadId m
threadId String
"timeout-monitoring-thread"
  m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    -- Grab the next timeout to consider
    (ThreadId m
tid, Time
deadline, TVar m TimeoutState
timeoutStateVar) <- MonitorState m -> m (ThreadId m, Time, TVar m TimeoutState)
forall (m :: * -> *).
MonadSTM m =>
MonitorState m -> m (ThreadId m, Time, TVar m TimeoutState)
readNextTimeout MonitorState m
monitorState

    -- Work out how long to wait for and do so. For already-expired timeouts
    -- this is in the past, leading to a negative delay.
    Time
now <- m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
    let delay :: DiffTime
delay = Time -> Time -> DiffTime
diffTime Time
deadline Time
now
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DiffTime
delay DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> DiffTime
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      TVar m Bool
timerExpired <- DiffTime -> m (TVar m Bool)
forall (m :: * -> *). MonadTimer m => DiffTime -> m (TVar m Bool)
registerDelay DiffTime
delay
      STM m () -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$
        -- Wait for either the timer to expire
        (TVar m Bool -> STM m Bool
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m Bool
timerExpired STM m Bool -> (Bool -> STM m ()) -> STM m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> STM m ()
forall (m :: * -> *). MonadSTM m => Bool -> STM m ()
check)
          STM m () -> STM m () -> STM m ()
forall (m :: * -> *) a. MonadSTM m => STM m a -> STM m a -> STM m a
`orElse`
        -- or to be notified that the timer deadline moved backwards
        (TVar m Bool -> STM m Bool
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m Bool
deadlineResetVar STM m Bool -> (Bool -> STM m ()) -> STM m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> STM m ()
forall (m :: * -> *). MonadSTM m => Bool -> STM m ()
check)

    -- Having woken up, we check to see if we need to send the timeout
    -- exception. If the timeoutStateVar we grabbed is still in the pending
    -- state after we have waited for the deadline then clearly it went over
    -- and we will send the timeout exception.
    --
    -- As described above, there is a race between the timeout and the action
    -- completing and we have to establish which happens first. So this is
    -- the other side of that race. Here if we win the race we move to the
    -- TimeoutFired state.
    Bool
cancelled <- STM m Bool -> m Bool
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m Bool -> m Bool) -> STM m Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ do
                   TimeoutState
st <- TVar m TimeoutState -> STM m TimeoutState
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m TimeoutState
timeoutStateVar
                   case TimeoutState
st of
                     TimeoutState
TimeoutPending   -> TVar m TimeoutState -> TimeoutState -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m TimeoutState
timeoutStateVar TimeoutState
TimeoutFired
                                      STM m () -> STM m Bool -> STM m Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> STM m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                     TimeoutState
TimeoutCancelled -> Bool -> STM m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                     TimeoutState
_                -> TimeoutAssertion -> STM m Bool
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM TimeoutAssertion
TimeoutImpossibleMonitorState

    -- If it turns out that the timeout was cancelled before the timeout
    -- expired then we do nothing and go back to the start.
    --
    -- But if it was not cancelled then we will send it the asynchronous
    -- exception. As described above there is a corner case where we won
    -- the race very narrowly and so the other thread has to block and wait
    -- for us to send the asynchronous exception. The way we make it block to
    -- wait for us -- without any concern that it might be classed as being
    -- blocked indefinitely -- is to make it wait for a state change that we
    -- will only perform /after/ we have raised the exception in the target
    -- thread.
    --
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
cancelled (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      ThreadId m -> TimeoutException -> m ()
forall (m :: * -> *) e.
(MonadFork m, Exception e) =>
ThreadId m -> e -> m ()
throwTo ThreadId m
tid TimeoutException
TimeoutException
      -- Set the state the other thread may be waiting for /after/ raising the
      -- exception in the other thread.
      STM m () -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ TVar m TimeoutState -> TimeoutState -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m TimeoutState
timeoutStateVar TimeoutState
TimeoutTerminated


-- | These are all \"impossible\" errors.
--
data TimeoutAssertion = TimeoutImpossibleReachedTerminated
                      | TimeoutImpossibleTimeoutState
                      | TimeoutImpossibleMonitorState
  deriving Int -> TimeoutAssertion -> ShowS
[TimeoutAssertion] -> ShowS
TimeoutAssertion -> String
(Int -> TimeoutAssertion -> ShowS)
-> (TimeoutAssertion -> String)
-> ([TimeoutAssertion] -> ShowS)
-> Show TimeoutAssertion
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TimeoutAssertion] -> ShowS
$cshowList :: [TimeoutAssertion] -> ShowS
show :: TimeoutAssertion -> String
$cshow :: TimeoutAssertion -> String
showsPrec :: Int -> TimeoutAssertion -> ShowS
$cshowsPrec :: Int -> TimeoutAssertion -> ShowS
Show

instance Exception TimeoutAssertion