{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TupleSections #-}
module Test.Util.LogicalClock (
LogicalClock (..)
, NumTicks (..)
, Tick (..)
, new
, sufficientTimeFor
, blockUntilTick
, onTick
, tickWatcher
, 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)
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)
newtype NumTicks = NumTicks Word64
data LogicalClock m = LogicalClock {
forall (m :: * -> *). LogicalClock m -> STM m Tick
getCurrentTick :: STM m Tick
, forall (m :: * -> *). LogicalClock m -> m ()
waitUntilDone :: m ()
, forall (m :: * -> *). LogicalClock m -> SystemTime m
mockSystemTime :: BTime.SystemTime m
}
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
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
tickDelay :: NominalDiffTime
tickDelay :: NominalDiffTime
tickDelay = NominalDiffTime
0.5
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
}
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)
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
Tick
now <- LogicalClock m -> STM m Tick
forall (m :: * -> *). LogicalClock m -> STM m Tick
getCurrentTick LogicalClock m
clock
if Tick
now Tick -> Tick -> Bool
forall a. Ord a => a -> a -> Bool
> Tick
tick then
Bool -> STM m Bool
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else do
Bool -> STM m () -> STM m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Tick
now Tick -> Tick -> Bool
forall a. Ord a => a -> a -> Bool
< Tick
tick) STM m ()
forall a. STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a
retry
Bool -> STM m Bool
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
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)
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
StrictTVar m Word64
current <- Word64 -> m (StrictTVar m Word64)
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO Word64
0
StrictMVar m ()
done <- m (StrictMVar m ())
forall (m :: * -> *) a.
(MonadMVar m, NoThunks a) =>
m (StrictMVar m a)
newEmptyMVar
Thread m ()
_thread <- ResourceRegistry m -> String -> m () -> m (Thread m ())
forall (m :: * -> *) a.
(MonadMask m, MonadAsync m, HasCallStack) =>
ResourceRegistry m -> String -> m a -> m (Thread m a)
forkThread ResourceRegistry m
registry String
"ticker" (m () -> m (Thread m ())) -> m () -> m (Thread m ())
forall a b. (a -> b) -> a -> b
$ do
Int -> m () -> m ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
numTicks Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay (NominalDiffTime -> DiffTime
nominalDelay NominalDiffTime
tickLen)
STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
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
$ StrictTVar m Word64 -> (Word64 -> Word64) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m Word64
current (Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1)
DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay (NominalDiffTime -> DiffTime
nominalDelay NominalDiffTime
tickLen)
StrictMVar m () -> () -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadMVar m) =>
StrictMVar m a -> a -> m ()
putMVar StrictMVar m ()
done ()
LogicalClock m -> m (LogicalClock m)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return LogicalClock {
getCurrentTick :: STM m Tick
getCurrentTick = Word64 -> Tick
Tick (Word64 -> Tick) -> STM m Word64 -> STM m Tick
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m Word64 -> STM m Word64
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m Word64
current
, waitUntilDone :: m ()
waitUntilDone = StrictMVar m () -> m ()
forall (m :: * -> *) a. MonadMVar m => StrictMVar m a -> m a
readMVar StrictMVar m ()
done
, mockSystemTime :: SystemTime m
mockSystemTime = BTime.SystemTime {
systemTimeCurrent :: m RelativeTime
BTime.systemTimeCurrent = do
Word64
tick <- STM m Word64 -> m Word64
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m Word64 -> m Word64) -> STM m Word64 -> m Word64
forall a b. (a -> b) -> a -> b
$ StrictTVar m Word64 -> STM m Word64
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m Word64
current
RelativeTime -> m RelativeTime
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (RelativeTime -> m RelativeTime) -> RelativeTime -> m RelativeTime
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> RelativeTime
BTime.RelativeTime (NominalDiffTime -> RelativeTime)
-> NominalDiffTime -> RelativeTime
forall a b. (a -> b) -> a -> b
$ Word64 -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
tick NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
tickLen
, systemTimeWait :: m ()
BTime.systemTimeWait =
() -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
}
}
waitForTick :: IOLike m => LogicalClock m -> Tick -> m ()
waitForTick :: forall (m :: * -> *). IOLike m => LogicalClock m -> Tick -> m ()
waitForTick LogicalClock m
clock Tick
tick = do
Tick
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
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Tick
start Tick -> Tick -> Bool
forall a. Ord a => a -> a -> Bool
>= Tick
tick) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
WaitForTickException -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (WaitForTickException -> m ()) -> WaitForTickException -> m ()
forall a b. (a -> b) -> a -> b
$ WaitForTickTooLate {
tickRequest :: Tick
tickRequest = Tick
tick
, tickCurrent :: Tick
tickCurrent = Tick
start
}
STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
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
Tick
now <- LogicalClock m -> STM m Tick
forall (m :: * -> *). LogicalClock m -> STM m Tick
getCurrentTick LogicalClock m
clock
Bool -> STM m ()
forall (m :: * -> *). MonadSTM m => Bool -> STM m ()
check (Tick
now Tick -> Tick -> Bool
forall a. Ord a => a -> a -> Bool
>= Tick
tick)
data WaitForTickException =
WaitForTickTooLate {
WaitForTickException -> Tick
tickRequest :: Tick
, 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