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

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

import Cardano.Ledger.BaseTypes (unNonZero)
import Control.Monad.Class.MonadTime.SI (Time (Time))
import qualified Data.Map as M
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 (..)
  , deforestBlockTree
  )
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)
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
  forall blk prop.
(Testable prop, Condense (StateView blk),
 CondenseList (NodeState blk), ShowProxy blk,
 ShowProxy (Header blk), ConfigSupportsNode blk,
 LedgerSupportsProtocol blk, SerialiseDiskConstraints blk,
 BlockSupportsDiffusionPipelining blk, InspectLedger blk,
 HasHardForkHistory blk, ConvertRawHash blk,
 CanUpgradeLedgerTables (LedgerState blk),
 HasPointScheduleTestParams blk, Eq (Header blk), Eq blk, Terse blk,
 Condense (NodeState blk)) =>
Gen (GenesisTestFull blk)
-> SchedulerConfig
-> (GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk])
-> (GenesisTestFull blk -> StateView blk -> prop)
-> Property
forAllGenesisTest @TestBlock
    ( 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 ())
forall blk.
(HasHeader blk, IssueTestBlock blk) =>
Gen Word -> Gen (GenesisTest blk ())
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
test -> Bool -> Bool
not (Bool -> Bool)
-> (StateView TestBlock -> Bool) -> StateView TestBlock -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockTree TestBlock -> ChainHash (Header TestBlock) -> Bool
forall blk.
(HasHeader blk, Eq blk) =>
BlockTree blk -> ChainHash (Header blk) -> Bool
hashOnTrunk (GenesisTestFull TestBlock -> BlockTree TestBlock
forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree GenesisTestFull TestBlock
test) (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 =
  forall blk prop.
(Testable prop, Condense (StateView blk),
 CondenseList (NodeState blk), ShowProxy blk,
 ShowProxy (Header blk), ConfigSupportsNode blk,
 LedgerSupportsProtocol blk, SerialiseDiskConstraints blk,
 BlockSupportsDiffusionPipelining blk, InspectLedger blk,
 HasHardForkHistory blk, ConvertRawHash blk,
 CanUpgradeLedgerTables (LedgerState blk),
 HasPointScheduleTestParams blk, Eq (Header blk), Eq blk, Terse blk,
 Condense (NodeState blk)) =>
Gen (GenesisTestFull blk)
-> SchedulerConfig
-> (GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk])
-> (GenesisTestFull blk -> StateView blk -> prop)
-> Property
forAllGenesisTest @TestBlock
    ( do
        gt@GenesisTest{gtSecurityParam, gtBlockTree} <- Gen Word -> Gen (GenesisTest TestBlock ())
forall blk.
(HasHeader blk, IssueTestBlock blk) =>
Gen Word -> Gen (GenesisTest blk ())
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
test -> BlockTree TestBlock -> ChainHash (Header TestBlock) -> Bool
forall blk.
(HasHeader blk, Eq blk) =>
BlockTree blk -> ChainHash (Header blk) -> Bool
hashOnTrunk (GenesisTestFull TestBlock -> BlockTree TestBlock
forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree GenesisTestFull TestBlock
test) (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 its corresponding block is on the trunk of
-- the block tree.
hashOnTrunk :: (AF.HasHeader blk, Eq blk) => BlockTree blk -> ChainHash (Header blk) -> Bool
hashOnTrunk :: forall blk.
(HasHeader blk, Eq blk) =>
BlockTree blk -> ChainHash (Header blk) -> Bool
hashOnTrunk BlockTree blk
_ ChainHash (Header blk)
GenesisHash = Bool
True
hashOnTrunk BlockTree blk
bt (BlockHash HeaderHash (Header blk)
hash) = do
  case HeaderHash blk
-> Map (HeaderHash blk) (AnchoredFragment blk)
-> Maybe (AnchoredFragment blk)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup HeaderHash blk
HeaderHash (Header blk)
hash (BlockTree blk -> Map (HeaderHash blk) (AnchoredFragment blk)
forall blk. BlockTree blk -> DeforestedBlockTree blk
deforestBlockTree BlockTree blk
bt) of
    Maybe (AnchoredFragment blk)
Nothing -> Bool
False
    Just AnchoredFragment blk
path -> AnchoredFragment blk -> AnchoredFragment blk -> Bool
forall v a b.
(Eq a, Eq b) =>
AnchoredSeq v a b -> AnchoredSeq v a b -> Bool
AF.isPrefixOf AnchoredFragment blk
path (AnchoredFragment blk -> Bool) -> AnchoredFragment blk -> Bool
forall a b. (a -> b) -> a -> b
$ BlockTree blk -> AnchoredFragment blk
forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk BlockTree blk
bt