{-# 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{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}
    -- 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)
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}}