{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# 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 Ouroboros.Network.Protocol.ChainSync.Codec (mustReplyTimeout)
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.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
  Gen (GenesisTestFull TestBlock)
-> SchedulerConfig
-> (GenesisTestFull TestBlock
    -> StateView TestBlock -> [GenesisTestFull TestBlock])
-> (GenesisTestFull TestBlock -> StateView TestBlock -> Property)
-> 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{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
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}}