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

-- | Limit on Eagerness tests.
module Test.Consensus.Genesis.Tests.LoE
  ( TestKey
  , testSuite
  ) where

import Data.Functor (($>))
import Ouroboros.Consensus.Block.Abstract (Header)
import Ouroboros.Consensus.Util.IOLike (Time (Time), fromException)
import Ouroboros.Network.AnchoredFragment (HasHeader (..))
import qualified Ouroboros.Network.AnchoredFragment as AF
import Ouroboros.Network.Driver.Limits
  ( ProtocolLimitFailure (ExceededTimeLimit)
  )
import Test.Consensus.BlockTree (BlockTree (..), BlockTreeBranch (..))
import Test.Consensus.Genesis.Setup
import Test.Consensus.Genesis.TestSuite
import Test.Consensus.PeerSimulator.Run
  ( SchedulerConfig (..)
  , defaultSchedulerConfig
  )
import Test.Consensus.PeerSimulator.StateView
import Test.Consensus.PointSchedule
import Test.Consensus.PointSchedule.Peers (peers')
import Test.Consensus.PointSchedule.SinglePeer
  ( scheduleBlockPoint
  , scheduleHeaderPoint
  , scheduleTipPoint
  )
import Test.Util.Orphans.IOLike ()
import Test.Util.PartialAccessors

-- | 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. Num a => a -> a -> a
* 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 -> Int
forall a. Integral a => a -> a -> a
`div` Int
5)

-- | Each value of this type uniquely corresponds to a test defined in this module.
data TestKey
  = AdversaryDoesNotHitTimeouts
  | AdversaryHitsTimeouts
  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
  , HasHeader (Header blk)
  , IssueTestBlock blk
  ) =>
  TestSuite blk TestKey
testSuite :: forall blk.
(HasHeader blk, HasHeader (Header 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
"LoE" (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
  TestKey
AdversaryDoesNotHitTimeouts ->
    String -> Bool -> ConformanceTest blk
forall blk.
(HasHeader blk, HasHeader (Header blk), IssueTestBlock blk) =>
String -> Bool -> ConformanceTest blk
testAdversaryHitsTimeouts String
"adversary does not hit timeouts" Bool
False
  TestKey
AdversaryHitsTimeouts ->
    String -> Bool -> ConformanceTest blk
forall blk.
(HasHeader blk, HasHeader (Header blk), IssueTestBlock blk) =>
String -> Bool -> ConformanceTest blk
testAdversaryHitsTimeouts String
"adversary hits timeouts" Bool
True

-- | Tests that the selection advances in presence of the LoE when a peer is
-- killed by something that is not LoE-aware, eg. the timeouts. This test
-- features an honest peer behaving normally and an adversarial peer behaving
-- such that it will get killed by timeouts. We check that, after the adversary
-- gets disconnected, the LoE gets updated to stop taking it into account. There
-- are two variants of the test: one with timeouts enabled, and one without. In
-- the case where timeouts are disabled, we check that we do in fact remain
-- stuck at the intersection between trunk and other chain.
--
-- NOTE: Same as 'LoP.testDelayAttack' with timeouts instead of LoP.
testAdversaryHitsTimeouts ::
  ( HasHeader blk
  , HasHeader (Header blk)
  , IssueTestBlock blk
  ) =>
  String -> Bool -> ConformanceTest blk
testAdversaryHitsTimeouts :: forall blk.
(HasHeader blk, HasHeader (Header blk), IssueTestBlock blk) =>
String -> Bool -> ConformanceTest blk
testAdversaryHitsTimeouts String
description Bool
timeoutsEnabled =
  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
description
    AdjustTestCount
adjustTestCount
    AdjustMaxSize
adjustMaxSize
    ( do
        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)
        let ps = BlockTree blk -> PointSchedule blk
forall blk. HasHeader blk => BlockTree blk -> PointSchedule blk
delaySchedule BlockTree blk
gtBlockTree
        pure $ gt $> ps
    )
    -- NOTE: Crucially, there must be timeouts for this test.
    ( SchedulerConfig
defaultSchedulerConfig
        { scEnableChainSyncTimeouts = timeoutsEnabled
        , scEnableLoE = True
        , scEnableLoP = False
        }
    )
    -- Here we can't shrink because we exploit the properties of the
    -- point schedule to wait at the end of the test for the
    -- adversaries to get disconnected, by adding an extra point.
    -- If this point gets removed by the shrinker, we lose that
    -- property and the test becomes useless.
    GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk]
forall a. Monoid a => a
mempty
    ( \GenesisTest{BlockTree blk
gtBlockTree :: forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree :: BlockTree blk
gtBlockTree} stateView :: StateView blk
stateView@StateView{AnchoredFragment (Header blk)
svSelectedChain :: AnchoredFragment (Header blk)
svSelectedChain :: forall blk. StateView blk -> AnchoredFragment (Header blk)
svSelectedChain} ->
        let
          -- The tip of the blocktree trunk.
          treeTipPoint :: Point blk
treeTipPoint = AnchoredFragment blk -> Point blk
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint (AnchoredFragment blk -> Point blk)
-> AnchoredFragment blk -> Point blk
forall a b. (a -> b) -> a -> b
$ BlockTree blk -> AnchoredFragment blk
forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk BlockTree blk
gtBlockTree
          -- The tip of the selection.
          selectedTipPoint :: Point blk
selectedTipPoint = Point (Header blk) -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
AF.castPoint (Point (Header blk) -> Point blk)
-> Point (Header blk) -> Point blk
forall a b. (a -> b) -> a -> b
$ AnchoredFragment (Header blk) -> Point (Header blk)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint AnchoredFragment (Header blk)
svSelectedChain
          -- If timeouts are enabled, then the adversary should have been
          -- killed and the selection should be the whole trunk.
          selectedCorrect :: Bool
selectedCorrect = Bool
timeoutsEnabled Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== (Point blk
treeTipPoint Point blk -> Point blk -> Bool
forall a. Eq a => a -> a -> Bool
== Point blk
selectedTipPoint)
          -- If timeouts are enabled, then we expect exactly one
          -- `ExceededTimeLimit` exception in the adversary's ChainSync.
          exceptionsCorrect :: Bool
exceptionsCorrect = case PeerSimulatorComponent -> StateView blk -> [SomeException]
forall blk.
PeerSimulatorComponent -> StateView blk -> [SomeException]
exceptionsByComponent PeerSimulatorComponent
ChainSyncClient StateView blk
stateView of
            [] -> Bool -> Bool
not Bool
timeoutsEnabled
            [SomeException -> Maybe ProtocolLimitFailure
forall e. Exception e => SomeException -> Maybe e
fromException -> Just (ExceededTimeLimit StateToken st
_)] -> Bool
timeoutsEnabled
            [SomeException]
_ -> Bool
False
         in
          Bool
selectedCorrect Bool -> Bool -> Bool
&& Bool
exceptionsCorrect
    )
 where
  delaySchedule :: HasHeader blk => BlockTree blk -> PointSchedule blk
  delaySchedule :: forall blk. HasHeader blk => BlockTree blk -> PointSchedule blk
delaySchedule BlockTree blk
tree =
    let trunkTip :: blk
trunkTip = BlockTree blk -> blk
forall blk. HasHeader blk => BlockTree blk -> blk
getTrunkTip BlockTree blk
tree
        branch :: BlockTreeBranch blk
branch = BlockTree blk -> BlockTreeBranch blk
forall blk. BlockTree blk -> BlockTreeBranch blk
getOnlyBranch BlockTree blk
tree
        intersectM :: Maybe blk
intersectM = case BlockTreeBranch blk -> AnchoredFragment blk
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbPrefix BlockTreeBranch blk
branch of
          (AF.Empty Anchor blk
_) -> Maybe blk
forall a. Maybe a
Nothing
          (AnchoredFragment blk
_ AF.:> blk
tipBlock) -> blk -> Maybe blk
forall a. a -> Maybe a
Just blk
tipBlock
        branchTip :: blk
branchTip = BlockTree blk -> blk
forall blk. HasHeader blk => BlockTree blk -> blk
getOnlyBranchTip BlockTree blk
tree
        psSchedule :: Peers (PeerSchedule blk)
psSchedule =
          [PeerSchedule blk]
-> [PeerSchedule blk] -> Peers (PeerSchedule blk)
forall a. [a] -> [a] -> Peers a
peers'
            -- Eagerly serve the honest tree, but after the adversary has
            -- advertised its chain.
            [ (DiffTime -> Time
Time DiffTime
0, blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleTipPoint blk
trunkTip) (Time, SchedulePoint blk) -> PeerSchedule blk -> PeerSchedule blk
forall a. a -> [a] -> [a]
: case Maybe blk
intersectM of
                Maybe blk
Nothing ->
                  [ (DiffTime -> Time
Time DiffTime
0.5, blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleHeaderPoint blk
trunkTip)
                  , (DiffTime -> Time
Time DiffTime
0.5, blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleBlockPoint blk
trunkTip)
                  ]
                Just blk
intersect ->
                  [ (DiffTime -> Time
Time DiffTime
0.5, blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleHeaderPoint blk
intersect)
                  , (DiffTime -> Time
Time DiffTime
0.5, blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleBlockPoint blk
intersect)
                  , (DiffTime -> Time
Time DiffTime
5, blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleHeaderPoint blk
trunkTip)
                  , (DiffTime -> Time
Time DiffTime
5, blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleBlockPoint blk
trunkTip)
                  ]
            ]
            -- The one adversarial peer advertises and serves up to the
            -- intersection early, then waits more than the short wait timeout.
            [ (DiffTime -> Time
Time DiffTime
0, blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleTipPoint blk
branchTip) (Time, SchedulePoint blk) -> PeerSchedule blk -> PeerSchedule blk
forall a. a -> [a] -> [a]
: case Maybe blk
intersectM of
                -- the alternate branch forks from `Origin`
                Maybe blk
Nothing -> []
                -- the alternate branch forks from `intersect`
                Just blk
intersect ->
                  [ (DiffTime -> Time
Time DiffTime
0, blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleHeaderPoint blk
intersect)
                  , (DiffTime -> Time
Time DiffTime
0, blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleBlockPoint blk
intersect)
                  ]
            ]
        -- We want to wait more than the short wait timeout
        psMinEndTime :: Time
psMinEndTime = DiffTime -> Time
Time DiffTime
11
     in PointSchedule{Peers (PeerSchedule blk)
psSchedule :: Peers (PeerSchedule blk)
psSchedule :: Peers (PeerSchedule blk)
psSchedule, psStartOrder :: [PeerId]
psStartOrder = [], Time
psMinEndTime :: Time
psMinEndTime :: Time
psMinEndTime}