{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Test.Consensus.PeerSimulator.Tests.Rollback (tests) where

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@ tests that the selection of the node under test
-- changes branches when sent a rollback to a block no older than 'k' blocks
-- before the current selection.
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
        -- Create a block tree with @1@ alternative chain, such that we can rollback
        -- from the trunk to that chain.
        gt :: GenesisTest TestBlock ()
gt@GenesisTest{SecurityParam
gtSecurityParam :: SecurityParam
$sel:gtSecurityParam:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> SecurityParam
gtSecurityParam, BlockTree TestBlock
gtBlockTree :: BlockTree TestBlock
$sel:gtBlockTree:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> BlockTree blk
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)
        -- TODO: Trim block tree, the rollback schedule does not use all of it
        let cls :: Classifiers
cls = GenesisTest TestBlock () -> Classifiers
forall blk schedule.
HasHeader blk =>
GenesisTest blk schedule -> Classifiers
classifiers GenesisTest TestBlock ()
gt
        if Classifiers -> Bool
allAdversariesForecastable Classifiers
cls Bool -> Bool -> Bool
&& Classifiers -> Bool
allAdversariesKPlus1InForecast Classifiers
cls
          then GenesisTestFull TestBlock -> Gen (GenesisTestFull TestBlock)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenesisTest TestBlock ()
gt {gtSchedule = rollbackSchedule (fromIntegral (maxRollbacks gtSecurityParam)) gtBlockTree}
          else Gen (GenesisTestFull TestBlock)
forall a. a
discard)

    SchedulerConfig
defaultSchedulerConfig

    -- No shrinking because the schedule is tiny and hand-crafted
    (\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@ tests that the selection of the node under test *does
-- not* change branches when sent a rollback to a block strictly older than 'k'
-- blocks before the current selection.
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 TestBlock ()
gt@GenesisTest{SecurityParam
$sel:gtSecurityParam:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> SecurityParam
gtSecurityParam :: SecurityParam
gtSecurityParam, BlockTree TestBlock
$sel:gtBlockTree:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree :: BlockTree TestBlock
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)
        GenesisTestFull TestBlock -> Gen (GenesisTestFull TestBlock)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenesisTest TestBlock ()
gt {gtSchedule = rollbackSchedule (fromIntegral (maxRollbacks gtSecurityParam + 1)) gtBlockTree})

    SchedulerConfig
defaultSchedulerConfig

    -- No shrinking because the schedule is tiny and hand-crafted
    (\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)

-- | A schedule that advertises all the points of the trunk up until the nth
-- block after the intersection, then switches to the first alternative
-- chain of the given block tree.
--
-- PRECONDITION: Block tree with at least one alternative chain.
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 Peers (PeerSchedule blk) -> PointSchedule blk
forall blk. Peers (PeerSchedule blk) -> PointSchedule blk
mkPointSchedule (Peers (PeerSchedule blk) -> PointSchedule blk)
-> Peers (PeerSchedule blk) -> PointSchedule blk
forall a b. (a -> b) -> a -> b
$ 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
  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]

-- | Given a hash, checks whether it is on the trunk of the block tree, that is
-- if it only contains zeroes.
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