{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
module Test.Consensus.PeerSimulator.Tests.Timeouts (tests) where
import Data.Functor (($>))
import Data.Maybe (fromJust)
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 (defaultSchedulerConfig)
import Test.Consensus.PeerSimulator.StateView
import Test.Consensus.PointSchedule
import Test.Consensus.PointSchedule.Peers (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{ChainSyncTimeout
gtChainSyncTimeouts :: ChainSyncTimeout
$sel:gtChainSyncTimeouts:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> ChainSyncTimeout
gtChainSyncTimeouts, 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)
let schedule :: PointSchedule TestBlock
schedule = DiffTime -> AnchoredFragment TestBlock -> PointSchedule TestBlock
forall blk.
HasHeader blk =>
DiffTime -> AnchoredFragment blk -> PointSchedule blk
dullSchedule (Maybe DiffTime -> DiffTime
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe DiffTime -> DiffTime) -> Maybe DiffTime -> DiffTime
forall a b. (a -> b) -> a -> b
$ ChainSyncTimeout -> Maybe DiffTime
mustReplyTimeout ChainSyncTimeout
gtChainSyncTimeouts) (BlockTree TestBlock -> AnchoredFragment TestBlock
forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk 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
schedule
)
SchedulerConfig
defaultSchedulerConfig
(\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 PeerHasAgency pr 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
dullSchedule :: AF.HasHeader blk => DiffTime -> AF.AnchoredFragment blk -> PointSchedule blk
dullSchedule :: forall blk.
HasHeader blk =>
DiffTime -> AnchoredFragment blk -> PointSchedule blk
dullSchedule DiffTime
_ (AF.Empty Anchor blk
_) = TestName -> PointSchedule blk
forall a. HasCallStack => TestName -> a
error TestName
"requires a non-empty block tree"
dullSchedule DiffTime
timeout (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 = 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)
]
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, Time
psMinEndTime :: Time
$sel:psMinEndTime:PointSchedule :: Time
psMinEndTime}