{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE LambdaCase #-}
{-# 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
  ( TestKey
  , testSuite
  ) 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.Genesis.TestSuite
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.Util.Orphans.IOLike ()

data TestKey = ChainSyncKillsBlockFetch
  deriving (TestKey -> TestKey -> Bool
(TestKey -> TestKey -> Bool)
-> (TestKey -> TestKey -> Bool) -> Eq TestKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TestKey -> TestKey -> Bool
== :: TestKey -> TestKey -> Bool
$c/= :: TestKey -> TestKey -> Bool
/= :: TestKey -> TestKey -> Bool
Eq, Eq TestKey
Eq TestKey =>
(TestKey -> TestKey -> Ordering)
-> (TestKey -> TestKey -> Bool)
-> (TestKey -> TestKey -> Bool)
-> (TestKey -> TestKey -> Bool)
-> (TestKey -> TestKey -> Bool)
-> (TestKey -> TestKey -> TestKey)
-> (TestKey -> TestKey -> TestKey)
-> Ord TestKey
TestKey -> TestKey -> Bool
TestKey -> TestKey -> Ordering
TestKey -> TestKey -> TestKey
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: TestKey -> TestKey -> Ordering
compare :: TestKey -> TestKey -> Ordering
$c< :: TestKey -> TestKey -> Bool
< :: TestKey -> TestKey -> Bool
$c<= :: TestKey -> TestKey -> Bool
<= :: TestKey -> TestKey -> Bool
$c> :: TestKey -> TestKey -> Bool
> :: TestKey -> TestKey -> Bool
$c>= :: TestKey -> TestKey -> Bool
>= :: TestKey -> TestKey -> Bool
$cmax :: TestKey -> TestKey -> TestKey
max :: TestKey -> TestKey -> TestKey
$cmin :: TestKey -> TestKey -> TestKey
min :: TestKey -> TestKey -> TestKey
Ord, (forall x. TestKey -> Rep TestKey x)
-> (forall x. Rep TestKey x -> TestKey) -> Generic TestKey
forall x. Rep TestKey x -> TestKey
forall x. TestKey -> Rep TestKey x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TestKey -> Rep TestKey x
from :: forall x. TestKey -> Rep TestKey x
$cto :: forall x. Rep TestKey x -> TestKey
to :: forall x. Rep TestKey x -> TestKey
Generic)
  deriving [TestKey]
[TestKey] -> SmallKey TestKey
forall a. [a] -> SmallKey a
$callKeys :: [TestKey]
allKeys :: [TestKey]
SmallKey via Generically TestKey

-- | Default adjustment of the required number of test runs.
-- Can be set individually on each test definition.
adjustTestCount :: AdjustTestCount
adjustTestCount :: AdjustTestCount
adjustTestCount = (Int -> Int) -> AdjustTestCount
AdjustTestCount Int -> Int
forall a. a -> a
id

-- | Default adjustment of max test case size.
-- Can be set individually on each test definition.
adjustMaxSize :: AdjustMaxSize
adjustMaxSize :: AdjustMaxSize
adjustMaxSize = (Int -> Int) -> AdjustMaxSize
AdjustMaxSize Int -> Int
forall a. a -> a
id

testSuite ::
  ( IssueTestBlock blk
  , AF.HasHeader blk
  , Eq blk
  ) =>
  TestSuite blk TestKey
testSuite :: forall blk.
(IssueTestBlock blk, HasHeader blk, Eq blk) =>
TestSuite blk TestKey
testSuite = String -> TestSuite blk TestKey -> TestSuite blk TestKey
forall blk key. String -> TestSuite blk key -> TestSuite blk key
group String
"linked threads" (TestSuite blk TestKey -> TestSuite blk TestKey)
-> ((TestKey -> ConformanceTest blk) -> TestSuite blk TestKey)
-> (TestKey -> ConformanceTest blk)
-> TestSuite blk TestKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TestKey -> ConformanceTest blk) -> TestSuite blk TestKey
forall key blk.
(Ord key, SmallKey key) =>
(key -> ConformanceTest blk) -> TestSuite blk key
newTestSuite ((TestKey -> ConformanceTest blk) -> TestSuite blk TestKey)
-> (TestKey -> ConformanceTest blk) -> TestSuite blk TestKey
forall a b. (a -> b) -> a -> b
$ \case
  TestKey
ChainSyncKillsBlockFetch -> ConformanceTest blk
forall blk.
(IssueTestBlock blk, HasHeader blk, Eq blk) =>
ConformanceTest blk
testChainSyncKillsBlockFetch

-- | 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.
testChainSyncKillsBlockFetch ::
  ( IssueTestBlock blk
  , AF.HasHeader blk
  , Eq blk
  ) =>
  ConformanceTest blk
testChainSyncKillsBlockFetch :: forall blk.
(IssueTestBlock blk, HasHeader blk, Eq blk) =>
ConformanceTest blk
testChainSyncKillsBlockFetch =
  String
-> AdjustTestCount
-> AdjustMaxSize
-> Gen (GenesisTestFull blk)
-> SchedulerConfig
-> (GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk])
-> (GenesisTestFull blk -> StateView blk -> Bool)
-> ConformanceTest blk
forall prop blk.
Testable prop =>
String
-> AdjustTestCount
-> AdjustMaxSize
-> Gen (GenesisTestFull blk)
-> SchedulerConfig
-> (GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk])
-> (GenesisTestFull blk -> StateView blk -> prop)
-> ConformanceTest blk
mkConformanceTest
    String
"ChainSync kills BlockFetch"
    AdjustTestCount
adjustTestCount
    AdjustMaxSize
adjustMaxSize
    ( do
        gt@GenesisTest{gtBlockTree} <- Gen Word -> Gen (GenesisTest blk ())
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 blk -> StateView blk -> [GenesisTestFull blk]
forall a. Monoid a => a
mempty
    ( \GenesisTestFull blk
_ stateView :: StateView blk
stateView@StateView{Maybe blk
svTipBlock :: Maybe blk
svTipBlock :: forall blk. StateView blk -> Maybe blk
svTipBlock} ->
        Maybe blk
svTipBlock Maybe blk -> Maybe blk -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe blk
forall a. Maybe a
Nothing
          Bool -> Bool -> Bool
&& case PeerSimulatorComponent -> StateView blk -> [SomeException]
forall blk.
PeerSimulatorComponent -> StateView blk -> [SomeException]
exceptionsByComponent PeerSimulatorComponent
ChainSyncClient StateView blk
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 blk -> [SomeException]
forall blk.
PeerSimulatorComponent -> StateView blk -> [SomeException]
exceptionsByComponent PeerSimulatorComponent
BlockFetchClient StateView blk
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 blk -> [SomeException]
forall blk.
PeerSimulatorComponent -> StateView blk -> [SomeException]
exceptionsByComponent PeerSimulatorComponent
ChainSyncServer StateView blk
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 blk -> [SomeException]
forall blk.
PeerSimulatorComponent -> StateView blk -> [SomeException]
exceptionsByComponent PeerSimulatorComponent
BlockFetchServer StateView blk
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]
_ -> String -> (blk, blk)
forall a. HasCallStack => String -> a
error String
"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}}