{-# 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@ 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{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)
        -- TODO: Trim block tree, the rollback schedule does not use all of it
        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
    -- 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{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
    -- 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 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]

-- | 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