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