{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}

-- | In the context of diffusion pipelining, it is important that tentative
-- followers promptly emit an instruction to roll forward after the tentative
-- header got set. We check this behavior by comparing the timestamps when a
-- tentative header got set and when a tentative follower emits an instruction
-- containing it.
--
-- This test is making use of io-sim to measure and check the *exact* timings of
-- various events. In particular, we can really rely on something occuring at a
-- specific point in time, compared to just a plausible range as would be
-- necessary with ordinary wall-clock time.
module Test.Ouroboros.Storage.ChainDB.FollowerPromptness (tests) where

import Cardano.Ledger.BaseTypes (nonZero)
import Control.Monad (forever)
import Control.Monad.IOSim (runSimOrThrow)
import Control.ResourceRegistry
import Control.Tracer (Tracer, contramapM, mkTracer, traceWith)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Time.Clock (secondsToDiffTime)
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.Leios.Protocol (trivialLeiosLedgerView)
import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB)
import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB
import qualified Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment as Punishment
import qualified Ouroboros.Consensus.Storage.ChainDB.Impl as ChainDBImpl
import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Args as ChainDB
import Ouroboros.Consensus.Storage.LeiosDB (newLeiosDBInMemory)
import Ouroboros.Consensus.Util.Condense (Condense (..))
import Ouroboros.Consensus.Util.Enclose
import Ouroboros.Consensus.Util.IOLike
import qualified Ouroboros.Network.Mock.Chain as Chain
import Test.QuickCheck
import Test.Tasty
import Test.Tasty.QuickCheck
import Test.Util.ChainDB
import Test.Util.ChainUpdates
import Test.Util.Orphans.IOLike ()
import Test.Util.TestBlock
import Test.Util.Tracer (recordingTracerTVar)

tests :: TestTree
tests :: TestTree
tests =
  [Char] -> [TestTree] -> TestTree
testGroup
    [Char]
"FollowerPromptness"
    [ [Char] -> (FollowerPromptnessTestSetup -> Property) -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"followerPromptness" FollowerPromptnessTestSetup -> Property
prop_followerPromptness
    ]

prop_followerPromptness :: FollowerPromptnessTestSetup -> Property
prop_followerPromptness :: FollowerPromptnessTestSetup -> Property
prop_followerPromptness FollowerPromptnessTestSetup
fpts =
  [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char]
"Trace:\n" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [[Char]] -> [Char]
unlines ((Time, [Char]) -> [Char]
forall {a}. Show a => (a, [Char]) -> [Char]
ppTrace ((Time, [Char]) -> [Char]) -> [(Time, [Char])] -> [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Time, [Char])]
traceByTime)) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample (FollowerPromptnessTestSetup -> [Char]
forall a. Condense a => a -> [Char]
condense FollowerPromptnessTestSetup
fpts) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
      [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char]
"Instruction timings: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Map Time (Set TestHash) -> [Char]
forall a. Condense a => a -> [Char]
condense Map Time (Set TestHash)
followerInstrTimings) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
        [Char] -> Bool -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample
          ([Char]
"Failed to pipeline: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [(Time, Set TestHash)] -> [Char]
forall a. Condense a => a -> [Char]
condense [(Time, Set TestHash)]
notPipelined)
          ([(Time, Set TestHash)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Time, Set TestHash)]
notPipelined)
          Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. [Char] -> Bool -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample
            ([Char]
"Not processed: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [(Time, Set TestHash)] -> [Char]
forall a. Condense a => a -> [Char]
condense [(Time, Set TestHash)]
unprocessed)
            ([(Time, Set TestHash)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Time, Set TestHash)]
unprocessed)
 where
  FollowerPromptnessOutcome{[(Time, [Char])]
Map Time (Set TestHash)
traceByTime :: [(Time, [Char])]
followerInstrTimings :: Map Time (Set TestHash)
tentativeHeaderSetTimings :: Map Time (Set TestHash)
tentativeHeaderUnsetTimings :: Map Time (Set TestHash)
traceByTime :: FollowerPromptnessOutcome -> [(Time, [Char])]
followerInstrTimings :: FollowerPromptnessOutcome -> Map Time (Set TestHash)
tentativeHeaderUnsetTimings :: FollowerPromptnessOutcome -> Map Time (Set TestHash)
tentativeHeaderSetTimings :: FollowerPromptnessOutcome -> Map Time (Set TestHash)
..} =
    (forall s. IOSim s FollowerPromptnessOutcome)
-> FollowerPromptnessOutcome
forall a. (forall s. IOSim s a) -> a
runSimOrThrow ((forall s. IOSim s FollowerPromptnessOutcome)
 -> FollowerPromptnessOutcome)
-> (forall s. IOSim s FollowerPromptnessOutcome)
-> FollowerPromptnessOutcome
forall a b. (a -> b) -> a -> b
$ FollowerPromptnessTestSetup -> IOSim s FollowerPromptnessOutcome
forall (m :: * -> *).
IOLike m =>
FollowerPromptnessTestSetup -> m FollowerPromptnessOutcome
runFollowerPromptnessTest FollowerPromptnessTestSetup
fpts

  -- Hashes of tentative headers which were not immediately emitted as a
  -- follower instruction.
  notPipelined :: [(Time, Set TestHash)]
notPipelined =
    DiffTime -> Map Time (Set TestHash) -> [(Time, Set TestHash)]
tentativeHeadersWithoutFollowUp
      DiffTime
0
      Map Time (Set TestHash)
followerInstrTimings

  -- Hashes of tentative header which were not processed (i.e. made obsolete
  -- due to adoption, or identified as a trap).
  unprocessed :: [(Time, Set TestHash)]
unprocessed =
    DiffTime -> Map Time (Set TestHash) -> [(Time, Set TestHash)]
tentativeHeadersWithoutFollowUp
      (FollowerPromptnessTestSetup -> DiffTime
artificialDelay FollowerPromptnessTestSetup
fpts)
      Map Time (Set TestHash)
tentativeHeaderUnsetTimings

  -- Given a collection of timestamped hashes (considered as follow-up events
  -- of a specific hash), return the timestamped tentative header hashes which
  -- are not contained therein after the given delay.
  tentativeHeadersWithoutFollowUp ::
    DiffTime ->
    Map Time (Set TestHash) ->
    [(Time, Set TestHash)]
  tentativeHeadersWithoutFollowUp :: DiffTime -> Map Time (Set TestHash) -> [(Time, Set TestHash)]
tentativeHeadersWithoutFollowUp DiffTime
delay Map Time (Set TestHash)
followUpTimings =
    [ (Time
time, Set TestHash
notFollowedUp)
    | (Time
time, Set TestHash
tentativeHashes) <- Map Time (Set TestHash) -> [(Time, Set TestHash)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map Time (Set TestHash)
tentativeHeaderSetTimings
    , let followUpHashes :: Set TestHash
followUpHashes =
            Set TestHash -> Time -> Map Time (Set TestHash) -> Set TestHash
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Set TestHash
forall a. Monoid a => a
mempty (DiffTime -> Time -> Time
addTime DiffTime
delay Time
time) Map Time (Set TestHash)
followUpTimings
          notFollowedUp :: Set TestHash
notFollowedUp = Set TestHash
tentativeHashes Set TestHash -> Set TestHash -> Set TestHash
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set TestHash
followUpHashes
    , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Set TestHash -> Bool
forall a. Set a -> Bool
Set.null Set TestHash
notFollowedUp
    ]

  ppTrace :: (a, [Char]) -> [Char]
ppTrace (a
time, [Char]
ev) = a -> [Char]
forall a. Show a => a -> [Char]
show a
time [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
": " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
ev

data FollowerPromptnessOutcome = FollowerPromptnessOutcome
  { FollowerPromptnessOutcome -> Map Time (Set TestHash)
tentativeHeaderSetTimings :: Map Time (Set TestHash)
  -- ^ The set of tentative headers by timestamp when set. With the current
  -- implementation of ChainSel, all sets should contain exactly one element.
  , FollowerPromptnessOutcome -> Map Time (Set TestHash)
tentativeHeaderUnsetTimings :: Map Time (Set TestHash)
  -- ^ The set of tentative headers by timestamp when unset.
  , FollowerPromptnessOutcome -> Map Time (Set TestHash)
followerInstrTimings :: Map Time (Set TestHash)
  -- ^ The set of AddBlock instructions by a tentative follower by timestamp.
  , FollowerPromptnessOutcome -> [(Time, [Char])]
traceByTime :: [(Time, String)]
  -- ^ Trace message, only used for debugging.
  }

runFollowerPromptnessTest ::
  forall m.
  IOLike m =>
  FollowerPromptnessTestSetup ->
  m FollowerPromptnessOutcome
runFollowerPromptnessTest :: forall (m :: * -> *).
IOLike m =>
FollowerPromptnessTestSetup -> m FollowerPromptnessOutcome
runFollowerPromptnessTest FollowerPromptnessTestSetup{[ChainUpdate]
DiffTime
SecurityParam
artificialDelay :: FollowerPromptnessTestSetup -> DiffTime
securityParam :: SecurityParam
chainUpdates :: [ChainUpdate]
artificialDelay :: DiffTime
chainUpdates :: FollowerPromptnessTestSetup -> [ChainUpdate]
securityParam :: FollowerPromptnessTestSetup -> SecurityParam
..} = (ResourceRegistry m -> m FollowerPromptnessOutcome)
-> m FollowerPromptnessOutcome
forall (m :: * -> *) a.
(MonadSTM m, MonadMask m, MonadThread m, MonadEvaluate m,
 HasCallStack) =>
(ResourceRegistry m -> m a) -> m a
withRegistry \ResourceRegistry m
registry -> do
  varTentativeSetTimings <- Map Time (Set TestHash)
-> m (StrictTVar m (Map Time (Set TestHash)))
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
uncheckedNewTVarM Map Time (Set TestHash)
forall k a. Map k a
Map.empty
  varTentativeUnsetTimings <- uncheckedNewTVarM Map.empty
  varFollowerInstrTimings <- uncheckedNewTVarM Map.empty

  (withTime -> tracer, getTrace) <- recordingTracerTVar

  let chainDBTracer = (TraceEvent TestBlock -> m ()) -> Tracer m (TraceEvent TestBlock)
forall (m :: * -> *) a. Applicative m => (a -> m ()) -> Tracer m a
mkTracer \case
        ChainDBImpl.TraceAddBlockEvent TraceAddBlockEvent TestBlock
ev -> do
          Tracer m [Char] -> [Char] -> m ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
traceWith Tracer m [Char]
tracer ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"ChainDB: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> TraceAddBlockEvent TestBlock -> [Char]
forall a. Show a => a -> [Char]
show TraceAddBlockEvent TestBlock
ev
          case TraceAddBlockEvent TestBlock
ev of
            ChainDBImpl.PipeliningEvent TracePipeliningEvent TestBlock
pev -> case TracePipeliningEvent TestBlock
pev of
              ChainDBImpl.SetTentativeHeader Header TestBlock
hdr Enclosing' ()
FallingEdge -> do
                StrictTVar m (Map Time (Set TestHash)) -> TestHash -> m ()
forall {m :: * -> *} {a}.
(MonadMonotonicTime m, MonadSTM m, Ord a) =>
StrictTVar m (Map Time (Set a)) -> a -> m ()
addTiming StrictTVar m (Map Time (Set TestHash))
varTentativeSetTimings (Header TestBlock -> HeaderHash TestBlock
forall blk. HasHeader (Header blk) => Header blk -> HeaderHash blk
headerHash Header TestBlock
hdr)
                -- Wait some non-zero duration to delay the further chain
                -- selection logic (i.e. simulating expensive block body
                -- validation).
                DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
artificialDelay
              ChainDBImpl.OutdatedTentativeHeader Header TestBlock
hdr ->
                StrictTVar m (Map Time (Set TestHash)) -> TestHash -> m ()
forall {m :: * -> *} {a}.
(MonadMonotonicTime m, MonadSTM m, Ord a) =>
StrictTVar m (Map Time (Set a)) -> a -> m ()
addTiming StrictTVar m (Map Time (Set TestHash))
varTentativeUnsetTimings (Header TestBlock -> HeaderHash TestBlock
forall blk. HasHeader (Header blk) => Header blk -> HeaderHash blk
headerHash Header TestBlock
hdr)
              ChainDBImpl.TrapTentativeHeader Header TestBlock
hdr ->
                StrictTVar m (Map Time (Set TestHash)) -> TestHash -> m ()
forall {m :: * -> *} {a}.
(MonadMonotonicTime m, MonadSTM m, Ord a) =>
StrictTVar m (Map Time (Set a)) -> a -> m ()
addTiming StrictTVar m (Map Time (Set TestHash))
varTentativeUnsetTimings (Header TestBlock -> HeaderHash TestBlock
forall blk. HasHeader (Header blk) => Header blk -> HeaderHash blk
headerHash Header TestBlock
hdr)
              TracePipeliningEvent TestBlock
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            TraceAddBlockEvent TestBlock
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        TraceEvent TestBlock
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  chainDB <- openChainDB registry chainDBTracer

  -- Continually fetch instructions from a tentative follower.
  follower <-
    ChainDB.newFollower chainDB registry ChainDB.TentativeChain ChainDB.GetHash
  _ <-
    forkLinkedThread registry "Follower listener" $
      forever $
        ChainDB.followerInstructionBlocking follower >>= \case
          Chain.AddBlock TestHash
hdrHash -> StrictTVar m (Map Time (Set TestHash)) -> TestHash -> m ()
forall {m :: * -> *} {a}.
(MonadMonotonicTime m, MonadSTM m, Ord a) =>
StrictTVar m (Map Time (Set a)) -> a -> m ()
addTiming StrictTVar m (Map Time (Set TestHash))
varFollowerInstrTimings TestHash
hdrHash
          Chain.RollBack Point TestBlock
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  -- Add all blocks to the ChainDB, each with its predecessor's slot: the
  -- previous block of the same update, or else the tip the update extends.
  let addBlocks WithOrigin SlotNo
tipSlot = \case
        [] -> WithOrigin SlotNo -> m (WithOrigin SlotNo)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure WithOrigin SlotNo
tipSlot
        TestBlock
blk : [TestBlock]
blks -> do
          ChainDB m TestBlock
-> InvalidBlockPunishment m
-> WithOrigin SlotNo
-> StrictMaybe LeiosLedgerView
-> TestBlock
-> m ()
forall (m :: * -> *) blk.
IOLike m =>
ChainDB m blk
-> InvalidBlockPunishment m
-> WithOrigin SlotNo
-> StrictMaybe LeiosLedgerView
-> blk
-> m ()
ChainDB.addBlock_
            ChainDB m TestBlock
chainDB
            InvalidBlockPunishment m
forall (m :: * -> *). Applicative m => InvalidBlockPunishment m
Punishment.noPunishment
            WithOrigin SlotNo
tipSlot
            (Proxy TestBlock -> StrictMaybe LeiosLedgerView
forall blk (proxy :: * -> *).
(LeiosProtocol (BlockProtocol blk),
 LedgerView (BlockProtocol blk) ~ ()) =>
proxy blk -> StrictMaybe LeiosLedgerView
trivialLeiosLedgerView (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @TestBlock))
            TestBlock
blk
          WithOrigin SlotNo -> [TestBlock] -> m (WithOrigin SlotNo)
addBlocks (SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin (TestBlock -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot TestBlock
blk)) [TestBlock]
blks
      addUpdates WithOrigin SlotNo
tipSlot = \case
        [] -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        AddBlock TestBlock
blk : [ChainUpdate]
upds ->
          WithOrigin SlotNo -> [TestBlock] -> m (WithOrigin SlotNo)
addBlocks WithOrigin SlotNo
tipSlot [TestBlock
blk] m (WithOrigin SlotNo) -> (WithOrigin SlotNo -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \WithOrigin SlotNo
tipSlot' -> WithOrigin SlotNo -> [ChainUpdate] -> m ()
addUpdates WithOrigin SlotNo
tipSlot' [ChainUpdate]
upds
        SwitchFork Point TestBlock
p [TestBlock]
blks : [ChainUpdate]
upds ->
          WithOrigin SlotNo -> [TestBlock] -> m (WithOrigin SlotNo)
addBlocks (Point TestBlock -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot Point TestBlock
p) [TestBlock]
blks m (WithOrigin SlotNo) -> (WithOrigin SlotNo -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \WithOrigin SlotNo
tipSlot' -> WithOrigin SlotNo -> [ChainUpdate] -> m ()
addUpdates WithOrigin SlotNo
tipSlot' [ChainUpdate]
upds
  addUpdates Origin chainUpdates

  tentativeHeaderSetTimings <- readTVarIO varTentativeSetTimings
  tentativeHeaderUnsetTimings <- readTVarIO varTentativeUnsetTimings
  followerInstrTimings <- readTVarIO varFollowerInstrTimings
  traceByTime <- getTrace
  pure FollowerPromptnessOutcome{..}
 where
  openChainDB ::
    ResourceRegistry m ->
    Tracer m (ChainDBImpl.TraceEvent TestBlock) ->
    m (ChainDB m TestBlock)
  openChainDB :: ResourceRegistry m
-> Tracer m (TraceEvent TestBlock) -> m (ChainDB m TestBlock)
openChainDB ResourceRegistry m
registry Tracer m (TraceEvent TestBlock)
cdbTracer = do
    chainDbArgs <- do
      let mcdbTopLevelConfig :: TopLevelConfig TestBlock
mcdbTopLevelConfig = SecurityParam -> TopLevelConfig TestBlock
singleNodeTestConfigWithK SecurityParam
securityParam
          mcdbChunkInfo :: ChunkInfo
mcdbChunkInfo = TopLevelConfig TestBlock -> ChunkInfo
mkTestChunkInfo TopLevelConfig TestBlock
mcdbTopLevelConfig
          mcdbInitLedger :: ExtLedgerState TestBlock ValuesMK
mcdbInitLedger = ExtLedgerState TestBlock ValuesMK
testInitExtLedger
          mcdbRegistry :: ResourceRegistry m
mcdbRegistry = ResourceRegistry m
registry
      mcdbNodeDBs <- m (NodeDBs (StrictTMVar m MockFS))
forall (m :: * -> *).
MonadSTM m =>
m (NodeDBs (StrictTMVar m MockFS))
emptyNodeDBs
      mcdbLeiosDb <- newLeiosDBInMemory
      let cdbArgs = MinimalChainDbArgs m TestBlock -> ChainDbArgs Identity m TestBlock
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk,
 LedgerDbSerialiseConstraints blk,
 CanUpgradeLedgerTables LedgerState blk) =>
MinimalChainDbArgs m blk -> Complete ChainDbArgs m blk
fromMinimalChainDbArgs MinimalChainDbArgs{LeiosDbHandle m
TopLevelConfig TestBlock
ChunkInfo
ExtLedgerState TestBlock ValuesMK
ResourceRegistry m
NodeDBs (StrictTMVar m MockFS)
mcdbTopLevelConfig :: TopLevelConfig TestBlock
mcdbChunkInfo :: ChunkInfo
mcdbInitLedger :: ExtLedgerState TestBlock ValuesMK
mcdbRegistry :: ResourceRegistry m
mcdbNodeDBs :: NodeDBs (StrictTMVar m MockFS)
mcdbLeiosDb :: LeiosDbHandle m
mcdbChunkInfo :: ChunkInfo
mcdbInitLedger :: ExtLedgerState TestBlock ValuesMK
mcdbLeiosDb :: LeiosDbHandle m
mcdbNodeDBs :: NodeDBs (StrictTMVar m MockFS)
mcdbRegistry :: ResourceRegistry m
mcdbTopLevelConfig :: TopLevelConfig TestBlock
..}
      pure $ ChainDB.updateTracer cdbTracer cdbArgs
    (_, (chainDB, ChainDBImpl.Internal{intAddBlockRunner})) <-
      allocate
        registry
        (\ResourceId
_ -> ChainDbArgs Identity m TestBlock
-> Bool -> m (ChainDB m TestBlock, Internal m TestBlock)
forall (m :: * -> *) blk.
(IOLike m, All Top (HardForkIndices blk),
 LedgerSupportsProtocol blk, StateSupportsPerasEpochContext blk,
 BlockSupportsDiffusionPipelining blk, BlockSupportsLeios blk,
 BlockSupportsPeras blk, InspectLedger blk, ConvertRawHash blk,
 SerialiseDiskConstraints blk, HasCallStack) =>
Complete ChainDbArgs m blk
-> Bool -> m (ChainDB m blk, Internal m blk)
ChainDBImpl.openDBInternal ChainDbArgs Identity m TestBlock
chainDbArgs Bool
False)
        (ChainDB.closeDB . fst)
    _ <- forkLinkedThread registry "AddBlockRunner" intAddBlockRunner
    pure chainDB

  withTime :: Tracer m (Time, t) -> Tracer m t
withTime = (t -> m (Time, t)) -> Tracer m (Time, t) -> Tracer m t
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Tracer m b -> Tracer m a
contramapM \t
ev -> (,t
ev) (Time -> (Time, t)) -> m Time -> m (Time, t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime

  addTiming :: StrictTVar m (Map Time (Set a)) -> a -> m ()
addTiming StrictTVar m (Map Time (Set a))
varTiming a
hash = do
    now <- m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
    atomically $
      modifyTVar varTiming $
        Map.unionWith Set.union (Map.singleton now (Set.singleton hash))

data FollowerPromptnessTestSetup = FollowerPromptnessTestSetup
  { FollowerPromptnessTestSetup -> SecurityParam
securityParam :: SecurityParam
  , FollowerPromptnessTestSetup -> [ChainUpdate]
chainUpdates :: [ChainUpdate]
  , FollowerPromptnessTestSetup -> DiffTime
artificialDelay :: DiffTime
  }
  deriving stock Int -> FollowerPromptnessTestSetup -> [Char] -> [Char]
[FollowerPromptnessTestSetup] -> [Char] -> [Char]
FollowerPromptnessTestSetup -> [Char]
(Int -> FollowerPromptnessTestSetup -> [Char] -> [Char])
-> (FollowerPromptnessTestSetup -> [Char])
-> ([FollowerPromptnessTestSetup] -> [Char] -> [Char])
-> Show FollowerPromptnessTestSetup
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> FollowerPromptnessTestSetup -> [Char] -> [Char]
showsPrec :: Int -> FollowerPromptnessTestSetup -> [Char] -> [Char]
$cshow :: FollowerPromptnessTestSetup -> [Char]
show :: FollowerPromptnessTestSetup -> [Char]
$cshowList :: [FollowerPromptnessTestSetup] -> [Char] -> [Char]
showList :: [FollowerPromptnessTestSetup] -> [Char] -> [Char]
Show

instance Condense FollowerPromptnessTestSetup where
  condense :: FollowerPromptnessTestSetup -> [Char]
condense FollowerPromptnessTestSetup{[ChainUpdate]
DiffTime
SecurityParam
artificialDelay :: FollowerPromptnessTestSetup -> DiffTime
chainUpdates :: FollowerPromptnessTestSetup -> [ChainUpdate]
securityParam :: FollowerPromptnessTestSetup -> SecurityParam
securityParam :: SecurityParam
chainUpdates :: [ChainUpdate]
artificialDelay :: DiffTime
..} =
    [Char]
"Chain updates: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [ChainUpdate] -> [Char]
forall a. Condense a => a -> [Char]
condense [ChainUpdate]
chainUpdates

instance Arbitrary FollowerPromptnessTestSetup where
  arbitrary :: Gen FollowerPromptnessTestSetup
arbitrary = do
    securityParam <- NonZero Word64 -> SecurityParam
SecurityParam (NonZero Word64 -> SecurityParam)
-> Gen (NonZero Word64) -> Gen SecurityParam
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word64, Word64) -> Gen Word64
forall a. Enum a => (a, a) -> Gen a
chooseEnum (Word64
1, Word64
5) Gen Word64
-> (Word64 -> Maybe (NonZero Word64)) -> Gen (NonZero Word64)
forall a b. Gen a -> (a -> Maybe b) -> Gen b
`suchThatMap` Word64 -> Maybe (NonZero Word64)
forall a. HasZero a => a -> Maybe (NonZero a)
nonZero
    -- Note that genChainUpdates does not guarantee that every update (i.e. a
    -- SwitchFork) will result in a new tentative header, but we don't rely on
    -- this here; rather, we only want to see a tentative candidate
    -- sufficiently often.
    chainUpdates <- genChainUpdates TentativeChainBehavior securityParam 20
    artificialDelay <- secondsToDiffTime <$> chooseInteger (1, 10)
    pure FollowerPromptnessTestSetup{..}

  shrink :: FollowerPromptnessTestSetup -> [FollowerPromptnessTestSetup]
shrink FollowerPromptnessTestSetup{[ChainUpdate]
DiffTime
SecurityParam
artificialDelay :: FollowerPromptnessTestSetup -> DiffTime
chainUpdates :: FollowerPromptnessTestSetup -> [ChainUpdate]
securityParam :: FollowerPromptnessTestSetup -> SecurityParam
securityParam :: SecurityParam
chainUpdates :: [ChainUpdate]
artificialDelay :: DiffTime
..} =
    [ FollowerPromptnessTestSetup
        { chainUpdates :: [ChainUpdate]
chainUpdates = [ChainUpdate] -> [ChainUpdate]
forall a. HasCallStack => [a] -> [a]
init [ChainUpdate]
chainUpdates
        , DiffTime
SecurityParam
artificialDelay :: DiffTime
securityParam :: SecurityParam
securityParam :: SecurityParam
artificialDelay :: DiffTime
..
        }
    | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [ChainUpdate] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ChainUpdate]
chainUpdates
    ]