{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- | Db changelog ledger DB tests.
--
-- The in-memory component of the ledger DB is a bit tricky: it stores only a
-- few snapshots of the ledger state, in order to reduce memory footprint, but
-- must nonetheless be able to construct any ledger state (within @k@ blocks
-- from the chain tip) efficiently. The properties we are verify here are
-- various invariants of this data type, things such as
--
-- * Rolling back and then reapplying the same blocks is an identity operation
--   (provided the rollback is not too far)
-- * The shape of the datatype (where we store snapshots and how many we store)
--   always matches the policy set by the user, and is invariant under any of
--   the operations (add a block, switch to a fork, etc.)
-- * The maximum rollback supported is always @k@ (unless we are near genesis)
-- * etc.
module Test.Ouroboros.Storage.LedgerDB.V1.DbChangelog (tests) where

import Cardano.Ledger.BaseTypes (NonZero (..), unsafeNonZero)
import Cardano.Slotting.Slot (WithOrigin (..))
import Control.Monad hiding (ap)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State.Strict hiding (state)
import Data.Foldable
import qualified Data.Map.Diff.Strict.Internal as Diff
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (catMaybes, fromJust, isJust, isNothing)
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Word
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks)
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.BlockchainTime
import Ouroboros.Consensus.Config
import qualified Ouroboros.Consensus.HardFork.History as HardFork
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Storage.LedgerDB.API
import Ouroboros.Consensus.Storage.LedgerDB.V1.DbChangelog hiding
  ( tip
  )
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.DbChangelog as DbChangelog
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.DiffSeq as DS
import Ouroboros.Consensus.Util
import Ouroboros.Consensus.Util.IndexedMemPack
import qualified Ouroboros.Network.AnchoredSeq as AS
import Ouroboros.Network.Block (Point (..))
import qualified Ouroboros.Network.Point as Point
import Test.QuickCheck
import Test.Tasty
import Test.Tasty.QuickCheck hiding (elements)
import Test.Util.Orphans.Arbitrary ()
import Test.Util.QuickCheck
import qualified Test.Util.TestBlock as TestBlock
import Text.Show.Pretty (ppShow)

samples :: Int
samples :: Int
samples = Int
1000

tests :: TestTree
tests :: TestTree
tests =
  TestName -> [TestTree] -> TestTree
testGroup
    TestName
"DbChangelog"
    [ TestName -> [TestTree] -> TestTree
testGroup
        TestName
"Genesis"
        [ TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"current" Property
prop_genesisCurrent
        ]
    , TestName -> [TestTree] -> TestTree
testGroup
        TestName
"Push"
        [ TestName -> (ChainSetup -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"expectedLedger" ChainSetup -> Property
prop_pushExpectedLedger
        , TestName -> (ChainSetup -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"pastLedger" ChainSetup -> Property
prop_pastLedger
        ]
    , TestName -> [TestTree] -> TestTree
testGroup
        TestName
"Rollback"
        [ TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"maxRollbackGenesisZero" Property
prop_maxRollbackGenesisZero
        , TestName -> (ChainSetup -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"ledgerDbMaxRollback" ChainSetup -> Property
prop_snapshotsMaxRollback
        , TestName -> (SwitchSetup -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"switchSameChain" SwitchSetup -> Property
prop_switchSameChain
        , TestName -> (SwitchSetup -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"switchExpectedLedger" SwitchSetup -> Property
prop_switchExpectedLedger
        , TestName -> (SwitchSetup -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"pastAfterSwitch" SwitchSetup -> Property
prop_pastAfterSwitch
        ]
    , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"flushing" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
        Int -> Property -> Property
forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
samples (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
            [ TestName -> (DbChangelogTestSetup -> Property) -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample
                TestName
"flushing keeps immutable tip"
                DbChangelogTestSetup -> Property
prop_flushingSplitsTheChangelog
            ]
    , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"rolling back" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
        Int -> Property -> Property
forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
samples (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
            [ TestName
-> (DbChangelogTestSetup -> Positive Int -> Property) -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample
                TestName
"rollback after extension is noop"
                DbChangelogTestSetup -> Positive Int -> Property
prop_rollbackAfterExtendIsNoop
            , TestName -> (DbChangelogTestSetup -> Property) -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample
                TestName
"prefixing back to anchor is rolling back volatile states"
                DbChangelogTestSetup -> Property
prop_rollbackToAnchorIsRollingBackVolatileStates
            , TestName
-> (Positive Int -> DbChangelogTestSetup -> Property) -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample
                TestName
"prefix back to volatile tip is a noop"
                Positive Int -> DbChangelogTestSetup -> Property
prop_rollBackToVolatileTipIsNoop
            ]
    , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"extending adds head to volatile states" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
        Int -> (DbChangelogTestSetup -> Property) -> Property
forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
samples DbChangelogTestSetup -> Property
prop_extendingAdvancesTipOfVolatileStates
    , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"pruning leaves at most maxRollback volatile states" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
        Int
-> (DbChangelogTestSetup -> SecurityParam -> Property) -> Property
forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
samples DbChangelogTestSetup -> SecurityParam -> Property
prop_pruningLeavesAtMostMaxRollbacksVolatileStates
    ]

{-------------------------------------------------------------------------------
  Genesis
-------------------------------------------------------------------------------}

prop_genesisCurrent :: Property
prop_genesisCurrent :: Property
prop_genesisCurrent =
  DbChangelog (LedgerState TestBlock)
-> LedgerState TestBlock EmptyMK
forall (l :: MapKind -> *). GetTip l => DbChangelog l -> l EmptyMK
current DbChangelog (LedgerState TestBlock)
genSnaps LedgerState TestBlock EmptyMK
-> LedgerState TestBlock EmptyMK -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== LedgerState TestBlock ValuesMK -> LedgerState TestBlock EmptyMK
forall (mk :: MapKind) (mk' :: MapKind).
LedgerState TestBlock mk -> LedgerState TestBlock mk'
forall (l :: MapKind -> *) (mk :: MapKind) (mk' :: MapKind).
LedgerTablesAreTrivial l =>
l mk -> l mk'
convertMapKind LedgerState TestBlock ValuesMK
TestBlock.testInitLedger
 where
  genSnaps :: DbChangelog (LedgerState TestBlock)
genSnaps = LedgerState TestBlock EmptyMK
-> DbChangelog (LedgerState TestBlock)
forall (l :: MapKind -> *).
(HasLedgerTables l, GetTip l) =>
l EmptyMK -> DbChangelog l
empty (LedgerState TestBlock ValuesMK -> LedgerState TestBlock EmptyMK
forall (mk :: MapKind) (mk' :: MapKind).
LedgerState TestBlock mk -> LedgerState TestBlock mk'
forall (l :: MapKind -> *) (mk :: MapKind) (mk' :: MapKind).
LedgerTablesAreTrivial l =>
l mk -> l mk'
convertMapKind LedgerState TestBlock ValuesMK
TestBlock.testInitLedger)

{-------------------------------------------------------------------------------
  Constructing snapshots
-------------------------------------------------------------------------------}

prop_pushExpectedLedger :: ChainSetup -> Property
prop_pushExpectedLedger :: ChainSetup -> Property
prop_pushExpectedLedger setup :: ChainSetup
setup@ChainSetup{[TestBlock]
Word64
SecurityParam
DbChangelog (LedgerState TestBlock)
csSecParam :: SecurityParam
csNumBlocks :: Word64
csPrefixLen :: Word64
csGenSnaps :: DbChangelog (LedgerState TestBlock)
csChain :: [TestBlock]
csPushed :: DbChangelog (LedgerState TestBlock)
csPushed :: ChainSetup -> DbChangelog (LedgerState TestBlock)
csChain :: ChainSetup -> [TestBlock]
csGenSnaps :: ChainSetup -> DbChangelog (LedgerState TestBlock)
csPrefixLen :: ChainSetup -> Word64
csNumBlocks :: ChainSetup -> Word64
csSecParam :: ChainSetup -> SecurityParam
..} =
  Bool -> TestName -> Property -> Property
forall prop. Testable prop => Bool -> TestName -> prop -> Property
classify (ChainSetup -> Bool
chainSetupSaturated ChainSetup
setup) TestName
"saturated" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
      [ LedgerState TestBlock EmptyMK
l
          LedgerState TestBlock EmptyMK
-> LedgerState TestBlock EmptyMK -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== LedgerState TestBlock ValuesMK -> LedgerState TestBlock EmptyMK
forall (mk :: MapKind) (mk' :: MapKind).
LedgerState TestBlock mk -> LedgerState TestBlock mk'
forall (l :: MapKind -> *) (mk :: MapKind) (mk' :: MapKind).
LedgerTablesAreTrivial l =>
l mk -> l mk'
convertMapKind
            (ComputeLedgerEvents
-> LedgerCfg (LedgerState TestBlock)
-> [TestBlock]
-> LedgerState TestBlock ValuesMK
-> LedgerState TestBlock ValuesMK
forall (l :: MapKind -> *) blk.
ApplyBlock l blk =>
ComputeLedgerEvents
-> LedgerCfg l -> [blk] -> l ValuesMK -> l ValuesMK
refoldLedger ComputeLedgerEvents
OmitLedgerEvents LedgerCfg (LedgerState TestBlock)
cfg (Word64 -> [TestBlock]
expectedChain Word64
o) (LedgerState TestBlock ValuesMK -> LedgerState TestBlock ValuesMK
forall (mk :: MapKind) (mk' :: MapKind).
LedgerState TestBlock mk -> LedgerState TestBlock mk'
forall (l :: MapKind -> *) (mk :: MapKind) (mk' :: MapKind).
LedgerTablesAreTrivial l =>
l mk -> l mk'
convertMapKind LedgerState TestBlock ValuesMK
TestBlock.testInitLedger))
      | (Word64
o, LedgerState TestBlock EmptyMK
l) <- DbChangelog (LedgerState TestBlock)
-> [(Word64, LedgerState TestBlock EmptyMK)]
forall (l :: MapKind -> *). DbChangelog l -> [(Word64, l EmptyMK)]
snapshots DbChangelog (LedgerState TestBlock)
csPushed
      ]
 where
  expectedChain :: Word64 -> [TestBlock.TestBlock]
  expectedChain :: Word64 -> [TestBlock]
expectedChain Word64
o = Int -> [TestBlock] -> [TestBlock]
forall a. Int -> [a] -> [a]
take (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
csNumBlocks Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
o)) [TestBlock]
csChain

  cfg :: LedgerConfig TestBlock.TestBlock
  cfg :: LedgerCfg (LedgerState TestBlock)
cfg = LedgerDbCfgF Identity (LedgerState TestBlock)
-> HKD Identity (LedgerCfg (LedgerState TestBlock))
forall (f :: * -> *) (l :: MapKind -> *).
LedgerDbCfgF f l -> HKD f (LedgerCfg l)
ledgerDbCfg (ChainSetup -> LedgerDbCfgF Identity (LedgerState TestBlock)
csBlockConfig ChainSetup
setup)

prop_pastLedger :: ChainSetup -> Property
prop_pastLedger :: ChainSetup -> Property
prop_pastLedger setup :: ChainSetup
setup@ChainSetup{[TestBlock]
Word64
SecurityParam
DbChangelog (LedgerState TestBlock)
csPushed :: ChainSetup -> DbChangelog (LedgerState TestBlock)
csChain :: ChainSetup -> [TestBlock]
csGenSnaps :: ChainSetup -> DbChangelog (LedgerState TestBlock)
csPrefixLen :: ChainSetup -> Word64
csNumBlocks :: ChainSetup -> Word64
csSecParam :: ChainSetup -> SecurityParam
csSecParam :: SecurityParam
csNumBlocks :: Word64
csPrefixLen :: Word64
csGenSnaps :: DbChangelog (LedgerState TestBlock)
csChain :: [TestBlock]
csPushed :: DbChangelog (LedgerState TestBlock)
..} =
  Bool -> TestName -> Property -> Property
forall prop. Testable prop => Bool -> TestName -> prop -> Property
classify (ChainSetup -> Bool
chainSetupSaturated ChainSetup
setup) TestName
"saturated" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    Bool -> TestName -> Property -> Property
forall prop. Testable prop => Bool -> TestName -> prop -> Property
classify Bool
withinReach TestName
"within reach" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
      Point TestBlock
-> DbChangelog (LedgerState TestBlock)
-> Maybe (LedgerState TestBlock EmptyMK)
forall blk (l :: MapKind -> *).
(HasHeader blk, IsLedger l, HeaderHash l ~ HeaderHash blk,
 StandardHash l, HasLedgerTables l) =>
Point blk -> DbChangelog l -> Maybe (l EmptyMK)
getPastLedgerAt Point TestBlock
tip DbChangelog (LedgerState TestBlock)
csPushed
        Maybe (LedgerState TestBlock EmptyMK)
-> Maybe (LedgerState TestBlock EmptyMK) -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== if Bool
withinReach
          then LedgerState TestBlock EmptyMK
-> Maybe (LedgerState TestBlock EmptyMK)
forall a. a -> Maybe a
Just (DbChangelog (LedgerState TestBlock)
-> LedgerState TestBlock EmptyMK
forall (l :: MapKind -> *). GetTip l => DbChangelog l -> l EmptyMK
current DbChangelog (LedgerState TestBlock)
afterPrefix)
          else Maybe (LedgerState TestBlock EmptyMK)
forall a. Maybe a
Nothing
 where
  prefix :: [TestBlock.TestBlock]
  prefix :: [TestBlock]
prefix = Int -> [TestBlock] -> [TestBlock]
forall a. Int -> [a] -> [a]
take (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
csPrefixLen) [TestBlock]
csChain

  tip :: Point TestBlock.TestBlock
  tip :: Point TestBlock
tip = Point TestBlock
-> (TestBlock -> Point TestBlock)
-> Maybe TestBlock
-> Point TestBlock
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Point TestBlock
forall {k} (block :: k). Point block
GenesisPoint TestBlock -> Point TestBlock
forall block. HasHeader block => block -> Point block
blockPoint ([TestBlock] -> Maybe TestBlock
forall a. [a] -> Maybe a
lastMaybe [TestBlock]
prefix)

  afterPrefix :: DbChangelog (LedgerState TestBlock.TestBlock)
  afterPrefix :: DbChangelog (LedgerState TestBlock)
afterPrefix = LedgerDbCfgF Identity (LedgerState TestBlock)
-> [TestBlock]
-> DbChangelog (LedgerState TestBlock)
-> DbChangelog (LedgerState TestBlock)
forall (l :: MapKind -> *) blk.
(ApplyBlock l blk, LedgerTablesAreTrivial l) =>
LedgerDbCfg l -> [blk] -> DbChangelog l -> DbChangelog l
reapplyThenPushMany' (ChainSetup -> LedgerDbCfgF Identity (LedgerState TestBlock)
csBlockConfig ChainSetup
setup) [TestBlock]
prefix DbChangelog (LedgerState TestBlock)
csGenSnaps

  -- See 'prop_snapshotsMaxRollback'
  withinReach :: Bool
  withinReach :: Bool
withinReach = (Word64
csNumBlocks Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
csPrefixLen) Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= DbChangelog (LedgerState TestBlock) -> Word64
forall (l :: MapKind -> *). GetTip l => DbChangelog l -> Word64
maxRollback DbChangelog (LedgerState TestBlock)
csPushed

{-------------------------------------------------------------------------------
  Rollback
-------------------------------------------------------------------------------}

prop_maxRollbackGenesisZero :: Property
prop_maxRollbackGenesisZero :: Property
prop_maxRollbackGenesisZero =
  DbChangelog (LedgerState TestBlock) -> Word64
forall (l :: MapKind -> *). GetTip l => DbChangelog l -> Word64
maxRollback (LedgerState TestBlock EmptyMK
-> DbChangelog (LedgerState TestBlock)
forall (l :: MapKind -> *).
(HasLedgerTables l, GetTip l) =>
l EmptyMK -> DbChangelog l
empty (LedgerState TestBlock ValuesMK -> LedgerState TestBlock EmptyMK
forall (mk :: MapKind) (mk' :: MapKind).
LedgerState TestBlock mk -> LedgerState TestBlock mk'
forall (l :: MapKind -> *) (mk :: MapKind) (mk' :: MapKind).
LedgerTablesAreTrivial l =>
l mk -> l mk'
convertMapKind LedgerState TestBlock ValuesMK
TestBlock.testInitLedger))
    Word64 -> Word64 -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Word64
0

prop_snapshotsMaxRollback :: ChainSetup -> Property
prop_snapshotsMaxRollback :: ChainSetup -> Property
prop_snapshotsMaxRollback setup :: ChainSetup
setup@ChainSetup{[TestBlock]
Word64
SecurityParam
DbChangelog (LedgerState TestBlock)
csPushed :: ChainSetup -> DbChangelog (LedgerState TestBlock)
csChain :: ChainSetup -> [TestBlock]
csGenSnaps :: ChainSetup -> DbChangelog (LedgerState TestBlock)
csPrefixLen :: ChainSetup -> Word64
csNumBlocks :: ChainSetup -> Word64
csSecParam :: ChainSetup -> SecurityParam
csSecParam :: SecurityParam
csNumBlocks :: Word64
csPrefixLen :: Word64
csGenSnaps :: DbChangelog (LedgerState TestBlock)
csChain :: [TestBlock]
csPushed :: DbChangelog (LedgerState TestBlock)
..} =
  Bool -> TestName -> Property -> Property
forall prop. Testable prop => Bool -> TestName -> prop -> Property
classify (ChainSetup -> Bool
chainSetupSaturated ChainSetup
setup) TestName
"saturated" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
      [ if ChainSetup -> Bool
chainSetupSaturated ChainSetup
setup
          then (DbChangelog (LedgerState TestBlock) -> Word64
forall (l :: MapKind -> *). GetTip l => DbChangelog l -> Word64
maxRollback DbChangelog (LedgerState TestBlock)
csPushed) Word64 -> Word64 -> Property
forall a. (Ord a, Show a) => a -> a -> Property
`ge` NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero NonZero Word64
k
          else (DbChangelog (LedgerState TestBlock) -> Word64
forall (l :: MapKind -> *). GetTip l => DbChangelog l -> Word64
maxRollback DbChangelog (LedgerState TestBlock)
csPushed) Word64 -> Word64 -> Property
forall a. (Ord a, Show a) => a -> a -> Property
`ge` (Word64 -> Word64 -> Word64
forall a. Ord a => a -> a -> a
min (NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero NonZero Word64
k) Word64
csNumBlocks)
      , (DbChangelog (LedgerState TestBlock) -> Word64
forall (l :: MapKind -> *). GetTip l => DbChangelog l -> Word64
maxRollback DbChangelog (LedgerState TestBlock)
csPushed) Word64 -> Word64 -> Property
forall a. (Ord a, Show a) => a -> a -> Property
`le` NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero NonZero Word64
k
      ]
 where
  SecurityParam NonZero Word64
k = SecurityParam
csSecParam

prop_switchSameChain :: SwitchSetup -> Property
prop_switchSameChain :: SwitchSetup -> Property
prop_switchSameChain setup :: SwitchSetup
setup@SwitchSetup{[TestBlock]
Word64
DbChangelog (LedgerState TestBlock)
ChainSetup
ssChainSetup :: ChainSetup
ssNumRollback :: Word64
ssNumNew :: Word64
ssPrefixLen :: Word64
ssNumBlocks :: Word64
ssRemoved :: [TestBlock]
ssNewBlocks :: [TestBlock]
ssChain :: [TestBlock]
ssSwitched :: DbChangelog (LedgerState TestBlock)
ssSwitched :: SwitchSetup -> DbChangelog (LedgerState TestBlock)
ssChain :: SwitchSetup -> [TestBlock]
ssNewBlocks :: SwitchSetup -> [TestBlock]
ssRemoved :: SwitchSetup -> [TestBlock]
ssNumBlocks :: SwitchSetup -> Word64
ssPrefixLen :: SwitchSetup -> Word64
ssNumNew :: SwitchSetup -> Word64
ssNumRollback :: SwitchSetup -> Word64
ssChainSetup :: SwitchSetup -> ChainSetup
..} =
  Bool -> TestName -> Property -> Property
forall prop. Testable prop => Bool -> TestName -> prop -> Property
classify (SwitchSetup -> Bool
switchSetupSaturated SwitchSetup
setup) TestName
"saturated" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    LedgerDbCfgF Identity (LedgerState TestBlock)
-> Word64
-> [TestBlock]
-> DbChangelog (LedgerState TestBlock)
-> Maybe (DbChangelog (LedgerState TestBlock))
forall (l :: MapKind -> *) blk.
(ApplyBlock l blk, LedgerTablesAreTrivial l) =>
LedgerDbCfg l
-> Word64 -> [blk] -> DbChangelog l -> Maybe (DbChangelog l)
switch' (ChainSetup -> LedgerDbCfgF Identity (LedgerState TestBlock)
csBlockConfig ChainSetup
ssChainSetup) Word64
ssNumRollback [TestBlock]
blockInfo DbChangelog (LedgerState TestBlock)
csPushed
      Maybe (DbChangelog (LedgerState TestBlock))
-> Maybe (DbChangelog (LedgerState TestBlock)) -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== DbChangelog (LedgerState TestBlock)
-> Maybe (DbChangelog (LedgerState TestBlock))
forall a. a -> Maybe a
Just DbChangelog (LedgerState TestBlock)
csPushed
 where
  ChainSetup{DbChangelog (LedgerState TestBlock)
csPushed :: ChainSetup -> DbChangelog (LedgerState TestBlock)
csPushed :: DbChangelog (LedgerState TestBlock)
csPushed} = ChainSetup
ssChainSetup
  blockInfo :: [TestBlock]
blockInfo = [TestBlock]
ssRemoved

prop_switchExpectedLedger :: SwitchSetup -> Property
prop_switchExpectedLedger :: SwitchSetup -> Property
prop_switchExpectedLedger setup :: SwitchSetup
setup@SwitchSetup{[TestBlock]
Word64
DbChangelog (LedgerState TestBlock)
ChainSetup
ssSwitched :: SwitchSetup -> DbChangelog (LedgerState TestBlock)
ssChain :: SwitchSetup -> [TestBlock]
ssNewBlocks :: SwitchSetup -> [TestBlock]
ssRemoved :: SwitchSetup -> [TestBlock]
ssNumBlocks :: SwitchSetup -> Word64
ssPrefixLen :: SwitchSetup -> Word64
ssNumNew :: SwitchSetup -> Word64
ssNumRollback :: SwitchSetup -> Word64
ssChainSetup :: SwitchSetup -> ChainSetup
ssChainSetup :: ChainSetup
ssNumRollback :: Word64
ssNumNew :: Word64
ssPrefixLen :: Word64
ssNumBlocks :: Word64
ssRemoved :: [TestBlock]
ssNewBlocks :: [TestBlock]
ssChain :: [TestBlock]
ssSwitched :: DbChangelog (LedgerState TestBlock)
..} =
  Bool -> TestName -> Property -> Property
forall prop. Testable prop => Bool -> TestName -> prop -> Property
classify (SwitchSetup -> Bool
switchSetupSaturated SwitchSetup
setup) TestName
"saturated" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
      [ LedgerState TestBlock EmptyMK
l
          LedgerState TestBlock EmptyMK
-> LedgerState TestBlock EmptyMK -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== LedgerState TestBlock ValuesMK -> LedgerState TestBlock EmptyMK
forall (mk :: MapKind) (mk' :: MapKind).
LedgerState TestBlock mk -> LedgerState TestBlock mk'
forall (l :: MapKind -> *) (mk :: MapKind) (mk' :: MapKind).
LedgerTablesAreTrivial l =>
l mk -> l mk'
convertMapKind
            (ComputeLedgerEvents
-> LedgerCfg (LedgerState TestBlock)
-> [TestBlock]
-> LedgerState TestBlock ValuesMK
-> LedgerState TestBlock ValuesMK
forall (l :: MapKind -> *) blk.
ApplyBlock l blk =>
ComputeLedgerEvents
-> LedgerCfg l -> [blk] -> l ValuesMK -> l ValuesMK
refoldLedger ComputeLedgerEvents
OmitLedgerEvents LedgerCfg (LedgerState TestBlock)
cfg (Word64 -> [TestBlock]
expectedChain Word64
o) (LedgerState TestBlock ValuesMK -> LedgerState TestBlock ValuesMK
forall (mk :: MapKind) (mk' :: MapKind).
LedgerState TestBlock mk -> LedgerState TestBlock mk'
forall (l :: MapKind -> *) (mk :: MapKind) (mk' :: MapKind).
LedgerTablesAreTrivial l =>
l mk -> l mk'
convertMapKind LedgerState TestBlock ValuesMK
TestBlock.testInitLedger))
      | (Word64
o, LedgerState TestBlock EmptyMK
l) <- DbChangelog (LedgerState TestBlock)
-> [(Word64, LedgerState TestBlock EmptyMK)]
forall (l :: MapKind -> *). DbChangelog l -> [(Word64, l EmptyMK)]
snapshots DbChangelog (LedgerState TestBlock)
ssSwitched
      ]
 where
  expectedChain :: Word64 -> [TestBlock.TestBlock]
  expectedChain :: Word64 -> [TestBlock]
expectedChain Word64
o = Int -> [TestBlock] -> [TestBlock]
forall a. Int -> [a] -> [a]
take (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
ssNumBlocks Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
o)) [TestBlock]
ssChain

  cfg :: LedgerConfig TestBlock.TestBlock
  cfg :: LedgerCfg (LedgerState TestBlock)
cfg = LedgerDbCfgF Identity (LedgerState TestBlock)
-> HKD Identity (LedgerCfg (LedgerState TestBlock))
forall (f :: * -> *) (l :: MapKind -> *).
LedgerDbCfgF f l -> HKD f (LedgerCfg l)
ledgerDbCfg (ChainSetup -> LedgerDbCfgF Identity (LedgerState TestBlock)
csBlockConfig ChainSetup
ssChainSetup)

-- | Check 'prop_pastLedger' still holds after switching to a fork
prop_pastAfterSwitch :: SwitchSetup -> Property
prop_pastAfterSwitch :: SwitchSetup -> Property
prop_pastAfterSwitch setup :: SwitchSetup
setup@SwitchSetup{[TestBlock]
Word64
DbChangelog (LedgerState TestBlock)
ChainSetup
ssSwitched :: SwitchSetup -> DbChangelog (LedgerState TestBlock)
ssChain :: SwitchSetup -> [TestBlock]
ssNewBlocks :: SwitchSetup -> [TestBlock]
ssRemoved :: SwitchSetup -> [TestBlock]
ssNumBlocks :: SwitchSetup -> Word64
ssPrefixLen :: SwitchSetup -> Word64
ssNumNew :: SwitchSetup -> Word64
ssNumRollback :: SwitchSetup -> Word64
ssChainSetup :: SwitchSetup -> ChainSetup
ssChainSetup :: ChainSetup
ssNumRollback :: Word64
ssNumNew :: Word64
ssPrefixLen :: Word64
ssNumBlocks :: Word64
ssRemoved :: [TestBlock]
ssNewBlocks :: [TestBlock]
ssChain :: [TestBlock]
ssSwitched :: DbChangelog (LedgerState TestBlock)
..} =
  Bool -> TestName -> Property -> Property
forall prop. Testable prop => Bool -> TestName -> prop -> Property
classify (SwitchSetup -> Bool
switchSetupSaturated SwitchSetup
setup) TestName
"saturated" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    Bool -> TestName -> Property -> Property
forall prop. Testable prop => Bool -> TestName -> prop -> Property
classify Bool
withinReach TestName
"within reach" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
      Point TestBlock
-> DbChangelog (LedgerState TestBlock)
-> Maybe (LedgerState TestBlock EmptyMK)
forall blk (l :: MapKind -> *).
(HasHeader blk, IsLedger l, HeaderHash l ~ HeaderHash blk,
 StandardHash l, HasLedgerTables l) =>
Point blk -> DbChangelog l -> Maybe (l EmptyMK)
getPastLedgerAt Point TestBlock
tip DbChangelog (LedgerState TestBlock)
ssSwitched
        Maybe (LedgerState TestBlock EmptyMK)
-> Maybe (LedgerState TestBlock EmptyMK) -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== if Bool
withinReach
          then LedgerState TestBlock EmptyMK
-> Maybe (LedgerState TestBlock EmptyMK)
forall a. a -> Maybe a
Just (DbChangelog (LedgerState TestBlock)
-> LedgerState TestBlock EmptyMK
forall (l :: MapKind -> *). GetTip l => DbChangelog l -> l EmptyMK
current DbChangelog (LedgerState TestBlock)
afterPrefix)
          else Maybe (LedgerState TestBlock EmptyMK)
forall a. Maybe a
Nothing
 where
  prefix :: [TestBlock.TestBlock]
  prefix :: [TestBlock]
prefix = Int -> [TestBlock] -> [TestBlock]
forall a. Int -> [a] -> [a]
take (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
ssPrefixLen) [TestBlock]
ssChain

  tip :: Point TestBlock.TestBlock
  tip :: Point TestBlock
tip = Point TestBlock
-> (TestBlock -> Point TestBlock)
-> Maybe TestBlock
-> Point TestBlock
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Point TestBlock
forall {k} (block :: k). Point block
GenesisPoint TestBlock -> Point TestBlock
forall block. HasHeader block => block -> Point block
blockPoint ([TestBlock] -> Maybe TestBlock
forall a. [a] -> Maybe a
lastMaybe [TestBlock]
prefix)

  afterPrefix :: DbChangelog (LedgerState TestBlock.TestBlock)
  afterPrefix :: DbChangelog (LedgerState TestBlock)
afterPrefix = LedgerDbCfgF Identity (LedgerState TestBlock)
-> [TestBlock]
-> DbChangelog (LedgerState TestBlock)
-> DbChangelog (LedgerState TestBlock)
forall (l :: MapKind -> *) blk.
(ApplyBlock l blk, LedgerTablesAreTrivial l) =>
LedgerDbCfg l -> [blk] -> DbChangelog l -> DbChangelog l
reapplyThenPushMany' (ChainSetup -> LedgerDbCfgF Identity (LedgerState TestBlock)
csBlockConfig ChainSetup
ssChainSetup) [TestBlock]
prefix (ChainSetup -> DbChangelog (LedgerState TestBlock)
csGenSnaps ChainSetup
ssChainSetup)

  -- See 'prop_snapshotsMaxRollback'
  withinReach :: Bool
  withinReach :: Bool
withinReach = (Word64
ssNumBlocks Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
ssPrefixLen) Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= DbChangelog (LedgerState TestBlock) -> Word64
forall (l :: MapKind -> *). GetTip l => DbChangelog l -> Word64
maxRollback DbChangelog (LedgerState TestBlock)
ssSwitched

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

data ChainSetup = ChainSetup
  { ChainSetup -> SecurityParam
csSecParam :: SecurityParam
  -- ^ Security parameter
  , ChainSetup -> Word64
csNumBlocks :: Word64
  -- ^ Number of blocks applied
  , ChainSetup -> Word64
csPrefixLen :: Word64
  -- ^ Some prefix of the chain
  --
  -- Although we choose this to be less than or equal to 'csNumBlocks',
  -- we don't guarantee this during shrinking. If 'csPrefixLen' is larger
  -- than 'csNumBlocks', the prefix should simply be considered to be the
  -- entire chain.
  , ChainSetup -> DbChangelog (LedgerState TestBlock)
csGenSnaps :: DbChangelog (LedgerState TestBlock.TestBlock)
  -- ^ Derived: genesis snapshots
  , ChainSetup -> [TestBlock]
csChain :: [TestBlock.TestBlock]
  -- ^ Derived: the actual blocks that got applied (old to new)
  , ChainSetup -> DbChangelog (LedgerState TestBlock)
csPushed :: DbChangelog (LedgerState TestBlock.TestBlock)
  -- ^ Derived: the snapshots after all blocks were applied
  }
  deriving Int -> ChainSetup -> ShowS
[ChainSetup] -> ShowS
ChainSetup -> TestName
(Int -> ChainSetup -> ShowS)
-> (ChainSetup -> TestName)
-> ([ChainSetup] -> ShowS)
-> Show ChainSetup
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ChainSetup -> ShowS
showsPrec :: Int -> ChainSetup -> ShowS
$cshow :: ChainSetup -> TestName
show :: ChainSetup -> TestName
$cshowList :: [ChainSetup] -> ShowS
showList :: [ChainSetup] -> ShowS
Show

csBlockConfig :: ChainSetup -> LedgerDbCfg (LedgerState TestBlock.TestBlock)
csBlockConfig :: ChainSetup -> LedgerDbCfgF Identity (LedgerState TestBlock)
csBlockConfig = SecurityParam -> LedgerDbCfgF Identity (LedgerState TestBlock)
csBlockConfig' (SecurityParam -> LedgerDbCfgF Identity (LedgerState TestBlock))
-> (ChainSetup -> SecurityParam)
-> ChainSetup
-> LedgerDbCfgF Identity (LedgerState TestBlock)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainSetup -> SecurityParam
csSecParam

csBlockConfig' :: SecurityParam -> LedgerDbCfg (LedgerState TestBlock.TestBlock)
csBlockConfig' :: SecurityParam -> LedgerDbCfgF Identity (LedgerState TestBlock)
csBlockConfig' SecurityParam
secParam =
  LedgerDbCfg
    { ledgerDbCfgSecParam :: HKD Identity SecurityParam
ledgerDbCfgSecParam = SecurityParam
HKD Identity SecurityParam
secParam
    , ledgerDbCfg :: HKD Identity (LedgerCfg (LedgerState TestBlock))
ledgerDbCfg =
        EraParams -> TestBlockLedgerConfig
TestBlock.testBlockLedgerConfigFrom (EraParams -> TestBlockLedgerConfig)
-> EraParams -> TestBlockLedgerConfig
forall a b. (a -> b) -> a -> b
$
          SecurityParam -> SlotLength -> EraParams
HardFork.defaultEraParams SecurityParam
secParam SlotLength
slotLength
    , ledgerDbCfgComputeLedgerEvents :: ComputeLedgerEvents
ledgerDbCfgComputeLedgerEvents = ComputeLedgerEvents
OmitLedgerEvents
    }
 where
  slotLength :: SlotLength
slotLength = Integer -> SlotLength
slotLengthFromSec Integer
20

chainSetupSaturated :: ChainSetup -> Bool
chainSetupSaturated :: ChainSetup -> Bool
chainSetupSaturated ChainSetup{[TestBlock]
Word64
SecurityParam
DbChangelog (LedgerState TestBlock)
csPushed :: ChainSetup -> DbChangelog (LedgerState TestBlock)
csChain :: ChainSetup -> [TestBlock]
csGenSnaps :: ChainSetup -> DbChangelog (LedgerState TestBlock)
csPrefixLen :: ChainSetup -> Word64
csNumBlocks :: ChainSetup -> Word64
csSecParam :: ChainSetup -> SecurityParam
csSecParam :: SecurityParam
csNumBlocks :: Word64
csPrefixLen :: Word64
csGenSnaps :: DbChangelog (LedgerState TestBlock)
csChain :: [TestBlock]
csPushed :: DbChangelog (LedgerState TestBlock)
..} = SecurityParam -> DbChangelog (LedgerState TestBlock) -> Bool
forall (l :: MapKind -> *).
GetTip l =>
SecurityParam -> DbChangelog l -> Bool
isSaturated SecurityParam
csSecParam DbChangelog (LedgerState TestBlock)
csPushed

data SwitchSetup = SwitchSetup
  { SwitchSetup -> ChainSetup
ssChainSetup :: ChainSetup
  -- ^ Chain setup
  , SwitchSetup -> Word64
ssNumRollback :: Word64
  -- ^ Number of blocks to roll back
  , SwitchSetup -> Word64
ssNumNew :: Word64
  -- ^ Number of new blocks (to be applied after the rollback)
  , SwitchSetup -> Word64
ssPrefixLen :: Word64
  -- ^ Prefix of the new chain
  --
  -- See also 'csPrefixLen'
  , SwitchSetup -> Word64
ssNumBlocks :: Word64
  -- ^ Derived: number of blocks in the new chain
  , SwitchSetup -> [TestBlock]
ssRemoved :: [TestBlock.TestBlock]
  -- ^ Derived: the blocks that were removed
  , SwitchSetup -> [TestBlock]
ssNewBlocks :: [TestBlock.TestBlock]
  -- ^ Derived: the new blocks themselves
  , SwitchSetup -> [TestBlock]
ssChain :: [TestBlock.TestBlock]
  -- ^ Derived: the full chain after switching to this fork
  , SwitchSetup -> DbChangelog (LedgerState TestBlock)
ssSwitched :: DbChangelog (LedgerState TestBlock.TestBlock)
  -- ^ Derived; the snapshots after the switch was performed
  }
  deriving Int -> SwitchSetup -> ShowS
[SwitchSetup] -> ShowS
SwitchSetup -> TestName
(Int -> SwitchSetup -> ShowS)
-> (SwitchSetup -> TestName)
-> ([SwitchSetup] -> ShowS)
-> Show SwitchSetup
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SwitchSetup -> ShowS
showsPrec :: Int -> SwitchSetup -> ShowS
$cshow :: SwitchSetup -> TestName
show :: SwitchSetup -> TestName
$cshowList :: [SwitchSetup] -> ShowS
showList :: [SwitchSetup] -> ShowS
Show

switchSetupSaturated :: SwitchSetup -> Bool
switchSetupSaturated :: SwitchSetup -> Bool
switchSetupSaturated = ChainSetup -> Bool
chainSetupSaturated (ChainSetup -> Bool)
-> (SwitchSetup -> ChainSetup) -> SwitchSetup -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SwitchSetup -> ChainSetup
ssChainSetup

mkTestSetup :: SecurityParam -> Word64 -> Word64 -> ChainSetup
mkTestSetup :: SecurityParam -> Word64 -> Word64 -> ChainSetup
mkTestSetup SecurityParam
csSecParam Word64
csNumBlocks Word64
csPrefixLen =
  ChainSetup{[TestBlock]
Word64
SecurityParam
DbChangelog (LedgerState TestBlock)
csPushed :: DbChangelog (LedgerState TestBlock)
csChain :: [TestBlock]
csGenSnaps :: DbChangelog (LedgerState TestBlock)
csPrefixLen :: Word64
csNumBlocks :: Word64
csSecParam :: SecurityParam
csSecParam :: SecurityParam
csNumBlocks :: Word64
csPrefixLen :: Word64
csGenSnaps :: DbChangelog (LedgerState TestBlock)
csChain :: [TestBlock]
csPushed :: DbChangelog (LedgerState TestBlock)
..}
 where
  csGenSnaps :: DbChangelog (LedgerState TestBlock)
csGenSnaps = LedgerState TestBlock EmptyMK
-> DbChangelog (LedgerState TestBlock)
forall (l :: MapKind -> *).
(HasLedgerTables l, GetTip l) =>
l EmptyMK -> DbChangelog l
empty (LedgerState TestBlock ValuesMK -> LedgerState TestBlock EmptyMK
forall (mk :: MapKind) (mk' :: MapKind).
LedgerState TestBlock mk -> LedgerState TestBlock mk'
forall (l :: MapKind -> *) (mk :: MapKind) (mk' :: MapKind).
LedgerTablesAreTrivial l =>
l mk -> l mk'
convertMapKind LedgerState TestBlock ValuesMK
TestBlock.testInitLedger)
  csChain :: [TestBlock]
csChain =
    Int -> [TestBlock] -> [TestBlock]
forall a. Int -> [a] -> [a]
take (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
csNumBlocks) ([TestBlock] -> [TestBlock]) -> [TestBlock] -> [TestBlock]
forall a b. (a -> b) -> a -> b
$
      (TestBlock -> TestBlock) -> TestBlock -> [TestBlock]
forall a. (a -> a) -> a -> [a]
iterate TestBlock -> TestBlock
TestBlock.successorBlock (Word64 -> TestBlock
TestBlock.firstBlock Word64
0)
  csPushed :: DbChangelog (LedgerState TestBlock)
csPushed = LedgerDbCfgF Identity (LedgerState TestBlock)
-> [TestBlock]
-> DbChangelog (LedgerState TestBlock)
-> DbChangelog (LedgerState TestBlock)
forall (l :: MapKind -> *) blk.
(ApplyBlock l blk, LedgerTablesAreTrivial l) =>
LedgerDbCfg l -> [blk] -> DbChangelog l -> DbChangelog l
reapplyThenPushMany' (SecurityParam -> LedgerDbCfgF Identity (LedgerState TestBlock)
csBlockConfig' SecurityParam
csSecParam) [TestBlock]
csChain DbChangelog (LedgerState TestBlock)
csGenSnaps

mkRollbackSetup :: ChainSetup -> Word64 -> Word64 -> Word64 -> SwitchSetup
mkRollbackSetup :: ChainSetup -> Word64 -> Word64 -> Word64 -> SwitchSetup
mkRollbackSetup ChainSetup
ssChainSetup Word64
ssNumRollback Word64
ssNumNew Word64
ssPrefixLen =
  SwitchSetup{[TestBlock]
Word64
DbChangelog (LedgerState TestBlock)
ChainSetup
ssSwitched :: DbChangelog (LedgerState TestBlock)
ssChain :: [TestBlock]
ssNewBlocks :: [TestBlock]
ssRemoved :: [TestBlock]
ssNumBlocks :: Word64
ssPrefixLen :: Word64
ssNumNew :: Word64
ssNumRollback :: Word64
ssChainSetup :: ChainSetup
ssChainSetup :: ChainSetup
ssNumRollback :: Word64
ssNumNew :: Word64
ssPrefixLen :: Word64
ssNumBlocks :: Word64
ssRemoved :: [TestBlock]
ssNewBlocks :: [TestBlock]
ssChain :: [TestBlock]
ssSwitched :: DbChangelog (LedgerState TestBlock)
..}
 where
  ChainSetup{[TestBlock]
Word64
SecurityParam
DbChangelog (LedgerState TestBlock)
csPushed :: ChainSetup -> DbChangelog (LedgerState TestBlock)
csChain :: ChainSetup -> [TestBlock]
csGenSnaps :: ChainSetup -> DbChangelog (LedgerState TestBlock)
csPrefixLen :: ChainSetup -> Word64
csNumBlocks :: ChainSetup -> Word64
csSecParam :: ChainSetup -> SecurityParam
csSecParam :: SecurityParam
csNumBlocks :: Word64
csPrefixLen :: Word64
csGenSnaps :: DbChangelog (LedgerState TestBlock)
csChain :: [TestBlock]
csPushed :: DbChangelog (LedgerState TestBlock)
..} = ChainSetup
ssChainSetup

  ssNumBlocks :: Word64
ssNumBlocks = Word64
csNumBlocks Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
ssNumRollback Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
ssNumNew
  ssRemoved :: [TestBlock]
ssRemoved = Word64 -> [TestBlock] -> [TestBlock]
forall a. Word64 -> [a] -> [a]
takeLast Word64
ssNumRollback [TestBlock]
csChain
  ssNewBlocks :: [TestBlock]
ssNewBlocks =
    let afterRollback :: [TestBlock]
afterRollback = Word64 -> [TestBlock] -> [TestBlock]
forall a. Word64 -> [a] -> [a]
dropLast Word64
ssNumRollback [TestBlock]
csChain
        firstAfterRollback :: TestBlock
firstAfterRollback =
          case [TestBlock] -> Maybe TestBlock
forall a. [a] -> Maybe a
lastMaybe [TestBlock]
afterRollback of
            Maybe TestBlock
Nothing -> Word64 -> TestBlock
TestBlock.firstBlock Word64
1
            Just TestBlock
b -> (Word64 -> Word64) -> TestBlock -> TestBlock
TestBlock.modifyFork (Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1) (TestBlock -> TestBlock) -> TestBlock -> TestBlock
forall a b. (a -> b) -> a -> b
$ TestBlock -> TestBlock
TestBlock.successorBlock TestBlock
b
     in Int -> [TestBlock] -> [TestBlock]
forall a. Int -> [a] -> [a]
take (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
ssNumNew) ([TestBlock] -> [TestBlock]) -> [TestBlock] -> [TestBlock]
forall a b. (a -> b) -> a -> b
$
          (TestBlock -> TestBlock) -> TestBlock -> [TestBlock]
forall a. (a -> a) -> a -> [a]
iterate TestBlock -> TestBlock
TestBlock.successorBlock TestBlock
firstAfterRollback
  ssChain :: [TestBlock]
ssChain =
    [[TestBlock]] -> [TestBlock]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ Int -> [TestBlock] -> [TestBlock]
forall a. Int -> [a] -> [a]
take (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
csNumBlocks Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
ssNumRollback)) [TestBlock]
csChain
      , [TestBlock]
ssNewBlocks
      ]
  ssSwitched :: DbChangelog (LedgerState TestBlock)
ssSwitched = Maybe (DbChangelog (LedgerState TestBlock))
-> DbChangelog (LedgerState TestBlock)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (DbChangelog (LedgerState TestBlock))
 -> DbChangelog (LedgerState TestBlock))
-> Maybe (DbChangelog (LedgerState TestBlock))
-> DbChangelog (LedgerState TestBlock)
forall a b. (a -> b) -> a -> b
$ LedgerDbCfgF Identity (LedgerState TestBlock)
-> Word64
-> [TestBlock]
-> DbChangelog (LedgerState TestBlock)
-> Maybe (DbChangelog (LedgerState TestBlock))
forall (l :: MapKind -> *) blk.
(ApplyBlock l blk, LedgerTablesAreTrivial l) =>
LedgerDbCfg l
-> Word64 -> [blk] -> DbChangelog l -> Maybe (DbChangelog l)
switch' (ChainSetup -> LedgerDbCfgF Identity (LedgerState TestBlock)
csBlockConfig ChainSetup
ssChainSetup) Word64
ssNumRollback [TestBlock]
ssNewBlocks DbChangelog (LedgerState TestBlock)
csPushed

instance Arbitrary ChainSetup where
  arbitrary :: Gen ChainSetup
arbitrary = do
    secParam <- Gen SecurityParam
forall a. Arbitrary a => Gen a
arbitrary
    let 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
secParam
    numBlocks <- choose (0, k * 2)
    prefixLen <- choose (0, numBlocks)
    return $ mkTestSetup secParam numBlocks prefixLen

  shrink :: ChainSetup -> [ChainSetup]
shrink ChainSetup{[TestBlock]
Word64
SecurityParam
DbChangelog (LedgerState TestBlock)
csPushed :: ChainSetup -> DbChangelog (LedgerState TestBlock)
csChain :: ChainSetup -> [TestBlock]
csGenSnaps :: ChainSetup -> DbChangelog (LedgerState TestBlock)
csPrefixLen :: ChainSetup -> Word64
csNumBlocks :: ChainSetup -> Word64
csSecParam :: ChainSetup -> SecurityParam
csSecParam :: SecurityParam
csNumBlocks :: Word64
csPrefixLen :: Word64
csGenSnaps :: DbChangelog (LedgerState TestBlock)
csChain :: [TestBlock]
csPushed :: DbChangelog (LedgerState TestBlock)
..} =
    [[ChainSetup]] -> [ChainSetup]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ -- Shrink the policy
        [ SecurityParam -> Word64 -> Word64 -> ChainSetup
mkTestSetup SecurityParam
csSecParam' Word64
csNumBlocks Word64
csPrefixLen
        | SecurityParam
csSecParam' <- SecurityParam -> [SecurityParam]
forall a. Arbitrary a => a -> [a]
shrink SecurityParam
csSecParam
        ]
      , -- Reduce number of blocks
        [ SecurityParam -> Word64 -> Word64 -> ChainSetup
mkTestSetup SecurityParam
csSecParam Word64
csNumBlocks' Word64
csPrefixLen
        | Word64
csNumBlocks' <- Word64 -> [Word64]
forall a. Arbitrary a => a -> [a]
shrink Word64
csNumBlocks
        ]
      ]

instance Arbitrary SwitchSetup where
  arbitrary :: Gen SwitchSetup
arbitrary = do
    chainSetup <- Gen ChainSetup
forall a. Arbitrary a => Gen a
arbitrary
    numRollback <- choose (0, maxRollback (csPushed chainSetup))
    numNew <- choose (numRollback, 2 * numRollback)
    prefixLen <- choose (0, csNumBlocks chainSetup - numRollback + numNew)
    return $ mkRollbackSetup chainSetup numRollback numNew prefixLen

  shrink :: SwitchSetup -> [SwitchSetup]
shrink SwitchSetup{[TestBlock]
Word64
DbChangelog (LedgerState TestBlock)
ChainSetup
ssSwitched :: SwitchSetup -> DbChangelog (LedgerState TestBlock)
ssChain :: SwitchSetup -> [TestBlock]
ssNewBlocks :: SwitchSetup -> [TestBlock]
ssRemoved :: SwitchSetup -> [TestBlock]
ssNumBlocks :: SwitchSetup -> Word64
ssPrefixLen :: SwitchSetup -> Word64
ssNumNew :: SwitchSetup -> Word64
ssNumRollback :: SwitchSetup -> Word64
ssChainSetup :: SwitchSetup -> ChainSetup
ssChainSetup :: ChainSetup
ssNumRollback :: Word64
ssNumNew :: Word64
ssPrefixLen :: Word64
ssNumBlocks :: Word64
ssRemoved :: [TestBlock]
ssNewBlocks :: [TestBlock]
ssChain :: [TestBlock]
ssSwitched :: DbChangelog (LedgerState TestBlock)
..} =
    [[SwitchSetup]] -> [SwitchSetup]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ -- If we shrink the chain setup, we might restrict max rollback
        [ ChainSetup -> Word64 -> Word64 -> Word64 -> SwitchSetup
mkRollbackSetup ChainSetup
ssChainSetup' Word64
ssNumRollback Word64
ssNumNew Word64
ssPrefixLen
        | ChainSetup
ssChainSetup' <- ChainSetup -> [ChainSetup]
forall a. Arbitrary a => a -> [a]
shrink ChainSetup
ssChainSetup
        , Word64
ssNumRollback Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= DbChangelog (LedgerState TestBlock) -> Word64
forall (l :: MapKind -> *). GetTip l => DbChangelog l -> Word64
maxRollback (ChainSetup -> DbChangelog (LedgerState TestBlock)
csPushed ChainSetup
ssChainSetup')
        ]
      , -- Number of new blocks must be at least the rollback
        [ ChainSetup -> Word64 -> Word64 -> Word64 -> SwitchSetup
mkRollbackSetup ChainSetup
ssChainSetup Word64
ssNumRollback Word64
ssNumNew' Word64
ssPrefixLen
        | Word64
ssNumNew' <- Word64 -> [Word64]
forall a. Arbitrary a => a -> [a]
shrink Word64
ssNumNew
        , Word64
ssNumNew' Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
ssNumRollback
        ]
      , -- But rolling back less is always possible
        [ ChainSetup -> Word64 -> Word64 -> Word64 -> SwitchSetup
mkRollbackSetup ChainSetup
ssChainSetup Word64
ssNumRollback' Word64
ssNumNew Word64
ssPrefixLen
        | Word64
ssNumRollback' <- Word64 -> [Word64]
forall a. Arbitrary a => a -> [a]
shrink Word64
ssNumRollback
        ]
      ]

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

data TestLedger (mk :: MapKind) = TestLedger
  { forall (mk :: MapKind). TestLedger mk -> mk Key Int
tlUtxos :: mk Key Int
  , forall (mk :: MapKind). TestLedger mk -> Point TestLedger
tlTip :: Point TestLedger
  }

nextState :: DbChangelog TestLedger -> TestLedger DiffMK
nextState :: DbChangelog TestLedger -> TestLedger DiffMK
nextState DbChangelog TestLedger
dblog =
  TestLedger
    { tlTip :: Point TestLedger
tlTip = WithOrigin SlotNo -> Point TestLedger
pointAtSlot (WithOrigin SlotNo -> Point TestLedger)
-> WithOrigin SlotNo -> Point TestLedger
forall a b. (a -> b) -> a -> b
$ WithOrigin SlotNo -> WithOrigin SlotNo
nextSlot (TestLedger EmptyMK -> WithOrigin SlotNo
forall (l :: MapKind -> *) (mk :: MapKind).
GetTip l =>
l mk -> WithOrigin SlotNo
getTipSlot TestLedger EmptyMK
old)
    , tlUtxos :: DiffMK Key Int
tlUtxos = Diff Key Int -> DiffMK Key Int
forall k v. Diff k v -> DiffMK k v
DiffMK Diff Key Int
forall a. Monoid a => a
mempty
    }
 where
  old :: TestLedger EmptyMK
old = DbChangelog TestLedger -> TestLedger EmptyMK
forall (l :: MapKind -> *). GetTip l => DbChangelog l -> l EmptyMK
DbChangelog.current DbChangelog TestLedger
dblog
  nextSlot :: WithOrigin SlotNo -> WithOrigin SlotNo
nextSlot = SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
At (SlotNo -> WithOrigin SlotNo)
-> (WithOrigin SlotNo -> SlotNo)
-> WithOrigin SlotNo
-> WithOrigin SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlotNo -> (SlotNo -> SlotNo) -> WithOrigin SlotNo -> SlotNo
forall b t. b -> (t -> b) -> WithOrigin t -> b
withOrigin SlotNo
1 (SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
1)

deriving instance Show (mk Key Int) => Show (TestLedger mk)

instance GetTip TestLedger where
  getTip :: forall (mk :: MapKind). TestLedger mk -> Point TestLedger
getTip = Point TestLedger -> Point TestLedger
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point TestLedger -> Point TestLedger)
-> (TestLedger mk -> Point TestLedger)
-> TestLedger mk
-> Point TestLedger
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestLedger mk -> Point TestLedger
forall (mk :: MapKind). TestLedger mk -> Point TestLedger
tlTip

data H = H deriving (H -> H -> Bool
(H -> H -> Bool) -> (H -> H -> Bool) -> Eq H
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: H -> H -> Bool
== :: H -> H -> Bool
$c/= :: H -> H -> Bool
/= :: H -> H -> Bool
Eq, Eq H
Eq H =>
(H -> H -> Ordering)
-> (H -> H -> Bool)
-> (H -> H -> Bool)
-> (H -> H -> Bool)
-> (H -> H -> Bool)
-> (H -> H -> H)
-> (H -> H -> H)
-> Ord H
H -> H -> Bool
H -> H -> Ordering
H -> H -> H
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 :: H -> H -> Ordering
compare :: H -> H -> Ordering
$c< :: H -> H -> Bool
< :: H -> H -> Bool
$c<= :: H -> H -> Bool
<= :: H -> H -> Bool
$c> :: H -> H -> Bool
> :: H -> H -> Bool
$c>= :: H -> H -> Bool
>= :: H -> H -> Bool
$cmax :: H -> H -> H
max :: H -> H -> H
$cmin :: H -> H -> H
min :: H -> H -> H
Ord, Int -> H -> ShowS
[H] -> ShowS
H -> TestName
(Int -> H -> ShowS) -> (H -> TestName) -> ([H] -> ShowS) -> Show H
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> H -> ShowS
showsPrec :: Int -> H -> ShowS
$cshow :: H -> TestName
show :: H -> TestName
$cshowList :: [H] -> ShowS
showList :: [H] -> ShowS
Show, (forall x. H -> Rep H x) -> (forall x. Rep H x -> H) -> Generic H
forall x. Rep H x -> H
forall x. H -> Rep H x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. H -> Rep H x
from :: forall x. H -> Rep H x
$cto :: forall x. Rep H x -> H
to :: forall x. Rep H x -> H
Generic)
deriving anyclass instance NoThunks H
type instance HeaderHash TestLedger = H

instance StandardHash TestLedger

deriving instance Eq (TestLedger EmptyMK)

type instance TxIn TestLedger = Key
type instance TxOut TestLedger = Int

instance HasLedgerTables TestLedger where
  projectLedgerTables :: forall (mk :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
TestLedger mk -> LedgerTables TestLedger mk
projectLedgerTables = mk Key Int -> LedgerTables TestLedger mk
mk (TxIn TestLedger) (TxOut TestLedger)
-> LedgerTables TestLedger mk
forall (l :: MapKind -> *) (mk :: MapKind).
mk (TxIn l) (TxOut l) -> LedgerTables l mk
LedgerTables (mk Key Int -> LedgerTables TestLedger mk)
-> (TestLedger mk -> mk Key Int)
-> TestLedger mk
-> LedgerTables TestLedger mk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestLedger mk -> mk Key Int
forall (mk :: MapKind). TestLedger mk -> mk Key Int
tlUtxos
  withLedgerTables :: forall (mk :: MapKind) (any :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
TestLedger any -> LedgerTables TestLedger mk -> TestLedger mk
withLedgerTables TestLedger any
st (LedgerTables mk (TxIn TestLedger) (TxOut TestLedger)
x) = TestLedger any
st{tlUtxos = x}

instance IndexedMemPack (TestLedger EmptyMK) Int where
  indexedTypeName :: TestLedger EmptyMK -> TestName
indexedTypeName TestLedger EmptyMK
_ = forall a. MemPack a => TestName
typeName @Int
  indexedPackedByteCount :: TestLedger EmptyMK -> Int -> Int
indexedPackedByteCount TestLedger EmptyMK
_ = Int -> Int
forall a. MemPack a => a -> Int
packedByteCount
  indexedPackM :: forall s. TestLedger EmptyMK -> Int -> Pack s ()
indexedPackM TestLedger EmptyMK
_ = Int -> Pack s ()
forall s. Int -> Pack s ()
forall a s. MemPack a => a -> Pack s ()
packM
  indexedUnpackM :: forall b. Buffer b => TestLedger EmptyMK -> Unpack b Int
indexedUnpackM TestLedger EmptyMK
_ = Unpack b Int
forall b. Buffer b => Unpack b Int
forall a b. (MemPack a, Buffer b) => Unpack b a
unpackM

data DbChangelogTestSetup = DbChangelogTestSetup
  { -- The operations are applied on the right, i.e., the newest operation is at the head of the list.
    DbChangelogTestSetup -> [Operation TestLedger]
operations :: [Operation TestLedger]
  , DbChangelogTestSetup -> WithOrigin SlotNo
dbChangelogStartsAt :: WithOrigin SlotNo
  }

data Operation l = Extend (l DiffMK) | Prune LedgerDbPrune
deriving instance Show (l DiffMK) => Show (Operation l)

data DbChangelogTestSetupWithRollbacks = DbChangelogTestSetupWithRollbacks
  { DbChangelogTestSetupWithRollbacks -> DbChangelogTestSetup
testSetup :: DbChangelogTestSetup
  , DbChangelogTestSetupWithRollbacks -> Int
rollbacks :: Int
  }
  deriving Int -> DbChangelogTestSetupWithRollbacks -> ShowS
[DbChangelogTestSetupWithRollbacks] -> ShowS
DbChangelogTestSetupWithRollbacks -> TestName
(Int -> DbChangelogTestSetupWithRollbacks -> ShowS)
-> (DbChangelogTestSetupWithRollbacks -> TestName)
-> ([DbChangelogTestSetupWithRollbacks] -> ShowS)
-> Show DbChangelogTestSetupWithRollbacks
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DbChangelogTestSetupWithRollbacks -> ShowS
showsPrec :: Int -> DbChangelogTestSetupWithRollbacks -> ShowS
$cshow :: DbChangelogTestSetupWithRollbacks -> TestName
show :: DbChangelogTestSetupWithRollbacks -> TestName
$cshowList :: [DbChangelogTestSetupWithRollbacks] -> ShowS
showList :: [DbChangelogTestSetupWithRollbacks] -> ShowS
Show

instance Show DbChangelogTestSetup where
  show :: DbChangelogTestSetup -> TestName
show = [Operation TestLedger] -> TestName
forall a. Show a => a -> TestName
ppShow ([Operation TestLedger] -> TestName)
-> (DbChangelogTestSetup -> [Operation TestLedger])
-> DbChangelogTestSetup
-> TestName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DbChangelogTestSetup -> [Operation TestLedger]
operations

instance Arbitrary DbChangelogTestSetup where
  arbitrary :: Gen DbChangelogTestSetup
arbitrary = (Int -> Gen DbChangelogTestSetup) -> Gen DbChangelogTestSetup
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen DbChangelogTestSetup) -> Gen DbChangelogTestSetup)
-> (Int -> Gen DbChangelogTestSetup) -> Gen DbChangelogTestSetup
forall a b. (a -> b) -> a -> b
$ \Int
n -> do
    slotNo <- [Gen (WithOrigin SlotNo)] -> Gen (WithOrigin SlotNo)
forall a. HasCallStack => [Gen a] -> Gen a
oneof [WithOrigin SlotNo -> Gen (WithOrigin SlotNo)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure WithOrigin SlotNo
forall t. WithOrigin t
Origin, SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
At (SlotNo -> WithOrigin SlotNo)
-> (Word64 -> SlotNo) -> Word64 -> WithOrigin SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> SlotNo
SlotNo (Word64 -> WithOrigin SlotNo)
-> Gen Word64 -> Gen (WithOrigin SlotNo)
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
1000)]
    ops <- genOperations slotNo n
    pure $
      DbChangelogTestSetup
        { operations = ops
        , dbChangelogStartsAt = slotNo
        }

  -- Shrinking finds the shortest prefix of the list of operations that result
  -- in a failed property, by simply testing prefixes in increasing order.
  shrink :: DbChangelogTestSetup -> [DbChangelogTestSetup]
shrink DbChangelogTestSetup
setup = [DbChangelogTestSetup] -> [DbChangelogTestSetup]
forall a. [a] -> [a]
reverse ([DbChangelogTestSetup] -> [DbChangelogTestSetup])
-> [DbChangelogTestSetup] -> [DbChangelogTestSetup]
forall a b. (a -> b) -> a -> b
$ [Maybe DbChangelogTestSetup] -> [DbChangelogTestSetup]
forall {a}. [Maybe a] -> [a]
takeWhileJust ([Maybe DbChangelogTestSetup] -> [DbChangelogTestSetup])
-> [Maybe DbChangelogTestSetup] -> [DbChangelogTestSetup]
forall a b. (a -> b) -> a -> b
$ Int -> [Maybe DbChangelogTestSetup] -> [Maybe DbChangelogTestSetup]
forall a. Int -> [a] -> [a]
drop Int
1 ((Maybe DbChangelogTestSetup -> Maybe DbChangelogTestSetup)
-> Maybe DbChangelogTestSetup -> [Maybe DbChangelogTestSetup]
forall a. (a -> a) -> a -> [a]
iterate Maybe DbChangelogTestSetup -> Maybe DbChangelogTestSetup
reduce (DbChangelogTestSetup -> Maybe DbChangelogTestSetup
forall a. a -> Maybe a
Just DbChangelogTestSetup
setup))
   where
    reduce :: Maybe DbChangelogTestSetup -> Maybe DbChangelogTestSetup
reduce (Just (DbChangelogTestSetup (Operation TestLedger
_ : [Operation TestLedger]
ops) WithOrigin SlotNo
dblog)) = DbChangelogTestSetup -> Maybe DbChangelogTestSetup
forall a. a -> Maybe a
Just (DbChangelogTestSetup -> Maybe DbChangelogTestSetup)
-> DbChangelogTestSetup -> Maybe DbChangelogTestSetup
forall a b. (a -> b) -> a -> b
$ [Operation TestLedger] -> WithOrigin SlotNo -> DbChangelogTestSetup
DbChangelogTestSetup [Operation TestLedger]
ops WithOrigin SlotNo
dblog
    reduce Maybe DbChangelogTestSetup
_ = Maybe DbChangelogTestSetup
forall a. Maybe a
Nothing
    takeWhileJust :: [Maybe a] -> [a]
takeWhileJust = [Maybe a] -> [a]
forall {a}. [Maybe a] -> [a]
catMaybes ([Maybe a] -> [a]) -> ([Maybe a] -> [Maybe a]) -> [Maybe a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe a -> Bool) -> [Maybe a] -> [Maybe a]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Maybe a -> Bool
forall a. Maybe a -> Bool
isJust

instance Arbitrary DbChangelogTestSetupWithRollbacks where
  arbitrary :: Gen DbChangelogTestSetupWithRollbacks
arbitrary = do
    setup <- Gen DbChangelogTestSetup
forall a. Arbitrary a => Gen a
arbitrary
    let dblog = DbChangelogTestSetup -> DbChangelog TestLedger
resultingDbChangelog DbChangelogTestSetup
setup
    rolls <- chooseInt (0, AS.length (DbChangelog.changelogStates dblog))
    pure $
      DbChangelogTestSetupWithRollbacks
        { testSetup = setup
        , rollbacks = rolls
        }

  shrink :: DbChangelogTestSetupWithRollbacks
-> [DbChangelogTestSetupWithRollbacks]
shrink DbChangelogTestSetupWithRollbacks
setupWithRollback = DbChangelogTestSetup -> DbChangelogTestSetupWithRollbacks
toWithRollbacks (DbChangelogTestSetup -> DbChangelogTestSetupWithRollbacks)
-> [DbChangelogTestSetup] -> [DbChangelogTestSetupWithRollbacks]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DbChangelogTestSetup]
setups
   where
    setups :: [DbChangelogTestSetup]
setups = DbChangelogTestSetup -> [DbChangelogTestSetup]
forall a. Arbitrary a => a -> [a]
shrink (DbChangelogTestSetupWithRollbacks -> DbChangelogTestSetup
testSetup DbChangelogTestSetupWithRollbacks
setupWithRollback)
    shrinkRollback :: DbChangelogTestSetup -> Int -> Int
    shrinkRollback :: DbChangelogTestSetup -> Int -> Int
shrinkRollback DbChangelogTestSetup
setup Int
rollbacks =
      AnchoredSeq
  (WithOrigin SlotNo) (TestLedger EmptyMK) (TestLedger EmptyMK)
-> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AS.length (DbChangelog TestLedger
-> AnchoredSeq
     (WithOrigin SlotNo) (TestLedger EmptyMK) (TestLedger EmptyMK)
forall (l :: MapKind -> *).
DbChangelog l
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
DbChangelog.changelogStates (DbChangelog TestLedger
 -> AnchoredSeq
      (WithOrigin SlotNo) (TestLedger EmptyMK) (TestLedger EmptyMK))
-> DbChangelog TestLedger
-> AnchoredSeq
     (WithOrigin SlotNo) (TestLedger EmptyMK) (TestLedger EmptyMK)
forall a b. (a -> b) -> a -> b
$ DbChangelogTestSetup -> DbChangelog TestLedger
resultingDbChangelog DbChangelogTestSetup
setup) Int -> Int -> Int
forall a. Ord a => a -> a -> a
`min` Int
rollbacks
    toWithRollbacks :: DbChangelogTestSetup -> DbChangelogTestSetupWithRollbacks
toWithRollbacks DbChangelogTestSetup
setup =
      DbChangelogTestSetupWithRollbacks
        { testSetup :: DbChangelogTestSetup
testSetup = DbChangelogTestSetup
setup
        , rollbacks :: Int
rollbacks = DbChangelogTestSetup -> Int -> Int
shrinkRollback DbChangelogTestSetup
setup (DbChangelogTestSetupWithRollbacks -> Int
rollbacks DbChangelogTestSetupWithRollbacks
setupWithRollback)
        }

resultingDbChangelog :: DbChangelogTestSetup -> DbChangelog TestLedger
resultingDbChangelog :: DbChangelogTestSetup -> DbChangelog TestLedger
resultingDbChangelog DbChangelogTestSetup
setup = [Operation TestLedger]
-> DbChangelog TestLedger -> DbChangelog TestLedger
forall (l :: MapKind -> *).
(HasLedgerTables l, GetTip l) =>
[Operation l] -> DbChangelog l -> DbChangelog l
applyOperations (DbChangelogTestSetup -> [Operation TestLedger]
operations DbChangelogTestSetup
setup) DbChangelog TestLedger
originalDbChangelog
 where
  originalDbChangelog :: DbChangelog TestLedger
originalDbChangelog = TestLedger EmptyMK -> DbChangelog TestLedger
forall (l :: MapKind -> *).
(HasLedgerTables l, GetTip l) =>
l EmptyMK -> DbChangelog l
DbChangelog.empty (TestLedger EmptyMK -> DbChangelog TestLedger)
-> TestLedger EmptyMK -> DbChangelog TestLedger
forall a b. (a -> b) -> a -> b
$ EmptyMK Key Int -> Point TestLedger -> TestLedger EmptyMK
forall (mk :: MapKind).
mk Key Int -> Point TestLedger -> TestLedger mk
TestLedger EmptyMK Key Int
forall k v. EmptyMK k v
EmptyMK Point TestLedger
theAnchor
  theAnchor :: Point TestLedger
theAnchor = WithOrigin SlotNo -> Point TestLedger
pointAtSlot (DbChangelogTestSetup -> WithOrigin SlotNo
dbChangelogStartsAt DbChangelogTestSetup
setup)

applyOperations ::
  (HasLedgerTables l, GetTip l) =>
  [Operation l] -> DbChangelog l -> DbChangelog l
applyOperations :: forall (l :: MapKind -> *).
(HasLedgerTables l, GetTip l) =>
[Operation l] -> DbChangelog l -> DbChangelog l
applyOperations [Operation l]
ops DbChangelog l
dblog = (Operation l -> DbChangelog l -> DbChangelog l)
-> DbChangelog l -> [Operation l] -> DbChangelog l
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' Operation l -> DbChangelog l -> DbChangelog l
forall {l :: MapKind -> *}.
(GetTip l, HasLedgerTables l) =>
Operation l -> DbChangelog l -> DbChangelog l
apply' DbChangelog l
dblog [Operation l]
ops
 where
  apply' :: Operation l -> DbChangelog l -> DbChangelog l
apply' (Extend l DiffMK
newState) DbChangelog l
dblog' = l DiffMK -> DbChangelog l -> DbChangelog l
forall (l :: MapKind -> *).
(GetTip l, HasLedgerTables l) =>
l DiffMK -> DbChangelog l -> DbChangelog l
DbChangelog.extend l DiffMK
newState DbChangelog l
dblog'
  apply' (Prune LedgerDbPrune
sp) DbChangelog l
dblog' = LedgerDbPrune -> DbChangelog l -> DbChangelog l
forall (l :: MapKind -> *).
GetTip l =>
LedgerDbPrune -> DbChangelog l -> DbChangelog l
DbChangelog.prune LedgerDbPrune
sp DbChangelog l
dblog'

{-------------------------------------------------------------------------------
  Properties
-------------------------------------------------------------------------------}

-- | Changelog states and diffs appear in one either the changelog to flush or the changelog to
-- keep, moreover, the to flush changelog has no volatile states, and the to keep changelog has no
-- immutable states.
prop_flushingSplitsTheChangelog :: DbChangelogTestSetup -> Property
prop_flushingSplitsTheChangelog :: DbChangelogTestSetup -> Property
prop_flushingSplitsTheChangelog DbChangelogTestSetup
setup =
  Maybe (DiffsToFlush TestLedger) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (DiffsToFlush TestLedger)
toFlush
    Bool -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.||. ( WithOrigin SlotNo
toKeepTip WithOrigin SlotNo -> WithOrigin SlotNo -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
At SlotNo
toFlushTip
             Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. Diff Key Int -> Diff Key Int
forall k v. Diff k v -> Diff k v
DS.fromAntiDiff (DiffSeq Key Int -> Diff Key Int
forall k v. SM k v => DiffSeq k v -> Diff k v
DS.cumulativeDiff DiffSeq Key Int
DiffSeq (TxIn TestLedger) (TxOut TestLedger)
diffs)
               Diff Key Int -> Diff Key Int -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Diff Key Int
Diff (TxIn TestLedger) (TxOut TestLedger)
toFlushDiffs Diff Key Int -> Diff Key Int -> Diff Key Int
forall a. Semigroup a => a -> a -> a
<> Diff Key Int -> Diff Key Int
forall k v. Diff k v -> Diff k v
DS.fromAntiDiff (DiffSeq Key Int -> Diff Key Int
forall k v. SM k v => DiffSeq k v -> Diff k v
DS.cumulativeDiff DiffSeq Key Int
DiffSeq (TxIn TestLedger) (TxOut TestLedger)
toKeepDiffs)
         )
 where
  dblog :: DbChangelog TestLedger
dblog = DbChangelogTestSetup -> DbChangelog TestLedger
resultingDbChangelog DbChangelogTestSetup
setup
  (Maybe (DiffsToFlush TestLedger)
toFlush, DbChangelog TestLedger
toKeep) = DbChangelog TestLedger
-> (Maybe (DiffsToFlush TestLedger), DbChangelog TestLedger)
forall (l :: MapKind -> *).
(GetTip l, HasLedgerTables l) =>
DbChangelog l -> (Maybe (DiffsToFlush l), DbChangelog l)
DbChangelog.splitForFlushing DbChangelog TestLedger
dblog
  toFlushTip :: SlotNo
toFlushTip = SlotNo
-> (DiffsToFlush TestLedger -> SlotNo)
-> Maybe (DiffsToFlush TestLedger)
-> SlotNo
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SlotNo
forall a. HasCallStack => a
undefined DiffsToFlush TestLedger -> SlotNo
forall (l :: MapKind -> *). DiffsToFlush l -> SlotNo
DbChangelog.toFlushSlot Maybe (DiffsToFlush TestLedger)
toFlush
  toKeepTip :: WithOrigin SlotNo
toKeepTip = DbChangelog TestLedger -> WithOrigin SlotNo
forall (l :: MapKind -> *).
GetTip l =>
DbChangelog l -> WithOrigin SlotNo
DbChangelog.immutableTipSlot DbChangelog TestLedger
toKeep
  LedgerTables (SeqDiffMK DiffSeq (TxIn TestLedger) (TxOut TestLedger)
toKeepDiffs) = DbChangelog TestLedger -> LedgerTables TestLedger SeqDiffMK
forall (l :: MapKind -> *).
DbChangelog l -> LedgerTables l SeqDiffMK
DbChangelog.changelogDiffs DbChangelog TestLedger
toKeep
  LedgerTables (DiffMK Diff (TxIn TestLedger) (TxOut TestLedger)
toFlushDiffs) = LedgerTables TestLedger DiffMK
-> (DiffsToFlush TestLedger -> LedgerTables TestLedger DiffMK)
-> Maybe (DiffsToFlush TestLedger)
-> LedgerTables TestLedger DiffMK
forall b a. b -> (a -> b) -> Maybe a -> b
maybe LedgerTables TestLedger DiffMK
forall a. HasCallStack => a
undefined DiffsToFlush TestLedger -> LedgerTables TestLedger DiffMK
forall (l :: MapKind -> *). DiffsToFlush l -> LedgerTables l DiffMK
DbChangelog.toFlushDiffs Maybe (DiffsToFlush TestLedger)
toFlush
  LedgerTables (SeqDiffMK DiffSeq (TxIn TestLedger) (TxOut TestLedger)
diffs) = DbChangelog TestLedger -> LedgerTables TestLedger SeqDiffMK
forall (l :: MapKind -> *).
DbChangelog l -> LedgerTables l SeqDiffMK
DbChangelog.changelogDiffs DbChangelog TestLedger
dblog

-- | Extending the changelog adds the correct head to the volatile states.
prop_extendingAdvancesTipOfVolatileStates :: DbChangelogTestSetup -> Property
prop_extendingAdvancesTipOfVolatileStates :: DbChangelogTestSetup -> Property
prop_extendingAdvancesTipOfVolatileStates DbChangelogTestSetup
setup =
  Bool -> Property
forall prop. Testable prop => prop -> Property
property (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$ TestLedger DiffMK -> Point TestLedger
forall (mk :: MapKind). TestLedger mk -> Point TestLedger
tlTip TestLedger DiffMK
state Point TestLedger -> Point TestLedger -> Bool
forall a. Eq a => a -> a -> Bool
== TestLedger EmptyMK -> Point TestLedger
forall (mk :: MapKind). TestLedger mk -> Point TestLedger
tlTip TestLedger EmptyMK
new
 where
  dblog :: DbChangelog TestLedger
dblog = DbChangelogTestSetup -> DbChangelog TestLedger
resultingDbChangelog DbChangelogTestSetup
setup
  state :: TestLedger DiffMK
state = DbChangelog TestLedger -> TestLedger DiffMK
nextState DbChangelog TestLedger
dblog
  dblog' :: DbChangelog TestLedger
dblog' = TestLedger DiffMK
-> DbChangelog TestLedger -> DbChangelog TestLedger
forall (l :: MapKind -> *).
(GetTip l, HasLedgerTables l) =>
l DiffMK -> DbChangelog l -> DbChangelog l
DbChangelog.extend TestLedger DiffMK
state DbChangelog TestLedger
dblog
  new :: TestLedger EmptyMK
new = AnchoredSeq
  (WithOrigin SlotNo) (TestLedger EmptyMK) (TestLedger EmptyMK)
-> TestLedger EmptyMK
forall v a b. Anchorable v a b => AnchoredSeq v a b -> a
AS.headAnchor (DbChangelog TestLedger
-> AnchoredSeq
     (WithOrigin SlotNo) (TestLedger EmptyMK) (TestLedger EmptyMK)
forall (l :: MapKind -> *).
DbChangelog l
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
DbChangelog.changelogStates DbChangelog TestLedger
dblog')

-- | Rolling back n extensions is the same as doing nothing.
prop_rollbackAfterExtendIsNoop :: DbChangelogTestSetup -> Positive Int -> Property
prop_rollbackAfterExtendIsNoop :: DbChangelogTestSetup -> Positive Int -> Property
prop_rollbackAfterExtendIsNoop DbChangelogTestSetup
setup (Positive Int
n) =
  Bool -> Property
forall prop. Testable prop => prop -> Property
property (DbChangelog TestLedger
dblog DbChangelog TestLedger -> DbChangelog TestLedger -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe (DbChangelog TestLedger) -> DbChangelog TestLedger
forall a. HasCallStack => Maybe a -> a
fromJust (Word64 -> DbChangelog TestLedger -> Maybe (DbChangelog TestLedger)
forall (l :: MapKind -> *).
(GetTip l, HasLedgerTables l) =>
Word64 -> DbChangelog l -> Maybe (DbChangelog l)
DbChangelog.rollbackN (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) (DbChangelog TestLedger -> Maybe (DbChangelog TestLedger))
-> DbChangelog TestLedger -> Maybe (DbChangelog TestLedger)
forall a b. (a -> b) -> a -> b
$ Int -> DbChangelog TestLedger -> DbChangelog TestLedger
nExtensions Int
n DbChangelog TestLedger
dblog))
 where
  dblog :: DbChangelog TestLedger
dblog = DbChangelogTestSetup -> DbChangelog TestLedger
resultingDbChangelog DbChangelogTestSetup
setup

-- | The number of volatile states left after pruning is at most the maximum number of rollbacks.
prop_pruningLeavesAtMostMaxRollbacksVolatileStates ::
  DbChangelogTestSetup -> SecurityParam -> Property
prop_pruningLeavesAtMostMaxRollbacksVolatileStates :: DbChangelogTestSetup -> SecurityParam -> Property
prop_pruningLeavesAtMostMaxRollbacksVolatileStates DbChangelogTestSetup
setup sp :: SecurityParam
sp@(SecurityParam NonZero Word64
k) =
  Bool -> Property
forall prop. Testable prop => prop -> Property
property (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$ AnchoredSeq
  (WithOrigin SlotNo) (TestLedger EmptyMK) (TestLedger EmptyMK)
-> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AS.length (DbChangelog TestLedger
-> AnchoredSeq
     (WithOrigin SlotNo) (TestLedger EmptyMK) (TestLedger EmptyMK)
forall (l :: MapKind -> *).
DbChangelog l
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
DbChangelog.changelogStates DbChangelog TestLedger
dblog') Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero NonZero Word64
k)
 where
  dblog :: DbChangelog TestLedger
dblog = DbChangelogTestSetup -> DbChangelog TestLedger
resultingDbChangelog DbChangelogTestSetup
setup
  dblog' :: DbChangelog TestLedger
dblog' = LedgerDbPrune -> DbChangelog TestLedger -> DbChangelog TestLedger
forall (l :: MapKind -> *).
GetTip l =>
LedgerDbPrune -> DbChangelog l -> DbChangelog l
DbChangelog.prune (SecurityParam -> LedgerDbPrune
LedgerDbPruneKeeping SecurityParam
sp) DbChangelog TestLedger
dblog

-- | The rollbackToAnchor function rolls back all volatile states.
prop_rollbackToAnchorIsRollingBackVolatileStates :: DbChangelogTestSetup -> Property
prop_rollbackToAnchorIsRollingBackVolatileStates :: DbChangelogTestSetup -> Property
prop_rollbackToAnchorIsRollingBackVolatileStates DbChangelogTestSetup
setup =
  Bool -> Property
forall prop. Testable prop => prop -> Property
property (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$ DbChangelog TestLedger
rolledBack DbChangelog TestLedger -> DbChangelog TestLedger -> Bool
forall a. Eq a => a -> a -> Bool
== DbChangelog TestLedger
toAnchor
 where
  dblog :: DbChangelog TestLedger
dblog = DbChangelogTestSetup -> DbChangelog TestLedger
resultingDbChangelog DbChangelogTestSetup
setup
  n :: Int
n = AnchoredSeq
  (WithOrigin SlotNo) (TestLedger EmptyMK) (TestLedger EmptyMK)
-> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AS.length (DbChangelog TestLedger
-> AnchoredSeq
     (WithOrigin SlotNo) (TestLedger EmptyMK) (TestLedger EmptyMK)
forall (l :: MapKind -> *).
DbChangelog l
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
DbChangelog.changelogStates DbChangelog TestLedger
dblog)
  rolledBack :: DbChangelog TestLedger
rolledBack = Maybe (DbChangelog TestLedger) -> DbChangelog TestLedger
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (DbChangelog TestLedger) -> DbChangelog TestLedger)
-> Maybe (DbChangelog TestLedger) -> DbChangelog TestLedger
forall a b. (a -> b) -> a -> b
$ Word64 -> DbChangelog TestLedger -> Maybe (DbChangelog TestLedger)
forall (l :: MapKind -> *).
(GetTip l, HasLedgerTables l) =>
Word64 -> DbChangelog l -> Maybe (DbChangelog l)
DbChangelog.rollbackN (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) DbChangelog TestLedger
dblog
  toAnchor :: DbChangelog TestLedger
toAnchor = DbChangelog TestLedger -> DbChangelog TestLedger
forall (l :: MapKind -> *).
(GetTip l, HasLedgerTables l) =>
DbChangelog l -> DbChangelog l
DbChangelog.rollbackToAnchor DbChangelog TestLedger
dblog

-- | Rolling back to the last state is the same as doing nothing.
prop_rollBackToVolatileTipIsNoop ::
  Positive Int -> DbChangelogTestSetup -> Property
prop_rollBackToVolatileTipIsNoop :: Positive Int -> DbChangelogTestSetup -> Property
prop_rollBackToVolatileTipIsNoop (Positive Int
n) DbChangelogTestSetup
setup = Bool -> Property
forall prop. Testable prop => prop -> Property
property (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$ DbChangelog TestLedger -> Maybe (DbChangelog TestLedger)
forall a. a -> Maybe a
Just DbChangelog TestLedger
dblog Maybe (DbChangelog TestLedger)
-> Maybe (DbChangelog TestLedger) -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe (DbChangelog TestLedger)
dblog'
 where
  dblog :: DbChangelog TestLedger
dblog = DbChangelogTestSetup -> DbChangelog TestLedger
resultingDbChangelog DbChangelogTestSetup
setup
  pt :: Point TestLedger
pt = TestLedger EmptyMK -> Point TestLedger
forall (mk :: MapKind). TestLedger mk -> Point TestLedger
forall (l :: MapKind -> *) (mk :: MapKind).
GetTip l =>
l mk -> Point l
getTip (TestLedger EmptyMK -> Point TestLedger)
-> TestLedger EmptyMK -> Point TestLedger
forall a b. (a -> b) -> a -> b
$ DbChangelog TestLedger -> TestLedger EmptyMK
forall (l :: MapKind -> *). GetTip l => DbChangelog l -> l EmptyMK
DbChangelog.current DbChangelog TestLedger
dblog
  dblog' :: Maybe (DbChangelog TestLedger)
dblog' = Point TestLedger
-> DbChangelog TestLedger -> Maybe (DbChangelog TestLedger)
forall (l :: MapKind -> *).
(StandardHash l, GetTip l, HasLedgerTables l) =>
Point l -> DbChangelog l -> Maybe (DbChangelog l)
DbChangelog.rollbackToPoint Point TestLedger
pt (DbChangelog TestLedger -> Maybe (DbChangelog TestLedger))
-> DbChangelog TestLedger -> Maybe (DbChangelog TestLedger)
forall a b. (a -> b) -> a -> b
$ Int -> DbChangelog TestLedger -> DbChangelog TestLedger
nExtensions Int
n DbChangelog TestLedger
dblog

nExtensions :: Int -> DbChangelog TestLedger -> DbChangelog TestLedger
nExtensions :: Int -> DbChangelog TestLedger -> DbChangelog TestLedger
nExtensions Int
n DbChangelog TestLedger
dblog = (DbChangelog TestLedger -> DbChangelog TestLedger)
-> DbChangelog TestLedger -> [DbChangelog TestLedger]
forall a. (a -> a) -> a -> [a]
iterate DbChangelog TestLedger -> DbChangelog TestLedger
ext DbChangelog TestLedger
dblog [DbChangelog TestLedger] -> Int -> DbChangelog TestLedger
forall a. HasCallStack => [a] -> Int -> a
!! Int
n
 where
  ext :: DbChangelog TestLedger -> DbChangelog TestLedger
ext DbChangelog TestLedger
dblog' = TestLedger DiffMK
-> DbChangelog TestLedger -> DbChangelog TestLedger
forall (l :: MapKind -> *).
(GetTip l, HasLedgerTables l) =>
l DiffMK -> DbChangelog l -> DbChangelog l
DbChangelog.extend (DbChangelog TestLedger -> TestLedger DiffMK
nextState DbChangelog TestLedger
dblog') DbChangelog TestLedger
dblog'

{-------------------------------------------------------------------------------
  Generators
-------------------------------------------------------------------------------}

pointAtSlot :: WithOrigin SlotNo -> Point TestLedger
pointAtSlot :: WithOrigin SlotNo -> Point TestLedger
pointAtSlot = Point TestLedger
-> (SlotNo -> Point TestLedger)
-> WithOrigin SlotNo
-> Point TestLedger
forall b t. b -> (t -> b) -> WithOrigin t -> b
Point.withOrigin Point TestLedger
forall {k} (block :: k). Point block
GenesisPoint (\SlotNo
slotNo -> WithOrigin (Block SlotNo (HeaderHash TestLedger))
-> Point TestLedger
forall {k} (block :: k).
WithOrigin (Block SlotNo (HeaderHash block)) -> Point block
Point (WithOrigin (Block SlotNo (HeaderHash TestLedger))
 -> Point TestLedger)
-> WithOrigin (Block SlotNo (HeaderHash TestLedger))
-> Point TestLedger
forall a b. (a -> b) -> a -> b
$ Block SlotNo (HeaderHash TestLedger)
-> WithOrigin (Block SlotNo (HeaderHash TestLedger))
forall t. t -> WithOrigin t
At (Block SlotNo (HeaderHash TestLedger)
 -> WithOrigin (Block SlotNo (HeaderHash TestLedger)))
-> Block SlotNo (HeaderHash TestLedger)
-> WithOrigin (Block SlotNo (HeaderHash TestLedger))
forall a b. (a -> b) -> a -> b
$ SlotNo -> H -> Block SlotNo H
forall slot hash. slot -> hash -> Block slot hash
Point.Block SlotNo
slotNo H
H)

type Key = T.Text

data GenOperationsState = GenOperationsState
  { GenOperationsState -> WithOrigin SlotNo
gosSlotNo :: !(WithOrigin SlotNo)
  -- ^ The current slot number on the sequence of generated operations
  , GenOperationsState -> [Operation TestLedger]
gosOps :: ![Operation TestLedger]
  -- ^ Accumulation of operations
  , GenOperationsState -> Map Key Int
gosActiveUtxos :: !(Map Key Int)
  -- ^ UTxOs in the UTxO set
  , GenOperationsState -> Map Key Int
gosPendingInsertions :: !(Map Key Int)
  -- ^ UTxOs for which an insertion has been generated
  --
  -- Just after generation, they will be moved to 'gosActiveUtxos'
  , GenOperationsState -> Set Key
gosConsumedUtxos :: !(Set Key)
  -- ^ UTxOs for which a delete has been generated
  }
  deriving Int -> GenOperationsState -> ShowS
[GenOperationsState] -> ShowS
GenOperationsState -> TestName
(Int -> GenOperationsState -> ShowS)
-> (GenOperationsState -> TestName)
-> ([GenOperationsState] -> ShowS)
-> Show GenOperationsState
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GenOperationsState -> ShowS
showsPrec :: Int -> GenOperationsState -> ShowS
$cshow :: GenOperationsState -> TestName
show :: GenOperationsState -> TestName
$cshowList :: [GenOperationsState] -> ShowS
showList :: [GenOperationsState] -> ShowS
Show

applyPending :: GenOperationsState -> GenOperationsState
applyPending :: GenOperationsState -> GenOperationsState
applyPending GenOperationsState
gosState =
  GenOperationsState
gosState
    { gosActiveUtxos = Map.union (gosActiveUtxos gosState) (gosPendingInsertions gosState)
    , gosPendingInsertions = Map.empty
    }

genOperations :: WithOrigin SlotNo -> Int -> Gen [Operation TestLedger]
genOperations :: WithOrigin SlotNo -> Int -> Gen [Operation TestLedger]
genOperations WithOrigin SlotNo
slotNo Int
nOps = GenOperationsState -> [Operation TestLedger]
gosOps (GenOperationsState -> [Operation TestLedger])
-> Gen GenOperationsState -> Gen [Operation TestLedger]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT GenOperationsState Gen ()
-> GenOperationsState -> Gen GenOperationsState
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (Int
-> StateT GenOperationsState Gen ()
-> StateT GenOperationsState Gen ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
nOps StateT GenOperationsState Gen ()
genOperation) GenOperationsState
initState
 where
  initState :: GenOperationsState
initState =
    GenOperationsState
      { gosSlotNo :: WithOrigin SlotNo
gosSlotNo = WithOrigin SlotNo
slotNo
      , gosActiveUtxos :: Map Key Int
gosActiveUtxos = Map Key Int
forall k a. Map k a
Map.empty
      , gosPendingInsertions :: Map Key Int
gosPendingInsertions = Map Key Int
forall k a. Map k a
Map.empty
      , gosConsumedUtxos :: Set Key
gosConsumedUtxos = Set Key
forall a. Set a
Set.empty
      , gosOps :: [Operation TestLedger]
gosOps = []
      }

  genOperation :: StateT GenOperationsState Gen ()
  genOperation :: StateT GenOperationsState Gen ()
genOperation = do
    op <- [(Int, StateT GenOperationsState Gen (Operation TestLedger))]
-> StateT GenOperationsState Gen (Operation TestLedger)
forall (t :: (* -> *) -> * -> *) a.
(MonadTrans t, Monad (t Gen)) =>
[(Int, t Gen a)] -> t Gen a
frequency' [(Int
1, StateT GenOperationsState Gen (Operation TestLedger)
genPrune), (Int
10, StateT GenOperationsState Gen (Operation TestLedger)
genExtend)]
    modify' $ \GenOperationsState
st -> GenOperationsState
st{gosOps = op : gosOps st}

  genPrune :: StateT GenOperationsState Gen (Operation TestLedger)
  genPrune :: StateT GenOperationsState Gen (Operation TestLedger)
genPrune =
    LedgerDbPrune -> Operation TestLedger
forall (l :: MapKind -> *). LedgerDbPrune -> Operation l
Prune
      (LedgerDbPrune -> Operation TestLedger)
-> StateT GenOperationsState Gen LedgerDbPrune
-> StateT GenOperationsState Gen (Operation TestLedger)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen LedgerDbPrune -> StateT GenOperationsState Gen LedgerDbPrune
forall (m :: * -> *) a.
Monad m =>
m a -> StateT GenOperationsState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
        ( [Gen LedgerDbPrune] -> Gen LedgerDbPrune
forall a. HasCallStack => [Gen a] -> Gen a
oneof
            [ LedgerDbPrune -> Gen LedgerDbPrune
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LedgerDbPrune
LedgerDbPruneAll
            , SecurityParam -> LedgerDbPrune
LedgerDbPruneKeeping (SecurityParam -> LedgerDbPrune)
-> (Word64 -> SecurityParam) -> Word64 -> LedgerDbPrune
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonZero Word64 -> SecurityParam
SecurityParam (NonZero Word64 -> SecurityParam)
-> (Word64 -> NonZero Word64) -> Word64 -> SecurityParam
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> NonZero Word64
forall a. a -> NonZero a
unsafeNonZero (Word64 -> LedgerDbPrune) -> Gen Word64 -> Gen LedgerDbPrune
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
10)
            ]
        )

  genExtend :: StateT GenOperationsState Gen (Operation TestLedger)
  genExtend :: StateT GenOperationsState Gen (Operation TestLedger)
genExtend = do
    nextSlotNo <- SlotNo -> StateT GenOperationsState Gen (WithOrigin SlotNo)
advanceSlotNo (SlotNo -> StateT GenOperationsState Gen (WithOrigin SlotNo))
-> StateT GenOperationsState Gen SlotNo
-> StateT GenOperationsState Gen (WithOrigin SlotNo)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Gen SlotNo -> StateT GenOperationsState Gen SlotNo
forall (m :: * -> *) a.
Monad m =>
m a -> StateT GenOperationsState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ((SlotNo, SlotNo) -> Gen SlotNo
forall a. Enum a => (a, a) -> Gen a
chooseEnum (SlotNo
1, SlotNo
5))
    d <- genUtxoDiff
    pure $ Extend $ TestLedger (DiffMK $ DS.fromAntiDiff d) (castPoint $ pointAtSlot nextSlotNo)

  advanceSlotNo :: SlotNo -> StateT GenOperationsState Gen (WithOrigin SlotNo)
  advanceSlotNo :: SlotNo -> StateT GenOperationsState Gen (WithOrigin SlotNo)
advanceSlotNo SlotNo
by = do
    nextSlotNo <- (GenOperationsState -> WithOrigin SlotNo)
-> StateT GenOperationsState Gen (WithOrigin SlotNo)
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets (SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
At (SlotNo -> WithOrigin SlotNo)
-> (GenOperationsState -> SlotNo)
-> GenOperationsState
-> WithOrigin SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlotNo -> (SlotNo -> SlotNo) -> WithOrigin SlotNo -> SlotNo
forall b t. b -> (t -> b) -> WithOrigin t -> b
Point.withOrigin SlotNo
by (SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
by) (WithOrigin SlotNo -> SlotNo)
-> (GenOperationsState -> WithOrigin SlotNo)
-> GenOperationsState
-> SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenOperationsState -> WithOrigin SlotNo
gosSlotNo)
    modify' $ \GenOperationsState
st -> GenOperationsState
st{gosSlotNo = nextSlotNo}
    pure nextSlotNo

  genUtxoDiff :: StateT GenOperationsState Gen (Diff.Diff Key Int)
  genUtxoDiff :: StateT GenOperationsState Gen (Diff Key Int)
genUtxoDiff = do
    nEntries <- Gen Int -> StateT GenOperationsState Gen Int
forall (m :: * -> *) a.
Monad m =>
m a -> StateT GenOperationsState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen Int -> StateT GenOperationsState Gen Int)
-> Gen Int -> StateT GenOperationsState Gen Int
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Gen Int
chooseInt (Int
1, Int
10)
    entries <- replicateM nEntries genUtxoDiffEntry
    modify' applyPending
    pure $ Diff.fromList entries

  genUtxoDiffEntry :: StateT GenOperationsState Gen (Key, Diff.Delta Int)
  genUtxoDiffEntry :: StateT GenOperationsState Gen (Key, Delta Int)
genUtxoDiffEntry = do
    activeUtxos <- (GenOperationsState -> Map Key Int)
-> StateT GenOperationsState Gen (Map Key Int)
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets GenOperationsState -> Map Key Int
gosActiveUtxos
    consumedUtxos <- gets gosConsumedUtxos
    oneof' $
      catMaybes
        [ genDelEntry activeUtxos
        , genInsertEntry consumedUtxos
        ]

  genDelEntry :: Map Key Int -> Maybe (StateT GenOperationsState Gen (Key, Diff.Delta Int))
  genDelEntry :: Map Key Int
-> Maybe (StateT GenOperationsState Gen (Key, Delta Int))
genDelEntry Map Key Int
activeUtxos =
    if Map Key Int -> Bool
forall k a. Map k a -> Bool
Map.null Map Key Int
activeUtxos
      then Maybe (StateT GenOperationsState Gen (Key, Delta Int))
forall a. Maybe a
Nothing
      else StateT GenOperationsState Gen (Key, Delta Int)
-> Maybe (StateT GenOperationsState Gen (Key, Delta Int))
forall a. a -> Maybe a
Just (StateT GenOperationsState Gen (Key, Delta Int)
 -> Maybe (StateT GenOperationsState Gen (Key, Delta Int)))
-> StateT GenOperationsState Gen (Key, Delta Int)
-> Maybe (StateT GenOperationsState Gen (Key, Delta Int))
forall a b. (a -> b) -> a -> b
$ do
        (k, _) <- Gen (Key, Int) -> StateT GenOperationsState Gen (Key, Int)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT GenOperationsState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen (Key, Int) -> StateT GenOperationsState Gen (Key, Int))
-> Gen (Key, Int) -> StateT GenOperationsState Gen (Key, Int)
forall a b. (a -> b) -> a -> b
$ [(Key, Int)] -> Gen (Key, Int)
forall a. HasCallStack => [a] -> Gen a
elements (Map Key Int -> [(Key, Int)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Key Int
activeUtxos)
        modify' $ \GenOperationsState
st ->
          GenOperationsState
st
            { gosActiveUtxos = Map.delete k (gosActiveUtxos st)
            }
        pure (k, Diff.Delete)

  genInsertEntry :: Set Key -> Maybe (StateT GenOperationsState Gen (Key, Diff.Delta Int))
  genInsertEntry :: Set Key -> Maybe (StateT GenOperationsState Gen (Key, Delta Int))
genInsertEntry Set Key
consumedUtxos = StateT GenOperationsState Gen (Key, Delta Int)
-> Maybe (StateT GenOperationsState Gen (Key, Delta Int))
forall a. a -> Maybe a
Just (StateT GenOperationsState Gen (Key, Delta Int)
 -> Maybe (StateT GenOperationsState Gen (Key, Delta Int)))
-> StateT GenOperationsState Gen (Key, Delta Int)
-> Maybe (StateT GenOperationsState Gen (Key, Delta Int))
forall a b. (a -> b) -> a -> b
$ do
    k <- Gen Key -> StateT GenOperationsState Gen Key
forall (m :: * -> *) a.
Monad m =>
m a -> StateT GenOperationsState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen Key -> StateT GenOperationsState Gen Key)
-> Gen Key -> StateT GenOperationsState Gen Key
forall a b. (a -> b) -> a -> b
$ Gen Key
genKey Gen Key -> (Key -> Bool) -> Gen Key
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (Key -> Set Key -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Key
consumedUtxos)
    v <- lift arbitrary
    modify' $ \GenOperationsState
st ->
      GenOperationsState
st
        { gosPendingInsertions = Map.insert k v (gosPendingInsertions st)
        , gosConsumedUtxos = Set.insert k (gosConsumedUtxos st)
        }
    pure (k, Diff.Insert v)

genKey :: Gen Key
genKey :: Gen Key
genKey = TestName -> Key
T.pack (TestName -> Key) -> Gen TestName -> Gen Key
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen Char -> Gen TestName
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
2 (TestName -> Gen Char
forall a. HasCallStack => [a] -> Gen a
elements [Char
'A' .. Char
'Z'])