{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ViewPatterns #-}

-- | The scheduled ChainSync and BlockFetch servers are supposed to be linked,
-- such that if one gets disconnected, then so does the other. This module
-- contains a collection of smoke tests to make sure of that.
module Test.Consensus.PeerSimulator.Tests.LinkedThreads (tests) where

import           Control.Monad.Class.MonadAsync (AsyncCancelled (..))
import           Control.Monad.Class.MonadTime.SI (Time (Time))
import           Data.Functor (($>))
import           Ouroboros.Consensus.Util.IOLike (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 (BlockTree (..))
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 (peersOnlyHonest)
import           Test.Consensus.PointSchedule.SinglePeer (scheduleHeaderPoint,
                     scheduleTipPoint)
import           Test.QuickCheck
import           Test.Tasty
import           Test.Tasty.QuickCheck
import           Test.Util.Orphans.IOLike ()

tests :: TestTree
tests :: TestTree
tests = TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"ChainSync kills BlockFetch" Property
prop_chainSyncKillsBlockFetch

-- | Check that when the scheduled ChainSync server gets killed, it takes the
-- BlockFetch one with it. For this, we rely on ChainSync timeouts: the
-- ChainSync server serves just one header and then waits long enough to get
-- disconnected. After that, we give a tick for the BlockFetch server to serve
-- the corresponding block. We check that the block is not served.
prop_chainSyncKillsBlockFetch :: Property
prop_chainSyncKillsBlockFetch :: Property
prop_chainSyncKillsBlockFetch = do
  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
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. AnchoredFragment blk -> PointSchedule blk
dullSchedule (BlockTree TestBlock -> AnchoredFragment TestBlock
forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk BlockTree TestBlock
gtBlockTree)
    )

    SchedulerConfig
defaultSchedulerConfig {scEnableChainSyncTimeouts = True}

    -- No shrinking because the schedule is tiny and hand-crafted
    (\GenesisTestFull TestBlock
_ StateView TestBlock
_ -> [])

    ( \GenesisTestFull TestBlock
_ stateView :: StateView TestBlock
stateView@StateView {Maybe TestBlock
svTipBlock :: Maybe TestBlock
svTipBlock :: forall blk. StateView blk -> Maybe blk
svTipBlock} ->
        Maybe TestBlock
svTipBlock Maybe TestBlock -> Maybe TestBlock -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe TestBlock
forall a. Maybe a
Nothing
          Bool -> Bool -> Bool
&& case PeerSimulatorComponent -> StateView TestBlock -> [SomeException]
forall blk.
PeerSimulatorComponent -> StateView blk -> [SomeException]
exceptionsByComponent PeerSimulatorComponent
ChainSyncClient StateView TestBlock
stateView of
            [SomeException -> Maybe ProtocolLimitFailure
forall e. Exception e => SomeException -> Maybe e
fromException -> Just (ExceededTimeLimit StateToken st
_)] -> Bool
True
            [SomeException]
_                                             -> Bool
False
          Bool -> Bool -> Bool
&& case PeerSimulatorComponent -> StateView TestBlock -> [SomeException]
forall blk.
PeerSimulatorComponent -> StateView blk -> [SomeException]
exceptionsByComponent PeerSimulatorComponent
BlockFetchClient StateView TestBlock
stateView of
            [SomeException -> Maybe AsyncCancelled
forall e. Exception e => SomeException -> Maybe e
fromException -> Just AsyncCancelled
AsyncCancelled] -> Bool
True
            [SomeException]
_                                      -> Bool
False
          Bool -> Bool -> Bool
&& case PeerSimulatorComponent -> StateView TestBlock -> [SomeException]
forall blk.
PeerSimulatorComponent -> StateView blk -> [SomeException]
exceptionsByComponent PeerSimulatorComponent
ChainSyncServer StateView TestBlock
stateView of
            [SomeException -> Maybe AsyncCancelled
forall e. Exception e => SomeException -> Maybe e
fromException -> Just AsyncCancelled
AsyncCancelled] -> Bool
True
            [SomeException]
_                                      -> Bool
False
          Bool -> Bool -> Bool
&& case PeerSimulatorComponent -> StateView TestBlock -> [SomeException]
forall blk.
PeerSimulatorComponent -> StateView blk -> [SomeException]
exceptionsByComponent PeerSimulatorComponent
BlockFetchServer StateView TestBlock
stateView of
            [SomeException -> Maybe AsyncCancelled
forall e. Exception e => SomeException -> Maybe e
fromException -> Just AsyncCancelled
AsyncCancelled] -> Bool
True
            [SomeException]
_                                      -> Bool
False
    )
  where
    timeout :: DiffTime
timeout = DiffTime
10

    dullSchedule :: AF.AnchoredFragment blk -> PointSchedule blk
    dullSchedule :: forall blk. AnchoredFragment blk -> PointSchedule blk
dullSchedule AnchoredFragment blk
trunk =
      let (blk
firstBlock, blk
secondBlock) = case AnchoredFragment blk -> [blk]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst AnchoredFragment blk
trunk of
            blk
b1 : blk
b2 : [blk]
_ -> (blk
b1, blk
b2)
            [blk]
_           -> TestName -> (blk, blk)
forall a. HasCallStack => TestName -> a
error TestName
"block tree must have two blocks"
          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
secondBlock),
              (DiffTime -> Time
Time DiffTime
0, blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleHeaderPoint blk
firstBlock)
            ]
          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
1
       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 } }