{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE PatternGuards              #-}
{-# LANGUAGE BangPatterns               #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE DeriveGeneric              #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Distributed.Process.ManagedProcess.Timer
-- Copyright   :  (c) Tim Watson 2017
-- License     :  BSD3 (see the file LICENSE)
--
-- Maintainer  :  Tim Watson <watson.timothy@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable (requires concurrency)
--
-- This module provides a wrap around a simple 'Timer' that can be started,
-- stopped, reset, cleared, and read. A convenient function is provided for
-- creating a @Match@ expression for the timer.
--
-- [Notes]
--
-- The timers defined in this module are based on a @TVar Bool@. When the
-- client program is @-threaded@ (i.e. @rtsSupportsBoundThreads == True@), then
-- the timers are set using @registerDelay@, which is very efficient and relies
-- only no the RTS IO Manager. When we're not @-threaded@, we fall back to using
-- "Control.Distributed.Process.Extras.Timer" to set the @TVar@, which has much
-- the same effect, but requires us to spawn a process to handle setting the
-- @TVar@ - a process which could theoretically die before setting the variable.
--
module Control.Distributed.Process.ManagedProcess.Timer
  ( Timer(timerDelay)
  , TimerKey
  , delayTimer
  , startTimer
  , stopTimer
  , resetTimer
  , clearTimer
  , matchTimeout
  , matchKey
  , matchRun
  , isActive
  , readTimer
  , TimedOut(..)
  ) where

import Control.Concurrent (rtsSupportsBoundThreads)
import Control.Concurrent.STM hiding (check)
import Control.Distributed.Process
  ( matchSTM
  , Process
  , ProcessId
  , Match
  , Message
  , liftIO
  )
import qualified Control.Distributed.Process as P
  ( liftIO
  )
import Control.Distributed.Process.Extras.Time (asTimeout, Delay(..))
import Control.Distributed.Process.Extras.Timer
  ( cancelTimer
  , runAfter
  , TimerRef
  )
import Data.Binary (Binary)
import Data.Maybe (isJust, fromJust)
import Data.Typeable (Typeable)
import GHC.Generics

--------------------------------------------------------------------------------
-- Timeout Management                                                         --
--------------------------------------------------------------------------------

-- | A key for storing timers in prioritised process backing state.
type TimerKey = Int

-- | Used during STM reads on Timers and to implement blocking. Since timers
-- can be associated with a "TimerKey", the second constructor for this type
-- yields a key indicating whic "Timer" it refers to. Note that the user is
-- responsible for establishing and maintaining the mapping between @Timer@s
-- and their keys.
data TimedOut = TimedOut | Yield TimerKey
  deriving (TimedOut -> TimedOut -> Bool
(TimedOut -> TimedOut -> Bool)
-> (TimedOut -> TimedOut -> Bool) -> Eq TimedOut
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TimedOut -> TimedOut -> Bool
== :: TimedOut -> TimedOut -> Bool
$c/= :: TimedOut -> TimedOut -> Bool
/= :: TimedOut -> TimedOut -> Bool
Eq, TimerKey -> TimedOut -> ShowS
[TimedOut] -> ShowS
TimedOut -> String
(TimerKey -> TimedOut -> ShowS)
-> (TimedOut -> String) -> ([TimedOut] -> ShowS) -> Show TimedOut
forall a.
(TimerKey -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: TimerKey -> TimedOut -> ShowS
showsPrec :: TimerKey -> TimedOut -> ShowS
$cshow :: TimedOut -> String
show :: TimedOut -> String
$cshowList :: [TimedOut] -> ShowS
showList :: [TimedOut] -> ShowS
Show, Typeable, (forall x. TimedOut -> Rep TimedOut x)
-> (forall x. Rep TimedOut x -> TimedOut) -> Generic TimedOut
forall x. Rep TimedOut x -> TimedOut
forall x. TimedOut -> Rep TimedOut x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TimedOut -> Rep TimedOut x
from :: forall x. TimedOut -> Rep TimedOut x
$cto :: forall x. Rep TimedOut x -> TimedOut
to :: forall x. Rep TimedOut x -> TimedOut
Generic)
instance Binary TimedOut where

-- | We hold timers in 2 states, each described by a Delay.
-- isActive = isJust . mtSignal
-- the TimerRef is optional since we only use the Timer module from extras
-- when we're unable to registerDelay (i.e. not running under -threaded)
data Timer = Timer { Timer -> Delay
timerDelay :: Delay
                   , Timer -> Maybe TimerRef
mtPidRef   :: Maybe TimerRef
                   , Timer -> Maybe (TVar Bool)
mtSignal   :: Maybe (TVar Bool)
                   }

-- | @True@ if a @Timer@ is currently active.
isActive :: Timer -> Bool
isActive :: Timer -> Bool
isActive = Maybe (TVar Bool) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (TVar Bool) -> Bool)
-> (Timer -> Maybe (TVar Bool)) -> Timer -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Timer -> Maybe (TVar Bool)
mtSignal

-- | Creates a default @Timer@ which is inactive.
delayTimer :: Delay -> Timer
delayTimer :: Delay -> Timer
delayTimer Delay
d = Delay -> Maybe TimerRef -> Maybe (TVar Bool) -> Timer
Timer Delay
d Maybe TimerRef
noPid Maybe (TVar Bool)
noTVar
  where
    noPid :: Maybe TimerRef
noPid  = Maybe TimerRef
forall a. Maybe a
Nothing :: Maybe ProcessId
    noTVar :: Maybe (TVar Bool)
noTVar = Maybe (TVar Bool)
forall a. Maybe a
Nothing :: Maybe (TVar Bool)

-- | Starts a @Timer@
-- Will use the GHC @registerDelay@ API if @rtsSupportsBoundThreads == True@
startTimer :: Delay -> Process Timer
startTimer :: Delay -> Process Timer
startTimer Delay
d
  | Delay TimeInterval
t <- Delay
d = TimeInterval -> Process Timer
establishTimer TimeInterval
t
  | Bool
otherwise    = Timer -> Process Timer
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Timer -> Process Timer) -> Timer -> Process Timer
forall a b. (a -> b) -> a -> b
$ Delay -> Timer
delayTimer Delay
d
  where
    establishTimer :: TimeInterval -> Process Timer
establishTimer TimeInterval
t'
      | Bool
rtsSupportsBoundThreads = do TVar Bool
sig <- IO (TVar Bool) -> Process (TVar Bool)
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TVar Bool) -> Process (TVar Bool))
-> IO (TVar Bool) -> Process (TVar Bool)
forall a b. (a -> b) -> a -> b
$ TimerKey -> IO (TVar Bool)
registerDelay (TimeInterval -> TimerKey
asTimeout TimeInterval
t')
                                     Timer -> Process Timer
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return Timer { timerDelay :: Delay
timerDelay = Delay
d
                                                  , mtPidRef :: Maybe TimerRef
mtPidRef = Maybe TimerRef
forall a. Maybe a
Nothing
                                                  , mtSignal :: Maybe (TVar Bool)
mtSignal = TVar Bool -> Maybe (TVar Bool)
forall a. a -> Maybe a
Just TVar Bool
sig
                                                  }
      | Bool
otherwise = do
          TVar Bool
tSig  <- IO (TVar Bool) -> Process (TVar Bool)
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TVar Bool) -> Process (TVar Bool))
-> IO (TVar Bool) -> Process (TVar Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
newTVarIO Bool
False
          -- NB: runAfter spawns a process, which is defined in terms of
          -- expectTimeout (asTimeout t) :: Process (Maybe CancelTimer)
          --
          TimerRef
tRef <- TimeInterval -> Process () -> Process TimerRef
runAfter TimeInterval
t' (Process () -> Process TimerRef) -> Process () -> Process TimerRef
forall a b. (a -> b) -> a -> b
$ IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
P.liftIO (IO () -> Process ()) -> IO () -> Process ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
tSig Bool
True
          Timer -> Process Timer
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return Timer { timerDelay :: Delay
timerDelay  = Delay
d
                       , mtPidRef :: Maybe TimerRef
mtPidRef = TimerRef -> Maybe TimerRef
forall a. a -> Maybe a
Just TimerRef
tRef
                       , mtSignal :: Maybe (TVar Bool)
mtSignal = TVar Bool -> Maybe (TVar Bool)
forall a. a -> Maybe a
Just TVar Bool
tSig
                       }

-- | Stops a previously started @Timer@. Has no effect if the @Timer@ is inactive.
stopTimer :: Timer -> Process Timer
stopTimer :: Timer -> Process Timer
stopTimer t :: Timer
t@Timer{Maybe (TVar Bool)
Maybe TimerRef
Delay
timerDelay :: Timer -> Delay
mtPidRef :: Timer -> Maybe TimerRef
mtSignal :: Timer -> Maybe (TVar Bool)
timerDelay :: Delay
mtPidRef :: Maybe TimerRef
mtSignal :: Maybe (TVar Bool)
..} = do
  Maybe TimerRef -> Process ()
clearTimer Maybe TimerRef
mtPidRef
  Timer -> Process Timer
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return Timer
t { mtPidRef = Nothing
           , mtSignal = Nothing
           }

-- | Clears and restarts a @Timer@.
resetTimer :: Timer -> Delay -> Process Timer
resetTimer :: Timer -> Delay -> Process Timer
resetTimer Timer{Maybe (TVar Bool)
Maybe TimerRef
Delay
timerDelay :: Timer -> Delay
mtPidRef :: Timer -> Maybe TimerRef
mtSignal :: Timer -> Maybe (TVar Bool)
timerDelay :: Delay
mtPidRef :: Maybe TimerRef
mtSignal :: Maybe (TVar Bool)
..} Delay
d = Maybe TimerRef -> Process ()
clearTimer Maybe TimerRef
mtPidRef Process () -> Process Timer -> Process Timer
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Delay -> Process Timer
startTimer Delay
d

-- | Clears/cancels a running timer. Has no effect if the @Timer@ is inactive.
clearTimer :: Maybe TimerRef -> Process ()
clearTimer :: Maybe TimerRef -> Process ()
clearTimer Maybe TimerRef
ref
  | Maybe TimerRef -> Bool
forall a. Maybe a -> Bool
isJust Maybe TimerRef
ref = TimerRef -> Process ()
cancelTimer (Maybe TimerRef -> TimerRef
forall a. HasCallStack => Maybe a -> a
fromJust Maybe TimerRef
ref)
  | Bool
otherwise  = () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Creates a @Match@ for a given timer, for use with Cloud Haskell's messaging
-- primitives for selective receives.
matchTimeout :: Timer -> [Match (Either TimedOut Message)]
matchTimeout :: Timer -> [Match (Either TimedOut Message)]
matchTimeout t :: Timer
t@Timer{Maybe (TVar Bool)
Maybe TimerRef
Delay
timerDelay :: Timer -> Delay
mtPidRef :: Timer -> Maybe TimerRef
mtSignal :: Timer -> Maybe (TVar Bool)
timerDelay :: Delay
mtPidRef :: Maybe TimerRef
mtSignal :: Maybe (TVar Bool)
..}
    | Timer -> Bool
isActive Timer
t = [ STM TimedOut
-> (TimedOut -> Process (Either TimedOut Message))
-> Match (Either TimedOut Message)
forall a b. STM a -> (a -> Process b) -> Match b
matchSTM (TVar Bool -> STM TimedOut
readTimer (TVar Bool -> STM TimedOut) -> TVar Bool -> STM TimedOut
forall a b. (a -> b) -> a -> b
$ Maybe (TVar Bool) -> TVar Bool
forall a. HasCallStack => Maybe a -> a
fromJust Maybe (TVar Bool)
mtSignal)
                              (Either TimedOut Message -> Process (Either TimedOut Message)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either TimedOut Message -> Process (Either TimedOut Message))
-> (TimedOut -> Either TimedOut Message)
-> TimedOut
-> Process (Either TimedOut Message)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimedOut -> Either TimedOut Message
forall a b. a -> Either a b
Left) ]
    | Bool
otherwise  = []

-- | Create a match expression for a given @Timer@. When the timer expires
-- (i.e. the "TVar Bool" is set to @True@), the "Match" will return @Yield i@,
-- where @i@ is the given "TimerKey".
matchKey :: TimerKey -> Timer -> [Match (Either TimedOut Message)]
matchKey :: TimerKey -> Timer -> [Match (Either TimedOut Message)]
matchKey TimerKey
i t :: Timer
t@Timer{Maybe (TVar Bool)
Maybe TimerRef
Delay
timerDelay :: Timer -> Delay
mtPidRef :: Timer -> Maybe TimerRef
mtSignal :: Timer -> Maybe (TVar Bool)
timerDelay :: Delay
mtPidRef :: Maybe TimerRef
mtSignal :: Maybe (TVar Bool)
..}
  | Timer -> Bool
isActive Timer
t = [STM TimedOut
-> (TimedOut -> Process (Either TimedOut Message))
-> Match (Either TimedOut Message)
forall a b. STM a -> (a -> Process b) -> Match b
matchSTM (TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar (Maybe (TVar Bool) -> TVar Bool
forall a. HasCallStack => Maybe a -> a
fromJust Maybe (TVar Bool)
mtSignal) STM Bool -> (Bool -> STM TimedOut) -> STM TimedOut
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
expired ->
                               if Bool
expired then TimedOut -> STM TimedOut
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (TimerKey -> TimedOut
Yield TimerKey
i) else STM TimedOut
forall a. STM a
retry)
                           (Either TimedOut Message -> Process (Either TimedOut Message)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either TimedOut Message -> Process (Either TimedOut Message))
-> (TimedOut -> Either TimedOut Message)
-> TimedOut
-> Process (Either TimedOut Message)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimedOut -> Either TimedOut Message
forall a b. a -> Either a b
Left)]
  | Bool
otherwise  = []

-- | As "matchKey", but instead of a returning @Yield i@, the generated "Match"
-- handler evaluates the first argument - and expression from "TimerKey" to
-- @Process Message@ - to determine its result.
matchRun :: (TimerKey -> Process Message)
         -> TimerKey
         -> Timer
         -> [Match Message]
matchRun :: (TimerKey -> Process Message)
-> TimerKey -> Timer -> [Match Message]
matchRun TimerKey -> Process Message
f TimerKey
k t :: Timer
t@Timer{Maybe (TVar Bool)
Maybe TimerRef
Delay
timerDelay :: Timer -> Delay
mtPidRef :: Timer -> Maybe TimerRef
mtSignal :: Timer -> Maybe (TVar Bool)
timerDelay :: Delay
mtPidRef :: Maybe TimerRef
mtSignal :: Maybe (TVar Bool)
..}
  | Timer -> Bool
isActive Timer
t = [STM TimerKey -> (TimerKey -> Process Message) -> Match Message
forall a b. STM a -> (a -> Process b) -> Match b
matchSTM (TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar (Maybe (TVar Bool) -> TVar Bool
forall a. HasCallStack => Maybe a -> a
fromJust Maybe (TVar Bool)
mtSignal) STM Bool -> (Bool -> STM TimerKey) -> STM TimerKey
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
expired ->
                               if Bool
expired then TimerKey -> STM TimerKey
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return TimerKey
k else STM TimerKey
forall a. STM a
retry) TimerKey -> Process Message
f]
  | Bool
otherwise  = []

-- | Reads a given @TVar Bool@ for a timer, and returns @STM TimedOut@ once the
-- variable is set to true. Will @retry@ in the meanwhile.
readTimer :: TVar Bool -> STM TimedOut
readTimer :: TVar Bool -> STM TimedOut
readTimer TVar Bool
t = do
   Bool
expired <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
t
   if Bool
expired then TimedOut -> STM TimedOut
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return TimedOut
TimedOut
              else STM TimedOut
forall a. STM a
retry