{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Test.Consensus.PeerSimulator.Tests.Rollback (tests) where
import Cardano.Ledger.BaseTypes (unNonZero)
import Control.Monad.Class.MonadTime.SI (Time (Time))
import Ouroboros.Consensus.Block (ChainHash (..), Header)
import Ouroboros.Consensus.Config.SecurityParam
import Ouroboros.Network.AnchoredFragment
( AnchoredFragment
, toOldestFirst
)
import qualified Ouroboros.Network.AnchoredFragment as AF
import Test.Consensus.BlockTree (BlockTree (..), BlockTreeBranch (..))
import Test.Consensus.Genesis.Setup
import Test.Consensus.Genesis.Setup.Classifiers
( Classifiers (allAdversariesKPlus1InForecast)
, allAdversariesForecastable
, classifiers
)
import Test.Consensus.PeerSimulator.Run (defaultSchedulerConfig)
import Test.Consensus.PeerSimulator.StateView
import Test.Consensus.PointSchedule
import Test.Consensus.PointSchedule.Peers (peersOnlyHonest)
import Test.Consensus.PointSchedule.SinglePeer
( SchedulePoint (..)
, scheduleBlockPoint
, scheduleHeaderPoint
, scheduleTipPoint
)
import Test.QuickCheck
import Test.Tasty
import Test.Tasty.QuickCheck
import Test.Util.Orphans.IOLike ()
import Test.Util.TestBlock (TestBlock, unTestHash)
import Test.Util.TestEnv (adjustQuickCheckTests)
tests :: TestTree
tests :: TestTree
tests =
TestName -> [TestTree] -> TestTree
testGroup
TestName
"rollback"
[ (Int -> Int) -> TestTree -> TestTree
adjustQuickCheckTests (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"can rollback" Property
prop_rollback
, (Int -> Int) -> TestTree -> TestTree
adjustQuickCheckTests (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"cannot rollback" Property
prop_cannotRollback
]
prop_rollback :: Property
prop_rollback :: Property
prop_rollback = do
Gen (GenesisTestFull TestBlock)
-> SchedulerConfig
-> (GenesisTestFull TestBlock
-> StateView TestBlock -> [GenesisTestFull TestBlock])
-> (GenesisTestFull TestBlock -> StateView TestBlock -> Bool)
-> Property
forall prop.
Testable prop =>
Gen (GenesisTestFull TestBlock)
-> SchedulerConfig
-> (GenesisTestFull TestBlock
-> StateView TestBlock -> [GenesisTestFull TestBlock])
-> (GenesisTestFull TestBlock -> StateView TestBlock -> prop)
-> Property
forAllGenesisTest
( do
gt@GenesisTest{gtSecurityParam, gtBlockTree} <- Gen Word -> Gen (GenesisTest TestBlock ())
genChains (Word -> Gen Word
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word
1)
let cls = GenesisTest TestBlock () -> Classifiers
forall blk schedule.
HasHeader blk =>
GenesisTest blk schedule -> Classifiers
classifiers GenesisTest TestBlock ()
gt
if allAdversariesForecastable cls && allAdversariesKPlus1InForecast cls
then
pure
gt
{ gtSchedule = rollbackSchedule (fromIntegral (unNonZero $ maxRollbacks gtSecurityParam)) gtBlockTree
}
else discard
)
SchedulerConfig
defaultSchedulerConfig
(\GenesisTestFull TestBlock
_ StateView TestBlock
_ -> [])
(\GenesisTestFull TestBlock
_ -> Bool -> Bool
not (Bool -> Bool)
-> (StateView TestBlock -> Bool) -> StateView TestBlock -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainHash (Header TestBlock) -> Bool
hashOnTrunk (ChainHash (Header TestBlock) -> Bool)
-> (StateView TestBlock -> ChainHash (Header TestBlock))
-> StateView TestBlock
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredFragment (Header TestBlock) -> ChainHash (Header TestBlock)
forall block.
HasHeader block =>
AnchoredFragment block -> ChainHash block
AF.headHash (AnchoredFragment (Header TestBlock)
-> ChainHash (Header TestBlock))
-> (StateView TestBlock -> AnchoredFragment (Header TestBlock))
-> StateView TestBlock
-> ChainHash (Header TestBlock)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateView TestBlock -> AnchoredFragment (Header TestBlock)
forall blk. StateView blk -> AnchoredFragment (Header blk)
svSelectedChain)
prop_cannotRollback :: Property
prop_cannotRollback :: Property
prop_cannotRollback =
Gen (GenesisTestFull TestBlock)
-> SchedulerConfig
-> (GenesisTestFull TestBlock
-> StateView TestBlock -> [GenesisTestFull TestBlock])
-> (GenesisTestFull TestBlock -> StateView TestBlock -> Bool)
-> Property
forall prop.
Testable prop =>
Gen (GenesisTestFull TestBlock)
-> SchedulerConfig
-> (GenesisTestFull TestBlock
-> StateView TestBlock -> [GenesisTestFull TestBlock])
-> (GenesisTestFull TestBlock -> StateView TestBlock -> prop)
-> Property
forAllGenesisTest
( do
gt@GenesisTest{gtSecurityParam, gtBlockTree} <- Gen Word -> Gen (GenesisTest TestBlock ())
genChains (Word -> Gen Word
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word
1)
pure
gt
{ gtSchedule =
rollbackSchedule (fromIntegral (unNonZero $ maxRollbacks gtSecurityParam) + 1) gtBlockTree
}
)
SchedulerConfig
defaultSchedulerConfig
(\GenesisTestFull TestBlock
_ StateView TestBlock
_ -> [])
(\GenesisTestFull TestBlock
_ -> ChainHash (Header TestBlock) -> Bool
hashOnTrunk (ChainHash (Header TestBlock) -> Bool)
-> (StateView TestBlock -> ChainHash (Header TestBlock))
-> StateView TestBlock
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredFragment (Header TestBlock) -> ChainHash (Header TestBlock)
forall block.
HasHeader block =>
AnchoredFragment block -> ChainHash block
AF.headHash (AnchoredFragment (Header TestBlock)
-> ChainHash (Header TestBlock))
-> (StateView TestBlock -> AnchoredFragment (Header TestBlock))
-> StateView TestBlock
-> ChainHash (Header TestBlock)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateView TestBlock -> AnchoredFragment (Header TestBlock)
forall blk. StateView blk -> AnchoredFragment (Header blk)
svSelectedChain)
rollbackSchedule :: AF.HasHeader blk => Int -> BlockTree blk -> PointSchedule blk
rollbackSchedule :: forall blk.
HasHeader blk =>
Int -> BlockTree blk -> PointSchedule blk
rollbackSchedule Int
n BlockTree blk
blockTree =
let branch :: BlockTreeBranch blk
branch = case BlockTree blk -> [BlockTreeBranch blk]
forall blk. BlockTree blk -> [BlockTreeBranch blk]
btBranches BlockTree blk
blockTree of
[BlockTreeBranch blk
b] -> BlockTreeBranch blk
b
[BlockTreeBranch blk]
_ -> TestName -> BlockTreeBranch blk
forall a. HasCallStack => TestName -> a
error TestName
"The block tree must have exactly one alternative branch"
trunkSuffix :: AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk
trunkSuffix = Int
-> AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk
-> AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk
forall v a b.
Anchorable v a b =>
Int -> AnchoredSeq v a b -> AnchoredSeq v a b
AF.takeOldest Int
n (BlockTreeBranch blk
-> AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbTrunkSuffix BlockTreeBranch blk
branch)
schedulePoints :: [SchedulePoint blk]
schedulePoints =
[[SchedulePoint blk]] -> [SchedulePoint blk]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk
-> [SchedulePoint blk]
forall blk. AnchoredFragment blk -> [SchedulePoint blk]
banalSchedulePoints (BlockTreeBranch blk
-> AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbPrefix BlockTreeBranch blk
branch)
, AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk
-> [SchedulePoint blk]
forall blk. AnchoredFragment blk -> [SchedulePoint blk]
banalSchedulePoints AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk
trunkSuffix
, AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk
-> [SchedulePoint blk]
forall blk. AnchoredFragment blk -> [SchedulePoint blk]
banalSchedulePoints (BlockTreeBranch blk
-> AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbSuffix BlockTreeBranch blk
branch)
]
in PointSchedule
{ psSchedule :: Peers (PeerSchedule blk)
psSchedule = PeerSchedule blk -> Peers (PeerSchedule blk)
forall a. a -> Peers a
peersOnlyHonest (PeerSchedule blk -> Peers (PeerSchedule blk))
-> PeerSchedule blk -> Peers (PeerSchedule blk)
forall a b. (a -> b) -> a -> b
$ [Time] -> [SchedulePoint blk] -> PeerSchedule blk
forall a b. [a] -> [b] -> [(a, b)]
zip ((DiffTime -> Time) -> [DiffTime] -> [Time]
forall a b. (a -> b) -> [a] -> [b]
map (DiffTime -> Time
Time (DiffTime -> Time) -> (DiffTime -> DiffTime) -> DiffTime -> Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DiffTime -> DiffTime -> DiffTime
forall a. Fractional a => a -> a -> a
/ DiffTime
30)) [DiffTime
0 ..]) [SchedulePoint blk]
schedulePoints
, psStartOrder :: [PeerId]
psStartOrder = []
, psMinEndTime :: Time
psMinEndTime = DiffTime -> Time
Time DiffTime
0
}
where
banalSchedulePoints :: AnchoredFragment blk -> [SchedulePoint blk]
banalSchedulePoints :: forall blk. AnchoredFragment blk -> [SchedulePoint blk]
banalSchedulePoints = (blk -> [SchedulePoint blk]) -> [blk] -> [SchedulePoint blk]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap blk -> [SchedulePoint blk]
forall blk. blk -> [SchedulePoint blk]
banalSchedulePoints' ([blk] -> [SchedulePoint blk])
-> (AnchoredFragment blk -> [blk])
-> AnchoredFragment blk
-> [SchedulePoint blk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredFragment blk -> [blk]
forall v a b. AnchoredSeq v a b -> [b]
toOldestFirst
banalSchedulePoints' :: blk -> [SchedulePoint blk]
banalSchedulePoints' :: forall blk. blk -> [SchedulePoint blk]
banalSchedulePoints' blk
block = [blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleTipPoint blk
block, blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleHeaderPoint blk
block, blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleBlockPoint blk
block]
hashOnTrunk :: ChainHash (Header TestBlock) -> Bool
hashOnTrunk :: ChainHash (Header TestBlock) -> Bool
hashOnTrunk ChainHash (Header TestBlock)
GenesisHash = Bool
True
hashOnTrunk (BlockHash HeaderHash (Header TestBlock)
hash) = (Word64 -> Bool) -> NonEmpty Word64 -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0) (NonEmpty Word64 -> Bool) -> NonEmpty Word64 -> Bool
forall a b. (a -> b) -> a -> b
$ TestHash -> NonEmpty Word64
unTestHash HeaderHash (Header TestBlock)
TestHash
hash