{-# 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 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
0)
        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
$ GenesisTestFull TestBlock -> GenesisTestFull TestBlock
forall blk schedule.
GenesisTest blk schedule -> GenesisTest blk schedule
enableMustReplyTimeout (GenesisTestFull TestBlock -> GenesisTestFull TestBlock)
-> GenesisTestFull TestBlock -> 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
$> AnchoredFragment TestBlock -> PointSchedule TestBlock
forall blk.
HasHeader blk =>
AnchoredFragment blk -> PointSchedule blk
dullSchedule (BlockTree TestBlock -> AnchoredFragment TestBlock
forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk BlockTree TestBlock
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)
$sel:psSchedule:PointSchedule :: Peers (PeerSchedule blk)
psSchedule, $sel:psStartOrder:PointSchedule :: [PeerId]
psStartOrder = [], Time
psMinEndTime :: Time
$sel:psMinEndTime:PointSchedule :: 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 } }