{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}

{-# OPTIONS_GHC -Wno-orphans #-}

-- | In-memory 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.InMemory (tests) where

import           Codec.CBOR.FlatTerm (FlatTerm, TermToken (..), fromFlatTerm,
                     toFlatTerm)
import           Codec.Serialise (decode, encode)
import           Data.Maybe (fromJust)
import           Data.Word
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
import           Ouroboros.Consensus.Util
import           Test.Ouroboros.Storage.LedgerDB.OrphanArbitrary ()
import           Test.QuickCheck
import           Test.Tasty
import           Test.Tasty.HUnit
import           Test.Tasty.QuickCheck
import           Test.Util.QuickCheck
import           Test.Util.TestBlock

tests :: TestTree
tests :: TestTree
tests = String -> [TestTree] -> TestTree
testGroup String
"InMemory" [
      String -> [TestTree] -> TestTree
testGroup String
"Serialisation" [
          String -> Assertion -> TestTree
testCase     String
"encode"                 Assertion
test_encode_ledger
        , String -> Assertion -> TestTree
testCase     String
"decode"                 Assertion
test_decode_ledger
        , String -> Assertion -> TestTree
testCase     String
"decode ChainSummary"    Assertion
test_decode_ChainSummary
        ]
    , String -> [TestTree] -> TestTree
testGroup String
"Genesis" [
          String -> Property -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"current"                Property
prop_genesisCurrent
        ]
    , String -> [TestTree] -> TestTree
testGroup String
"Push" [
          String -> (ChainSetup -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"expectedLedger"         ChainSetup -> Property
prop_pushExpectedLedger
        , String -> (ChainSetup -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"pastLedger"             ChainSetup -> Property
prop_pastLedger
        ]
    , String -> [TestTree] -> TestTree
testGroup String
"Rollback" [
          String -> Property -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"maxRollbackGenesisZero" Property
prop_maxRollbackGenesisZero
        , String -> (ChainSetup -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"ledgerDbMaxRollback"    ChainSetup -> Property
prop_snapshotsMaxRollback
        , String -> (SwitchSetup -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"switchSameChain"        SwitchSetup -> Property
prop_switchSameChain
        , String -> (SwitchSetup -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"switchExpectedLedger"   SwitchSetup -> Property
prop_switchExpectedLedger
        , String -> (SwitchSetup -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"pastAfterSwitch"        SwitchSetup -> Property
prop_pastAfterSwitch
        ]
    ]

{-------------------------------------------------------------------------------
  Serialisation
-------------------------------------------------------------------------------}

-- | The LedgerDB is parametric in the ledger @l@. We use @Int@ for simplicity.
example_ledger :: Int
example_ledger :: Int
example_ledger = Int
100

golden_ledger :: FlatTerm
golden_ledger :: FlatTerm
golden_ledger =
    [ Word -> TermToken
TkListLen Word
2
      -- VersionNumber
    , Int -> TermToken
TkInt Int
1
      -- ledger: Int
    , Int -> TermToken
TkInt Int
100
    ]

-- | The old format based on the @ChainSummary@. To remain backwards compatible
-- we still accept this old format.
golden_ChainSummary :: FlatTerm
golden_ChainSummary :: FlatTerm
golden_ChainSummary =
    [ Word -> TermToken
TkListLen Word
3
      -- tip: WithOrigin (RealPoint TestBlock)
    , Word -> TermToken
TkListLen Word
1
    , Word -> TermToken
TkListLen Word
2
    , Int -> TermToken
TkInt Int
3
    , TermToken
TkListBegin, Int -> TermToken
TkInt Int
0, Int -> TermToken
TkInt Int
0, TermToken
TkBreak
      -- chain length: Word64
    , Int -> TermToken
TkInt Int
10
      -- ledger: Int for simplicity
    , Int -> TermToken
TkInt Int
100
    ]

test_encode_ledger :: Assertion
test_encode_ledger :: Assertion
test_encode_ledger =
    Encoding -> FlatTerm
toFlatTerm (Int -> Encoding
enc Int
example_ledger) FlatTerm -> FlatTerm -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= FlatTerm
golden_ledger
  where
    enc :: Int -> Encoding
enc = (Int -> Encoding) -> Int -> Encoding
forall l. (l -> Encoding) -> l -> Encoding
encodeSnapshot Int -> Encoding
forall a. Serialise a => a -> Encoding
encode

test_decode_ledger :: Assertion
test_decode_ledger :: Assertion
test_decode_ledger =
    (forall s. Decoder s Int) -> FlatTerm -> Either String Int
forall a. (forall s. Decoder s a) -> FlatTerm -> Either String a
fromFlatTerm Decoder s Int
forall s. Decoder s Int
dec FlatTerm
golden_ledger Either String Int -> Either String Int -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Int -> Either String Int
forall a b. b -> Either a b
Right Int
example_ledger
  where
    dec :: Decoder s Int
dec = Proxy TestBlock
-> (forall s. Decoder s Int)
-> (forall s. Decoder s (HeaderHash TestBlock))
-> forall s. Decoder s Int
forall l blk.
Proxy blk
-> (forall s. Decoder s l)
-> (forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s l
decodeSnapshotBackwardsCompatible (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @TestBlock) Decoder s Int
forall s. Decoder s Int
forall a s. Serialise a => Decoder s a
decode Decoder s (HeaderHash TestBlock)
Decoder s TestHash
forall s. Decoder s (HeaderHash TestBlock)
forall s. Decoder s TestHash
forall a s. Serialise a => Decoder s a
decode

-- | For backwards compatibility
test_decode_ChainSummary :: Assertion
test_decode_ChainSummary :: Assertion
test_decode_ChainSummary =
    (forall s. Decoder s Int) -> FlatTerm -> Either String Int
forall a. (forall s. Decoder s a) -> FlatTerm -> Either String a
fromFlatTerm Decoder s Int
forall s. Decoder s Int
dec FlatTerm
golden_ChainSummary Either String Int -> Either String Int -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Int -> Either String Int
forall a b. b -> Either a b
Right Int
example_ledger
  where
    dec :: Decoder s Int
dec = Proxy TestBlock
-> (forall s. Decoder s Int)
-> (forall s. Decoder s (HeaderHash TestBlock))
-> forall s. Decoder s Int
forall l blk.
Proxy blk
-> (forall s. Decoder s l)
-> (forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s l
decodeSnapshotBackwardsCompatible (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @TestBlock) Decoder s Int
forall s. Decoder s Int
forall a s. Serialise a => Decoder s a
decode Decoder s (HeaderHash TestBlock)
Decoder s TestHash
forall s. Decoder s (HeaderHash TestBlock)
forall s. Decoder s TestHash
forall a s. Serialise a => Decoder s a
decode

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

prop_genesisCurrent :: Property
prop_genesisCurrent :: Property
prop_genesisCurrent =
    LedgerDB (LedgerState TestBlock) -> LedgerState TestBlock
forall l. GetTip l => LedgerDB l -> l
ledgerDbCurrent LedgerDB (LedgerState TestBlock)
genSnaps LedgerState TestBlock -> LedgerState TestBlock -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== LedgerState TestBlock
testInitLedger
  where
    genSnaps :: LedgerDB (LedgerState TestBlock)
genSnaps = LedgerState TestBlock -> LedgerDB (LedgerState TestBlock)
forall l. GetTip l => l -> LedgerDB l
ledgerDbWithAnchor LedgerState TestBlock
testInitLedger

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

prop_pushExpectedLedger :: ChainSetup -> Property
prop_pushExpectedLedger :: ChainSetup -> Property
prop_pushExpectedLedger setup :: ChainSetup
setup@ChainSetup{[TestBlock]
Word64
SecurityParam
LedgerDB (LedgerState TestBlock)
csSecParam :: SecurityParam
csNumBlocks :: Word64
csPrefixLen :: Word64
csGenSnaps :: LedgerDB (LedgerState TestBlock)
csChain :: [TestBlock]
csPushed :: LedgerDB (LedgerState TestBlock)
csSecParam :: ChainSetup -> SecurityParam
csNumBlocks :: ChainSetup -> Word64
csPrefixLen :: ChainSetup -> Word64
csGenSnaps :: ChainSetup -> LedgerDB (LedgerState TestBlock)
csChain :: ChainSetup -> [TestBlock]
csPushed :: ChainSetup -> LedgerDB (LedgerState TestBlock)
..} =
    Bool -> String -> Property -> Property
forall prop. Testable prop => Bool -> String -> prop -> Property
classify (ChainSetup -> Bool
chainSetupSaturated ChainSetup
setup) String
"saturated" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
      [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin [
          LedgerState TestBlock
l LedgerState TestBlock -> LedgerState TestBlock -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== LedgerCfg (LedgerState TestBlock)
-> [TestBlock] -> LedgerState TestBlock -> LedgerState TestBlock
forall l blk. ApplyBlock l blk => LedgerCfg l -> [blk] -> l -> l
refoldLedger LedgerCfg (LedgerState TestBlock)
cfg (Word64 -> [TestBlock]
expectedChain Word64
o) LedgerState TestBlock
testInitLedger
        | (Word64
o, LedgerState TestBlock
l) <- LedgerDB (LedgerState TestBlock)
-> [(Word64, LedgerState TestBlock)]
forall l. LedgerDB l -> [(Word64, l)]
ledgerDbSnapshots LedgerDB (LedgerState TestBlock)
csPushed
        ]
  where
    expectedChain :: Word64 -> [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
    cfg :: LedgerCfg (LedgerState TestBlock)
cfg = LedgerDbCfg (LedgerState TestBlock)
-> LedgerCfg (LedgerState TestBlock)
forall l. LedgerDbCfg l -> LedgerCfg l
ledgerDbCfg (ChainSetup -> LedgerDbCfg (LedgerState TestBlock)
csBlockConfig ChainSetup
setup)

prop_pastLedger :: ChainSetup -> Property
prop_pastLedger :: ChainSetup -> Property
prop_pastLedger setup :: ChainSetup
setup@ChainSetup{[TestBlock]
Word64
SecurityParam
LedgerDB (LedgerState TestBlock)
csSecParam :: ChainSetup -> SecurityParam
csNumBlocks :: ChainSetup -> Word64
csPrefixLen :: ChainSetup -> Word64
csGenSnaps :: ChainSetup -> LedgerDB (LedgerState TestBlock)
csChain :: ChainSetup -> [TestBlock]
csPushed :: ChainSetup -> LedgerDB (LedgerState TestBlock)
csSecParam :: SecurityParam
csNumBlocks :: Word64
csPrefixLen :: Word64
csGenSnaps :: LedgerDB (LedgerState TestBlock)
csChain :: [TestBlock]
csPushed :: LedgerDB (LedgerState TestBlock)
..} =
    Bool -> String -> Property -> Property
forall prop. Testable prop => Bool -> String -> prop -> Property
classify (ChainSetup -> Bool
chainSetupSaturated ChainSetup
setup) String
"saturated"    (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    Bool -> String -> Property -> Property
forall prop. Testable prop => Bool -> String -> prop -> Property
classify Bool
withinReach                 String
"within reach" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          Point TestBlock
-> LedgerDB (LedgerState TestBlock)
-> Maybe (LedgerState TestBlock)
forall blk l.
(HasHeader blk, IsLedger l, HeaderHash l ~ HeaderHash blk) =>
Point blk -> LedgerDB l -> Maybe l
ledgerDbPast Point TestBlock
tip LedgerDB (LedgerState TestBlock)
csPushed
      Maybe (LedgerState TestBlock)
-> Maybe (LedgerState TestBlock) -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== if Bool
withinReach
            then LedgerState TestBlock -> Maybe (LedgerState TestBlock)
forall a. a -> Maybe a
Just (LedgerDB (LedgerState TestBlock) -> LedgerState TestBlock
forall l. GetTip l => LedgerDB l -> l
ledgerDbCurrent LedgerDB (LedgerState TestBlock)
afterPrefix)
            else Maybe (LedgerState TestBlock)
forall a. Maybe a
Nothing
  where
    prefix :: [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
    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 :: LedgerDB (LedgerState TestBlock)
    afterPrefix :: LedgerDB (LedgerState TestBlock)
afterPrefix = LedgerDbCfg (LedgerState TestBlock)
-> [TestBlock]
-> LedgerDB (LedgerState TestBlock)
-> LedgerDB (LedgerState TestBlock)
forall l blk.
ApplyBlock l blk =>
LedgerDbCfg l -> [blk] -> LedgerDB l -> LedgerDB l
ledgerDbPushMany' (ChainSetup -> LedgerDbCfg (LedgerState TestBlock)
csBlockConfig ChainSetup
setup) [TestBlock]
prefix LedgerDB (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
<= LedgerDB (LedgerState TestBlock) -> Word64
forall l. GetTip l => LedgerDB l -> Word64
ledgerDbMaxRollback LedgerDB (LedgerState TestBlock)
csPushed

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

prop_maxRollbackGenesisZero :: Property
prop_maxRollbackGenesisZero :: Property
prop_maxRollbackGenesisZero =
        LedgerDB (LedgerState TestBlock) -> Word64
forall l. GetTip l => LedgerDB l -> Word64
ledgerDbMaxRollback (LedgerState TestBlock -> LedgerDB (LedgerState TestBlock)
forall l. GetTip l => l -> LedgerDB l
ledgerDbWithAnchor LedgerState 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
LedgerDB (LedgerState TestBlock)
csSecParam :: ChainSetup -> SecurityParam
csNumBlocks :: ChainSetup -> Word64
csPrefixLen :: ChainSetup -> Word64
csGenSnaps :: ChainSetup -> LedgerDB (LedgerState TestBlock)
csChain :: ChainSetup -> [TestBlock]
csPushed :: ChainSetup -> LedgerDB (LedgerState TestBlock)
csSecParam :: SecurityParam
csNumBlocks :: Word64
csPrefixLen :: Word64
csGenSnaps :: LedgerDB (LedgerState TestBlock)
csChain :: [TestBlock]
csPushed :: LedgerDB (LedgerState TestBlock)
..} =
    Bool -> String -> Property -> Property
forall prop. Testable prop => Bool -> String -> prop -> Property
classify (ChainSetup -> Bool
chainSetupSaturated ChainSetup
setup) String
"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 (LedgerDB (LedgerState TestBlock) -> Word64
forall l. GetTip l => LedgerDB l -> Word64
ledgerDbMaxRollback LedgerDB (LedgerState TestBlock)
csPushed) Word64 -> Word64 -> Property
forall a. (Ord a, Show a) => a -> a -> Property
`ge` Word64
k
            else (LedgerDB (LedgerState TestBlock) -> Word64
forall l. GetTip l => LedgerDB l -> Word64
ledgerDbMaxRollback LedgerDB (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 Word64
k Word64
csNumBlocks)
        , (LedgerDB (LedgerState TestBlock) -> Word64
forall l. GetTip l => LedgerDB l -> Word64
ledgerDbMaxRollback LedgerDB (LedgerState TestBlock)
csPushed) Word64 -> Word64 -> Property
forall a. (Ord a, Show a) => a -> a -> Property
`le` Word64
k
        ]
  where
    SecurityParam Word64
k = SecurityParam
csSecParam

prop_switchSameChain :: SwitchSetup -> Property
prop_switchSameChain :: SwitchSetup -> Property
prop_switchSameChain setup :: SwitchSetup
setup@SwitchSetup{[TestBlock]
Word64
LedgerDB (LedgerState TestBlock)
ChainSetup
ssChainSetup :: ChainSetup
ssNumRollback :: Word64
ssNumNew :: Word64
ssPrefixLen :: Word64
ssNumBlocks :: Word64
ssRemoved :: [TestBlock]
ssNewBlocks :: [TestBlock]
ssChain :: [TestBlock]
ssSwitched :: LedgerDB (LedgerState TestBlock)
ssChainSetup :: SwitchSetup -> ChainSetup
ssNumRollback :: SwitchSetup -> Word64
ssNumNew :: SwitchSetup -> Word64
ssPrefixLen :: SwitchSetup -> Word64
ssNumBlocks :: SwitchSetup -> Word64
ssRemoved :: SwitchSetup -> [TestBlock]
ssNewBlocks :: SwitchSetup -> [TestBlock]
ssChain :: SwitchSetup -> [TestBlock]
ssSwitched :: SwitchSetup -> LedgerDB (LedgerState TestBlock)
..} =
    Bool -> String -> Property -> Property
forall prop. Testable prop => Bool -> String -> prop -> Property
classify (SwitchSetup -> Bool
switchSetupSaturated SwitchSetup
setup) String
"saturated" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          LedgerDbCfg (LedgerState TestBlock)
-> Word64
-> [TestBlock]
-> LedgerDB (LedgerState TestBlock)
-> Maybe (LedgerDB (LedgerState TestBlock))
forall l blk.
ApplyBlock l blk =>
LedgerDbCfg l
-> Word64 -> [blk] -> LedgerDB l -> Maybe (LedgerDB l)
ledgerDbSwitch' (ChainSetup -> LedgerDbCfg (LedgerState TestBlock)
csBlockConfig ChainSetup
ssChainSetup) Word64
ssNumRollback [TestBlock]
blockInfo LedgerDB (LedgerState TestBlock)
csPushed
      Maybe (LedgerDB (LedgerState TestBlock))
-> Maybe (LedgerDB (LedgerState TestBlock)) -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== LedgerDB (LedgerState TestBlock)
-> Maybe (LedgerDB (LedgerState TestBlock))
forall a. a -> Maybe a
Just LedgerDB (LedgerState TestBlock)
csPushed
  where
    ChainSetup{LedgerDB (LedgerState TestBlock)
csPushed :: ChainSetup -> LedgerDB (LedgerState TestBlock)
csPushed :: LedgerDB (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
LedgerDB (LedgerState TestBlock)
ChainSetup
ssChainSetup :: SwitchSetup -> ChainSetup
ssNumRollback :: SwitchSetup -> Word64
ssNumNew :: SwitchSetup -> Word64
ssPrefixLen :: SwitchSetup -> Word64
ssNumBlocks :: SwitchSetup -> Word64
ssRemoved :: SwitchSetup -> [TestBlock]
ssNewBlocks :: SwitchSetup -> [TestBlock]
ssChain :: SwitchSetup -> [TestBlock]
ssSwitched :: SwitchSetup -> LedgerDB (LedgerState TestBlock)
ssChainSetup :: ChainSetup
ssNumRollback :: Word64
ssNumNew :: Word64
ssPrefixLen :: Word64
ssNumBlocks :: Word64
ssRemoved :: [TestBlock]
ssNewBlocks :: [TestBlock]
ssChain :: [TestBlock]
ssSwitched :: LedgerDB (LedgerState TestBlock)
..} =
    Bool -> String -> Property -> Property
forall prop. Testable prop => Bool -> String -> prop -> Property
classify (SwitchSetup -> Bool
switchSetupSaturated SwitchSetup
setup) String
"saturated" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
      [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin [
          LedgerState TestBlock
l LedgerState TestBlock -> LedgerState TestBlock -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== LedgerCfg (LedgerState TestBlock)
-> [TestBlock] -> LedgerState TestBlock -> LedgerState TestBlock
forall l blk. ApplyBlock l blk => LedgerCfg l -> [blk] -> l -> l
refoldLedger LedgerCfg (LedgerState TestBlock)
cfg (Word64 -> [TestBlock]
expectedChain Word64
o) LedgerState TestBlock
testInitLedger
        | (Word64
o, LedgerState TestBlock
l) <- LedgerDB (LedgerState TestBlock)
-> [(Word64, LedgerState TestBlock)]
forall l. LedgerDB l -> [(Word64, l)]
ledgerDbSnapshots LedgerDB (LedgerState TestBlock)
ssSwitched
        ]
  where
    expectedChain :: Word64 -> [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
    cfg :: LedgerCfg (LedgerState TestBlock)
cfg = LedgerDbCfg (LedgerState TestBlock)
-> LedgerCfg (LedgerState TestBlock)
forall l. LedgerDbCfg l -> LedgerCfg l
ledgerDbCfg (ChainSetup -> LedgerDbCfg (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
LedgerDB (LedgerState TestBlock)
ChainSetup
ssChainSetup :: SwitchSetup -> ChainSetup
ssNumRollback :: SwitchSetup -> Word64
ssNumNew :: SwitchSetup -> Word64
ssPrefixLen :: SwitchSetup -> Word64
ssNumBlocks :: SwitchSetup -> Word64
ssRemoved :: SwitchSetup -> [TestBlock]
ssNewBlocks :: SwitchSetup -> [TestBlock]
ssChain :: SwitchSetup -> [TestBlock]
ssSwitched :: SwitchSetup -> LedgerDB (LedgerState TestBlock)
ssChainSetup :: ChainSetup
ssNumRollback :: Word64
ssNumNew :: Word64
ssPrefixLen :: Word64
ssNumBlocks :: Word64
ssRemoved :: [TestBlock]
ssNewBlocks :: [TestBlock]
ssChain :: [TestBlock]
ssSwitched :: LedgerDB (LedgerState TestBlock)
..} =
    Bool -> String -> Property -> Property
forall prop. Testable prop => Bool -> String -> prop -> Property
classify (SwitchSetup -> Bool
switchSetupSaturated SwitchSetup
setup) String
"saturated"    (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    Bool -> String -> Property -> Property
forall prop. Testable prop => Bool -> String -> prop -> Property
classify Bool
withinReach                  String
"within reach" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          Point TestBlock
-> LedgerDB (LedgerState TestBlock)
-> Maybe (LedgerState TestBlock)
forall blk l.
(HasHeader blk, IsLedger l, HeaderHash l ~ HeaderHash blk) =>
Point blk -> LedgerDB l -> Maybe l
ledgerDbPast Point TestBlock
tip LedgerDB (LedgerState TestBlock)
ssSwitched
      Maybe (LedgerState TestBlock)
-> Maybe (LedgerState TestBlock) -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== if Bool
withinReach
            then LedgerState TestBlock -> Maybe (LedgerState TestBlock)
forall a. a -> Maybe a
Just (LedgerDB (LedgerState TestBlock) -> LedgerState TestBlock
forall l. GetTip l => LedgerDB l -> l
ledgerDbCurrent LedgerDB (LedgerState TestBlock)
afterPrefix)
            else Maybe (LedgerState TestBlock)
forall a. Maybe a
Nothing
  where
    prefix :: [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
    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 :: LedgerDB (LedgerState TestBlock)
    afterPrefix :: LedgerDB (LedgerState TestBlock)
afterPrefix = LedgerDbCfg (LedgerState TestBlock)
-> [TestBlock]
-> LedgerDB (LedgerState TestBlock)
-> LedgerDB (LedgerState TestBlock)
forall l blk.
ApplyBlock l blk =>
LedgerDbCfg l -> [blk] -> LedgerDB l -> LedgerDB l
ledgerDbPushMany' (ChainSetup -> LedgerDbCfg (LedgerState TestBlock)
csBlockConfig ChainSetup
ssChainSetup) [TestBlock]
prefix (ChainSetup -> LedgerDB (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
<= LedgerDB (LedgerState TestBlock) -> Word64
forall l. GetTip l => LedgerDB l -> Word64
ledgerDbMaxRollback LedgerDB (LedgerState TestBlock)
ssSwitched

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

data ChainSetup = ChainSetup {
      -- | Security parameter
      ChainSetup -> SecurityParam
csSecParam  :: SecurityParam

      -- | Number of blocks applied
    , ChainSetup -> Word64
csNumBlocks :: 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 -> Word64
csPrefixLen :: Word64

      -- | Derived: genesis snapshots
    , ChainSetup -> LedgerDB (LedgerState TestBlock)
csGenSnaps  :: LedgerDB (LedgerState TestBlock)

      -- | Derived: the actual blocks that got applied (old to new)
    , ChainSetup -> [TestBlock]
csChain     :: [TestBlock]

      -- | Derived: the snapshots after all blocks were applied
    , ChainSetup -> LedgerDB (LedgerState TestBlock)
csPushed    :: LedgerDB (LedgerState TestBlock)
    }
  deriving (Int -> ChainSetup -> ShowS
[ChainSetup] -> ShowS
ChainSetup -> String
(Int -> ChainSetup -> ShowS)
-> (ChainSetup -> String)
-> ([ChainSetup] -> ShowS)
-> Show ChainSetup
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ChainSetup -> ShowS
showsPrec :: Int -> ChainSetup -> ShowS
$cshow :: ChainSetup -> String
show :: ChainSetup -> String
$cshowList :: [ChainSetup] -> ShowS
showList :: [ChainSetup] -> ShowS
Show)

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

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

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

data SwitchSetup = SwitchSetup {
      -- | Chain setup
      SwitchSetup -> ChainSetup
ssChainSetup  :: ChainSetup

      -- | Number of blocks to roll back
    , SwitchSetup -> Word64
ssNumRollback :: Word64

      -- | Number of new blocks (to be applied after the rollback)
    , SwitchSetup -> Word64
ssNumNew      :: Word64

      -- | Prefix of the new chain
      --
      -- See also 'csPrefixLen'
    , SwitchSetup -> Word64
ssPrefixLen   :: Word64

      -- | Derived: number of blocks in the new chain
    , SwitchSetup -> Word64
ssNumBlocks   :: Word64

      -- | Derived: the blocks that were removed
    , SwitchSetup -> [TestBlock]
ssRemoved     :: [TestBlock]

      -- | Derived: the new blocks themselves
    , SwitchSetup -> [TestBlock]
ssNewBlocks   :: [TestBlock]

      -- | Derived: the full chain after switching to this fork
    , SwitchSetup -> [TestBlock]
ssChain       :: [TestBlock]

      -- | Derived; the snapshots after the switch was performed
    , SwitchSetup -> LedgerDB (LedgerState TestBlock)
ssSwitched    :: LedgerDB (LedgerState TestBlock)
    }
  deriving (Int -> SwitchSetup -> ShowS
[SwitchSetup] -> ShowS
SwitchSetup -> String
(Int -> SwitchSetup -> ShowS)
-> (SwitchSetup -> String)
-> ([SwitchSetup] -> ShowS)
-> Show SwitchSetup
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SwitchSetup -> ShowS
showsPrec :: Int -> SwitchSetup -> ShowS
$cshow :: SwitchSetup -> String
show :: SwitchSetup -> String
$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
LedgerDB (LedgerState TestBlock)
csSecParam :: SecurityParam
csNumBlocks :: Word64
csPrefixLen :: Word64
csGenSnaps :: LedgerDB (LedgerState TestBlock)
csChain :: [TestBlock]
csPushed :: LedgerDB (LedgerState TestBlock)
csSecParam :: SecurityParam
csNumBlocks :: Word64
csPrefixLen :: Word64
csGenSnaps :: LedgerDB (LedgerState TestBlock)
csChain :: [TestBlock]
csPushed :: LedgerDB (LedgerState TestBlock)
..}
  where
    csGenSnaps :: LedgerDB (LedgerState TestBlock)
csGenSnaps = LedgerState TestBlock -> LedgerDB (LedgerState TestBlock)
forall l. GetTip l => l -> LedgerDB l
ledgerDbWithAnchor LedgerState 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
successorBlock (Word64 -> TestBlock
firstBlock Word64
0)
    csPushed :: LedgerDB (LedgerState TestBlock)
csPushed   = LedgerDbCfg (LedgerState TestBlock)
-> [TestBlock]
-> LedgerDB (LedgerState TestBlock)
-> LedgerDB (LedgerState TestBlock)
forall l blk.
ApplyBlock l blk =>
LedgerDbCfg l -> [blk] -> LedgerDB l -> LedgerDB l
ledgerDbPushMany' (SecurityParam -> LedgerDbCfg (LedgerState TestBlock)
csBlockConfig' SecurityParam
csSecParam) [TestBlock]
csChain LedgerDB (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
LedgerDB (LedgerState TestBlock)
ChainSetup
ssChainSetup :: ChainSetup
ssNumRollback :: Word64
ssNumNew :: Word64
ssPrefixLen :: Word64
ssNumBlocks :: Word64
ssRemoved :: [TestBlock]
ssNewBlocks :: [TestBlock]
ssChain :: [TestBlock]
ssSwitched :: LedgerDB (LedgerState TestBlock)
ssChainSetup :: ChainSetup
ssNumRollback :: Word64
ssNumNew :: Word64
ssPrefixLen :: Word64
ssNumBlocks :: Word64
ssRemoved :: [TestBlock]
ssNewBlocks :: [TestBlock]
ssChain :: [TestBlock]
ssSwitched :: LedgerDB (LedgerState TestBlock)
..}
  where
    ChainSetup{[TestBlock]
Word64
SecurityParam
LedgerDB (LedgerState TestBlock)
csSecParam :: ChainSetup -> SecurityParam
csNumBlocks :: ChainSetup -> Word64
csPrefixLen :: ChainSetup -> Word64
csGenSnaps :: ChainSetup -> LedgerDB (LedgerState TestBlock)
csChain :: ChainSetup -> [TestBlock]
csPushed :: ChainSetup -> LedgerDB (LedgerState TestBlock)
csSecParam :: SecurityParam
csNumBlocks :: Word64
csPrefixLen :: Word64
csGenSnaps :: LedgerDB (LedgerState TestBlock)
csChain :: [TestBlock]
csPushed :: LedgerDB (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
firstBlock Word64
1
                          Just TestBlock
b  -> (Word64 -> Word64) -> 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
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
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 :: LedgerDB (LedgerState TestBlock)
ssSwitched  = Maybe (LedgerDB (LedgerState TestBlock))
-> LedgerDB (LedgerState TestBlock)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (LedgerDB (LedgerState TestBlock))
 -> LedgerDB (LedgerState TestBlock))
-> Maybe (LedgerDB (LedgerState TestBlock))
-> LedgerDB (LedgerState TestBlock)
forall a b. (a -> b) -> a -> b
$ LedgerDbCfg (LedgerState TestBlock)
-> Word64
-> [TestBlock]
-> LedgerDB (LedgerState TestBlock)
-> Maybe (LedgerDB (LedgerState TestBlock))
forall l blk.
ApplyBlock l blk =>
LedgerDbCfg l
-> Word64 -> [blk] -> LedgerDB l -> Maybe (LedgerDB l)
ledgerDbSwitch' (ChainSetup -> LedgerDbCfg (LedgerState TestBlock)
csBlockConfig ChainSetup
ssChainSetup) Word64
ssNumRollback [TestBlock]
ssNewBlocks LedgerDB (LedgerState TestBlock)
csPushed

instance Arbitrary ChainSetup where
  arbitrary :: Gen ChainSetup
arbitrary = do
      SecurityParam
secParam <- Gen SecurityParam
forall a. Arbitrary a => Gen a
arbitrary
      let k :: Word64
k = SecurityParam -> Word64
maxRollbacks SecurityParam
secParam
      Word64
numBlocks <- (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
0, Word64
k Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
2)
      Word64
prefixLen <- (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
0, Word64
numBlocks)
      ChainSetup -> Gen ChainSetup
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (ChainSetup -> Gen ChainSetup) -> ChainSetup -> Gen ChainSetup
forall a b. (a -> b) -> a -> b
$ SecurityParam -> Word64 -> Word64 -> ChainSetup
mkTestSetup SecurityParam
secParam Word64
numBlocks Word64
prefixLen

  shrink :: ChainSetup -> [ChainSetup]
shrink ChainSetup{[TestBlock]
Word64
SecurityParam
LedgerDB (LedgerState TestBlock)
csSecParam :: ChainSetup -> SecurityParam
csNumBlocks :: ChainSetup -> Word64
csPrefixLen :: ChainSetup -> Word64
csGenSnaps :: ChainSetup -> LedgerDB (LedgerState TestBlock)
csChain :: ChainSetup -> [TestBlock]
csPushed :: ChainSetup -> LedgerDB (LedgerState TestBlock)
csSecParam :: SecurityParam
csNumBlocks :: Word64
csPrefixLen :: Word64
csGenSnaps :: LedgerDB (LedgerState TestBlock)
csChain :: [TestBlock]
csPushed :: LedgerDB (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
chainSetup  <- Gen ChainSetup
forall a. Arbitrary a => Gen a
arbitrary
      Word64
numRollback <- (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
0, LedgerDB (LedgerState TestBlock) -> Word64
forall l. GetTip l => LedgerDB l -> Word64
ledgerDbMaxRollback (ChainSetup -> LedgerDB (LedgerState TestBlock)
csPushed ChainSetup
chainSetup))
      Word64
numNew      <- (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
numRollback, Word64
2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
numRollback)
      Word64
prefixLen   <- (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
0, ChainSetup -> Word64
csNumBlocks ChainSetup
chainSetup Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
numRollback Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
numNew)
      SwitchSetup -> Gen SwitchSetup
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (SwitchSetup -> Gen SwitchSetup) -> SwitchSetup -> Gen SwitchSetup
forall a b. (a -> b) -> a -> b
$ ChainSetup -> Word64 -> Word64 -> Word64 -> SwitchSetup
mkRollbackSetup ChainSetup
chainSetup Word64
numRollback Word64
numNew Word64
prefixLen

  shrink :: SwitchSetup -> [SwitchSetup]
shrink SwitchSetup{[TestBlock]
Word64
LedgerDB (LedgerState TestBlock)
ChainSetup
ssChainSetup :: SwitchSetup -> ChainSetup
ssNumRollback :: SwitchSetup -> Word64
ssNumNew :: SwitchSetup -> Word64
ssPrefixLen :: SwitchSetup -> Word64
ssNumBlocks :: SwitchSetup -> Word64
ssRemoved :: SwitchSetup -> [TestBlock]
ssNewBlocks :: SwitchSetup -> [TestBlock]
ssChain :: SwitchSetup -> [TestBlock]
ssSwitched :: SwitchSetup -> LedgerDB (LedgerState TestBlock)
ssChainSetup :: ChainSetup
ssNumRollback :: Word64
ssNumNew :: Word64
ssPrefixLen :: Word64
ssNumBlocks :: Word64
ssRemoved :: [TestBlock]
ssNewBlocks :: [TestBlock]
ssChain :: [TestBlock]
ssSwitched :: LedgerDB (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
<= LedgerDB (LedgerState TestBlock) -> Word64
forall l. GetTip l => LedgerDB l -> Word64
ledgerDbMaxRollback (ChainSetup -> LedgerDB (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
        ]
      ]