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

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

import Data.Functor (($>))
import Test.Consensus.Genesis.Setup
import Test.Consensus.Genesis.Setup.Classifiers
  ( allAdversariesForecastable
  , allAdversariesSelectable
  , classifiers
  )
import Test.Consensus.PeerSimulator.Run (defaultSchedulerConfig)
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)
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
$
    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.
          gt@GenesisTest{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)
          -- 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]
forall blk.
(HasHeader blk, Ord blk) =>
GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk]
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
genesisTest -> Bool -> Bool
not (Bool -> Bool)
-> (StateView TestBlock -> Bool) -> StateView TestBlock -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenesisTestFull TestBlock -> StateView TestBlock -> Bool
forall blk.
GetHeader blk =>
GenesisTestFull blk -> StateView blk -> Bool
selectedHonestChain GenesisTestFull TestBlock
genesisTest)