{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}

module Test.Consensus.Genesis.Tests.CSJ (tests) where

import           Data.List (nub)
import qualified Data.Map.Strict as Map
import           Data.Maybe (mapMaybe)
import           Ouroboros.Consensus.Block (Header, blockSlot, succWithOrigin)
import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client
                     (TraceChainSyncClientEvent (..))
import           Ouroboros.Consensus.Util.Condense (PaddingDirection (..),
                     condenseListWithPadding)
import qualified Ouroboros.Network.AnchoredFragment as AF
import           Test.Consensus.BlockTree (BlockTree (..))
import           Test.Consensus.Genesis.Setup
import           Test.Consensus.Genesis.Tests.Uniform (genUniformSchedulePoints)
import           Test.Consensus.PeerSimulator.Run (SchedulerConfig (..),
                     defaultSchedulerConfig)
import           Test.Consensus.PeerSimulator.StateView (StateView (..))
import           Test.Consensus.PeerSimulator.Trace (TraceEvent (..))
import           Test.Consensus.PointSchedule
import qualified Test.Consensus.PointSchedule.Peers as Peers
import           Test.Consensus.PointSchedule.Peers (Peers (..), peers')
import           Test.Consensus.PointSchedule.Shrinking (shrinkPeerSchedules)
import           Test.Tasty
import           Test.Tasty.QuickCheck
import           Test.Util.Orphans.IOLike ()
import           Test.Util.PartialAccessors
import           Test.Util.TestBlock (TestBlock)
import           Test.Util.TestEnv (adjustQuickCheckMaxSize)

tests :: TestTree
tests :: TestTree
tests =
  (Int -> Int) -> TestTree -> TestTree
adjustQuickCheckMaxSize (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
5) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
    TestName -> [TestTree] -> TestTree
testGroup
      TestName
"CSJ"
      [ TestName -> [TestTree] -> TestTree
testGroup
          TestName
"Happy Path"
          [ TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"honest peers are synchronised" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$ WithAdversariesFlag -> NumHonestSchedulesFlag -> Property
prop_CSJ WithAdversariesFlag
NoAdversaries NumHonestSchedulesFlag
OneScheduleForAllPeers,
            TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"honest peers do their own thing" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$ WithAdversariesFlag -> NumHonestSchedulesFlag -> Property
prop_CSJ WithAdversariesFlag
NoAdversaries NumHonestSchedulesFlag
OneSchedulePerHonestPeer
          ],
        TestName -> [TestTree] -> TestTree
testGroup
          TestName
"With some adversaries"
          [ TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"honest peers are synchronised" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$ WithAdversariesFlag -> NumHonestSchedulesFlag -> Property
prop_CSJ WithAdversariesFlag
WithAdversaries NumHonestSchedulesFlag
OneScheduleForAllPeers,
            TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"honest peers do their own thing" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$ WithAdversariesFlag -> NumHonestSchedulesFlag -> Property
prop_CSJ WithAdversariesFlag
WithAdversaries NumHonestSchedulesFlag
OneSchedulePerHonestPeer
          ]
      ]

-- | A flag to indicate if properties are tested with adversarial peers
data WithAdversariesFlag = NoAdversaries | WithAdversaries

-- | A flag to indicate if properties are tested using the same schedule for the
-- honest peers, or if each peer should used its own schedule.
data NumHonestSchedulesFlag = OneScheduleForAllPeers | OneSchedulePerHonestPeer

-- | Test of ChainSync Jumping (CSJ).
--
-- This test features several peers that all sync the “honest” chain (ie. the
-- trunk of the block tree) with CSJ enabled. What we expect to observe is that
-- one of the honest peers becomes the dynamo while the others become jumpers.
-- Because the jumpers will agree to all the jumps, the whole syncing should
-- happen with CSJ.
--
-- There are two variants of this test: the “happy path” variant features no
-- adversaries. As such, everything should happen with one dynamo and no
-- objector. Another variant adds adversaries, so we expect to see some
-- dynamo-vs-objector action.
--
-- Regardless, the final property is that “honest” headers should only ever be
-- downloaded at most once from honest peers. They may however be downloaded
-- several times from adversaries. This is true except when almost caught-up:
-- when the dynamo or objector is caught-up, it gets disengaged and one of the
-- jumpers takes its place and starts serving headers. This might lead to
-- duplication of headers, but only in a window of @jumpSize@ slots near the tip
-- of the chain.
--
prop_CSJ :: WithAdversariesFlag -> NumHonestSchedulesFlag -> Property
prop_CSJ :: WithAdversariesFlag -> NumHonestSchedulesFlag -> Property
prop_CSJ WithAdversariesFlag
adversariesFlag NumHonestSchedulesFlag
numHonestSchedules = do
  let genForks :: Gen Word
genForks = case WithAdversariesFlag
adversariesFlag of
                   WithAdversariesFlag
NoAdversaries   -> Word -> Gen Word
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word
0
                   WithAdversariesFlag
WithAdversaries -> (Word, Word) -> Gen Word
forall a. Random a => (a, a) -> Gen a
choose (Word
2, Word
4)
  Gen (GenesisTestFull TestBlock)
-> SchedulerConfig
-> (GenesisTestFull TestBlock
    -> StateView TestBlock -> [GenesisTestFull TestBlock])
-> (GenesisTestFull TestBlock -> StateView TestBlock -> Property)
-> Property
forall prop.
Testable prop =>
Gen (GenesisTestFull TestBlock)
-> SchedulerConfig
-> (GenesisTestFull TestBlock
    -> StateView TestBlock -> [GenesisTestFull TestBlock])
-> (GenesisTestFull TestBlock -> StateView TestBlock -> prop)
-> Property
forAllGenesisTest
    ( case NumHonestSchedulesFlag
numHonestSchedules of
        NumHonestSchedulesFlag
OneScheduleForAllPeers ->
          Gen Word -> Gen (GenesisTest TestBlock ())
genChains Gen Word
genForks
          Gen (GenesisTest TestBlock ())
-> (GenesisTest TestBlock () -> Gen (PointSchedule TestBlock))
-> Gen (GenesisTestFull TestBlock)
forall (f :: * -> *) (m :: * -> *) a b.
(Functor f, Monad m) =>
m (f a) -> (f a -> m b) -> m (f b)
`enrichedWith` GenesisTest TestBlock () -> Gen (PointSchedule TestBlock)
genDuplicatedHonestSchedule
        NumHonestSchedulesFlag
OneSchedulePerHonestPeer ->
          Gen Word -> Gen Word -> Gen (GenesisTest TestBlock ())
genChainsWithExtraHonestPeers ((Word, Word) -> Gen Word
forall a. Random a => (a, a) -> Gen a
choose (Word
2, Word
4)) Gen Word
genForks
          Gen (GenesisTest TestBlock ())
-> (GenesisTest TestBlock () -> Gen (PointSchedule TestBlock))
-> Gen (GenesisTestFull TestBlock)
forall (f :: * -> *) (m :: * -> *) a b.
(Functor f, Monad m) =>
m (f a) -> (f a -> m b) -> m (f b)
`enrichedWith` GenesisTest TestBlock () -> Gen (PointSchedule TestBlock)
genUniformSchedulePoints
    )
    ( SchedulerConfig
defaultSchedulerConfig
      { scEnableCSJ = True
      , scEnableLoE = True
      , scEnableLoP = True
      }
    )
    GenesisTestFull TestBlock
-> StateView TestBlock -> [GenesisTestFull TestBlock]
shrinkPeerSchedules
    ( \GenesisTestFull TestBlock
gt StateView{[TraceEvent TestBlock]
svTrace :: [TraceEvent TestBlock]
svTrace :: forall blk. StateView blk -> [TraceEvent blk]
svTrace} ->
        let
          -- The list of 'TraceDownloadedHeader' events that are not newer than
          -- jumpSize from the tip of the chain. These are the ones that we
          -- expect to see only once per header if CSJ works properly.
          headerHonestDownloadEvents :: [(PeerId, Header TestBlock)]
headerHonestDownloadEvents =
            (TraceEvent TestBlock -> Maybe (PeerId, Header TestBlock))
-> [TraceEvent TestBlock] -> [(PeerId, Header TestBlock)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
              (\case
                TraceChainSyncClientEvent PeerId
pid (TraceDownloadedHeader Header TestBlock
hdr)
                  | Bool -> Bool
not (GenesisTestFull TestBlock -> Header TestBlock -> Bool
isNewerThanJumpSizeFromTip GenesisTestFull TestBlock
gt Header TestBlock
hdr)
                  , Peers.HonestPeer Int
_ <- PeerId
pid
                  -> (PeerId, Header TestBlock) -> Maybe (PeerId, Header TestBlock)
forall a. a -> Maybe a
Just (PeerId
pid, Header TestBlock
hdr)
                TraceEvent TestBlock
_ -> Maybe (PeerId, Header TestBlock)
forall a. Maybe a
Nothing
              )
              [TraceEvent TestBlock]
svTrace
          receivedHeadersAtMostOnceFromHonestPeers :: Bool
receivedHeadersAtMostOnceFromHonestPeers =
            [Header TestBlock] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Header TestBlock] -> [Header TestBlock]
forall a. Eq a => [a] -> [a]
nub ([Header TestBlock] -> [Header TestBlock])
-> [Header TestBlock] -> [Header TestBlock]
forall a b. (a -> b) -> a -> b
$ (PeerId, Header TestBlock) -> Header TestBlock
forall a b. (a, b) -> b
snd ((PeerId, Header TestBlock) -> Header TestBlock)
-> [(PeerId, Header TestBlock)] -> [Header TestBlock]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PeerId, Header TestBlock)]
headerHonestDownloadEvents) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [(PeerId, Header TestBlock)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(PeerId, Header TestBlock)]
headerHonestDownloadEvents
        in
          TestName -> [TestName] -> Property -> Property
forall prop.
Testable prop =>
TestName -> [TestName] -> prop -> Property
tabulate TestName
""
            [ if [(PeerId, Header TestBlock)]
headerHonestDownloadEvents [(PeerId, Header TestBlock)]
-> [(PeerId, Header TestBlock)] -> Bool
forall a. Eq a => a -> a -> Bool
== []
                then TestName
"All headers are within the last jump window"
                else TestName
"There exist headers that have to be downloaded exactly once"
            ] (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample
          (TestName
"Downloaded headers (except jumpSize slots near the tip):\n" TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++
            ( [TestName] -> TestName
unlines ([TestName] -> TestName) -> [TestName] -> TestName
forall a b. (a -> b) -> a -> b
$ (TestName -> TestName) -> [TestName] -> [TestName]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TestName
"  " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++) ([TestName] -> [TestName]) -> [TestName] -> [TestName]
forall a b. (a -> b) -> a -> b
$ (TestName -> TestName -> TestName)
-> [TestName] -> [TestName] -> [TestName]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
              (\TestName
peer TestName
header -> TestName
peer TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
" | " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
header)
              (PaddingDirection -> [PeerId] -> [TestName]
forall a. Condense a => PaddingDirection -> [a] -> [TestName]
condenseListWithPadding PaddingDirection
PadRight ([PeerId] -> [TestName]) -> [PeerId] -> [TestName]
forall a b. (a -> b) -> a -> b
$ (PeerId, Header TestBlock) -> PeerId
forall a b. (a, b) -> a
fst ((PeerId, Header TestBlock) -> PeerId)
-> [(PeerId, Header TestBlock)] -> [PeerId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PeerId, Header TestBlock)]
headerHonestDownloadEvents)
              (PaddingDirection -> [Header TestBlock] -> [TestName]
forall a. Condense a => PaddingDirection -> [a] -> [TestName]
condenseListWithPadding PaddingDirection
PadRight ([Header TestBlock] -> [TestName])
-> [Header TestBlock] -> [TestName]
forall a b. (a -> b) -> a -> b
$ (PeerId, Header TestBlock) -> Header TestBlock
forall a b. (a, b) -> b
snd ((PeerId, Header TestBlock) -> Header TestBlock)
-> [(PeerId, Header TestBlock)] -> [Header TestBlock]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PeerId, Header TestBlock)]
headerHonestDownloadEvents)
            )
          )
          Bool
receivedHeadersAtMostOnceFromHonestPeers
    )
  where
    genDuplicatedHonestSchedule :: GenesisTest TestBlock () -> Gen (PointSchedule TestBlock)
    genDuplicatedHonestSchedule :: GenesisTest TestBlock () -> Gen (PointSchedule TestBlock)
genDuplicatedHonestSchedule gt :: GenesisTest TestBlock ()
gt@GenesisTest {Word
gtExtraHonestPeers :: Word
$sel:gtExtraHonestPeers:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> Word
gtExtraHonestPeers} = do
      ps :: PointSchedule TestBlock
ps@PointSchedule {$sel:psSchedule:PointSchedule :: forall blk. PointSchedule blk -> Peers (PeerSchedule blk)
psSchedule = Peers {Map Int (PeerSchedule TestBlock)
honestPeers :: Map Int (PeerSchedule TestBlock)
$sel:honestPeers:Peers :: forall a. Peers a -> Map Int a
honestPeers, Map Int (PeerSchedule TestBlock)
adversarialPeers :: Map Int (PeerSchedule TestBlock)
$sel:adversarialPeers:Peers :: forall a. Peers a -> Map Int a
adversarialPeers}} <- GenesisTest TestBlock () -> Gen (PointSchedule TestBlock)
genUniformSchedulePoints GenesisTest TestBlock ()
gt
      PointSchedule TestBlock -> Gen (PointSchedule TestBlock)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PointSchedule TestBlock -> Gen (PointSchedule TestBlock))
-> PointSchedule TestBlock -> Gen (PointSchedule TestBlock)
forall a b. (a -> b) -> a -> b
$ PointSchedule TestBlock
ps {
        psSchedule =
          Peers.unionWithKey
            (\PeerId
_ PeerSchedule TestBlock
_ PeerSchedule TestBlock
_ -> TestName -> PeerSchedule TestBlock
forall a. HasCallStack => TestName -> a
error TestName
"should not happen")
            ( peers'
                (replicate (fromIntegral gtExtraHonestPeers + 1) (getHonestPeer honestPeers))
                []
            )
            (Peers Map.empty adversarialPeers)
        }

    isNewerThanJumpSizeFromTip :: GenesisTestFull TestBlock -> Header TestBlock -> Bool
    isNewerThanJumpSizeFromTip :: GenesisTestFull TestBlock -> Header TestBlock -> Bool
isNewerThanJumpSizeFromTip GenesisTestFull TestBlock
gt Header TestBlock
hdr =
      let jumpSize :: SlotNo
jumpSize = CSJParams -> SlotNo
csjpJumpSize (CSJParams -> SlotNo) -> CSJParams -> SlotNo
forall a b. (a -> b) -> a -> b
$ GenesisTestFull TestBlock -> CSJParams
forall blk schedule. GenesisTest blk schedule -> CSJParams
gtCSJParams GenesisTestFull TestBlock
gt
          tipSlot :: WithOrigin SlotNo
tipSlot = AnchoredFragment TestBlock -> WithOrigin SlotNo
forall block.
HasHeader block =>
AnchoredFragment block -> WithOrigin SlotNo
AF.headSlot (AnchoredFragment TestBlock -> WithOrigin SlotNo)
-> AnchoredFragment TestBlock -> WithOrigin SlotNo
forall a b. (a -> b) -> a -> b
$ BlockTree TestBlock -> AnchoredFragment TestBlock
forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk (BlockTree TestBlock -> AnchoredFragment TestBlock)
-> BlockTree TestBlock -> AnchoredFragment TestBlock
forall a b. (a -> b) -> a -> b
$ GenesisTestFull TestBlock -> BlockTree TestBlock
forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree GenesisTestFull TestBlock
gt
          hdrSlot :: SlotNo
hdrSlot = Header TestBlock -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Header TestBlock
hdr
       in
        -- Sanity check: add @1 +@ after @>@ and watch the World burn.
        SlotNo
hdrSlot SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
jumpSize SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>= WithOrigin SlotNo -> SlotNo
forall t. (Bounded t, Enum t) => WithOrigin t -> t
succWithOrigin WithOrigin SlotNo
tipSlot