{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}

-- | Test that ledger snapshots are performed at /predictable/ points on the
-- immutable chain (modulo rate limiting).
--
-- We open a ChainDB and add to it a (shuffled) list of blocks such that the
-- immutable chain is predetermined. Then, we check that ledger snapshots were
-- created for precisely the points we expect given the configured
-- 'SnapshotFrequencyArgs'.
module Test.Ouroboros.Storage.ChainDB.LedgerSnapshots (tests) where

import Cardano.Ledger.BaseTypes.NonZero
import Control.Monad (guard, replicateM)
import Control.Monad.IOSim (runSim)
import Control.ResourceRegistry
import Control.Tracer
import Data.Foldable (for_)
import qualified Data.List.NonEmpty as NE
import Data.Maybe (mapMaybe)
import qualified Data.Set as Set
import Data.Time (secondsToDiffTime)
import Data.Traversable (for)
import Data.Word (Word64)
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Config
import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB
import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB)
import qualified Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment as Punishment
import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Args as ChainDB
import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB
import Ouroboros.Consensus.Storage.LedgerDB.Args (LedgerDbBackendArgs)
import Ouroboros.Consensus.Storage.LedgerDB.Snapshots
import qualified Ouroboros.Consensus.Storage.LedgerDB.Snapshots as LedgerDB
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Args as LedgerDB.V1
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore as LedgerDB.V1
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.InMemory as LedgerDB.V1.InMemory
import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Backend as LedgerDB.V2
import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory as LedgerDB.V2.InMemory
import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.LSM as LedgerDB.V2.LSM
import Ouroboros.Consensus.Util (dropLast)
import Ouroboros.Consensus.Util.Args
import Ouroboros.Consensus.Util.Condense
import Ouroboros.Consensus.Util.Enclose (Enclosing' (FallingEdgeWith))
import Ouroboros.Consensus.Util.IOLike
import Ouroboros.Network.AnchoredFragment (Anchor, AnchoredFragment)
import qualified Ouroboros.Network.AnchoredFragment as AF
import System.FS.API (SomeHasFS)
import System.FS.API.Types (mkFsPath)
import System.FS.BlockIO.Sim (simHasBlockIO')
import qualified System.FS.Sim.MockFS as MockFS
import Test.Tasty
import Test.Tasty.QuickCheck hiding (NonZero)
import Test.Util.ChainDB
import Test.Util.Orphans.IOLike ()
import Test.Util.QuickCheck
import Test.Util.TestBlock
import Test.Util.Tracer (recordingTracerTVar)

tests :: TestTree
tests :: TestTree
tests =
  String -> [TestTree] -> TestTree
testGroup
    String
"LedgerSnapshots"
    [ String -> (TestSetup -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"InMemV1" ((TestSetup -> Property) -> TestTree)
-> (TestSetup -> Property) -> TestTree
forall a b. (a -> b) -> a -> b
$ (forall (m :: * -> *). IOLike m => LedgerDbBackendArgs m TestBlock)
-> TestSetup -> Property
prop_ledgerSnapshots LedgerDbBackendArgs m TestBlock
forall (m :: * -> *). IOLike m => LedgerDbBackendArgs m TestBlock
inMemV1
    , String -> (TestSetup -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"InMemV2" ((TestSetup -> Property) -> TestTree)
-> (TestSetup -> Property) -> TestTree
forall a b. (a -> b) -> a -> b
$ (forall (m :: * -> *). IOLike m => LedgerDbBackendArgs m TestBlock)
-> TestSetup -> Property
prop_ledgerSnapshots LedgerDbBackendArgs m TestBlock
forall (m :: * -> *). IOLike m => LedgerDbBackendArgs m TestBlock
inMemV2
    , String -> (Word64 -> TestSetup -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"LSM" ((Word64 -> TestSetup -> Property) -> TestTree)
-> (Word64 -> TestSetup -> Property) -> TestTree
forall a b. (a -> b) -> a -> b
$ \Word64
salt -> (forall (m :: * -> *). IOLike m => LedgerDbBackendArgs m TestBlock)
-> TestSetup -> Property
prop_ledgerSnapshots (Word64 -> LedgerDbBackendArgs m TestBlock
forall (m :: * -> *).
IOLike m =>
Word64 -> LedgerDbBackendArgs m TestBlock
lsm Word64
salt)
    , String -> [TestTree] -> TestTree
testGroup
        String
"addBlocks while a snapshot is enqueued"
        [ String -> (TestSetup -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"InMemV1" ((TestSetup -> Property) -> TestTree)
-> (TestSetup -> Property) -> TestTree
forall a b. (a -> b) -> a -> b
$ (forall (m :: * -> *). IOLike m => LedgerDbBackendArgs m TestBlock)
-> TestSetup -> Property
prop_addBlocksWhileSnapshotting LedgerDbBackendArgs m TestBlock
forall (m :: * -> *). IOLike m => LedgerDbBackendArgs m TestBlock
inMemV1
        , String -> (TestSetup -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"InMemV2" ((TestSetup -> Property) -> TestTree)
-> (TestSetup -> Property) -> TestTree
forall a b. (a -> b) -> a -> b
$ (forall (m :: * -> *). IOLike m => LedgerDbBackendArgs m TestBlock)
-> TestSetup -> Property
prop_addBlocksWhileSnapshotting LedgerDbBackendArgs m TestBlock
forall (m :: * -> *). IOLike m => LedgerDbBackendArgs m TestBlock
inMemV2
        , String -> (Word64 -> TestSetup -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"LSM" ((Word64 -> TestSetup -> Property) -> TestTree)
-> (Word64 -> TestSetup -> Property) -> TestTree
forall a b. (a -> b) -> a -> b
$ \Word64
salt -> (forall (m :: * -> *). IOLike m => LedgerDbBackendArgs m TestBlock)
-> TestSetup -> Property
prop_addBlocksWhileSnapshotting (Word64 -> LedgerDbBackendArgs m TestBlock
forall (m :: * -> *).
IOLike m =>
Word64 -> LedgerDbBackendArgs m TestBlock
lsm Word64
salt)
        ]
    ]
 where
  inMemV1, inMemV2 :: IOLike m => LedgerDbBackendArgs m TestBlock
  inMemV1 :: forall (m :: * -> *). IOLike m => LedgerDbBackendArgs m TestBlock
inMemV1 =
    LedgerDbBackendArgs m (ExtLedgerState TestBlock)
-> LedgerDbBackendArgs m TestBlock
forall (m :: * -> *) blk.
LedgerDbBackendArgs m (ExtLedgerState blk)
-> LedgerDbBackendArgs m blk
LedgerDB.LedgerDbBackendArgsV1 (LedgerDbBackendArgs m (ExtLedgerState TestBlock)
 -> LedgerDbBackendArgs m TestBlock)
-> LedgerDbBackendArgs m (ExtLedgerState TestBlock)
-> LedgerDbBackendArgs m TestBlock
forall a b. (a -> b) -> a -> b
$
      FlushFrequency
-> SomeBackendArgs m (ExtLedgerState TestBlock)
-> LedgerDbBackendArgs m (ExtLedgerState TestBlock)
forall (m :: * -> *) (l :: LedgerStateKind).
FlushFrequency -> SomeBackendArgs m l -> LedgerDbBackendArgs m l
LedgerDB.V1.V1Args FlushFrequency
LedgerDB.V1.DisableFlushing (SomeBackendArgs m (ExtLedgerState TestBlock)
 -> LedgerDbBackendArgs m (ExtLedgerState TestBlock))
-> SomeBackendArgs m (ExtLedgerState TestBlock)
-> LedgerDbBackendArgs m (ExtLedgerState TestBlock)
forall a b. (a -> b) -> a -> b
$
        Args m Mem -> SomeBackendArgs m (ExtLedgerState TestBlock)
forall (m :: * -> *) backend (l :: LedgerStateKind).
Backend m backend l =>
Args m backend -> SomeBackendArgs m l
LedgerDB.V1.SomeBackendArgs Args m Mem
forall (m :: * -> *). Args m Mem
LedgerDB.V1.InMemory.InMemArgs
  inMemV2 :: forall (m :: * -> *). IOLike m => LedgerDbBackendArgs m TestBlock
inMemV2 =
    SomeBackendArgs m TestBlock -> LedgerDbBackendArgs m TestBlock
forall (m :: * -> *) blk.
SomeBackendArgs m blk -> LedgerDbBackendArgs m blk
LedgerDB.LedgerDbBackendArgsV2 (SomeBackendArgs m TestBlock -> LedgerDbBackendArgs m TestBlock)
-> SomeBackendArgs m TestBlock -> LedgerDbBackendArgs m TestBlock
forall a b. (a -> b) -> a -> b
$
      Args m Mem -> SomeBackendArgs m TestBlock
forall (m :: * -> *) backend blk.
Backend m backend blk =>
Args m backend -> SomeBackendArgs m blk
LedgerDB.V2.SomeBackendArgs Args m Mem
forall (m :: * -> *). Args m Mem
LedgerDB.V2.InMemory.InMemArgs

  lsm ::
    IOLike m =>
    LedgerDB.V2.LSM.Salt ->
    LedgerDbBackendArgs m TestBlock
  lsm :: forall (m :: * -> *).
IOLike m =>
Word64 -> LedgerDbBackendArgs m TestBlock
lsm Word64
salt =
    SomeBackendArgs m TestBlock -> LedgerDbBackendArgs m TestBlock
forall (m :: * -> *) blk.
SomeBackendArgs m blk -> LedgerDbBackendArgs m blk
LedgerDB.LedgerDbBackendArgsV2 (SomeBackendArgs m TestBlock -> LedgerDbBackendArgs m TestBlock)
-> SomeBackendArgs m TestBlock -> LedgerDbBackendArgs m TestBlock
forall a b. (a -> b) -> a -> b
$
      Args m LSM -> SomeBackendArgs m TestBlock
forall (m :: * -> *) backend blk.
Backend m backend blk =>
Args m backend -> SomeBackendArgs m blk
LedgerDB.V2.SomeBackendArgs (Args m LSM -> SomeBackendArgs m TestBlock)
-> Args m LSM -> SomeBackendArgs m TestBlock
forall a b. (a -> b) -> a -> b
$
        FsPath
-> Word64
-> (forall st. WithTempRegistry st m (SomeHasFSAndBlockIO m))
-> Args m LSM
forall (m :: * -> *).
FsPath
-> Word64
-> (forall st. WithTempRegistry st m (SomeHasFSAndBlockIO m))
-> Args m LSM
LedgerDB.V2.LSM.LSMArgs ([String] -> FsPath
mkFsPath []) Word64
salt WithTempRegistry st m (SomeHasFSAndBlockIO m)
forall st. WithTempRegistry st m (SomeHasFSAndBlockIO m)
mkSimBlockIOFS
   where
    mkSimBlockIOFS :: WithTempRegistry st m (SomeHasFSAndBlockIO m)
mkSimBlockIOFS =
      (HasFS m HandleMock
 -> HasBlockIO m HandleMock -> SomeHasFSAndBlockIO m)
-> (HasFS m HandleMock, HasBlockIO m HandleMock)
-> SomeHasFSAndBlockIO m
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry HasFS m HandleMock
-> HasBlockIO m HandleMock -> SomeHasFSAndBlockIO m
forall h (m :: * -> *).
(Eq h, Typeable h) =>
HasFS m h -> HasBlockIO m h -> SomeHasFSAndBlockIO m
LedgerDB.V2.LSM.SomeHasFSAndBlockIO
        ((HasFS m HandleMock, HasBlockIO m HandleMock)
 -> SomeHasFSAndBlockIO m)
-> WithTempRegistry
     st m (HasFS m HandleMock, HasBlockIO m HandleMock)
-> WithTempRegistry st m (SomeHasFSAndBlockIO m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (HasFS m HandleMock, HasBlockIO m HandleMock)
-> ((HasFS m HandleMock, HasBlockIO m HandleMock) -> m Bool)
-> (st -> (HasFS m HandleMock, HasBlockIO m HandleMock) -> Bool)
-> WithTempRegistry
     st m (HasFS m HandleMock, HasBlockIO m HandleMock)
forall (m :: * -> *) a st.
(MonadSTM m, MonadMask m, MonadThread m, HasCallStack) =>
m a
-> (a -> m Bool) -> (st -> a -> Bool) -> WithTempRegistry st m a
allocateTemp
          (MockFS -> m (HasFS m HandleMock, HasBlockIO m HandleMock)
forall (m :: * -> *).
(MonadCatch m, MonadMVar m, PrimMonad m, MonadSTM m) =>
MockFS -> m (HasFS m HandleMock, HasBlockIO m HandleMock)
simHasBlockIO' MockFS
MockFS.empty)
          (\(HasFS m HandleMock, HasBlockIO m HandleMock)
_ -> Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True)
          st -> (HasFS m HandleMock, HasBlockIO m HandleMock) -> Bool
forall a b. a -> b -> Bool
impossibleToNotTransfer

prop_ledgerSnapshots ::
  (forall m. IOLike m => LedgerDbBackendArgs m TestBlock) ->
  TestSetup ->
  Property
prop_ledgerSnapshots :: (forall (m :: * -> *). IOLike m => LedgerDbBackendArgs m TestBlock)
-> TestSetup -> Property
prop_ledgerSnapshots forall (m :: * -> *). IOLike m => LedgerDbBackendArgs m TestBlock
lgrDbBackendArgs TestSetup
testSetup =
  case (forall s. IOSim s TestOutcome) -> Either Failure TestOutcome
forall a. (forall s. IOSim s a) -> Either Failure a
runSim (LedgerDbBackendArgs (IOSim s) TestBlock
-> TestSetup -> IOSim s TestOutcome
forall (m :: * -> *).
IOLike m =>
LedgerDbBackendArgs m TestBlock -> TestSetup -> m TestOutcome
runTest LedgerDbBackendArgs (IOSim s) TestBlock
forall (m :: * -> *). IOLike m => LedgerDbBackendArgs m TestBlock
lgrDbBackendArgs TestSetup
testSetup) of
    Right TestOutcome
testOutcome -> TestSetup -> TestOutcome -> Property
checkTestOutcome TestSetup
testSetup TestOutcome
testOutcome
    Left Failure
err -> String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Failure: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Failure -> String
forall a. Show a => a -> String
show Failure
err) Bool
False

prop_addBlocksWhileSnapshotting ::
  (forall m. IOLike m => LedgerDbBackendArgs m TestBlock) ->
  TestSetup ->
  Property
prop_addBlocksWhileSnapshotting :: (forall (m :: * -> *). IOLike m => LedgerDbBackendArgs m TestBlock)
-> TestSetup -> Property
prop_addBlocksWhileSnapshotting forall (m :: * -> *). IOLike m => LedgerDbBackendArgs m TestBlock
lgrDbBackendArgs TestSetup
testSetup =
  case (forall s. IOSim s AddBlockCount) -> Either Failure AddBlockCount
forall a. (forall s. IOSim s a) -> Either Failure a
runSim (LedgerDbBackendArgs (IOSim s) TestBlock
-> TestSetup -> IOSim s AddBlockCount
forall (m :: * -> *).
IOLike m =>
LedgerDbBackendArgs m TestBlock -> TestSetup -> m AddBlockCount
runAddBlocks LedgerDbBackendArgs (IOSim s) TestBlock
forall (m :: * -> *). IOLike m => LedgerDbBackendArgs m TestBlock
lgrDbBackendArgs TestSetup
testSetup) of
    Right AddBlockCount
outcome -> do
      String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
label
        (Int -> String
forall a. Show a => a -> String
show (AddBlockCount -> Int
blocksAddedWhileSnapshotting AddBlockCount
outcome) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" blocks were added while a snapshot was enqueued")
        (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ AddBlockCount -> Int
totalBlocksAdded AddBlockCount
outcome Int -> Int -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== [TestBlock] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (TestSetup -> [TestBlock]
tsBlocksToAdd TestSetup
testSetup)
    Left Failure
err -> String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Failure: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Failure -> String
forall a. Show a => a -> String
show Failure
err) Bool
False

data AddBlockCount = AddBlockCount
  { AddBlockCount -> Int
blocksAddedWhileSnapshotting :: !Int
  , AddBlockCount -> Int
totalBlocksAdded :: !Int
  }
  deriving (Int -> AddBlockCount -> String -> String
[AddBlockCount] -> String -> String
AddBlockCount -> String
(Int -> AddBlockCount -> String -> String)
-> (AddBlockCount -> String)
-> ([AddBlockCount] -> String -> String)
-> Show AddBlockCount
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> AddBlockCount -> String -> String
showsPrec :: Int -> AddBlockCount -> String -> String
$cshow :: AddBlockCount -> String
show :: AddBlockCount -> String
$cshowList :: [AddBlockCount] -> String -> String
showList :: [AddBlockCount] -> String -> String
Show, AddBlockCount -> AddBlockCount -> Bool
(AddBlockCount -> AddBlockCount -> Bool)
-> (AddBlockCount -> AddBlockCount -> Bool) -> Eq AddBlockCount
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AddBlockCount -> AddBlockCount -> Bool
== :: AddBlockCount -> AddBlockCount -> Bool
$c/= :: AddBlockCount -> AddBlockCount -> Bool
/= :: AddBlockCount -> AddBlockCount -> Bool
Eq, Eq AddBlockCount
Eq AddBlockCount =>
(AddBlockCount -> AddBlockCount -> Ordering)
-> (AddBlockCount -> AddBlockCount -> Bool)
-> (AddBlockCount -> AddBlockCount -> Bool)
-> (AddBlockCount -> AddBlockCount -> Bool)
-> (AddBlockCount -> AddBlockCount -> Bool)
-> (AddBlockCount -> AddBlockCount -> AddBlockCount)
-> (AddBlockCount -> AddBlockCount -> AddBlockCount)
-> Ord AddBlockCount
AddBlockCount -> AddBlockCount -> Bool
AddBlockCount -> AddBlockCount -> Ordering
AddBlockCount -> AddBlockCount -> AddBlockCount
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 :: AddBlockCount -> AddBlockCount -> Ordering
compare :: AddBlockCount -> AddBlockCount -> Ordering
$c< :: AddBlockCount -> AddBlockCount -> Bool
< :: AddBlockCount -> AddBlockCount -> Bool
$c<= :: AddBlockCount -> AddBlockCount -> Bool
<= :: AddBlockCount -> AddBlockCount -> Bool
$c> :: AddBlockCount -> AddBlockCount -> Bool
> :: AddBlockCount -> AddBlockCount -> Bool
$c>= :: AddBlockCount -> AddBlockCount -> Bool
>= :: AddBlockCount -> AddBlockCount -> Bool
$cmax :: AddBlockCount -> AddBlockCount -> AddBlockCount
max :: AddBlockCount -> AddBlockCount -> AddBlockCount
$cmin :: AddBlockCount -> AddBlockCount -> AddBlockCount
min :: AddBlockCount -> AddBlockCount -> AddBlockCount
Ord)

instance Semigroup AddBlockCount where
  AddBlockCount
a <> :: AddBlockCount -> AddBlockCount -> AddBlockCount
<> AddBlockCount
b =
    Int -> Int -> AddBlockCount
AddBlockCount
      (AddBlockCount -> Int
blocksAddedWhileSnapshotting AddBlockCount
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ AddBlockCount -> Int
blocksAddedWhileSnapshotting AddBlockCount
b)
      (AddBlockCount -> Int
totalBlocksAdded AddBlockCount
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ AddBlockCount -> Int
totalBlocksAdded AddBlockCount
b)

instance Monoid AddBlockCount where
  mempty :: AddBlockCount
mempty = Int -> Int -> AddBlockCount
AddBlockCount Int
0 Int
0
  mappend :: AddBlockCount -> AddBlockCount -> AddBlockCount
mappend = AddBlockCount -> AddBlockCount -> AddBlockCount
forall a. Semigroup a => a -> a -> a
(<>)

runAddBlocks ::
  forall m.
  IOLike m =>
  LedgerDbBackendArgs m TestBlock ->
  TestSetup ->
  m AddBlockCount
runAddBlocks :: forall (m :: * -> *).
IOLike m =>
LedgerDbBackendArgs m TestBlock -> TestSetup -> m AddBlockCount
runAddBlocks LedgerDbBackendArgs m TestBlock
lgrDbBackendArgs TestSetup
testSetup = (ResourceRegistry m -> m AddBlockCount) -> m AddBlockCount
forall (m :: * -> *) a.
(MonadSTM m, MonadMask m, MonadThread m, HasCallStack) =>
(ResourceRegistry m -> m a) -> m a
withRegistry \ResourceRegistry m
registry -> do
  isSnapshottingTMVar :: StrictTMVar m () <- m (StrictTMVar m ())
forall (m :: * -> *) a. MonadSTM m => m (StrictTMVar m a)
newEmptyTMVarIO

  (chainDB, _lgrHasFS) <- openChainDB registry (isSnapshottingTracer isSnapshottingTMVar)

  addBlockCount <- for (tsBlocksToAdd testSetup) \TestBlock
blk -> do
    isNotSnapshotting <- 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
$ StrictTMVar m () -> STM m Bool
forall (m :: * -> *) a. MonadSTM m => StrictTMVar m a -> STM m Bool
isEmptyTMVar StrictTMVar m ()
isSnapshottingTMVar

    ChainDB.addBlock_ chainDB Punishment.noPunishment blk
    threadDelay 1
    pure $ AddBlockCount (if isNotSnapshotting then 0 else 1) 1

  pure $ mconcat addBlockCount
 where
  openChainDB ::
    ResourceRegistry m ->
    Tracer m (ChainDB.TraceEvent TestBlock) ->
    m (ChainDB m TestBlock, SomeHasFS m)
  openChainDB :: ResourceRegistry m
-> Tracer m (TraceEvent TestBlock)
-> m (ChainDB m TestBlock, SomeHasFS m)
openChainDB ResourceRegistry m
registry Tracer m (TraceEvent TestBlock)
cdbTracer = do
    chainDbArgs <- do
      mcdbNodeDBs <- m (NodeDBs (StrictTMVar m MockFS))
forall (m :: * -> *).
MonadSTM m =>
m (NodeDBs (StrictTMVar m MockFS))
emptyNodeDBs
      let mcdbTopLevelConfig = SecurityParam -> TopLevelConfig TestBlock
singleNodeTestConfigWithK (TestSetup -> SecurityParam
tsSecParam TestSetup
testSetup)
          cdbArgs =
            MinimalChainDbArgs m TestBlock -> ChainDbArgs Identity m TestBlock
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk,
 LedgerSupportsLedgerDB blk) =>
MinimalChainDbArgs m blk -> Complete ChainDbArgs m blk
fromMinimalChainDbArgs
              MinimalChainDbArgs
                { TopLevelConfig TestBlock
mcdbTopLevelConfig :: TopLevelConfig TestBlock
mcdbTopLevelConfig :: TopLevelConfig TestBlock
mcdbTopLevelConfig
                , NodeDBs (StrictTMVar m MockFS)
mcdbNodeDBs :: NodeDBs (StrictTMVar m MockFS)
mcdbNodeDBs :: NodeDBs (StrictTMVar m MockFS)
mcdbNodeDBs
                , 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
                }
          updLgrDbArgs ChainDbArgs f m TestBlock
a =
            ChainDbArgs f m TestBlock
a
              { ChainDB.cdbLgrDbArgs =
                  (ChainDB.cdbLgrDbArgs a)
                    { LedgerDB.lgrBackendArgs = lgrDbBackendArgs
                    , LedgerDB.lgrSnapshotPolicyArgs = tsSnapshotPolicyArgs testSetup
                    }
              }
      pure $ updLgrDbArgs $ ChainDB.updateTracer cdbTracer cdbArgs
    (_, chainDB) <-
      allocate
        registry
        (\ResourceId
_ -> ChainDbArgs Identity m TestBlock -> m (ChainDB m TestBlock)
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk, LedgerSupportsPeras blk,
 BlockSupportsDiffusionPipelining blk, InspectLedger blk,
 HasHardForkHistory blk, ConvertRawHash blk,
 SerialiseDiskConstraints blk, LedgerSupportsLedgerDB blk) =>
Complete ChainDbArgs m blk -> m (ChainDB m blk)
ChainDB.openDB ChainDbArgs Identity m TestBlock
chainDbArgs)
        (ChainDB.closeDB)
    pure (chainDB, LedgerDB.lgrHasFS $ ChainDB.cdbLgrDbArgs chainDbArgs)

  isSnapshottingTracer :: StrictTMVar m () -> Tracer m (ChainDB.TraceEvent TestBlock)
  isSnapshottingTracer :: StrictTMVar m () -> Tracer m (TraceEvent TestBlock)
isSnapshottingTracer StrictTMVar m ()
tmvar = (TraceEvent TestBlock -> m ()) -> Tracer m (TraceEvent TestBlock)
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer \case
    ChainDB.TraceLedgerDBEvent (LedgerDB.LedgerDBSnapshotEvent (SnapshotRequestDelayed Time
_ DiffTime
_ NonEmpty SlotNo
_)) ->
      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
$ StrictTMVar m () -> () -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTMVar m a -> a -> STM m ()
putTMVar StrictTMVar m ()
tmvar ()
    ChainDB.TraceLedgerDBEvent (LedgerDB.LedgerDBSnapshotEvent TraceSnapshotEvent TestBlock
SnapshotRequestCompleted) ->
      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
$ StrictTMVar m () -> STM m ()
forall (m :: * -> *) a. MonadSTM m => StrictTMVar m a -> STM m a
takeTMVar StrictTMVar m ()
tmvar
    TraceEvent TestBlock
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

{-------------------------------------------------------------------------------
  Test setup
-------------------------------------------------------------------------------}

data TestSetup = TestSetup
  { TestSetup -> SecurityParam
tsSecParam :: SecurityParam
  , TestSetup -> AnchoredFragment TestBlock
tsMainChain :: AnchoredFragment TestBlock
  , TestSetup -> [AnchoredFragment TestBlock]
tsForks :: [AnchoredFragment TestBlock]
  -- ^ Forks anchored in the immutable prefix of the main chain. Must be of
  -- length at most @k@.
  , TestSetup -> Permutation
tsPerm :: Permutation
  -- ^ Shuffle the blocks when adding them to the ChainDB, see 'tsBlocksToAdd'.
  , TestSetup -> TestSnapshotPolicyArgs
tsTestSnapshotPolicyArgs :: TestSnapshotPolicyArgs
  }
  deriving stock Int -> TestSetup -> String -> String
[TestSetup] -> String -> String
TestSetup -> String
(Int -> TestSetup -> String -> String)
-> (TestSetup -> String)
-> ([TestSetup] -> String -> String)
-> Show TestSetup
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> TestSetup -> String -> String
showsPrec :: Int -> TestSetup -> String -> String
$cshow :: TestSetup -> String
show :: TestSetup -> String
$cshowList :: [TestSetup] -> String -> String
showList :: [TestSetup] -> String -> String
Show

data TestSnapshotPolicyArgs = TestSnapshotPolicyArgs
  { TestSnapshotPolicyArgs -> NumOfDiskSnapshots
tspaNum :: NumOfDiskSnapshots
  , TestSnapshotPolicyArgs -> NonZero Word64
tspaInterval :: NonZero Word64
  , TestSnapshotPolicyArgs -> SlotNo
tspaOffset :: SlotNo
  , TestSnapshotPolicyArgs -> DiffTime
tspaRateLimit :: DiffTime
  , TestSnapshotPolicyArgs -> SnapshotDelayRange
tspaDelaySnapshotRange :: SnapshotDelayRange
  }
  deriving stock Int -> TestSnapshotPolicyArgs -> String -> String
[TestSnapshotPolicyArgs] -> String -> String
TestSnapshotPolicyArgs -> String
(Int -> TestSnapshotPolicyArgs -> String -> String)
-> (TestSnapshotPolicyArgs -> String)
-> ([TestSnapshotPolicyArgs] -> String -> String)
-> Show TestSnapshotPolicyArgs
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> TestSnapshotPolicyArgs -> String -> String
showsPrec :: Int -> TestSnapshotPolicyArgs -> String -> String
$cshow :: TestSnapshotPolicyArgs -> String
show :: TestSnapshotPolicyArgs -> String
$cshowList :: [TestSnapshotPolicyArgs] -> String -> String
showList :: [TestSnapshotPolicyArgs] -> String -> String
Show

instance Arbitrary TestSnapshotPolicyArgs where
  arbitrary :: Gen TestSnapshotPolicyArgs
arbitrary = do
    tspaNum <- Word -> NumOfDiskSnapshots
NumOfDiskSnapshots (Word -> NumOfDiskSnapshots) -> Gen Word -> Gen NumOfDiskSnapshots
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word, Word) -> Gen Word
forall a. Random a => (a, a) -> Gen a
choose (Word
1, Word
10)
    tspaInterval <- choose (1, 10) `suchThatMap` nonZero
    tspaOffset <- SlotNo <$> choose (1, 20)
    tspaRateLimit <-
      frequency
        [ (2, pure 0)
        , (1, secondsToDiffTime <$> choose (1, 10))
        ]
    tspaDelaySnapshotRange <-
      oneof
        [ arbitraryDelaySnapshotRange
        , pure $ SnapshotDelayRange 0 0
        ]
    pure
      TestSnapshotPolicyArgs
        { tspaNum
        , tspaInterval
        , tspaOffset
        , tspaRateLimit
        , tspaDelaySnapshotRange
        }
   where
    arbitraryDelaySnapshotRange :: Gen SnapshotDelayRange
arbitraryDelaySnapshotRange = do
      minimumDelay <- Integer -> DiffTime
forall a. Num a => Integer -> a
fromInteger (Integer -> DiffTime) -> Gen Integer -> Gen DiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Integer, Integer) -> Gen Integer
forall a. Random a => (a, a) -> Gen a
choose (DiffTime -> Integer
forall b. Integral b => DiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor DiffTime
fiveMinutes, DiffTime -> Integer
forall b. Integral b => DiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor DiffTime
tenMinutes)
      additionalDelay <- fromInteger <$> choose (0, floor fiveMinutes)
      pure $ SnapshotDelayRange minimumDelay (minimumDelay + additionalDelay)

    fiveMinutes :: DiffTime
    fiveMinutes :: DiffTime
fiveMinutes = DiffTime
5 DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
* DiffTime
60

    tenMinutes :: DiffTime
    tenMinutes :: DiffTime
tenMinutes = DiffTime
10 DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
* DiffTime
60

-- | Add blocks to the ChainDB in this order.
tsBlocksToAdd :: TestSetup -> [TestBlock]
tsBlocksToAdd :: TestSetup -> [TestBlock]
tsBlocksToAdd TestSetup
testSetup =
  Permutation -> [TestBlock] -> [TestBlock]
forall a. Permutation -> [a] -> [a]
permute Permutation
tsPerm ([TestBlock] -> [TestBlock]) -> [TestBlock] -> [TestBlock]
forall a b. (a -> b) -> a -> b
$
    (AnchoredFragment TestBlock -> [TestBlock])
-> [AnchoredFragment TestBlock] -> [TestBlock]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap AnchoredFragment TestBlock -> [TestBlock]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst (AnchoredFragment TestBlock
tsMainChain AnchoredFragment TestBlock
-> [AnchoredFragment TestBlock] -> [AnchoredFragment TestBlock]
forall a. a -> [a] -> [a]
: [AnchoredFragment TestBlock]
tsForks)
 where
  TestSetup{AnchoredFragment TestBlock
tsMainChain :: TestSetup -> AnchoredFragment TestBlock
tsMainChain :: AnchoredFragment TestBlock
tsMainChain, [AnchoredFragment TestBlock]
tsForks :: TestSetup -> [AnchoredFragment TestBlock]
tsForks :: [AnchoredFragment TestBlock]
tsForks, Permutation
tsPerm :: TestSetup -> Permutation
tsPerm :: Permutation
tsPerm} = TestSetup
testSetup

tsSnapshotPolicyArgs :: TestSetup -> SnapshotPolicyArgs
tsSnapshotPolicyArgs :: TestSetup -> SnapshotPolicyArgs
tsSnapshotPolicyArgs TestSetup{TestSnapshotPolicyArgs
tsTestSnapshotPolicyArgs :: TestSetup -> TestSnapshotPolicyArgs
tsTestSnapshotPolicyArgs :: TestSnapshotPolicyArgs
tsTestSnapshotPolicyArgs} =
  SnapshotPolicyArgs
    { SnapshotFrequency
spaFrequency :: SnapshotFrequency
spaFrequency :: SnapshotFrequency
spaFrequency
    , spaNum :: OverrideOrDefault NumOfDiskSnapshots
spaNum = NumOfDiskSnapshots -> OverrideOrDefault NumOfDiskSnapshots
forall a. a -> OverrideOrDefault a
Override (NumOfDiskSnapshots -> OverrideOrDefault NumOfDiskSnapshots)
-> NumOfDiskSnapshots -> OverrideOrDefault NumOfDiskSnapshots
forall a b. (a -> b) -> a -> b
$ TestSnapshotPolicyArgs -> NumOfDiskSnapshots
tspaNum TestSnapshotPolicyArgs
tsTestSnapshotPolicyArgs
    }
 where
  spaFrequency :: SnapshotFrequency
spaFrequency =
    SnapshotFrequencyArgs -> SnapshotFrequency
SnapshotFrequency
      SnapshotFrequencyArgs
        { sfaInterval :: OverrideOrDefault (NonZero Word64)
sfaInterval = NonZero Word64 -> OverrideOrDefault (NonZero Word64)
forall a. a -> OverrideOrDefault a
Override (NonZero Word64 -> OverrideOrDefault (NonZero Word64))
-> NonZero Word64 -> OverrideOrDefault (NonZero Word64)
forall a b. (a -> b) -> a -> b
$ TestSnapshotPolicyArgs -> NonZero Word64
tspaInterval TestSnapshotPolicyArgs
tsTestSnapshotPolicyArgs
        , sfaOffset :: OverrideOrDefault SlotNo
sfaOffset = SlotNo -> OverrideOrDefault SlotNo
forall a. a -> OverrideOrDefault a
Override (SlotNo -> OverrideOrDefault SlotNo)
-> SlotNo -> OverrideOrDefault SlotNo
forall a b. (a -> b) -> a -> b
$ TestSnapshotPolicyArgs -> SlotNo
tspaOffset TestSnapshotPolicyArgs
tsTestSnapshotPolicyArgs
        , sfaRateLimit :: OverrideOrDefault DiffTime
sfaRateLimit = DiffTime -> OverrideOrDefault DiffTime
forall a. a -> OverrideOrDefault a
Override (DiffTime -> OverrideOrDefault DiffTime)
-> DiffTime -> OverrideOrDefault DiffTime
forall a b. (a -> b) -> a -> b
$ TestSnapshotPolicyArgs -> DiffTime
tspaRateLimit TestSnapshotPolicyArgs
tsTestSnapshotPolicyArgs
        , sfaDelaySnapshotRange :: OverrideOrDefault SnapshotDelayRange
sfaDelaySnapshotRange = SnapshotDelayRange -> OverrideOrDefault SnapshotDelayRange
forall a. a -> OverrideOrDefault a
Override (SnapshotDelayRange -> OverrideOrDefault SnapshotDelayRange)
-> SnapshotDelayRange -> OverrideOrDefault SnapshotDelayRange
forall a b. (a -> b) -> a -> b
$ TestSnapshotPolicyArgs -> SnapshotDelayRange
tspaDelaySnapshotRange TestSnapshotPolicyArgs
tsTestSnapshotPolicyArgs
        }

instance Arbitrary TestSetup where
  arbitrary :: Gen TestSetup
arbitrary = do
    k <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
6)
    let
      -- Generate an anchored fragment of the given length starting from the
      -- given block, with random slot gaps.
      genChain ::
        Int -> -- Length of the chain
        Word64 -> -- Fork number
        Anchor TestBlock ->
        Gen (AnchoredFragment TestBlock)
      genChain Int
len Word64
forkNo Anchor TestBlock
anchor =
        Int
-> AnchoredFragment TestBlock -> Gen (AnchoredFragment TestBlock)
go Int
0 (Anchor TestBlock -> AnchoredFragment TestBlock
forall v a b. Anchorable v a b => a -> AnchoredSeq v a b
AF.Empty Anchor TestBlock
anchor)
       where
        go :: Int
-> AnchoredFragment TestBlock -> Gen (AnchoredFragment TestBlock)
go Int
n AnchoredFragment TestBlock
acc
          | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
len = AnchoredFragment TestBlock -> Gen (AnchoredFragment TestBlock)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AnchoredFragment TestBlock
acc
          | Bool
otherwise = do
              slotOffset <- Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Gen Word64 -> Gen SlotNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
1, Word64
10)
              let blk = (Word64 -> Word64) -> TestBlock -> TestBlock
modifyFork (\Word64
_ -> Word64
forkNo) (TestBlock -> TestBlock) -> TestBlock -> TestBlock
forall a b. (a -> b) -> a -> b
$
                    (\TestBlock
b -> TestBlock
b{tbSlot = tbSlot b + slotOffset}) (TestBlock -> TestBlock) -> TestBlock -> TestBlock
forall a b. (a -> b) -> a -> b
$
                      case AnchoredFragment TestBlock -> Point TestBlock
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint AnchoredFragment TestBlock
acc of
                        Point TestBlock
GenesisPoint -> Word64 -> TestBlock
firstBlock Word64
forkNo
                        BlockPoint SlotNo
slot HeaderHash TestBlock
hash ->
                          (TestHash -> SlotNo -> () -> TestBlock
forall ptype. TestHash -> SlotNo -> ptype -> TestBlockWith ptype
successorBlockWithPayload HeaderHash TestBlock
TestHash
hash SlotNo
slot ())
              go (n + 1) (acc AF.:> blk)

    immutableLength <- choose (0, 20)
    tsMainChain <- genChain (immutableLength + k) 0 AF.AnchorGenesis
    let immChain = Int -> AnchoredFragment TestBlock -> AnchoredFragment TestBlock
forall v a b.
Anchorable v a b =>
Int -> AnchoredSeq v a b -> AnchoredSeq v a b
AF.dropNewest Int
k AnchoredFragment TestBlock
tsMainChain
        immAnchors = AnchoredFragment TestBlock -> Anchor TestBlock
forall v a b. AnchoredSeq v a b -> a
AF.anchor AnchoredFragment TestBlock
immChain Anchor TestBlock -> [Anchor TestBlock] -> [Anchor TestBlock]
forall a. a -> [a] -> [a]
: (TestBlock -> Anchor TestBlock
forall block. HasHeader block => block -> Anchor block
AF.anchorFromBlock (TestBlock -> Anchor TestBlock)
-> [TestBlock] -> [Anchor TestBlock]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnchoredFragment TestBlock -> [TestBlock]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst AnchoredFragment TestBlock
immChain)
    numForks <- choose (0, 5)
    forkAnchors <- replicateM numForks $ elements immAnchors
    tsForks <- for ([1 ..] `zip` forkAnchors) $ \(Word64
forkNo, Anchor TestBlock
forkAnchor) -> do
      forkLength <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
k)
      genChain forkLength forkNo forkAnchor

    tsPerm <- arbitrary
    tsTestSnapshotPolicyArgs <- arbitrary
    pure
      TestSetup
        { tsSecParam = SecurityParam $ unsafeNonZero $ fromIntegral k
        , tsMainChain
        , tsForks
        , tsPerm
        , tsTestSnapshotPolicyArgs
        }

  shrink :: TestSetup -> [TestSetup]
shrink testSetup :: TestSetup
testSetup@TestSetup{SecurityParam
tsSecParam :: TestSetup -> SecurityParam
tsSecParam :: SecurityParam
tsSecParam, AnchoredFragment TestBlock
tsMainChain :: TestSetup -> AnchoredFragment TestBlock
tsMainChain :: AnchoredFragment TestBlock
tsMainChain, [AnchoredFragment TestBlock]
tsForks :: TestSetup -> [AnchoredFragment TestBlock]
tsForks :: [AnchoredFragment TestBlock]
tsForks} =
    [ TestSetup
testSetup
        { tsMainChain = tsMainChain'
        , tsForks = filter isStillAnchoredOnImmChain tsForks
        }
    | AnchoredFragment TestBlock
tsMainChain' <- [Int -> AnchoredFragment TestBlock -> AnchoredFragment TestBlock
forall v a b.
Anchorable v a b =>
Int -> AnchoredSeq v a b -> AnchoredSeq v a b
AF.dropNewest Int
1 AnchoredFragment TestBlock
tsMainChain | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ AnchoredFragment TestBlock -> Bool
forall v a b. AnchoredSeq v a b -> Bool
AF.null AnchoredFragment TestBlock
tsMainChain]
    , let k :: Word64
k = NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero (NonZero Word64 -> Word64) -> NonZero Word64 -> Word64
forall a b. (a -> b) -> a -> b
$ SecurityParam -> NonZero Word64
maxRollbacks SecurityParam
tsSecParam
          immChain' :: AnchoredFragment TestBlock
immChain' = Int -> AnchoredFragment TestBlock -> AnchoredFragment TestBlock
forall v a b.
Anchorable v a b =>
Int -> AnchoredSeq v a b -> AnchoredSeq v a b
AF.dropNewest (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
k) AnchoredFragment TestBlock
tsMainChain'
          isStillAnchoredOnImmChain :: AnchoredFragment TestBlock -> Bool
isStillAnchoredOnImmChain AnchoredFragment TestBlock
f =
            Point TestBlock -> AnchoredFragment TestBlock -> Bool
forall block.
HasHeader block =>
Point block -> AnchoredFragment block -> Bool
AF.withinFragmentBounds (AnchoredFragment TestBlock -> Point TestBlock
forall block. AnchoredFragment block -> Point block
AF.anchorPoint AnchoredFragment TestBlock
f) AnchoredFragment TestBlock
immChain'
    ]

{-------------------------------------------------------------------------------
  Run test
-------------------------------------------------------------------------------}

data TestOutcome = TestOutcome
  { TestOutcome -> Anchor TestBlock
toutImmutableTip :: Anchor TestBlock
  , TestOutcome -> [(Time, TraceEvent TestBlock)]
toutTrace :: [(Time, ChainDB.TraceEvent TestBlock)]
  , TestOutcome -> [DiskSnapshot]
toutFinalSnapshots :: [DiskSnapshot]
  }
  deriving stock Int -> TestOutcome -> String -> String
[TestOutcome] -> String -> String
TestOutcome -> String
(Int -> TestOutcome -> String -> String)
-> (TestOutcome -> String)
-> ([TestOutcome] -> String -> String)
-> Show TestOutcome
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> TestOutcome -> String -> String
showsPrec :: Int -> TestOutcome -> String -> String
$cshow :: TestOutcome -> String
show :: TestOutcome -> String
$cshowList :: [TestOutcome] -> String -> String
showList :: [TestOutcome] -> String -> String
Show

runTest ::
  forall m.
  IOLike m =>
  LedgerDbBackendArgs m TestBlock ->
  TestSetup ->
  m TestOutcome
runTest :: forall (m :: * -> *).
IOLike m =>
LedgerDbBackendArgs m TestBlock -> TestSetup -> m TestOutcome
runTest LedgerDbBackendArgs m TestBlock
lgrDbBackendArgs TestSetup
testSetup = (ResourceRegistry m -> m TestOutcome) -> m TestOutcome
forall (m :: * -> *) a.
(MonadSTM m, MonadMask m, MonadThread m, HasCallStack) =>
(ResourceRegistry m -> m a) -> m a
withRegistry \ResourceRegistry m
registry -> do
  (withTime -> tracer, getTrace) <- m (Tracer m (Time, TraceEvent TestBlock),
   m [(Time, TraceEvent TestBlock)])
forall (m :: * -> *) ev. MonadSTM m => m (Tracer m ev, m [ev])
recordingTracerTVar

  isSnapshottingTMVar :: StrictTMVar m () <- newEmptyTMVarIO

  (chainDB, lgrHasFS) <- openChainDB registry (tracer <> isSnapshottingTracer isSnapshottingTMVar)

  for_ (tsBlocksToAdd testSetup) \TestBlock
blk -> do
    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 TestBlock
blk
    DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1
    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
$ StrictTMVar m () -> STM m Bool
forall (m :: * -> *) a. MonadSTM m => StrictTMVar m a -> STM m Bool
isEmptyTMVar StrictTMVar m ()
isSnapshottingTMVar STM m Bool -> (Bool -> STM m ()) -> STM m ()
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> STM m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard

  toutImmutableTip <-
    AF.castAnchor . AF.anchor <$> atomically (ChainDB.getCurrentChain chainDB)
  toutTrace <- getTrace
  toutFinalSnapshots <- LedgerDB.defaultListSnapshots lgrHasFS
  pure
    TestOutcome
      { toutImmutableTip
      , toutTrace
      , toutFinalSnapshots
      }
 where
  openChainDB ::
    ResourceRegistry m ->
    Tracer m (ChainDB.TraceEvent TestBlock) ->
    m (ChainDB m TestBlock, SomeHasFS m)
  openChainDB :: ResourceRegistry m
-> Tracer m (TraceEvent TestBlock)
-> m (ChainDB m TestBlock, SomeHasFS m)
openChainDB ResourceRegistry m
registry Tracer m (TraceEvent TestBlock)
cdbTracer = do
    chainDbArgs <- do
      mcdbNodeDBs <- m (NodeDBs (StrictTMVar m MockFS))
forall (m :: * -> *).
MonadSTM m =>
m (NodeDBs (StrictTMVar m MockFS))
emptyNodeDBs
      let mcdbTopLevelConfig = SecurityParam -> TopLevelConfig TestBlock
singleNodeTestConfigWithK (TestSetup -> SecurityParam
tsSecParam TestSetup
testSetup)
          cdbArgs =
            MinimalChainDbArgs m TestBlock -> ChainDbArgs Identity m TestBlock
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk,
 LedgerSupportsLedgerDB blk) =>
MinimalChainDbArgs m blk -> Complete ChainDbArgs m blk
fromMinimalChainDbArgs
              MinimalChainDbArgs
                { TopLevelConfig TestBlock
mcdbTopLevelConfig :: TopLevelConfig TestBlock
mcdbTopLevelConfig :: TopLevelConfig TestBlock
mcdbTopLevelConfig
                , NodeDBs (StrictTMVar m MockFS)
mcdbNodeDBs :: NodeDBs (StrictTMVar m MockFS)
mcdbNodeDBs :: NodeDBs (StrictTMVar m MockFS)
mcdbNodeDBs
                , 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
                }
          updLgrDbArgs ChainDbArgs f m TestBlock
a =
            ChainDbArgs f m TestBlock
a
              { ChainDB.cdbLgrDbArgs =
                  (ChainDB.cdbLgrDbArgs a)
                    { LedgerDB.lgrBackendArgs = lgrDbBackendArgs
                    , LedgerDB.lgrSnapshotPolicyArgs = tsSnapshotPolicyArgs testSetup
                    }
              }
      pure $ updLgrDbArgs $ ChainDB.updateTracer cdbTracer cdbArgs
    (_, chainDB) <-
      allocate
        registry
        (\ResourceId
_ -> ChainDbArgs Identity m TestBlock -> m (ChainDB m TestBlock)
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk, LedgerSupportsPeras blk,
 BlockSupportsDiffusionPipelining blk, InspectLedger blk,
 HasHardForkHistory blk, ConvertRawHash blk,
 SerialiseDiskConstraints blk, LedgerSupportsLedgerDB blk) =>
Complete ChainDbArgs m blk -> m (ChainDB m blk)
ChainDB.openDB ChainDbArgs Identity m TestBlock
chainDbArgs)
        (ChainDB.closeDB)
    pure (chainDB, LedgerDB.lgrHasFS . ChainDB.cdbLgrDbArgs $ chainDbArgs)

  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

  isSnapshottingTracer :: StrictTMVar m () -> Tracer m (ChainDB.TraceEvent TestBlock)
  isSnapshottingTracer :: StrictTMVar m () -> Tracer m (TraceEvent TestBlock)
isSnapshottingTracer StrictTMVar m ()
tmvar = (TraceEvent TestBlock -> m ()) -> Tracer m (TraceEvent TestBlock)
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer \case
    ChainDB.TraceLedgerDBEvent (LedgerDB.LedgerDBSnapshotEvent (SnapshotRequestDelayed Time
_ DiffTime
_ NonEmpty SlotNo
_)) ->
      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
$ StrictTMVar m () -> () -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTMVar m a -> a -> STM m ()
putTMVar StrictTMVar m ()
tmvar ()
    ChainDB.TraceLedgerDBEvent (LedgerDB.LedgerDBSnapshotEvent TraceSnapshotEvent TestBlock
SnapshotRequestCompleted) ->
      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
$ StrictTMVar m () -> STM m ()
forall (m :: * -> *) a. MonadSTM m => StrictTMVar m a -> STM m a
takeTMVar StrictTMVar m ()
tmvar
    TraceEvent TestBlock
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

{-------------------------------------------------------------------------------
  Assess a test outcome
-------------------------------------------------------------------------------}

checkTestOutcome :: TestSetup -> TestOutcome -> Property
checkTestOutcome :: TestSetup -> TestOutcome -> Property
checkTestOutcome TestSetup
testSetup TestOutcome
testOutcome =
  Property -> Property
withLabelling (Property -> Property)
-> (Property -> Property) -> Property -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Property -> Property
withTrace (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
      [ String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"Unexpected immutable tip" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          Anchor TestBlock
toutImmutableTip Anchor TestBlock -> Anchor TestBlock -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== AnchoredFragment TestBlock -> Anchor TestBlock
forall v a b. Anchorable v a b => AnchoredSeq v a b -> a
AF.headAnchor AnchoredFragment TestBlock
immChain
      , String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"Snapshots not strictly increasing" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          [SlotNo] -> Property
forall a. (Show a, Ord a) => [a] -> Property
strictlyIncreasing ((Time, SlotNo) -> SlotNo
forall a b. (a, b) -> b
snd ((Time, SlotNo) -> SlotNo) -> [(Time, SlotNo)] -> [SlotNo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Time, SlotNo)]
actualSnapshots)
      , String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Unexpected number of on-disk snapshots " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [DiskSnapshot] -> String
forall a. Show a => a -> String
show [DiskSnapshot]
toutFinalSnapshots) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          [DiskSnapshot] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DiskSnapshot]
toutFinalSnapshots
            Int -> Int -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Int -> Int -> Int
forall a. Ord a => a -> a -> a
min ([(Time, SlotNo)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Time, SlotNo)]
actualSnapshots) (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Int)
-> (NumOfDiskSnapshots -> Word) -> NumOfDiskSnapshots -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NumOfDiskSnapshots -> Word
getNumOfDiskSnapshots (NumOfDiskSnapshots -> Int) -> NumOfDiskSnapshots -> Int
forall a b. (a -> b) -> a -> b
$ NumOfDiskSnapshots
tspaNum)
      , String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Rate limit not respected...") (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
            [ String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"...between " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SlotNo -> String
forall a. Condense a => a -> String
condense SlotNo
pt1 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" and " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SlotNo -> String
forall a. Condense a => a -> String
condense SlotNo
pt2) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
                DiffTime
tspaRateLimit DiffTime -> DiffTime -> Property
forall a. (Ord a, Show a) => a -> a -> Property
`le` Time -> Time -> DiffTime
diffTime Time
t2 Time
t1
            | ((Time
t1, SlotNo
pt1), (Time
t2, SlotNo
pt2)) <- [(Time, SlotNo)]
actualSnapshots [(Time, SlotNo)]
-> [(Time, SlotNo)] -> [((Time, SlotNo), (Time, SlotNo))]
forall a b. [a] -> [b] -> [(a, b)]
`zip` Int -> [(Time, SlotNo)] -> [(Time, SlotNo)]
forall a. Int -> [a] -> [a]
drop Int
1 [(Time, SlotNo)]
actualSnapshots
            ]
      , String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"Unexpected snapshots performed" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Policy: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TestSnapshotPolicyArgs -> String
forall a. Show a => a -> String
show TestSnapshotPolicyArgs
policyArgs) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ do
            let actual :: Set SlotNo
actual = [SlotNo] -> Set SlotNo
forall a. Ord a => [a] -> Set a
Set.fromList ((Time, SlotNo) -> SlotNo
forall a b. (a, b) -> b
snd ((Time, SlotNo) -> SlotNo) -> [(Time, SlotNo)] -> [SlotNo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Time, SlotNo)]
actualSnapshots)
                expect :: Set SlotNo
expect = [SlotNo] -> Set SlotNo
forall a. Ord a => [a] -> Set a
Set.fromList [SlotNo]
expectedSnapshots
            String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Not expected: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Set SlotNo -> String
forall a. Condense a => a -> String
condense (Set SlotNo
actual Set SlotNo -> Set SlotNo -> Set SlotNo
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set SlotNo
expect)) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
              if DiffTime
tspaRateLimit DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
<= DiffTime
0
                then
                  String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Expected, but missing: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Set SlotNo -> String
forall a. Condense a => a -> String
condense (Set SlotNo
expect Set SlotNo -> Set SlotNo -> Set SlotNo
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set SlotNo
actual)) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
                    Set SlotNo
actual Set SlotNo -> Set SlotNo -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Set SlotNo
expect
                else
                  Bool -> Property
forall prop. Testable prop => prop -> Property
property (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$ Set SlotNo
actual Set SlotNo -> Set SlotNo -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set SlotNo
expect
      ]
 where
  TestSetup
    { tsSecParam :: TestSetup -> SecurityParam
tsSecParam = NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero (NonZero Word64 -> Word64)
-> (SecurityParam -> NonZero Word64) -> SecurityParam -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SecurityParam -> NonZero Word64
maxRollbacks -> Word64
k
    , AnchoredFragment TestBlock
tsMainChain :: TestSetup -> AnchoredFragment TestBlock
tsMainChain :: AnchoredFragment TestBlock
tsMainChain
    , tsTestSnapshotPolicyArgs :: TestSetup -> TestSnapshotPolicyArgs
tsTestSnapshotPolicyArgs =
      policyArgs :: TestSnapshotPolicyArgs
policyArgs@TestSnapshotPolicyArgs
        { NumOfDiskSnapshots
tspaNum :: TestSnapshotPolicyArgs -> NumOfDiskSnapshots
tspaNum :: NumOfDiskSnapshots
tspaNum
        , NonZero Word64
tspaInterval :: TestSnapshotPolicyArgs -> NonZero Word64
tspaInterval :: NonZero Word64
tspaInterval
        , SlotNo
tspaOffset :: TestSnapshotPolicyArgs -> SlotNo
tspaOffset :: SlotNo
tspaOffset
        , DiffTime
tspaRateLimit :: TestSnapshotPolicyArgs -> DiffTime
tspaRateLimit :: DiffTime
tspaRateLimit
        }
    } = TestSetup
testSetup

  immChain :: AnchoredFragment TestBlock
immChain = Int -> AnchoredFragment TestBlock -> AnchoredFragment TestBlock
forall v a b.
Anchorable v a b =>
Int -> AnchoredSeq v a b -> AnchoredSeq v a b
AF.dropNewest (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
k) AnchoredFragment TestBlock
tsMainChain

  ppTrace :: (a, a) -> String
ppTrace (a
time, a
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
<> a -> String
forall a. Show a => a -> String
show a
ev

  isTookSnapshot :: ChainDB.TraceEvent blk -> Maybe SlotNo
  isTookSnapshot :: forall blk. TraceEvent blk -> Maybe SlotNo
isTookSnapshot = \case
    ChainDB.TraceLedgerDBEvent
      ( LedgerDB.LedgerDBSnapshotEvent
          (LedgerDB.TookSnapshot DiskSnapshot
_ RealPoint blk
pt FallingEdgeWith{})
        ) -> SlotNo -> Maybe SlotNo
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SlotNo -> Maybe SlotNo) -> SlotNo -> Maybe SlotNo
forall a b. (a -> b) -> a -> b
$ RealPoint blk -> SlotNo
forall blk. RealPoint blk -> SlotNo
realPointSlot RealPoint blk
pt
    TraceEvent blk
_ -> Maybe SlotNo
forall a. Maybe a
Nothing

  TestOutcome
    { Anchor TestBlock
toutImmutableTip :: TestOutcome -> Anchor TestBlock
toutImmutableTip :: Anchor TestBlock
toutImmutableTip
    , [(Time, TraceEvent TestBlock)]
toutTrace :: TestOutcome -> [(Time, TraceEvent TestBlock)]
toutTrace :: [(Time, TraceEvent TestBlock)]
toutTrace
    , [DiskSnapshot]
toutFinalSnapshots :: TestOutcome -> [DiskSnapshot]
toutFinalSnapshots :: [DiskSnapshot]
toutFinalSnapshots
    } = TestOutcome
testOutcome

  actualSnapshots :: [(Time, SlotNo)]
  actualSnapshots :: [(Time, SlotNo)]
actualSnapshots = ((Time, TraceEvent TestBlock) -> Maybe (Time, SlotNo))
-> [(Time, TraceEvent TestBlock)] -> [(Time, SlotNo)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((TraceEvent TestBlock -> Maybe SlotNo)
-> (Time, TraceEvent TestBlock) -> Maybe (Time, SlotNo)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> (Time, a) -> f (Time, b)
traverse TraceEvent TestBlock -> Maybe SlotNo
forall blk. TraceEvent blk -> Maybe SlotNo
isTookSnapshot) [(Time, TraceEvent TestBlock)]
toutTrace

  -- Group on @(s1 - offset) / interval@ and take the last entry from each group
  -- (apart from the last one).
  expectedSnapshots :: [SlotNo]
  expectedSnapshots :: [SlotNo]
expectedSnapshots =
    (NonEmpty SlotNo -> SlotNo) -> [NonEmpty SlotNo] -> [SlotNo]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty SlotNo -> SlotNo
forall a. NonEmpty a -> a
NE.last
      -- For the last group, it is not yet necessarily clear what the last
      -- immutable block will be. (If there is a block in the last slot of a
      -- group, ie the predecessor of @offset + n * interval@ for some @n@,
      -- there can't be, but it doesn't seem important to handle this case in a
      -- special way.)
      ([NonEmpty SlotNo] -> [SlotNo])
-> (AnchoredFragment TestBlock -> [NonEmpty SlotNo])
-> AnchoredFragment TestBlock
-> [SlotNo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> [NonEmpty SlotNo] -> [NonEmpty SlotNo]
forall a. Word64 -> [a] -> [a]
dropLast Word64
1
      ([NonEmpty SlotNo] -> [NonEmpty SlotNo])
-> (AnchoredFragment TestBlock -> [NonEmpty SlotNo])
-> AnchoredFragment TestBlock
-> [NonEmpty SlotNo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SlotNo -> Maybe Word64) -> [SlotNo] -> [NonEmpty SlotNo]
forall (f :: * -> *) b a.
(Foldable f, Eq b) =>
(a -> b) -> f a -> [NonEmpty a]
NE.groupWith SlotNo -> Maybe Word64
snapshotGroup
      ([SlotNo] -> [NonEmpty SlotNo])
-> (AnchoredFragment TestBlock -> [SlotNo])
-> AnchoredFragment TestBlock
-> [NonEmpty SlotNo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TestBlock -> SlotNo) -> [TestBlock] -> [SlotNo]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TestBlock -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot
      ([TestBlock] -> [SlotNo])
-> (AnchoredFragment TestBlock -> [TestBlock])
-> AnchoredFragment TestBlock
-> [SlotNo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredFragment TestBlock -> [TestBlock]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst
      (AnchoredFragment TestBlock -> [SlotNo])
-> AnchoredFragment TestBlock -> [SlotNo]
forall a b. (a -> b) -> a -> b
$ AnchoredFragment TestBlock
immChain
   where
    snapshotGroup :: SlotNo -> Maybe Word64
snapshotGroup SlotNo
s1
      | SlotNo
s1 SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo
tspaOffset = Maybe Word64
forall a. Maybe a
Nothing
      | Bool
otherwise = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just (Word64 -> Maybe Word64) -> Word64 -> Maybe Word64
forall a b. (a -> b) -> a -> b
$ SlotNo -> Word64
unSlotNo (SlotNo
s1 SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
- SlotNo
tspaOffset) Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`div` NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero NonZero Word64
tspaInterval

  withTrace :: Property -> Property
withTrace =
    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, TraceEvent TestBlock) -> String
forall {a} {a}. (Show a, Show a) => (a, a) -> String
ppTrace ((Time, TraceEvent TestBlock) -> String)
-> [(Time, TraceEvent TestBlock)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Time, TraceEvent TestBlock)]
toutTrace))
      (Property -> Property)
-> (Property -> Property) -> Property -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Actual snapshots: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [(Time, SlotNo)] -> String
forall a. Condense a => a -> String
condense [(Time, SlotNo)]
actualSnapshots)
      (Property -> Property)
-> (Property -> Property) -> Property -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Actual immutable tip: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Point TestBlock -> String
forall a. Condense a => a -> String
condense (Anchor TestBlock -> Point TestBlock
forall block. Anchor block -> Point block
AF.anchorToPoint Anchor TestBlock
toutImmutableTip))
      (Property -> Property)
-> (Property -> Property) -> Property -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Immutable chain: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> AnchoredFragment TestBlock -> String
forall a. Condense a => a -> String
condense AnchoredFragment TestBlock
immChain)

  withLabelling :: Property -> Property
withLabelling =
    String -> [String] -> Property -> Property
forall prop.
Testable prop =>
String -> [String] -> prop -> Property
tabulate String
"# actual snapshots" [Int -> String
forall a. Show a => a -> String
show ([(Time, SlotNo)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Time, SlotNo)]
actualSnapshots)]
      (Property -> Property)
-> (Property -> Property) -> Property -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> Property -> Property
forall prop.
Testable prop =>
String -> [String] -> prop -> Property
tabulate String
"length of immutable chain" [WithOrigin BlockNo -> String
forall a. Show a => a -> String
show (Anchor TestBlock -> WithOrigin BlockNo
forall block. Anchor block -> WithOrigin BlockNo
AF.anchorToBlockNo Anchor TestBlock
toutImmutableTip)]