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

-- | Long range attack tests.
module Test.Consensus.Genesis.Tests.LongRangeAttack
  ( TestKey
  , testSuite
  ) where

import Data.Functor (($>))
import Ouroboros.Consensus.Block.Abstract (GetHeader, HasHeader)
import qualified Ouroboros.Network.AnchoredFragment as AF
import Test.Consensus.Genesis.Setup
import Test.Consensus.Genesis.Setup.Classifiers
  ( allAdversariesForecastable
  , allAdversariesSelectable
  , classifiers
  )
import Test.Consensus.Genesis.TestSuite
import Test.Consensus.PeerSimulator.Run (defaultSchedulerConfig)
import qualified Test.Consensus.PointSchedule as Schedule
import Test.Tasty.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
10)

-- | 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

-- | Each value of this type uniquely corresponds to a test defined in this module.
data TestKey = LongRangeAttack
  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 ::
  ( HasHeader blk
  , GetHeader blk
  , IssueTestBlock blk
  ) =>
  TestSuite blk TestKey
testSuite :: forall blk.
(HasHeader blk, GetHeader blk, IssueTestBlock blk) =>
TestSuite blk TestKey
testSuite = String -> TestSuite blk TestKey -> TestSuite blk TestKey
forall blk key. String -> TestSuite blk key -> TestSuite blk key
group String
"long range attack" (TestSuite blk TestKey -> TestSuite blk TestKey)
-> TestSuite blk TestKey -> TestSuite blk TestKey
forall a b. (a -> b) -> a -> b
$ (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
  -- 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
  -- below.
  TestKey
LongRangeAttack -> ConformanceTest blk
forall blk.
(HasHeader blk, GetHeader blk, IssueTestBlock blk) =>
ConformanceTest blk
testLongRangeAttack

-- | 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.
testLongRangeAttack ::
  forall blk.
  ( AF.HasHeader blk
  , GetHeader blk
  , IssueTestBlock blk
  ) =>
  ConformanceTest blk
testLongRangeAttack :: forall blk.
(HasHeader blk, GetHeader blk, IssueTestBlock blk) =>
ConformanceTest blk
testLongRangeAttack =
  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
"one adversary"
    AdjustTestCount
adjustTestCount
    AdjustMaxSize
adjustMaxSize
    ( do
        -- Create a block tree with @1@ alternative chain.
        gt@GenesisTest{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)
        -- Create a 'longRangeAttack' schedule based on the generated chains.
        ps <- Schedule.stToGen (Schedule.longRangeAttack gtBlockTree)
        let cls = GenesisTest blk () -> Classifiers
forall blk schedule.
HasHeader blk =>
GenesisTest blk schedule -> Classifiers
classifiers GenesisTest blk ()
gt
        if allAdversariesSelectable cls && allAdversariesForecastable cls
          then pure $ gt $> ps
          else discard
    )
    SchedulerConfig
defaultSchedulerConfig
    GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk]
forall a. Monoid a => a
mempty
    -- FIXME: This is the expected behaviour of Praos to be reversed with
    -- Genesis. But we are testing Praos for the moment. Do not forget to
    -- use `Test.Consensus.PointSchedule.Shrinking.shrinkPeerSchedules`
    -- above when removing this negation.
    (\GenesisTestFull blk
genesisTest -> Bool -> Bool
not (Bool -> Bool) -> (StateView blk -> Bool) -> StateView blk -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenesisTestFull blk -> StateView blk -> Bool
forall blk.
GetHeader blk =>
GenesisTestFull blk -> StateView blk -> Bool
selectedHonestChain GenesisTestFull blk
genesisTest)