{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeApplications #-}
{-# 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 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 ()
import Test.Util.TestBlock (TestBlock)

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
  forall blk prop.
(Testable prop, Condense (StateView blk),
 CondenseList (NodeState blk), ShowProxy blk,
 ShowProxy (Header blk), ConfigSupportsNode blk,
 LedgerSupportsProtocol blk, SerialiseDiskConstraints blk,
 BlockSupportsDiffusionPipelining blk, InspectLedger blk,
 HasHardForkHistory blk, ConvertRawHash blk,
 CanUpgradeLedgerTables (LedgerState blk),
 HasPointScheduleTestParams blk, Eq (Header blk), Eq blk, Terse blk,
 Condense (NodeState blk)) =>
Gen (GenesisTestFull blk)
-> SchedulerConfig
-> (GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk])
-> (GenesisTestFull blk -> StateView blk -> prop)
-> Property
forAllGenesisTest @TestBlock
    ( do
        gt@GenesisTest{gtBlockTree} <- Gen Word -> Gen (GenesisTest TestBlock ())
forall blk.
(HasHeader blk, IssueTestBlock blk) =>
Gen Word -> Gen (GenesisTest blk ())
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}}