{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}

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

import           Data.Functor (($>))
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.PeerSimulator.Run (SchedulerConfig (..),
                     defaultSchedulerConfig)
import           Test.Consensus.PeerSimulator.StateView
import           Test.Consensus.PointSchedule
import           Test.Consensus.PointSchedule.Peers (peers')
import           Test.Consensus.PointSchedule.Shrinking (shrinkPeerSchedules)
import           Test.Consensus.PointSchedule.SinglePeer (scheduleBlockPoint,
                     scheduleHeaderPoint, scheduleTipPoint)
import           Test.Tasty
import           Test.Tasty.QuickCheck
import           Test.Util.Orphans.IOLike ()
import           Test.Util.PartialAccessors
import           Test.Util.TestEnv (adjustQuickCheckTests)

tests :: TestTree
tests :: TestTree
tests =
  TestName -> [TestTree] -> TestTree
testGroup
    TestName
"LoE"
    [
      (Int -> Int) -> TestTree -> TestTree
adjustQuickCheckTests (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
5) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
        TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"adversary does not hit timeouts" (Bool -> Property
prop_adversaryHitsTimeouts Bool
False),
      (Int -> Int) -> TestTree -> TestTree
adjustQuickCheckTests (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
5) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
        TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"adversary hits timeouts" (Bool -> Property
prop_adversaryHitsTimeouts 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.
-- NOTE: Same as 'LoP.prop_delayAttack' with timeouts instead of LoP.
prop_adversaryHitsTimeouts :: Bool -> Property
prop_adversaryHitsTimeouts :: Bool -> Property
prop_adversaryHitsTimeouts Bool
timeoutsEnabled =
  -- 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.
  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
          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)
          let ps :: PointSchedule TestBlock
ps = BlockTree TestBlock -> PointSchedule TestBlock
forall blk. HasHeader blk => BlockTree blk -> PointSchedule blk
delaySchedule BlockTree TestBlock
gtBlockTree
          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
      )
      -- NOTE: Crucially, there must be timeouts for this test.
      ( SchedulerConfig
defaultSchedulerConfig
          { scEnableChainSyncTimeouts = timeoutsEnabled,
            scEnableLoE = True,
            scEnableLoP = False
          }
      )
      GenesisTestFull TestBlock
-> StateView TestBlock -> [GenesisTestFull TestBlock]
shrinkPeerSchedules
      ( \GenesisTest {BlockTree TestBlock
$sel:gtBlockTree:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree :: BlockTree TestBlock
gtBlockTree} stateView :: StateView TestBlock
stateView@StateView {AnchoredFragment (Header TestBlock)
svSelectedChain :: AnchoredFragment (Header TestBlock)
svSelectedChain :: forall blk. StateView blk -> AnchoredFragment (Header blk)
svSelectedChain} ->
          let -- The tip of the blocktree trunk.
              treeTipPoint :: Point TestBlock
treeTipPoint = AnchoredFragment TestBlock -> Point TestBlock
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint (AnchoredFragment TestBlock -> Point TestBlock)
-> AnchoredFragment TestBlock -> Point TestBlock
forall a b. (a -> b) -> a -> b
$ BlockTree TestBlock -> AnchoredFragment TestBlock
forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk BlockTree TestBlock
gtBlockTree
              -- The tip of the selection.
              selectedTipPoint :: Point TestBlock
selectedTipPoint = Point (Header TestBlock) -> Point TestBlock
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
AF.castPoint (Point (Header TestBlock) -> Point TestBlock)
-> Point (Header TestBlock) -> Point TestBlock
forall a b. (a -> b) -> a -> b
$ AnchoredFragment (Header TestBlock) -> Point (Header TestBlock)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint AnchoredFragment (Header TestBlock)
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 TestBlock
treeTipPoint Point TestBlock -> Point TestBlock -> Bool
forall a. Eq a => a -> a -> Bool
== Point TestBlock
selectedTipPoint)
              -- If timeouts are enabled, then we expect exactly one
              -- `ExceededTimeLimit` exception in the adversary's ChainSync.
              exceptionsCorrect :: Bool
exceptionsCorrect = case PeerSimulatorComponent -> StateView TestBlock -> [SomeException]
forall blk.
PeerSimulatorComponent -> StateView blk -> [SomeException]
exceptionsByComponent PeerSimulatorComponent
ChainSyncClient StateView TestBlock
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)
$sel:psSchedule:PointSchedule :: Peers (PeerSchedule blk)
psSchedule, Time
psMinEndTime :: Time
$sel:psMinEndTime:PointSchedule :: Time
psMinEndTime}