{-# 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           Data.Maybe (fromJust)
import           Ouroboros.Consensus.Util.IOLike (DiffTime, 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 (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{ChainSyncTimeout
gtChainSyncTimeouts :: ChainSyncTimeout
$sel:gtChainSyncTimeouts:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> ChainSyncTimeout
gtChainSyncTimeouts} <- 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 = GenesisTest TestBlock () -> DiffTime -> PointSchedule TestBlock
forall blk. GenesisTest blk () -> DiffTime -> PointSchedule blk
dullSchedule GenesisTest TestBlock ()
gt (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)
        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
    -- 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
    dullSchedule :: GenesisTest blk () -> DiffTime -> PointSchedule blk
    dullSchedule :: forall blk. GenesisTest blk () -> DiffTime -> PointSchedule blk
dullSchedule GenesisTest {BlockTree blk
gtBlockTree :: BlockTree blk
$sel:gtBlockTree:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree} DiffTime
timeout =
      let (blk
firstBlock, blk
secondBlock) = case AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk -> [blk]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst (AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk -> [blk])
-> AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk -> [blk]
forall a b. (a -> b) -> a -> b
$ BlockTree blk -> AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk
forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk BlockTree blk
gtBlockTree 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, Time
psMinEndTime :: Time
$sel:psMinEndTime:PointSchedule :: Time
psMinEndTime}