{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}

module Test.Consensus.PeerSimulator.Tests.Timeouts (tests) where

import Data.Functor (($>))
import Ouroboros.Consensus.Util.Condense
import Ouroboros.Consensus.Util.IOLike
  ( DiffTime
  , Time (Time)
  , fromException
  )
import qualified Ouroboros.Network.AnchoredFragment as AF
import Ouroboros.Network.Driver.Limits
  ( ProtocolLimitFailure (ExceededTimeLimit)
  )
import Test.Consensus.BlockTree (btTrunk)
import Test.Consensus.Genesis.Setup
import Test.Consensus.PeerSimulator.Run
  ( SchedulerConfig (scEnableChainSyncTimeouts)
  , defaultSchedulerConfig
  )
import Test.Consensus.PeerSimulator.StateView
import Test.Consensus.PointSchedule
import Test.Consensus.PointSchedule.Peers
  ( peersOnlyAdversary
  , peersOnlyHonest
  )
import Test.Consensus.PointSchedule.SinglePeer
  ( scheduleBlockPoint
  , scheduleHeaderPoint
  , scheduleTipPoint
  )
import Test.QuickCheck
import Test.Tasty
import Test.Tasty.QuickCheck
import Test.Util.Orphans.IOLike ()
import Test.Util.TestBlock (TestBlock)
import Test.Util.TestEnv (adjustQuickCheckTests)

tests :: TestTree
tests :: TestTree
tests =
  TestName -> [TestTree] -> TestTree
testGroup
    TestName
"timeouts"
    [ (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
"does time out" (Bool -> Property
prop_timeouts Bool
True)
    , (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
"does not time out" (Bool -> Property
prop_timeouts Bool
False)
    ]

prop_timeouts :: Bool -> Property
prop_timeouts :: Bool -> Property
prop_timeouts Bool
mustTimeout = do
  forall blk prop.
(Testable prop, Condense (StateView blk),
 CondenseList (NodeState blk), ShowProxy blk,
 ShowProxy (Header blk), ConfigSupportsNode blk,
 LedgerSupportsProtocol blk, SerialiseDiskConstraints blk,
 BlockSupportsDiffusionPipelining blk, InspectLedger blk,
 HasHardForkHistory blk, ConvertRawHash blk,
 CanUpgradeLedgerTables (LedgerState blk),
 HasPointScheduleTestParams blk, Eq (Header blk), Eq blk, Terse blk,
 Condense (NodeState blk)) =>
Gen (GenesisTestFull blk)
-> SchedulerConfig
-> (GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk])
-> (GenesisTestFull blk -> StateView blk -> prop)
-> Property
forAllGenesisTest @TestBlock
    ( do
        gt@GenesisTest{gtBlockTree} <- Gen Word -> Gen (GenesisTest TestBlock ())
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
0)
        pure $ enableMustReplyTimeout $ gt $> dullSchedule (btTrunk gtBlockTree)
    )
    SchedulerConfig
defaultSchedulerConfig{scEnableChainSyncTimeouts = True}
    -- 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 TestBlock
_ StateView TestBlock
_ -> [])
    ( \GenesisTestFull TestBlock
_ StateView TestBlock
stateView ->
        case PeerSimulatorComponent -> StateView TestBlock -> [SomeException]
forall blk.
PeerSimulatorComponent -> StateView blk -> [SomeException]
exceptionsByComponent PeerSimulatorComponent
ChainSyncClient StateView TestBlock
stateView of
          [] ->
            TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"result: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ AnchoredFragment (Header TestBlock) -> TestName
forall a. Condense a => a -> TestName
condense (StateView TestBlock -> AnchoredFragment (Header TestBlock)
forall blk. StateView blk -> AnchoredFragment (Header blk)
svSelectedChain StateView TestBlock
stateView)) (Bool -> Bool
not Bool
mustTimeout)
          [SomeException -> Maybe ProtocolLimitFailure
forall e. Exception e => SomeException -> Maybe e
fromException -> Just (ExceededTimeLimit StateToken st
_)] -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
mustTimeout
          [SomeException]
exns ->
            TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"exceptions: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ [SomeException] -> TestName
forall a. Show a => a -> TestName
show [SomeException]
exns) Bool
False
    )
 where
  timeout :: DiffTime
timeout = DiffTime
10

  dullSchedule :: AF.HasHeader blk => AF.AnchoredFragment blk -> PointSchedule blk
  dullSchedule :: forall blk.
HasHeader blk =>
AnchoredFragment blk -> PointSchedule blk
dullSchedule (AF.Empty Anchor blk
_) = TestName -> PointSchedule blk
forall a. HasCallStack => TestName -> a
error TestName
"requires a non-empty block tree"
  dullSchedule (AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk
_ AF.:> blk
tipBlock) =
    let DiffTime
offset :: DiffTime = if Bool
mustTimeout then DiffTime
1 else -DiffTime
1
        psSchedule :: Peers (PeerSchedule blk)
psSchedule =
          (if Bool
mustTimeout then PeerSchedule blk -> Peers (PeerSchedule blk)
forall a. a -> Peers a
peersOnlyAdversary else PeerSchedule blk -> Peers (PeerSchedule blk)
forall a. a -> Peers a
peersOnlyHonest) (PeerSchedule blk -> Peers (PeerSchedule blk))
-> PeerSchedule blk -> Peers (PeerSchedule blk)
forall a b. (a -> b) -> a -> b
$
            [ (DiffTime -> Time
Time DiffTime
0, blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleTipPoint blk
tipBlock)
            , (DiffTime -> Time
Time DiffTime
0, blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleHeaderPoint blk
tipBlock)
            , (DiffTime -> Time
Time DiffTime
0, blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleBlockPoint blk
tipBlock)
            ]
        -- This keeps the test running long enough to pass the timeout by 'offset'.
        psMinEndTime :: Time
psMinEndTime = DiffTime -> Time
Time (DiffTime -> Time) -> DiffTime -> Time
forall a b. (a -> b) -> a -> b
$ DiffTime
timeout DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
+ DiffTime
offset
     in PointSchedule{Peers (PeerSchedule blk)
psSchedule :: Peers (PeerSchedule blk)
psSchedule :: Peers (PeerSchedule blk)
psSchedule, psStartOrder :: [PeerId]
psStartOrder = [], Time
psMinEndTime :: Time
psMinEndTime :: Time
psMinEndTime}

  enableMustReplyTimeout :: GenesisTest blk schedule -> GenesisTest blk schedule
  enableMustReplyTimeout :: forall blk schedule.
GenesisTest blk schedule -> GenesisTest blk schedule
enableMustReplyTimeout GenesisTest blk schedule
gt = GenesisTest blk schedule
gt{gtChainSyncTimeouts = (gtChainSyncTimeouts gt){mustReplyTimeout = Just timeout}}