{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Test.Consensus.PeerSimulator.Tests.Rollback
  ( TestKey
  , testSuite
  ) 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.Genesis.TestSuite
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.Util.Orphans.IOLike ()

-- | Default adjustment of the required number of test runs.
-- Can be set individually on each test definition.
adjustTestCount :: AdjustTestCount
adjustTestCount :: AdjustTestCount
adjustTestCount = (Int -> Int) -> AdjustTestCount
AdjustTestCount (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2)

-- | Default adjustment of max test case size.
-- Can be set individually on each test definition.
adjustMaxSize :: AdjustMaxSize
adjustMaxSize :: AdjustMaxSize
adjustMaxSize = (Int -> Int) -> AdjustMaxSize
AdjustMaxSize Int -> Int
forall a. a -> a
id

data TestKey = CanRollback | CannotRollback
  deriving stock (TestKey -> TestKey -> Bool
(TestKey -> TestKey -> Bool)
-> (TestKey -> TestKey -> Bool) -> Eq TestKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TestKey -> TestKey -> Bool
== :: TestKey -> TestKey -> Bool
$c/= :: TestKey -> TestKey -> Bool
/= :: TestKey -> TestKey -> Bool
Eq, Eq TestKey
Eq TestKey =>
(TestKey -> TestKey -> Ordering)
-> (TestKey -> TestKey -> Bool)
-> (TestKey -> TestKey -> Bool)
-> (TestKey -> TestKey -> Bool)
-> (TestKey -> TestKey -> Bool)
-> (TestKey -> TestKey -> TestKey)
-> (TestKey -> TestKey -> TestKey)
-> Ord TestKey
TestKey -> TestKey -> Bool
TestKey -> TestKey -> Ordering
TestKey -> TestKey -> TestKey
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: TestKey -> TestKey -> Ordering
compare :: TestKey -> TestKey -> Ordering
$c< :: TestKey -> TestKey -> Bool
< :: TestKey -> TestKey -> Bool
$c<= :: TestKey -> TestKey -> Bool
<= :: TestKey -> TestKey -> Bool
$c> :: TestKey -> TestKey -> Bool
> :: TestKey -> TestKey -> Bool
$c>= :: TestKey -> TestKey -> Bool
>= :: TestKey -> TestKey -> Bool
$cmax :: TestKey -> TestKey -> TestKey
max :: TestKey -> TestKey -> TestKey
$cmin :: TestKey -> TestKey -> TestKey
min :: TestKey -> TestKey -> TestKey
Ord, (forall x. TestKey -> Rep TestKey x)
-> (forall x. Rep TestKey x -> TestKey) -> Generic TestKey
forall x. Rep TestKey x -> TestKey
forall x. TestKey -> Rep TestKey x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TestKey -> Rep TestKey x
from :: forall x. TestKey -> Rep TestKey x
$cto :: forall x. Rep TestKey x -> TestKey
to :: forall x. Rep TestKey x -> TestKey
Generic)
  deriving [TestKey]
[TestKey] -> SmallKey TestKey
forall a. [a] -> SmallKey a
$callKeys :: [TestKey]
allKeys :: [TestKey]
SmallKey via Generically TestKey

testSuite ::
  ( IssueTestBlock blk
  , AF.HasHeader blk
  , AF.HasHeader (Header blk)
  , Eq blk
  ) =>
  TestSuite blk TestKey
testSuite :: forall blk.
(IssueTestBlock blk, HasHeader blk, HasHeader (Header blk),
 Eq blk) =>
TestSuite blk TestKey
testSuite = String -> TestSuite blk TestKey -> TestSuite blk TestKey
forall blk key. String -> TestSuite blk key -> TestSuite blk key
group String
"rollback" (TestSuite blk TestKey -> TestSuite blk TestKey)
-> ((TestKey -> ConformanceTest blk) -> TestSuite blk TestKey)
-> (TestKey -> ConformanceTest blk)
-> TestSuite blk TestKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TestKey -> ConformanceTest blk) -> TestSuite blk TestKey
forall key blk.
(Ord key, SmallKey key) =>
(key -> ConformanceTest blk) -> TestSuite blk key
newTestSuite ((TestKey -> ConformanceTest blk) -> TestSuite blk TestKey)
-> (TestKey -> ConformanceTest blk) -> TestSuite blk TestKey
forall a b. (a -> b) -> a -> b
$ \case
  TestKey
CanRollback -> ConformanceTest blk
forall blk.
(IssueTestBlock blk, HasHeader blk, HasHeader (Header blk),
 Eq blk) =>
ConformanceTest blk
testRollback
  TestKey
CannotRollback -> ConformanceTest blk
forall blk.
(IssueTestBlock blk, HasHeader blk, HasHeader (Header blk),
 Eq blk) =>
ConformanceTest blk
testCannotRollback

-- | 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.
testRollback ::
  ( IssueTestBlock blk
  , AF.HasHeader blk
  , AF.HasHeader (Header blk)
  , Eq blk
  ) =>
  ConformanceTest blk
testRollback :: forall blk.
(IssueTestBlock blk, HasHeader blk, HasHeader (Header blk),
 Eq blk) =>
ConformanceTest blk
testRollback =
  String
-> AdjustTestCount
-> AdjustMaxSize
-> Gen (GenesisTestFull blk)
-> SchedulerConfig
-> (GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk])
-> (GenesisTestFull blk -> StateView blk -> Bool)
-> ConformanceTest blk
forall prop blk.
Testable prop =>
String
-> AdjustTestCount
-> AdjustMaxSize
-> Gen (GenesisTestFull blk)
-> SchedulerConfig
-> (GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk])
-> (GenesisTestFull blk -> StateView blk -> prop)
-> ConformanceTest blk
mkConformanceTest
    String
"can rollback"
    AdjustTestCount
adjustTestCount
    AdjustMaxSize
adjustMaxSize
    ( 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 blk ())
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 blk () -> Classifiers
forall blk schedule.
HasHeader blk =>
GenesisTest blk schedule -> Classifiers
classifiers GenesisTest blk ()
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 blk -> StateView blk -> [GenesisTestFull blk]
forall a. Monoid a => a
mempty
    (\GenesisTestFull blk
test -> Bool -> Bool
not (Bool -> Bool) -> (StateView blk -> Bool) -> StateView blk -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockTree blk -> ChainHash (Header blk) -> Bool
forall blk.
(HasHeader blk, Eq blk) =>
BlockTree blk -> ChainHash (Header blk) -> Bool
hashOnTrunk (GenesisTestFull blk -> BlockTree blk
forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree GenesisTestFull blk
test) (ChainHash (Header blk) -> Bool)
-> (StateView blk -> ChainHash (Header blk))
-> StateView blk
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredFragment (Header blk) -> ChainHash (Header blk)
forall block.
HasHeader block =>
AnchoredFragment block -> ChainHash block
AF.headHash (AnchoredFragment (Header blk) -> ChainHash (Header blk))
-> (StateView blk -> AnchoredFragment (Header blk))
-> StateView blk
-> ChainHash (Header blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateView blk -> AnchoredFragment (Header blk)
forall blk. StateView blk -> AnchoredFragment (Header blk)
svSelectedChain)

-- | 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.
testCannotRollback ::
  ( IssueTestBlock blk
  , AF.HasHeader blk
  , AF.HasHeader (Header blk)
  , Eq blk
  ) =>
  ConformanceTest blk
testCannotRollback :: forall blk.
(IssueTestBlock blk, HasHeader blk, HasHeader (Header blk),
 Eq blk) =>
ConformanceTest blk
testCannotRollback =
  String
-> AdjustTestCount
-> AdjustMaxSize
-> Gen (GenesisTestFull blk)
-> SchedulerConfig
-> (GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk])
-> (GenesisTestFull blk -> StateView blk -> Bool)
-> ConformanceTest blk
forall prop blk.
Testable prop =>
String
-> AdjustTestCount
-> AdjustMaxSize
-> Gen (GenesisTestFull blk)
-> SchedulerConfig
-> (GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk])
-> (GenesisTestFull blk -> StateView blk -> prop)
-> ConformanceTest blk
mkConformanceTest
    String
"cannot rollback"
    AdjustTestCount
adjustTestCount
    AdjustMaxSize
adjustMaxSize
    ( do
        gt@GenesisTest{gtSecurityParam, gtBlockTree} <- Gen Word -> Gen (GenesisTest blk ())
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 blk -> StateView blk -> [GenesisTestFull blk]
forall a. Monoid a => a
mempty
    (\GenesisTestFull blk
test -> BlockTree blk -> ChainHash (Header blk) -> Bool
forall blk.
(HasHeader blk, Eq blk) =>
BlockTree blk -> ChainHash (Header blk) -> Bool
hashOnTrunk (GenesisTestFull blk -> BlockTree blk
forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree GenesisTestFull blk
test) (ChainHash (Header blk) -> Bool)
-> (StateView blk -> ChainHash (Header blk))
-> StateView blk
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredFragment (Header blk) -> ChainHash (Header blk)
forall block.
HasHeader block =>
AnchoredFragment block -> ChainHash block
AF.headHash (AnchoredFragment (Header blk) -> ChainHash (Header blk))
-> (StateView blk -> AnchoredFragment (Header blk))
-> StateView blk
-> ChainHash (Header blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateView blk -> AnchoredFragment (Header blk)
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]
_ -> String -> BlockTreeBranch blk
forall a. HasCallStack => String -> a
error String
"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