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

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 TestBlock ()
gt@GenesisTest{BlockTree TestBlock
gtBlockTree :: BlockTree TestBlock
$sel:gtBlockTree:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> BlockTree blk
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.
        PointSchedule TestBlock
ps <- (forall s. STGenM QCGen s -> ST s (PointSchedule TestBlock))
-> Gen (PointSchedule TestBlock)
forall a. (forall s. STGenM QCGen s -> ST s a) -> Gen a
stToGen (BlockTree TestBlock
-> STGenM QCGen s -> ST s (PointSchedule TestBlock)
forall g (m :: * -> *) blk.
(StatefulGen g m, HasHeader blk) =>
BlockTree blk -> g -> m (PointSchedule blk)
longRangeAttack BlockTree TestBlock
gtBlockTree)
        let cls :: Classifiers
cls = GenesisTest TestBlock () -> Classifiers
forall blk schedule.
HasHeader blk =>
GenesisTest blk schedule -> Classifiers
classifiers GenesisTest TestBlock ()
gt
        if Classifiers -> Bool
allAdversariesSelectable Classifiers
cls Bool -> Bool -> Bool
&& Classifiers -> Bool
allAdversariesForecastable Classifiers
cls
          then GenesisTestFull TestBlock -> Gen (GenesisTestFull TestBlock)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenesisTestFull TestBlock -> Gen (GenesisTestFull TestBlock))
-> GenesisTestFull TestBlock -> Gen (GenesisTestFull TestBlock)
forall a b. (a -> b) -> a -> b
$ GenesisTest TestBlock ()
gt GenesisTest TestBlock ()
-> PointSchedule TestBlock -> GenesisTestFull TestBlock
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> PointSchedule TestBlock
ps
          else Gen (GenesisTestFull TestBlock)
forall a. a
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