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

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

import Data.Functor (($>))
import Ouroboros.Consensus.Block.Abstract (Header, HeaderHash)
import Ouroboros.Network.AnchoredFragment (headAnchor)
import qualified Ouroboros.Network.AnchoredFragment as AF
import Test.Consensus.Genesis.Setup
import Test.Consensus.Genesis.Setup.Classifiers
  ( allAdversariesForecastable
  , allAdversariesSelectable
  , classifiers
  )
import Test.Consensus.PeerSimulator.Run (defaultSchedulerConfig)
import Test.Consensus.PeerSimulator.StateView
import Test.Consensus.PointSchedule
import Test.Consensus.PointSchedule.Shrinking (shrinkPeerSchedules)
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
"long range attack"
    [ -- NOTE: We want to keep this test to show that Praos is vulnerable to this
      -- attack but Genesis is not. This requires to first fix it as mentioned
      -- above.
      --
      (Int -> Int) -> TestTree -> TestTree
adjustQuickCheckTests (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
10) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
        TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"one adversary" Property
prop_longRangeAttack
    ]

-- | This test case features a long-range attack with one adversary. The honest
-- peer serves the block tree trunk, while the adversary serves its own chain,
-- forking off the trunk by at least @k@ blocks, but less good than the trunk.
-- The adversary serves the chain more rapidly than the honest peer. We check at
-- the end that the selection is honest. This property does not hold with Praos,
-- but should hold with Genesis.
prop_longRangeAttack :: Property
prop_longRangeAttack :: Property
prop_longRangeAttack =
  -- NOTE: `shrinkPeerSchedules` only makes sense for tests that expect the
  -- honest node to win. Hence the `noShrinking`.

  Property -> Property
forall prop. Testable prop => prop -> Property
noShrinking (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    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.
          gt@GenesisTest{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)
          -- Create a 'longRangeAttack' schedule based on the generated chains.
          ps <- stToGen (longRangeAttack gtBlockTree)
          let cls = GenesisTest TestBlock () -> Classifiers
forall blk schedule.
HasHeader blk =>
GenesisTest blk schedule -> Classifiers
classifiers GenesisTest TestBlock ()
gt
          if allAdversariesSelectable cls && allAdversariesForecastable cls
            then pure $ gt $> ps
            else discard
      )
      SchedulerConfig
defaultSchedulerConfig
      GenesisTestFull TestBlock
-> StateView TestBlock -> [GenesisTestFull TestBlock]
shrinkPeerSchedules
      -- NOTE: This is the expected behaviour of Praos to be reversed with
      -- Genesis. But we are testing Praos for the moment. Do not forget to remove
      -- `noShrinking` above when removing this negation.
      (\GenesisTestFull TestBlock
_ -> Bool -> Bool
not (Bool -> Bool)
-> (StateView TestBlock -> Bool) -> StateView TestBlock -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredFragment (Header TestBlock) -> Bool
isHonestTestFragH (AnchoredFragment (Header TestBlock) -> Bool)
-> (StateView TestBlock -> AnchoredFragment (Header TestBlock))
-> StateView TestBlock
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateView TestBlock -> AnchoredFragment (Header TestBlock)
forall blk. StateView blk -> AnchoredFragment (Header blk)
svSelectedChain)
 where
  isHonestTestFragH :: AF.AnchoredFragment (Header TestBlock) -> Bool
  isHonestTestFragH :: AnchoredFragment (Header TestBlock) -> Bool
isHonestTestFragH AnchoredFragment (Header TestBlock)
frag = case AnchoredFragment (Header TestBlock) -> Anchor (Header TestBlock)
forall v a b. Anchorable v a b => AnchoredSeq v a b -> a
headAnchor AnchoredFragment (Header TestBlock)
frag of
    Anchor (Header TestBlock)
AF.AnchorGenesis -> Bool
True
    AF.Anchor SlotNo
_ HeaderHash (Header TestBlock)
hash BlockNo
_ -> HeaderHash TestBlock -> Bool
isHonestTestHeaderHash HeaderHash (Header TestBlock)
HeaderHash TestBlock
hash

  isHonestTestHeaderHash :: HeaderHash TestBlock -> Bool
  isHonestTestHeaderHash :: HeaderHash TestBlock -> Bool
isHonestTestHeaderHash = (Word64 -> Bool) -> NonEmpty Word64 -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Word64
0 Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
==) (NonEmpty Word64 -> Bool)
-> (TestHash -> NonEmpty Word64) -> TestHash -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestHash -> NonEmpty Word64
unTestHash