{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# 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           Control.Monad (forever)
import           Control.Monad.IOSim (runSimOrThrow)
import           Control.ResourceRegistry
import           Control.Tracer (Tracer (..), contramapM, traceWith)
import           Data.Foldable (for_)
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.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.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 = String -> [TestTree] -> TestTree
testGroup String
"FollowerPromptness"
    [ String -> (FollowerPromptnessTestSetup -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"followerPromptness" FollowerPromptnessTestSetup -> Property
prop_followerPromptness
    ]

prop_followerPromptness :: FollowerPromptnessTestSetup -> Property
prop_followerPromptness :: FollowerPromptnessTestSetup -> Property
prop_followerPromptness FollowerPromptnessTestSetup
fpts =
    String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Trace:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
unlines ((Time, String) -> String
forall {a}. Show a => (a, String) -> String
ppTrace ((Time, String) -> String) -> [(Time, String)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Time, String)]
traceByTime)) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (FollowerPromptnessTestSetup -> String
forall a. Condense a => a -> String
condense FollowerPromptnessTestSetup
fpts) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Instruction timings: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Map Time (Set TestHash) -> String
forall a. Condense a => a -> String
condense Map Time (Set TestHash)
followerInstrTimings) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
           String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Failed to pipeline: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [(Time, Set TestHash)] -> String
forall a. Condense a => a -> String
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
.&&. String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Not processed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [(Time, Set TestHash)] -> String
forall a. Condense a => a -> String
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, String)]
Map Time (Set TestHash)
traceByTime :: [(Time, String)]
followerInstrTimings :: Map Time (Set TestHash)
tentativeHeaderSetTimings :: Map Time (Set TestHash)
tentativeHeaderUnsetTimings :: Map Time (Set TestHash)
tentativeHeaderSetTimings :: FollowerPromptnessOutcome -> Map Time (Set TestHash)
tentativeHeaderUnsetTimings :: FollowerPromptnessOutcome -> Map Time (Set TestHash)
followerInstrTimings :: FollowerPromptnessOutcome -> Map Time (Set TestHash)
traceByTime :: FollowerPromptnessOutcome -> [(Time, String)]
..} =
      (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, String) -> String
ppTrace (a
time, String
ev) = a -> String
forall a. Show a => a -> String
show a
time String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
ev

data FollowerPromptnessOutcome = FollowerPromptnessOutcome {
    -- | 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)
tentativeHeaderSetTimings   :: Map Time (Set TestHash)
  , -- | The set of tentative headers by timestamp when unset.
    FollowerPromptnessOutcome -> Map Time (Set TestHash)
tentativeHeaderUnsetTimings :: Map Time (Set TestHash)
  , -- | The set of AddBlock instructions by a tentative follower by timestamp.
    FollowerPromptnessOutcome -> Map Time (Set TestHash)
followerInstrTimings        :: Map Time (Set TestHash)
    -- | Trace message, only used for debugging.
  , FollowerPromptnessOutcome -> [(Time, String)]
traceByTime                 :: [(Time, String)]
  }

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
securityParam :: FollowerPromptnessTestSetup -> SecurityParam
chainUpdates :: FollowerPromptnessTestSetup -> [ChainUpdate]
..} = (ResourceRegistry m -> m FollowerPromptnessOutcome)
-> m FollowerPromptnessOutcome
forall (m :: * -> *) a.
(MonadSTM m, MonadMask m, MonadThread m, HasCallStack) =>
(ResourceRegistry m -> m a) -> m a
withRegistry \ResourceRegistry m
registry -> do
    StrictTVar m (Map Time (Set (HeaderHash TestBlock)))
varTentativeSetTimings   <- Map Time (Set (HeaderHash TestBlock))
-> m (StrictTVar m (Map Time (Set (HeaderHash TestBlock))))
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
uncheckedNewTVarM Map Time (Set (HeaderHash TestBlock))
forall k a. Map k a
Map.empty
    StrictTVar m (Map Time (Set (HeaderHash TestBlock)))
varTentativeUnsetTimings <- Map Time (Set (HeaderHash TestBlock))
-> m (StrictTVar m (Map Time (Set (HeaderHash TestBlock))))
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
uncheckedNewTVarM Map Time (Set (HeaderHash TestBlock))
forall k a. Map k a
Map.empty
    StrictTVar m (Map Time (Set TestHash))
varFollowerInstrTimings  <- 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

    (Tracer m (Time, String) -> Tracer m String
forall {t}. Tracer m (Time, t) -> Tracer m t
withTime -> Tracer m String
tracer, m [(Time, String)]
getTrace) <- m (Tracer m (Time, String), m [(Time, String)])
forall (m :: * -> *) ev. MonadSTM m => m (Tracer m ev, m [ev])
recordingTracerTVar

    let chainDBTracer :: Tracer m (TraceEvent TestBlock)
chainDBTracer = (TraceEvent TestBlock -> m ()) -> Tracer m (TraceEvent TestBlock)
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer \case
            ChainDBImpl.TraceAddBlockEvent TraceAddBlockEvent TestBlock
ev -> do
              Tracer m String -> String -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m String
tracer (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"ChainDB: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TraceAddBlockEvent TestBlock -> String
forall a. Show a => a -> String
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 (HeaderHash TestBlock)))
-> HeaderHash TestBlock -> m ()
forall {m :: * -> *} {a}.
(MonadMonotonicTime m, MonadSTM m, Ord a) =>
StrictTVar m (Map Time (Set a)) -> a -> m ()
addTiming StrictTVar m (Map Time (Set (HeaderHash TestBlock)))
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 (HeaderHash TestBlock)))
-> HeaderHash TestBlock -> m ()
forall {m :: * -> *} {a}.
(MonadMonotonicTime m, MonadSTM m, Ord a) =>
StrictTVar m (Map Time (Set a)) -> a -> m ()
addTiming StrictTVar m (Map Time (Set (HeaderHash TestBlock)))
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 (HeaderHash TestBlock)))
-> HeaderHash TestBlock -> m ()
forall {m :: * -> *} {a}.
(MonadMonotonicTime m, MonadSTM m, Ord a) =>
StrictTVar m (Map Time (Set a)) -> a -> m ()
addTiming StrictTVar m (Map Time (Set (HeaderHash TestBlock)))
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 m TestBlock
chainDB <- ResourceRegistry m
-> Tracer m (TraceEvent TestBlock) -> m (ChainDB m TestBlock)
openChainDB ResourceRegistry m
registry Tracer m (TraceEvent TestBlock)
chainDBTracer

    -- Continually fetch instructions from a tentative follower.
    Follower m TestBlock TestHash
follower <-
      ChainDB m TestBlock
-> forall b.
   ResourceRegistry m
   -> ChainType
   -> BlockComponent TestBlock b
   -> m (Follower m TestBlock b)
forall (m :: * -> *) blk.
ChainDB m blk
-> forall b.
   ResourceRegistry m
   -> ChainType -> BlockComponent blk b -> m (Follower m blk b)
ChainDB.newFollower ChainDB m TestBlock
chainDB ResourceRegistry m
registry ChainType
ChainDB.TentativeChain BlockComponent TestBlock (HeaderHash TestBlock)
BlockComponent TestBlock TestHash
forall blk. BlockComponent blk (HeaderHash blk)
ChainDB.GetHash
    Thread m Any
_ <- ResourceRegistry m -> String -> m Any -> m (Thread m Any)
forall (m :: * -> *) a.
(MonadAsync m, MonadFork m, MonadMask m, HasCallStack) =>
ResourceRegistry m -> String -> m a -> m (Thread m a)
forkLinkedThread ResourceRegistry m
registry String
"Follower listener" (m Any -> m (Thread m Any)) -> m Any -> m (Thread m Any)
forall a b. (a -> b) -> a -> b
$ m () -> m Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m Any) -> m () -> m Any
forall a b. (a -> b) -> a -> b
$
      Follower m TestBlock TestHash -> m (ChainUpdate TestBlock TestHash)
forall (m :: * -> *) blk a.
Follower m blk a -> m (ChainUpdate blk a)
ChainDB.followerInstructionBlocking Follower m TestBlock TestHash
follower m (ChainUpdate TestBlock TestHash)
-> (ChainUpdate TestBlock TestHash -> 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
>>= \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.
    let addBlock :: TestBlock -> m ()
addBlock = ChainDB m TestBlock
-> InvalidBlockPunishment m -> TestBlock -> m ()
forall (m :: * -> *) blk.
IOLike m =>
ChainDB m blk -> InvalidBlockPunishment m -> blk -> m ()
ChainDB.addBlock_ ChainDB m TestBlock
chainDB InvalidBlockPunishment m
forall (m :: * -> *). Applicative m => InvalidBlockPunishment m
Punishment.noPunishment
    [ChainUpdate] -> (ChainUpdate -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [ChainUpdate]
chainUpdates \case
      AddBlock TestBlock
blk      -> TestBlock -> m ()
addBlock TestBlock
blk
      SwitchFork Point TestBlock
_ [TestBlock]
blks -> [TestBlock] -> (TestBlock -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [TestBlock]
blks TestBlock -> m ()
addBlock

    Map Time (Set TestHash)
tentativeHeaderSetTimings   <- StrictTVar m (Map Time (Set TestHash))
-> m (Map Time (Set TestHash))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO StrictTVar m (Map Time (Set (HeaderHash TestBlock)))
StrictTVar m (Map Time (Set TestHash))
varTentativeSetTimings
    Map Time (Set TestHash)
tentativeHeaderUnsetTimings <- StrictTVar m (Map Time (Set TestHash))
-> m (Map Time (Set TestHash))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO StrictTVar m (Map Time (Set (HeaderHash TestBlock)))
StrictTVar m (Map Time (Set TestHash))
varTentativeUnsetTimings
    Map Time (Set TestHash)
followerInstrTimings        <- StrictTVar m (Map Time (Set TestHash))
-> m (Map Time (Set TestHash))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO StrictTVar m (Map Time (Set TestHash))
varFollowerInstrTimings
    [(Time, String)]
traceByTime                 <- m [(Time, String)]
getTrace
    FollowerPromptnessOutcome -> m FollowerPromptnessOutcome
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FollowerPromptnessOutcome {[(Time, String)]
Map Time (Set TestHash)
tentativeHeaderSetTimings :: Map Time (Set TestHash)
tentativeHeaderUnsetTimings :: Map Time (Set TestHash)
followerInstrTimings :: Map Time (Set TestHash)
traceByTime :: [(Time, String)]
tentativeHeaderSetTimings :: Map Time (Set TestHash)
tentativeHeaderUnsetTimings :: Map Time (Set TestHash)
followerInstrTimings :: Map Time (Set TestHash)
traceByTime :: [(Time, String)]
..}
  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 Identity m TestBlock
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
mcdbInitLedger     = ExtLedgerState TestBlock
testInitExtLedger
              mcdbRegistry :: ResourceRegistry m
mcdbRegistry       = ResourceRegistry m
registry
          NodeDBs (StrictTMVar m MockFS)
mcdbNodeDBs <- m (NodeDBs (StrictTMVar m MockFS))
forall (m :: * -> *).
MonadSTM m =>
m (NodeDBs (StrictTMVar m MockFS))
emptyNodeDBs
          let cdbArgs :: ChainDbArgs Identity m TestBlock
cdbArgs = MinimalChainDbArgs m TestBlock -> ChainDbArgs Identity m TestBlock
forall (m :: * -> *) blk.
(MonadThrow m, MonadSTM m, ConsensusProtocol (BlockProtocol blk),
 PrimMonad m) =>
MinimalChainDbArgs m blk -> Complete ChainDbArgs m blk
fromMinimalChainDbArgs MinimalChainDbArgs{TopLevelConfig TestBlock
ChunkInfo
ExtLedgerState TestBlock
ResourceRegistry m
NodeDBs (StrictTMVar m MockFS)
mcdbTopLevelConfig :: TopLevelConfig TestBlock
mcdbChunkInfo :: ChunkInfo
mcdbInitLedger :: ExtLedgerState TestBlock
mcdbRegistry :: ResourceRegistry m
mcdbNodeDBs :: NodeDBs (StrictTMVar m MockFS)
mcdbTopLevelConfig :: TopLevelConfig TestBlock
mcdbChunkInfo :: ChunkInfo
mcdbInitLedger :: ExtLedgerState TestBlock
mcdbRegistry :: ResourceRegistry m
mcdbNodeDBs :: NodeDBs (StrictTMVar m MockFS)
..}
          ChainDbArgs Identity m TestBlock
-> m (ChainDbArgs Identity m TestBlock)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainDbArgs Identity m TestBlock
 -> m (ChainDbArgs Identity m TestBlock))
-> ChainDbArgs Identity m TestBlock
-> m (ChainDbArgs Identity m TestBlock)
forall a b. (a -> b) -> a -> b
$ Tracer m (TraceEvent TestBlock)
-> ChainDbArgs Identity m TestBlock
-> ChainDbArgs Identity m TestBlock
forall (m :: * -> *) blk (f :: * -> *).
Tracer m (TraceEvent blk)
-> ChainDbArgs f m blk -> ChainDbArgs f m blk
ChainDB.updateTracer Tracer m (TraceEvent TestBlock)
cdbTracer ChainDbArgs Identity m TestBlock
cdbArgs
        (ResourceKey m
_, (ChainDB m TestBlock
chainDB, ChainDBImpl.Internal{m Void
intAddBlockRunner :: m Void
intAddBlockRunner :: forall (m :: * -> *) blk. Internal m blk -> m Void
intAddBlockRunner})) <-
          ResourceRegistry m
-> (ResourceId -> m (ChainDB m TestBlock, Internal m TestBlock))
-> ((ChainDB m TestBlock, Internal m TestBlock) -> m ())
-> m (ResourceKey m, (ChainDB m TestBlock, Internal m TestBlock))
forall (m :: * -> *) a.
(MonadSTM m, MonadMask m, MonadThread m, HasCallStack) =>
ResourceRegistry m
-> (ResourceId -> m a) -> (a -> m ()) -> m (ResourceKey m, a)
allocate
            ResourceRegistry m
registry
            (\ResourceId
_ -> ChainDbArgs Identity m TestBlock
-> Bool -> m (ChainDB m TestBlock, Internal m TestBlock)
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk,
 BlockSupportsDiffusionPipelining blk, InspectLedger blk,
 HasHardForkHistory blk, ConvertRawHash blk,
 SerialiseDiskConstraints blk) =>
ChainDbArgs Identity m blk
-> Bool -> m (ChainDB m blk, Internal m blk)
ChainDBImpl.openDBInternal ChainDbArgs Identity m TestBlock
chainDbArgs Bool
False)
            (ChainDB m TestBlock -> m ()
forall (m :: * -> *) blk. ChainDB m blk -> m ()
ChainDB.closeDB (ChainDB m TestBlock -> m ())
-> ((ChainDB m TestBlock, Internal m TestBlock)
    -> ChainDB m TestBlock)
-> (ChainDB m TestBlock, Internal m TestBlock)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ChainDB m TestBlock, Internal m TestBlock) -> ChainDB m TestBlock
forall a b. (a, b) -> a
fst)
        Thread m Void
_ <- ResourceRegistry m -> String -> m Void -> m (Thread m Void)
forall (m :: * -> *) a.
(MonadAsync m, MonadFork m, MonadMask m, HasCallStack) =>
ResourceRegistry m -> String -> m a -> m (Thread m a)
forkLinkedThread ResourceRegistry m
registry String
"AddBlockRunner" m Void
intAddBlockRunner
        ChainDB m TestBlock -> m (ChainDB m TestBlock)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ChainDB m TestBlock
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
        Time
now <- m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
        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 (Map Time (Set a))
-> (Map Time (Set a) -> Map Time (Set a)) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m (Map Time (Set a))
varTiming ((Map Time (Set a) -> Map Time (Set a)) -> STM m ())
-> (Map Time (Set a) -> Map Time (Set a)) -> STM m ()
forall a b. (a -> b) -> a -> b
$
          (Set a -> Set a -> Set a)
-> Map Time (Set a) -> Map Time (Set a) -> Map Time (Set a)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
Set.union (Time -> Set a -> Map Time (Set a)
forall k a. k -> a -> Map k a
Map.singleton Time
now (a -> Set a
forall a. a -> Set a
Set.singleton a
hash))

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

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

instance Arbitrary FollowerPromptnessTestSetup where
  arbitrary :: Gen FollowerPromptnessTestSetup
arbitrary = do
      SecurityParam
securityParam   <- Word64 -> SecurityParam
SecurityParam (Word64 -> SecurityParam) -> Gen 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)
      -- 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.
      [ChainUpdate]
chainUpdates    <- UpdateBehavior -> SecurityParam -> Int -> Gen [ChainUpdate]
genChainUpdates UpdateBehavior
TentativeChainBehavior SecurityParam
securityParam Int
20
      DiffTime
artificialDelay <- Integer -> DiffTime
secondsToDiffTime (Integer -> DiffTime) -> Gen Integer -> Gen DiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Integer, Integer) -> Gen Integer
chooseInteger (Integer
1, Integer
10)
      FollowerPromptnessTestSetup -> Gen FollowerPromptnessTestSetup
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FollowerPromptnessTestSetup {[ChainUpdate]
DiffTime
SecurityParam
artificialDelay :: DiffTime
securityParam :: SecurityParam
chainUpdates :: [ChainUpdate]
securityParam :: SecurityParam
chainUpdates :: [ChainUpdate]
artificialDelay :: DiffTime
..}

  shrink :: FollowerPromptnessTestSetup -> [FollowerPromptnessTestSetup]
shrink FollowerPromptnessTestSetup{[ChainUpdate]
DiffTime
SecurityParam
artificialDelay :: FollowerPromptnessTestSetup -> DiffTime
securityParam :: FollowerPromptnessTestSetup -> SecurityParam
chainUpdates :: FollowerPromptnessTestSetup -> [ChainUpdate]
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
      ]