{-# 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           Cardano.Ledger.BaseTypes (nonZero)
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)
traceByTime :: FollowerPromptnessOutcome -> [(Time, String)]
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, 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
chainUpdates :: FollowerPromptnessTestSetup -> [ChainUpdate]
securityParam :: FollowerPromptnessTestSetup -> SecurityParam
..} = (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
    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. (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 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.
    let 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
    for_ 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

    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
          let 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 ValuesMK
ResourceRegistry m
NodeDBs (StrictTMVar m MockFS)
mcdbTopLevelConfig :: TopLevelConfig TestBlock
mcdbChunkInfo :: ChunkInfo
mcdbInitLedger :: ExtLedgerState TestBlock ValuesMK
mcdbRegistry :: ResourceRegistry m
mcdbNodeDBs :: NodeDBs (StrictTMVar m MockFS)
mcdbNodeDBs :: NodeDBs (StrictTMVar m MockFS)
mcdbRegistry :: ResourceRegistry m
mcdbInitLedger :: ExtLedgerState TestBlock ValuesMK
mcdbChunkInfo :: ChunkInfo
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, LedgerSupportsProtocol blk,
 BlockSupportsDiffusionPipelining blk, InspectLedger blk,
 HasHardForkHistory blk, ConvertRawHash blk,
 SerialiseDiskConstraints blk, HasCallStack,
 LedgerSupportsLedgerDB blk) =>
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 -> 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
chainUpdates :: FollowerPromptnessTestSetup -> [ChainUpdate]
securityParam :: FollowerPromptnessTestSetup -> SecurityParam
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   <- 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
      ]