{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TupleSections #-}

-- | Logical time (in terms of abstract " ticks ")
--
-- Intended for qualified import
--
-- > import Test.Util.LogicalClock (LogicalClock)
-- > import qualified Test.Util.LogicalClock as LogicalClock
module Test.Util.LogicalClock (
    -- * API
    LogicalClock (..)
  , NumTicks (..)
  , Tick (..)
    -- * Construction
  , new
  , sufficientTimeFor
    -- * Scheduling actions
  , blockUntilTick
  , onTick
  , tickWatcher
    -- * Utilities
  , tickTracer
  ) where

import           Control.Monad
import           Control.ResourceRegistry
import           Control.Tracer (Tracer, contramapM)
import           Data.Time (NominalDiffTime)
import           Data.Word
import           GHC.Stack
import qualified Ouroboros.Consensus.BlockchainTime as BTime
import           Ouroboros.Consensus.Util.IOLike
import           Ouroboros.Consensus.Util.STM
import           Ouroboros.Consensus.Util.Time
import           System.Random (Random)

{-------------------------------------------------------------------------------
  API
-------------------------------------------------------------------------------}

-- | Logical time unit
newtype Tick = Tick { Tick -> Word64
tickToWord64 :: Word64 }
  deriving stock   (Int -> Tick -> ShowS
[Tick] -> ShowS
Tick -> String
(Int -> Tick -> ShowS)
-> (Tick -> String) -> ([Tick] -> ShowS) -> Show Tick
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Tick -> ShowS
showsPrec :: Int -> Tick -> ShowS
$cshow :: Tick -> String
show :: Tick -> String
$cshowList :: [Tick] -> ShowS
showList :: [Tick] -> ShowS
Show, Tick -> Tick -> Bool
(Tick -> Tick -> Bool) -> (Tick -> Tick -> Bool) -> Eq Tick
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Tick -> Tick -> Bool
== :: Tick -> Tick -> Bool
$c/= :: Tick -> Tick -> Bool
/= :: Tick -> Tick -> Bool
Eq, Eq Tick
Eq Tick =>
(Tick -> Tick -> Ordering)
-> (Tick -> Tick -> Bool)
-> (Tick -> Tick -> Bool)
-> (Tick -> Tick -> Bool)
-> (Tick -> Tick -> Bool)
-> (Tick -> Tick -> Tick)
-> (Tick -> Tick -> Tick)
-> Ord Tick
Tick -> Tick -> Bool
Tick -> Tick -> Ordering
Tick -> Tick -> Tick
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Tick -> Tick -> Ordering
compare :: Tick -> Tick -> Ordering
$c< :: Tick -> Tick -> Bool
< :: Tick -> Tick -> Bool
$c<= :: Tick -> Tick -> Bool
<= :: Tick -> Tick -> Bool
$c> :: Tick -> Tick -> Bool
> :: Tick -> Tick -> Bool
$c>= :: Tick -> Tick -> Bool
>= :: Tick -> Tick -> Bool
$cmax :: Tick -> Tick -> Tick
max :: Tick -> Tick -> Tick
$cmin :: Tick -> Tick -> Tick
min :: Tick -> Tick -> Tick
Ord)
  deriving newtype (Integer -> Tick
Tick -> Tick
Tick -> Tick -> Tick
(Tick -> Tick -> Tick)
-> (Tick -> Tick -> Tick)
-> (Tick -> Tick -> Tick)
-> (Tick -> Tick)
-> (Tick -> Tick)
-> (Tick -> Tick)
-> (Integer -> Tick)
-> Num Tick
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: Tick -> Tick -> Tick
+ :: Tick -> Tick -> Tick
$c- :: Tick -> Tick -> Tick
- :: Tick -> Tick -> Tick
$c* :: Tick -> Tick -> Tick
* :: Tick -> Tick -> Tick
$cnegate :: Tick -> Tick
negate :: Tick -> Tick
$cabs :: Tick -> Tick
abs :: Tick -> Tick
$csignum :: Tick -> Tick
signum :: Tick -> Tick
$cfromInteger :: Integer -> Tick
fromInteger :: Integer -> Tick
Num, Int -> Tick
Tick -> Int
Tick -> [Tick]
Tick -> Tick
Tick -> Tick -> [Tick]
Tick -> Tick -> Tick -> [Tick]
(Tick -> Tick)
-> (Tick -> Tick)
-> (Int -> Tick)
-> (Tick -> Int)
-> (Tick -> [Tick])
-> (Tick -> Tick -> [Tick])
-> (Tick -> Tick -> [Tick])
-> (Tick -> Tick -> Tick -> [Tick])
-> Enum Tick
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Tick -> Tick
succ :: Tick -> Tick
$cpred :: Tick -> Tick
pred :: Tick -> Tick
$ctoEnum :: Int -> Tick
toEnum :: Int -> Tick
$cfromEnum :: Tick -> Int
fromEnum :: Tick -> Int
$cenumFrom :: Tick -> [Tick]
enumFrom :: Tick -> [Tick]
$cenumFromThen :: Tick -> Tick -> [Tick]
enumFromThen :: Tick -> Tick -> [Tick]
$cenumFromTo :: Tick -> Tick -> [Tick]
enumFromTo :: Tick -> Tick -> [Tick]
$cenumFromThenTo :: Tick -> Tick -> Tick -> [Tick]
enumFromThenTo :: Tick -> Tick -> Tick -> [Tick]
Enum, (forall g. RandomGen g => (Tick, Tick) -> g -> (Tick, g))
-> (forall g. RandomGen g => g -> (Tick, g))
-> (forall g. RandomGen g => (Tick, Tick) -> g -> [Tick])
-> (forall g. RandomGen g => g -> [Tick])
-> Random Tick
forall g. RandomGen g => g -> [Tick]
forall g. RandomGen g => g -> (Tick, g)
forall g. RandomGen g => (Tick, Tick) -> g -> [Tick]
forall g. RandomGen g => (Tick, Tick) -> g -> (Tick, g)
forall a.
(forall g. RandomGen g => (a, a) -> g -> (a, g))
-> (forall g. RandomGen g => g -> (a, g))
-> (forall g. RandomGen g => (a, a) -> g -> [a])
-> (forall g. RandomGen g => g -> [a])
-> Random a
$crandomR :: forall g. RandomGen g => (Tick, Tick) -> g -> (Tick, g)
randomR :: forall g. RandomGen g => (Tick, Tick) -> g -> (Tick, g)
$crandom :: forall g. RandomGen g => g -> (Tick, g)
random :: forall g. RandomGen g => g -> (Tick, g)
$crandomRs :: forall g. RandomGen g => (Tick, Tick) -> g -> [Tick]
randomRs :: forall g. RandomGen g => (Tick, Tick) -> g -> [Tick]
$crandoms :: forall g. RandomGen g => g -> [Tick]
randoms :: forall g. RandomGen g => g -> [Tick]
Random)

-- | Number of ticks the test will run for
newtype NumTicks = NumTicks Word64

-- | Logical clock (in terms of ticks rather than actual 'UTCTime')
data LogicalClock m = LogicalClock {
      -- | Get the current " time "
      forall (m :: * -> *). LogicalClock m -> STM m Tick
getCurrentTick :: STM m Tick

      -- | Wait for the end of time (each clock has a maximum number of ticks)
    , forall (m :: * -> *). LogicalClock m -> m ()
waitUntilDone  :: m ()

      -- | Translate the logical clock to mock 'SystemTime'
    , forall (m :: * -> *). LogicalClock m -> SystemTime m
mockSystemTime :: BTime.SystemTime m
    }

{-------------------------------------------------------------------------------
  Construction
-------------------------------------------------------------------------------}

new :: IOLike m => ResourceRegistry m -> NumTicks -> m (LogicalClock m)
new :: forall (m :: * -> *).
IOLike m =>
ResourceRegistry m -> NumTicks -> m (LogicalClock m)
new ResourceRegistry m
registry NumTicks
numTicks = ResourceRegistry m
-> NumTicks -> NominalDiffTime -> m (LogicalClock m)
forall (m :: * -> *).
(IOLike m, HasCallStack) =>
ResourceRegistry m
-> NumTicks -> NominalDiffTime -> m (LogicalClock m)
newWithDelay ResourceRegistry m
registry NumTicks
numTicks NominalDiffTime
tickDelay

-- | Set 'NumTicks' such that we will have seen all of the specified 'Tick's
sufficientTimeFor :: HasCallStack => [Tick] -> NumTicks
sufficientTimeFor :: HasCallStack => [Tick] -> NumTicks
sufficientTimeFor [] = String -> NumTicks
forall a. HasCallStack => String -> a
error String
"sufficientTimeFor: empty list"
sufficientTimeFor [Tick]
ts = Word64 -> NumTicks
NumTicks (Word64 -> NumTicks) -> ([Tick] -> Word64) -> [Tick] -> NumTicks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word64] -> Word64
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Word64] -> Word64) -> ([Tick] -> [Word64]) -> [Tick] -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word64 -> Word64) -> [Word64] -> [Word64]
forall a b. (a -> b) -> [a] -> [b]
map Word64 -> Word64
forall a. Enum a => a -> a
succ ([Word64] -> [Word64])
-> ([Tick] -> [Word64]) -> [Tick] -> [Word64]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tick -> Word64) -> [Tick] -> [Word64]
forall a b. (a -> b) -> [a] -> [b]
map Tick -> Word64
tickToWord64 ([Tick] -> NumTicks) -> [Tick] -> NumTicks
forall a b. (a -> b) -> a -> b
$ [Tick]
ts

-- | Time of a single tick
--
-- The exact value of 'tickDelay' delay is not very important, but the scale
-- should be somewhat on par with the "real time" (for example, the relation
-- between GC delay and slot length, which would in turn depend on some kind of
-- relation between ticks and slots).
tickDelay :: NominalDiffTime
tickDelay :: NominalDiffTime
tickDelay = NominalDiffTime
0.5

{-------------------------------------------------------------------------------
  Scheduling actions
-------------------------------------------------------------------------------}

-- | Execute action on every clock tick
tickWatcher :: LogicalClock m
            -> (Tick -> m ())
            -> Watcher m Tick Tick
tickWatcher :: forall (m :: * -> *).
LogicalClock m -> (Tick -> m ()) -> Watcher m Tick Tick
tickWatcher LogicalClock m
clock Tick -> m ()
action =
    Watcher {
        wFingerprint :: Tick -> Tick
wFingerprint = Tick -> Tick
forall a. a -> a
id
      , wInitial :: Maybe Tick
wInitial     = Maybe Tick
forall a. Maybe a
Nothing
      , wNotify :: Tick -> m ()
wNotify      = Tick -> m ()
action
      , wReader :: STM m Tick
wReader      = LogicalClock m -> STM m Tick
forall (m :: * -> *). LogicalClock m -> STM m Tick
getCurrentTick LogicalClock m
clock
      }

-- | Execute action once at the specified tick
onTick :: (IOLike m, HasCallStack)
       => ResourceRegistry m
       -> LogicalClock m
       -> String
       -> Tick
       -> m ()
       -> m ()
onTick :: forall (m :: * -> *).
(IOLike m, HasCallStack) =>
ResourceRegistry m
-> LogicalClock m -> String -> Tick -> m () -> m ()
onTick ResourceRegistry m
registry LogicalClock m
clock String
threadLabel Tick
tick m ()
action = do
    m (Thread m ()) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Thread m ()) -> m ()) -> m (Thread m ()) -> m ()
forall a b. (a -> b) -> a -> b
$
      ResourceRegistry m -> String -> m () -> m (Thread m ())
forall (m :: * -> *) a.
(MonadAsync m, MonadFork m, MonadMask m, HasCallStack) =>
ResourceRegistry m -> String -> m a -> m (Thread m a)
forkLinkedThread
        ResourceRegistry m
registry
        String
threadLabel
        (LogicalClock m -> Tick -> m ()
forall (m :: * -> *). IOLike m => LogicalClock m -> Tick -> m ()
waitForTick LogicalClock m
clock Tick
tick m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m ()
action)

-- | Block until the specified tick
--
-- Returns 'False' if the current tick is later than the requested one, or
-- 'True' if they were equal.
blockUntilTick :: MonadSTM m => LogicalClock m -> Tick -> m Bool
blockUntilTick :: forall (m :: * -> *).
MonadSTM m =>
LogicalClock m -> Tick -> m Bool
blockUntilTick LogicalClock m
clock Tick
tick = STM m Bool -> m Bool
forall a. HasCallStack => STM m a -> m a
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
    now <- LogicalClock m -> STM m Tick
forall (m :: * -> *). LogicalClock m -> STM m Tick
getCurrentTick LogicalClock m
clock
    if now > tick then
      return True
    else do
      when (now < tick) retry
      return False

{-------------------------------------------------------------------------------
  Utilities
-------------------------------------------------------------------------------}

tickTracer ::
     MonadSTM m
  => LogicalClock m
  -> Tracer m (Tick, ev)
  -> Tracer m ev
tickTracer :: forall (m :: * -> *) ev.
MonadSTM m =>
LogicalClock m -> Tracer m (Tick, ev) -> Tracer m ev
tickTracer LogicalClock m
clock = (ev -> m (Tick, ev)) -> Tracer m (Tick, ev) -> Tracer m ev
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Tracer m b -> Tracer m a
contramapM ((ev -> m (Tick, ev)) -> Tracer m (Tick, ev) -> Tracer m ev)
-> (ev -> m (Tick, ev)) -> Tracer m (Tick, ev) -> Tracer m ev
forall a b. (a -> b) -> a -> b
$ \ev
ev ->
    (,ev
ev) (Tick -> (Tick, ev)) -> m Tick -> m (Tick, ev)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m Tick -> m Tick
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (LogicalClock m -> STM m Tick
forall (m :: * -> *). LogicalClock m -> STM m Tick
getCurrentTick LogicalClock m
clock)

{-------------------------------------------------------------------------------
  Internal
-------------------------------------------------------------------------------}

-- | Generalization of 'new' that allows to override the 'tickDelay'
--
-- NOTE: Tests using the logical clock really should not need to know what the
-- tick delay is; that's kind of the point of a /logical/ clock after all.
newWithDelay :: (IOLike m, HasCallStack)
             => ResourceRegistry m
             -> NumTicks
             -> NominalDiffTime
             -> m (LogicalClock m)
newWithDelay :: forall (m :: * -> *).
(IOLike m, HasCallStack) =>
ResourceRegistry m
-> NumTicks -> NominalDiffTime -> m (LogicalClock m)
newWithDelay ResourceRegistry m
registry (NumTicks Word64
numTicks) NominalDiffTime
tickLen = do
    current <- Word64 -> m (StrictTVar m Word64)
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO Word64
0
    done    <- newEmptyMVar
    _thread <- forkThread registry "ticker" $ do
                 -- Tick 0 is the first tick, so increment @numTicks - 1@ times
                 replicateM_ (fromIntegral numTicks - 1) $ do
                   -- Give simulator chance to execute other threads
                   threadDelay (nominalDelay tickLen)
                   atomically $ modifyTVar current (+ 1)

                 -- Give tests that need to do some final processing on the last
                 -- tick a chance to do that before we indicate completion.
                 threadDelay (nominalDelay tickLen)
                 putMVar done ()

    return LogicalClock {
        getCurrentTick = Tick <$> readTVar current
      , waitUntilDone  = readMVar done
      , mockSystemTime = BTime.SystemTime {
            BTime.systemTimeCurrent = do
              tick <- atomically $ readTVar current
              return $ BTime.RelativeTime $ fromIntegral tick * tickLen
          , BTime.systemTimeWait =
              return ()
          }
      }

-- | Wait for the specified tick (blocking the current thread)
waitForTick :: IOLike m => LogicalClock m -> Tick -> m ()
waitForTick :: forall (m :: * -> *). IOLike m => LogicalClock m -> Tick -> m ()
waitForTick LogicalClock m
clock Tick
tick = do
    start <- STM m Tick -> m Tick
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m Tick -> m Tick) -> STM m Tick -> m Tick
forall a b. (a -> b) -> a -> b
$ LogicalClock m -> STM m Tick
forall (m :: * -> *). LogicalClock m -> STM m Tick
getCurrentTick LogicalClock m
clock
    when (start >= tick) $
      throwIO $ WaitForTickTooLate {
          tickRequest = tick
        , tickCurrent = start
        }

    atomically $ do
      now <- getCurrentTick clock
      check (now >= tick)

-- | Thrown by 'waitForTick' (and hence 'onTick')
data WaitForTickException =
    WaitForTickTooLate {
        -- | The time the action should have run at
        WaitForTickException -> Tick
tickRequest :: Tick

        -- | The time when 'onTick' was called
      , WaitForTickException -> Tick
tickCurrent :: Tick
      }
  deriving (WaitForTickException -> WaitForTickException -> Bool
(WaitForTickException -> WaitForTickException -> Bool)
-> (WaitForTickException -> WaitForTickException -> Bool)
-> Eq WaitForTickException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WaitForTickException -> WaitForTickException -> Bool
== :: WaitForTickException -> WaitForTickException -> Bool
$c/= :: WaitForTickException -> WaitForTickException -> Bool
/= :: WaitForTickException -> WaitForTickException -> Bool
Eq, Int -> WaitForTickException -> ShowS
[WaitForTickException] -> ShowS
WaitForTickException -> String
(Int -> WaitForTickException -> ShowS)
-> (WaitForTickException -> String)
-> ([WaitForTickException] -> ShowS)
-> Show WaitForTickException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WaitForTickException -> ShowS
showsPrec :: Int -> WaitForTickException -> ShowS
$cshow :: WaitForTickException -> String
show :: WaitForTickException -> String
$cshowList :: [WaitForTickException] -> ShowS
showList :: [WaitForTickException] -> ShowS
Show)

instance Exception WaitForTickException