{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

-- | Business logic of the ChainSync and BlockFetch protocol handlers that operate
-- on the 'NodeState' of a point schedule.
--
-- These are separated from the scheduling related mechanics of the
-- server mocks that the peer simulator uses, in
-- "Test.Consensus.PeerSimulator.ScheduledChainSyncServer" and
-- "Test.Consensus.PeerSimulator.ScheduledBlockFetchServer".
module Test.Consensus.PeerSimulator.Handlers (
    handlerBlockFetch
  , handlerFindIntersection
  , handlerRequestNext
  , handlerSendBlocks
  ) where

import           Cardano.Slotting.Slot (WithOrigin (..))
import           Control.Monad.Trans (lift)
import           Control.Monad.Writer.Strict (MonadWriter (tell),
                     WriterT (runWriterT))
import           Data.List (isSuffixOf)
import qualified Data.List.NonEmpty as NonEmpty
import           Data.Maybe (fromJust, fromMaybe)
import           Ouroboros.Consensus.Block (HasHeader, HeaderHash,
                     Point (GenesisPoint), blockHash, getHeader, withOrigin)
import           Ouroboros.Consensus.Util.IOLike (IOLike, STM, StrictTVar,
                     readTVar, writeTVar)
import           Ouroboros.Network.AnchoredFragment (AnchoredFragment)
import qualified Ouroboros.Network.AnchoredFragment as AF
import           Ouroboros.Network.Block (Tip (TipGenesis), blockPoint,
                     getTipPoint, tipFromHeader)
import           Ouroboros.Network.BlockFetch.ClientState
                     (ChainRange (ChainRange))
import qualified Test.Consensus.BlockTree as BT
import           Test.Consensus.BlockTree (BlockTree)
import           Test.Consensus.Network.AnchoredFragment.Extras (intersectWith)
import           Test.Consensus.PeerSimulator.ScheduledBlockFetchServer
                     (BlockFetch (..), SendBlocks (..))
import           Test.Consensus.PeerSimulator.ScheduledChainSyncServer
                     (FindIntersect (..),
                     RequestNext (AwaitReply, RollBackward, RollForward))
import           Test.Consensus.PeerSimulator.Trace
                     (TraceScheduledBlockFetchServerEvent (..),
                     TraceScheduledChainSyncServerEvent (..))
import           Test.Consensus.PointSchedule.NodeState
import           Test.Util.Orphans.IOLike ()
import           Test.Util.TestBlock (TestBlock, TestHash (TestHash))

-- | More efficient implementation of a check used in some of the handlers,
-- determining whether the first argument is on the chain that ends in the
-- second argument.
-- We would usually call @withinFragmentBounds@ for this, but since we're
-- using 'TestBlock', looking at the hash is cheaper.
--
-- TODO: Unify with 'Test.UtilTestBlock.isAncestorOf' which basically does the
-- same thing except not on 'WithOrigin'.
isAncestorOf ::
  HasHeader blk1 =>
  HasHeader blk2 =>
  HeaderHash blk1 ~ TestHash =>
  HeaderHash blk2 ~ TestHash =>
  WithOrigin blk1 ->
  WithOrigin blk2 ->
  Bool
isAncestorOf :: forall blk1 blk2.
(HasHeader blk1, HasHeader blk2, HeaderHash blk1 ~ TestHash,
 HeaderHash blk2 ~ TestHash) =>
WithOrigin blk1 -> WithOrigin blk2 -> Bool
isAncestorOf (At blk1
ancestor) (At blk2
descendant) =
  [Word64] -> [Word64] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isSuffixOf (NonEmpty Word64 -> [Word64]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Word64
hashA) (NonEmpty Word64 -> [Word64]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Word64
hashD)
  where
    TestHash NonEmpty Word64
hashA = blk1 -> HeaderHash blk1
forall b. HasHeader b => b -> HeaderHash b
blockHash blk1
ancestor
    TestHash NonEmpty Word64
hashD = blk2 -> HeaderHash blk2
forall b. HasHeader b => b -> HeaderHash b
blockHash blk2
descendant
isAncestorOf (At blk1
_) WithOrigin blk2
Origin = Bool
False
isAncestorOf WithOrigin blk1
Origin WithOrigin blk2
_ = Bool
True

-- | Handle a @MsgFindIntersect@ message.
--
-- Extracts the fragment up to the current advertised tip from the block tree,
-- then searches for any of the client's points in it.
handlerFindIntersection ::
  (IOLike m, HasHeader blk) =>
  StrictTVar m (Point blk) ->
  BlockTree blk ->
  [Point blk] ->
  NodeState blk ->
  STM m (Maybe (FindIntersect blk), [TraceScheduledChainSyncServerEvent (NodeState blk) blk])
handlerFindIntersection :: forall (m :: * -> *) blk.
(IOLike m, HasHeader blk) =>
StrictTVar m (Point blk)
-> BlockTree blk
-> [Point blk]
-> NodeState blk
-> STM
     m
     (Maybe (FindIntersect blk),
      [TraceScheduledChainSyncServerEvent (NodeState blk) blk])
handlerFindIntersection StrictTVar m (Point blk)
currentIntersection BlockTree blk
blockTree [Point blk]
clientPoints NodeState blk
points = do
  let tip' :: Tip blk
tip' = NodeState blk -> Tip blk
forall blk. HasHeader blk => NodeState blk -> Tip blk
nsTipTip NodeState blk
points
      tipPoint :: Point blk
tipPoint = Tip blk -> Point blk
forall {k} (b :: k). Tip b -> Point b
getTipPoint Tip blk
tip'
      fragment :: AnchoredFragment blk
fragment = Maybe (AnchoredFragment blk) -> AnchoredFragment blk
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (AnchoredFragment blk) -> AnchoredFragment blk)
-> Maybe (AnchoredFragment blk) -> AnchoredFragment blk
forall a b. (a -> b) -> a -> b
$ Point blk -> BlockTree blk -> Maybe (AnchoredFragment blk)
forall blk.
HasHeader blk =>
Point blk -> BlockTree blk -> Maybe (AnchoredFragment blk)
BT.findFragment Point blk
tipPoint BlockTree blk
blockTree
  case AnchoredFragment blk -> [Point blk] -> Maybe (Point blk)
forall b.
HasHeader b =>
AnchoredFragment b -> [Point b] -> Maybe (Point b)
intersectWith AnchoredFragment blk
fragment [Point blk]
clientPoints of
    Maybe (Point blk)
Nothing ->
      (Maybe (FindIntersect blk),
 [TraceScheduledChainSyncServerEvent (NodeState blk) blk])
-> STM
     m
     (Maybe (FindIntersect blk),
      [TraceScheduledChainSyncServerEvent (NodeState blk) blk])
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FindIntersect blk -> Maybe (FindIntersect blk)
forall a. a -> Maybe a
Just (Tip blk -> FindIntersect blk
forall blk. Tip blk -> FindIntersect blk
IntersectNotFound Tip blk
tip'), [])
    Just Point blk
intersection -> do
      StrictTVar m (Point blk) -> Point blk -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (Point blk)
currentIntersection Point blk
intersection
      (Maybe (FindIntersect blk),
 [TraceScheduledChainSyncServerEvent (NodeState blk) blk])
-> STM
     m
     (Maybe (FindIntersect blk),
      [TraceScheduledChainSyncServerEvent (NodeState blk) blk])
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FindIntersect blk -> Maybe (FindIntersect blk)
forall a. a -> Maybe a
Just (Point blk -> Tip blk -> FindIntersect blk
forall blk. Point blk -> Tip blk -> FindIntersect blk
IntersectFound Point blk
intersection Tip blk
tip'), [])

-- | Handle a @MsgRequestNext@ message.
--
-- Finds the potential path from the current intersection to the advertised header point for this turn,
-- which can have four distinct configurations for the anchor point and the path:
--
-- - Anchor == intersection == header point
-- - header point after intersection == header point
-- - header point before intersection (special case for the point scheduler architecture)
-- - Anchor != intersection
handlerRequestNext ::
  forall m.
  (IOLike m) =>
  StrictTVar m (Point TestBlock) ->
  BlockTree TestBlock ->
  NodeState TestBlock ->
  STM m (Maybe (RequestNext TestBlock), [TraceScheduledChainSyncServerEvent (NodeState TestBlock) TestBlock])
handlerRequestNext :: forall (m :: * -> *).
IOLike m =>
StrictTVar m (Point TestBlock)
-> BlockTree TestBlock
-> NodeState TestBlock
-> STM
     m
     (Maybe (RequestNext TestBlock),
      [TraceScheduledChainSyncServerEvent
         (NodeState TestBlock) TestBlock])
handlerRequestNext StrictTVar m (Point TestBlock)
currentIntersection BlockTree TestBlock
blockTree NodeState TestBlock
points =
  WriterT
  [TraceScheduledChainSyncServerEvent
     (NodeState TestBlock) TestBlock]
  (STM m)
  (Maybe (RequestNext TestBlock))
-> STM
     m
     (Maybe (RequestNext TestBlock),
      [TraceScheduledChainSyncServerEvent
         (NodeState TestBlock) TestBlock])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT
   [TraceScheduledChainSyncServerEvent
      (NodeState TestBlock) TestBlock]
   (STM m)
   (Maybe (RequestNext TestBlock))
 -> STM
      m
      (Maybe (RequestNext TestBlock),
       [TraceScheduledChainSyncServerEvent
          (NodeState TestBlock) TestBlock]))
-> WriterT
     [TraceScheduledChainSyncServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     (Maybe (RequestNext TestBlock))
-> STM
     m
     (Maybe (RequestNext TestBlock),
      [TraceScheduledChainSyncServerEvent
         (NodeState TestBlock) TestBlock])
forall a b. (a -> b) -> a -> b
$ do
    Point TestBlock
intersection <- STM m (Point TestBlock)
-> WriterT
     [TraceScheduledChainSyncServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     (Point TestBlock)
forall (m :: * -> *) a.
Monad m =>
m a
-> WriterT
     [TraceScheduledChainSyncServerEvent
        (NodeState TestBlock) TestBlock]
     m
     a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (STM m (Point TestBlock)
 -> WriterT
      [TraceScheduledChainSyncServerEvent
         (NodeState TestBlock) TestBlock]
      (STM m)
      (Point TestBlock))
-> STM m (Point TestBlock)
-> WriterT
     [TraceScheduledChainSyncServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     (Point TestBlock)
forall a b. (a -> b) -> a -> b
$ StrictTVar m (Point TestBlock) -> STM m (Point TestBlock)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Point TestBlock)
currentIntersection
    TraceScheduledChainSyncServerEvent (NodeState TestBlock) TestBlock
-> WriterT
     [TraceScheduledChainSyncServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     ()
trace (TraceScheduledChainSyncServerEvent (NodeState TestBlock) TestBlock
 -> WriterT
      [TraceScheduledChainSyncServerEvent
         (NodeState TestBlock) TestBlock]
      (STM m)
      ())
-> TraceScheduledChainSyncServerEvent
     (NodeState TestBlock) TestBlock
-> WriterT
     [TraceScheduledChainSyncServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     ()
forall a b. (a -> b) -> a -> b
$ Point TestBlock
-> TraceScheduledChainSyncServerEvent
     (NodeState TestBlock) TestBlock
forall state blk.
Point blk -> TraceScheduledChainSyncServerEvent state blk
TraceLastIntersection Point TestBlock
intersection
    Point TestBlock
-> WithOrigin TestBlock
-> WriterT
     [TraceScheduledChainSyncServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     (Maybe (RequestNext TestBlock))
withHeader Point TestBlock
intersection (NodeState TestBlock -> WithOrigin TestBlock
forall blk. NodeState blk -> WithOrigin blk
nsHeader NodeState TestBlock
points)
  where
    withHeader ::
      Point TestBlock ->
      WithOrigin TestBlock ->
      WriterT
        [TraceScheduledChainSyncServerEvent (NodeState TestBlock) TestBlock]
        (STM m)
        (Maybe (RequestNext TestBlock))
    withHeader :: Point TestBlock
-> WithOrigin TestBlock
-> WriterT
     [TraceScheduledChainSyncServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     (Maybe (RequestNext TestBlock))
withHeader Point TestBlock
intersection WithOrigin TestBlock
h =
      WriterT
  [TraceScheduledChainSyncServerEvent
     (NodeState TestBlock) TestBlock]
  (STM m)
  (Maybe (RequestNext TestBlock))
-> ((PathAnchoredAtSource,
     AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock)
    -> WriterT
         [TraceScheduledChainSyncServerEvent
            (NodeState TestBlock) TestBlock]
         (STM m)
         (Maybe (RequestNext TestBlock)))
-> Maybe
     (PathAnchoredAtSource,
      AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock)
-> WriterT
     [TraceScheduledChainSyncServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     (Maybe (RequestNext TestBlock))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe WriterT
  [TraceScheduledChainSyncServerEvent
     (NodeState TestBlock) TestBlock]
  (STM m)
  (Maybe (RequestNext TestBlock))
forall {a}. a
noPathError (PathAnchoredAtSource,
 AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock)
-> WriterT
     [TraceScheduledChainSyncServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     (Maybe (RequestNext TestBlock))
analysePath (Point TestBlock
-> Point TestBlock
-> BlockTree TestBlock
-> Maybe
     (PathAnchoredAtSource,
      AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock)
forall blk.
HasHeader blk =>
Point blk
-> Point blk
-> BlockTree blk
-> Maybe (PathAnchoredAtSource, AnchoredFragment blk)
BT.findPath Point TestBlock
intersection Point TestBlock
hp BlockTree TestBlock
blockTree)
      where
        hp :: Point TestBlock
hp = Point TestBlock
-> (TestBlock -> Point TestBlock)
-> WithOrigin TestBlock
-> Point TestBlock
forall b t. b -> (t -> b) -> WithOrigin t -> b
withOrigin Point TestBlock
forall {k} (block :: k). Point block
GenesisPoint TestBlock -> Point TestBlock
forall block. HasHeader block => block -> Point block
blockPoint WithOrigin TestBlock
h

    noPathError :: a
noPathError = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"serveHeader: intersection and headerPoint should always be in the block tree"

    analysePath :: (PathAnchoredAtSource,
 AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock)
-> WriterT
     [TraceScheduledChainSyncServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     (Maybe (RequestNext TestBlock))
analysePath = \case
      -- If the anchor is the intersection (the source of the path-finding) but
      -- the fragment is empty, then the intersection is exactly our header
      -- point and there is nothing to do. If additionally the header point is
      -- also the tip point or a descendent of it (because we served our whole
      -- chain, or we are stalling as an adversarial behaviour), then we ask the
      -- client to wait; otherwise we just do nothing.
      (BT.PathAnchoredAtSource Bool
True, AF.Empty Anchor TestBlock
_) | WithOrigin TestBlock -> WithOrigin TestBlock -> Bool
forall blk1 blk2.
(HasHeader blk1, HasHeader blk2, HeaderHash blk1 ~ TestHash,
 HeaderHash blk2 ~ TestHash) =>
WithOrigin blk1 -> WithOrigin blk2 -> Bool
isAncestorOf (NodeState TestBlock -> WithOrigin TestBlock
forall blk. NodeState blk -> WithOrigin blk
nsTip NodeState TestBlock
points) (NodeState TestBlock -> WithOrigin TestBlock
forall blk. NodeState blk -> WithOrigin blk
nsHeader NodeState TestBlock
points) -> do
        TraceScheduledChainSyncServerEvent (NodeState TestBlock) TestBlock
-> WriterT
     [TraceScheduledChainSyncServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     ()
trace TraceScheduledChainSyncServerEvent (NodeState TestBlock) TestBlock
forall state blk. TraceScheduledChainSyncServerEvent state blk
TraceChainIsFullyServed
        Maybe (RequestNext TestBlock)
-> WriterT
     [TraceScheduledChainSyncServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     (Maybe (RequestNext TestBlock))
forall a.
a
-> WriterT
     [TraceScheduledChainSyncServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RequestNext TestBlock -> Maybe (RequestNext TestBlock)
forall a. a -> Maybe a
Just RequestNext TestBlock
forall blk. RequestNext blk
AwaitReply)
      (BT.PathAnchoredAtSource Bool
True, AF.Empty Anchor TestBlock
_) -> do
        TraceScheduledChainSyncServerEvent (NodeState TestBlock) TestBlock
-> WriterT
     [TraceScheduledChainSyncServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     ()
trace TraceScheduledChainSyncServerEvent (NodeState TestBlock) TestBlock
forall state blk. TraceScheduledChainSyncServerEvent state blk
TraceIntersectionIsHeaderPoint
        Maybe (RequestNext TestBlock)
-> WriterT
     [TraceScheduledChainSyncServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     (Maybe (RequestNext TestBlock))
forall a.
a
-> WriterT
     [TraceScheduledChainSyncServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (RequestNext TestBlock)
forall a. Maybe a
Nothing
      -- If the anchor is the intersection and the fragment is non-empty, then
      -- we have something to serve.
      (BT.PathAnchoredAtSource Bool
True, fragmentAhead :: AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
fragmentAhead@(TestBlock
next AF.:< AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
_)) -> do
        TraceScheduledChainSyncServerEvent (NodeState TestBlock) TestBlock
-> WriterT
     [TraceScheduledChainSyncServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     ()
trace (TraceScheduledChainSyncServerEvent (NodeState TestBlock) TestBlock
 -> WriterT
      [TraceScheduledChainSyncServerEvent
         (NodeState TestBlock) TestBlock]
      (STM m)
      ())
-> TraceScheduledChainSyncServerEvent
     (NodeState TestBlock) TestBlock
-> WriterT
     [TraceScheduledChainSyncServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     ()
forall a b. (a -> b) -> a -> b
$ AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
-> TraceScheduledChainSyncServerEvent
     (NodeState TestBlock) TestBlock
forall state blk.
AnchoredFragment blk
-> TraceScheduledChainSyncServerEvent state blk
TraceIntersectionIsStrictAncestorOfHeaderPoint AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
fragmentAhead
        STM m ()
-> WriterT
     [TraceScheduledChainSyncServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     ()
forall (m :: * -> *) a.
Monad m =>
m a
-> WriterT
     [TraceScheduledChainSyncServerEvent
        (NodeState TestBlock) TestBlock]
     m
     a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (STM m ()
 -> WriterT
      [TraceScheduledChainSyncServerEvent
         (NodeState TestBlock) TestBlock]
      (STM m)
      ())
-> STM m ()
-> WriterT
     [TraceScheduledChainSyncServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     ()
forall a b. (a -> b) -> a -> b
$ StrictTVar m (Point TestBlock) -> Point TestBlock -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (Point TestBlock)
currentIntersection (Point TestBlock -> STM m ()) -> Point TestBlock -> STM m ()
forall a b. (a -> b) -> a -> b
$ TestBlock -> Point TestBlock
forall block. HasHeader block => block -> Point block
blockPoint TestBlock
next
        Maybe (RequestNext TestBlock)
-> WriterT
     [TraceScheduledChainSyncServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     (Maybe (RequestNext TestBlock))
forall a.
a
-> WriterT
     [TraceScheduledChainSyncServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (RequestNext TestBlock)
 -> WriterT
      [TraceScheduledChainSyncServerEvent
         (NodeState TestBlock) TestBlock]
      (STM m)
      (Maybe (RequestNext TestBlock)))
-> Maybe (RequestNext TestBlock)
-> WriterT
     [TraceScheduledChainSyncServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     (Maybe (RequestNext TestBlock))
forall a b. (a -> b) -> a -> b
$ RequestNext TestBlock -> Maybe (RequestNext TestBlock)
forall a. a -> Maybe a
Just (Header TestBlock -> Tip TestBlock -> RequestNext TestBlock
forall blk. Header blk -> Tip blk -> RequestNext blk
RollForward (TestBlock -> Header TestBlock
forall blk. GetHeader blk => blk -> Header blk
getHeader TestBlock
next) (NodeState TestBlock -> Tip TestBlock
forall blk. HasHeader blk => NodeState blk -> Tip blk
nsTipTip NodeState TestBlock
points))
      -- If the anchor is not the intersection but the fragment is empty, then
      -- the intersection is further than the tip that we can serve.
      (BT.PathAnchoredAtSource Bool
False, AF.Empty Anchor TestBlock
_) -> do
        TraceScheduledChainSyncServerEvent (NodeState TestBlock) TestBlock
-> WriterT
     [TraceScheduledChainSyncServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     ()
trace TraceScheduledChainSyncServerEvent (NodeState TestBlock) TestBlock
forall state blk. TraceScheduledChainSyncServerEvent state blk
TraceIntersectionIsStrictDescendentOfHeaderPoint
        -- REVIEW: The following is a hack that allows the honest peer to not
        -- get disconnected when it falls behind. Why does a peer doing that not
        -- get disconnected from?
        --
        -- We decided to hold off on making this work with timeouts, so we'll return
        -- Nothing here for now.
        -- The consequence of this is that a slow peer will just block until it reaches
        -- the fork intersection in its schedule.
        -- pure (Just AwaitReply)
        Maybe (RequestNext TestBlock)
-> WriterT
     [TraceScheduledChainSyncServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     (Maybe (RequestNext TestBlock))
forall a.
a
-> WriterT
     [TraceScheduledChainSyncServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (RequestNext TestBlock)
forall a. Maybe a
Nothing
      -- If the anchor is not the intersection and the fragment is non-empty,
      -- then we require a rollback
      (BT.PathAnchoredAtSource Bool
False, AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
fragment) -> do
        let point :: Point TestBlock
point = AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
-> Point TestBlock
forall block. AnchoredFragment block -> Point block
AF.anchorPoint AnchoredSeq (WithOrigin SlotNo) (Anchor TestBlock) TestBlock
fragment
        STM m ()
-> WriterT
     [TraceScheduledChainSyncServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     ()
forall (m :: * -> *) a.
Monad m =>
m a
-> WriterT
     [TraceScheduledChainSyncServerEvent
        (NodeState TestBlock) TestBlock]
     m
     a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (STM m ()
 -> WriterT
      [TraceScheduledChainSyncServerEvent
         (NodeState TestBlock) TestBlock]
      (STM m)
      ())
-> STM m ()
-> WriterT
     [TraceScheduledChainSyncServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     ()
forall a b. (a -> b) -> a -> b
$ StrictTVar m (Point TestBlock) -> Point TestBlock -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (Point TestBlock)
currentIntersection Point TestBlock
point
        Maybe (RequestNext TestBlock)
-> WriterT
     [TraceScheduledChainSyncServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     (Maybe (RequestNext TestBlock))
forall a.
a
-> WriterT
     [TraceScheduledChainSyncServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (RequestNext TestBlock)
 -> WriterT
      [TraceScheduledChainSyncServerEvent
         (NodeState TestBlock) TestBlock]
      (STM m)
      (Maybe (RequestNext TestBlock)))
-> Maybe (RequestNext TestBlock)
-> WriterT
     [TraceScheduledChainSyncServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     (Maybe (RequestNext TestBlock))
forall a b. (a -> b) -> a -> b
$ RequestNext TestBlock -> Maybe (RequestNext TestBlock)
forall a. a -> Maybe a
Just (Point TestBlock -> Tip TestBlock -> RequestNext TestBlock
forall blk. Point blk -> Tip blk -> RequestNext blk
RollBackward Point TestBlock
point Tip TestBlock
tip')

    tip' :: Tip TestBlock
tip' = Tip TestBlock
-> (TestBlock -> Tip TestBlock)
-> WithOrigin TestBlock
-> Tip TestBlock
forall b t. b -> (t -> b) -> WithOrigin t -> b
withOrigin Tip TestBlock
forall {k} (b :: k). Tip b
TipGenesis TestBlock -> Tip TestBlock
forall a. HasHeader a => a -> Tip a
tipFromHeader (WithOrigin TestBlock -> Tip TestBlock)
-> WithOrigin TestBlock -> Tip TestBlock
forall a b. (a -> b) -> a -> b
$ NodeState TestBlock -> WithOrigin TestBlock
forall blk. NodeState blk -> WithOrigin blk
nsTip NodeState TestBlock
points

    trace :: TraceScheduledChainSyncServerEvent (NodeState TestBlock) TestBlock
-> WriterT
     [TraceScheduledChainSyncServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     ()
trace = [TraceScheduledChainSyncServerEvent
   (NodeState TestBlock) TestBlock]
-> WriterT
     [TraceScheduledChainSyncServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell ([TraceScheduledChainSyncServerEvent
    (NodeState TestBlock) TestBlock]
 -> WriterT
      [TraceScheduledChainSyncServerEvent
         (NodeState TestBlock) TestBlock]
      (STM m)
      ())
-> (TraceScheduledChainSyncServerEvent
      (NodeState TestBlock) TestBlock
    -> [TraceScheduledChainSyncServerEvent
          (NodeState TestBlock) TestBlock])
-> TraceScheduledChainSyncServerEvent
     (NodeState TestBlock) TestBlock
-> WriterT
     [TraceScheduledChainSyncServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TraceScheduledChainSyncServerEvent (NodeState TestBlock) TestBlock
-> [TraceScheduledChainSyncServerEvent
      (NodeState TestBlock) TestBlock]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- REVIEW: We call this a lot, and I assume it creates some significant overhead.
-- We should figure out a cheaper way to achieve what we're doing with the result.
-- Since we're in blk, we can at least check whether a block can extend another block,
-- but then we won't be able to generalize later.
fragmentUpTo :: HasHeader blk => BlockTree blk -> String -> Point blk -> AnchoredFragment blk
fragmentUpTo :: forall blk.
HasHeader blk =>
BlockTree blk -> [Char] -> Point blk -> AnchoredFragment blk
fragmentUpTo BlockTree blk
blockTree [Char]
desc Point blk
b =
  AnchoredFragment blk
-> Maybe (AnchoredFragment blk) -> AnchoredFragment blk
forall a. a -> Maybe a -> a
fromMaybe AnchoredFragment blk
fatal (Point blk -> BlockTree blk -> Maybe (AnchoredFragment blk)
forall blk.
HasHeader blk =>
Point blk -> BlockTree blk -> Maybe (AnchoredFragment blk)
BT.findFragment Point blk
b BlockTree blk
blockTree)
  where
    fatal :: AnchoredFragment blk
fatal = [Char] -> AnchoredFragment blk
forall a. HasCallStack => [Char] -> a
error ([Char]
"BlockFetch: Could not find " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
desc [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" in the block tree")

-- | Handle the BlockFetch message (it actually has only one unnamed entry point).
--
-- If the requested range ends not after the block point, send them. If the
-- block point moved to a fork without serving all blocks corresponding to
-- advertised headers, serve them. Otherwise, stall.
handlerBlockFetch ::
  forall m blk.
  (IOLike m, HasHeader blk) =>
  BlockTree blk ->
  -- ^ The tree of blocks in this scenario -- aka. the “universe”.
  ChainRange (Point blk) ->
  -- ^ A requested range of blocks. If the client behaves correctly, they
  -- correspond to headers that have been sent before, and if the scheduled
  -- ChainSync server behaves correctly, then they are all in the block tree.
  NodeState blk ->
  -- ^ The current advertised points (tip point, header point and block point).
  -- They are in the block tree.
  STM m (Maybe (BlockFetch blk), [TraceScheduledBlockFetchServerEvent (NodeState blk) blk])
handlerBlockFetch :: forall (m :: * -> *) blk.
(IOLike m, HasHeader blk) =>
BlockTree blk
-> ChainRange (Point blk)
-> NodeState blk
-> STM
     m
     (Maybe (BlockFetch blk),
      [TraceScheduledBlockFetchServerEvent (NodeState blk) blk])
handlerBlockFetch BlockTree blk
blockTree (ChainRange Point blk
from Point blk
to) NodeState blk
_ =
  WriterT
  [TraceScheduledBlockFetchServerEvent (NodeState blk) blk]
  (STM m)
  (Maybe (BlockFetch blk))
-> STM
     m
     (Maybe (BlockFetch blk),
      [TraceScheduledBlockFetchServerEvent (NodeState blk) blk])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (Maybe (AnchoredFragment blk)
-> WriterT
     [TraceScheduledBlockFetchServerEvent (NodeState blk) blk]
     (STM m)
     (Maybe (BlockFetch blk))
serveFromBpFragment (AnchoredFragment blk
-> Point blk -> Point blk -> Maybe (AnchoredFragment blk)
forall block.
HasHeader block =>
AnchoredFragment block
-> Point block -> Point block -> Maybe (AnchoredFragment block)
AF.sliceRange AnchoredFragment blk
chain Point blk
from Point blk
to))
  where
    -- Check whether the requested range is contained in the fragment before the header point.
    -- We may only initiate batch serving if the full range is available; if the server has only some of the blocks, it
    -- must refuse.
    serveFromBpFragment :: Maybe (AnchoredFragment blk)
-> WriterT
     [TraceScheduledBlockFetchServerEvent (NodeState blk) blk]
     (STM m)
     (Maybe (BlockFetch blk))
serveFromBpFragment = \case
      Just AnchoredFragment blk
slice -> do
        TraceScheduledBlockFetchServerEvent (NodeState blk) blk
-> WriterT
     [TraceScheduledBlockFetchServerEvent (NodeState blk) blk]
     (STM m)
     ()
trace (TraceScheduledBlockFetchServerEvent (NodeState blk) blk
 -> WriterT
      [TraceScheduledBlockFetchServerEvent (NodeState blk) blk]
      (STM m)
      ())
-> TraceScheduledBlockFetchServerEvent (NodeState blk) blk
-> WriterT
     [TraceScheduledBlockFetchServerEvent (NodeState blk) blk]
     (STM m)
     ()
forall a b. (a -> b) -> a -> b
$ AnchoredFragment blk
-> TraceScheduledBlockFetchServerEvent (NodeState blk) blk
forall state blk.
AnchoredFragment blk
-> TraceScheduledBlockFetchServerEvent state blk
TraceStartingBatch AnchoredFragment blk
slice
        Maybe (BlockFetch blk)
-> WriterT
     [TraceScheduledBlockFetchServerEvent (NodeState blk) blk]
     (STM m)
     (Maybe (BlockFetch blk))
forall a.
a
-> WriterT
     [TraceScheduledBlockFetchServerEvent (NodeState blk) blk] (STM m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BlockFetch blk -> Maybe (BlockFetch blk)
forall a. a -> Maybe a
Just ([blk] -> BlockFetch blk
forall blk. [blk] -> BlockFetch blk
StartBatch (AnchoredFragment blk -> [blk]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst AnchoredFragment blk
slice)))
      Maybe (AnchoredFragment blk)
Nothing    -> do
        TraceScheduledBlockFetchServerEvent (NodeState blk) blk
-> WriterT
     [TraceScheduledBlockFetchServerEvent (NodeState blk) blk]
     (STM m)
     ()
trace (TraceScheduledBlockFetchServerEvent (NodeState blk) blk
 -> WriterT
      [TraceScheduledBlockFetchServerEvent (NodeState blk) blk]
      (STM m)
      ())
-> TraceScheduledBlockFetchServerEvent (NodeState blk) blk
-> WriterT
     [TraceScheduledBlockFetchServerEvent (NodeState blk) blk]
     (STM m)
     ()
forall a b. (a -> b) -> a -> b
$ Point blk
-> Point blk
-> TraceScheduledBlockFetchServerEvent (NodeState blk) blk
forall state blk.
Point blk
-> Point blk -> TraceScheduledBlockFetchServerEvent state blk
TraceWaitingForRange Point blk
from Point blk
to
        Maybe (BlockFetch blk)
-> WriterT
     [TraceScheduledBlockFetchServerEvent (NodeState blk) blk]
     (STM m)
     (Maybe (BlockFetch blk))
forall a.
a
-> WriterT
     [TraceScheduledBlockFetchServerEvent (NodeState blk) blk] (STM m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (BlockFetch blk)
forall a. Maybe a
Nothing

    chain :: AnchoredFragment blk
chain = BlockTree blk -> [Char] -> Point blk -> AnchoredFragment blk
forall blk.
HasHeader blk =>
BlockTree blk -> [Char] -> Point blk -> AnchoredFragment blk
fragmentUpTo BlockTree blk
blockTree [Char]
"upper range bound" Point blk
to

    trace :: TraceScheduledBlockFetchServerEvent (NodeState blk) blk
-> WriterT
     [TraceScheduledBlockFetchServerEvent (NodeState blk) blk]
     (STM m)
     ()
trace = [TraceScheduledBlockFetchServerEvent (NodeState blk) blk]
-> WriterT
     [TraceScheduledBlockFetchServerEvent (NodeState blk) blk]
     (STM m)
     ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell ([TraceScheduledBlockFetchServerEvent (NodeState blk) blk]
 -> WriterT
      [TraceScheduledBlockFetchServerEvent (NodeState blk) blk]
      (STM m)
      ())
-> (TraceScheduledBlockFetchServerEvent (NodeState blk) blk
    -> [TraceScheduledBlockFetchServerEvent (NodeState blk) blk])
-> TraceScheduledBlockFetchServerEvent (NodeState blk) blk
-> WriterT
     [TraceScheduledBlockFetchServerEvent (NodeState blk) blk]
     (STM m)
     ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TraceScheduledBlockFetchServerEvent (NodeState blk) blk
-> [TraceScheduledBlockFetchServerEvent (NodeState blk) blk]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure

{-
If we cannot serve blocks from the block point chain (that is the chain on which
the block point is), decide whether to yield control to the scheduler or serve
blocks anyway.

If the next block to deliver is part of the header point chain, we have to wait
for the block point to advance sufficiently, and we block without sending a
message, to simulate a slow response.

If the next block to deliver is not part of the header point chain, but the
block point is, we must have switched to a fork without ensuring that the block
point advances to the last header point advertised on the old chain.

While the block point is not on the same chain as the header point we wait,
because the block point might still advance to allow the next block to be sent.
If the block point is in the same chain as the header point, we interpret that
the block point has left the old branch, and the requested blocks should be sent
at this time.

The cases to consider follow:

 0 1 2 3 4 5 6
 x-x-x-x-x-x-x
         ^BP ^HP
       \-x-x-x
         ^next
✅ send the blocks because a rollback happened

 0 1 2 3 4 5 6
 x-x-x-x-x-x-x
   ^BP       ^HP
       \-x-x-x
         ^next

❌ BP might still go on the fork where next is, so don't send the blocks yet

 0 1 2 3 4 5 6
 x-x-x-x-x-x-x
   ^BP
     \-x-x-x-x
       ^next ^HP

❌ BP could still go on the fork where next is, don't send the blocks yet

 0 1 2 3 4 5 6
 x-x-x-x-x-x-x
     ^BP
   \-x-x-x-x-x
     ^next   ^HP

❌ BP could still go on the fork where next is, don't send the blocks yet

 0 1 2 3 4 5 6
 x-x-x-x-x-x-x
     ^BP
   \-x-x-x-x-x
     ^next
   \-x-x-x-x-x
       ^HP

❌ BP could still go on the fork where next is, don't send the blocks yet

 0 1 2 3 4 5 6
 x-x-x-x-x-x-x
     ^HP
   \-x-x-x-x-x
     ^next   ^BP

✅ send the blocks because BP is after next

 0 1 2 3 4 5 6
 x-x-x-x-x-x-x
     ^HP
   \-x-x-x-x-x
     ^BP   ^next

❌ BP could still advance past next, don't send the blocks yet

-}
handlerSendBlocks ::
  forall m .
  IOLike m =>
  [TestBlock] ->
  NodeState TestBlock ->
  STM m (Maybe (SendBlocks TestBlock), [TraceScheduledBlockFetchServerEvent (NodeState TestBlock) TestBlock])
handlerSendBlocks :: forall (m :: * -> *).
IOLike m =>
[TestBlock]
-> NodeState TestBlock
-> STM
     m
     (Maybe (SendBlocks TestBlock),
      [TraceScheduledBlockFetchServerEvent
         (NodeState TestBlock) TestBlock])
handlerSendBlocks [TestBlock]
blocks NodeState {WithOrigin TestBlock
nsHeader :: forall blk. NodeState blk -> WithOrigin blk
nsHeader :: WithOrigin TestBlock
nsHeader, WithOrigin TestBlock
nsBlock :: WithOrigin TestBlock
nsBlock :: forall blk. NodeState blk -> WithOrigin blk
nsBlock} =
  WriterT
  [TraceScheduledBlockFetchServerEvent
     (NodeState TestBlock) TestBlock]
  (STM m)
  (Maybe (SendBlocks TestBlock))
-> STM
     m
     (Maybe (SendBlocks TestBlock),
      [TraceScheduledBlockFetchServerEvent
         (NodeState TestBlock) TestBlock])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT ([TestBlock]
-> WriterT
     [TraceScheduledBlockFetchServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     (Maybe (SendBlocks TestBlock))
checkDone [TestBlock]
blocks)
  where
    checkDone :: [TestBlock]
-> WriterT
     [TraceScheduledBlockFetchServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     (Maybe (SendBlocks TestBlock))
checkDone = \case
      [] -> do
        TraceScheduledBlockFetchServerEvent (NodeState TestBlock) TestBlock
-> WriterT
     [TraceScheduledBlockFetchServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     ()
trace TraceScheduledBlockFetchServerEvent (NodeState TestBlock) TestBlock
forall state blk. TraceScheduledBlockFetchServerEvent state blk
TraceBatchIsDone
        Maybe (SendBlocks TestBlock)
-> WriterT
     [TraceScheduledBlockFetchServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     (Maybe (SendBlocks TestBlock))
forall a.
a
-> WriterT
     [TraceScheduledBlockFetchServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SendBlocks TestBlock -> Maybe (SendBlocks TestBlock)
forall a. a -> Maybe a
Just SendBlocks TestBlock
forall blk. SendBlocks blk
BatchDone)
      (TestBlock
next : [TestBlock]
future) ->
        TestBlock
-> [TestBlock]
-> WriterT
     [TraceScheduledBlockFetchServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     (Maybe (SendBlocks TestBlock))
blocksLeft TestBlock
next [TestBlock]
future

    blocksLeft :: TestBlock
-> [TestBlock]
-> WriterT
     [TraceScheduledBlockFetchServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     (Maybe (SendBlocks TestBlock))
blocksLeft TestBlock
next [TestBlock]
future
      | WithOrigin TestBlock -> WithOrigin TestBlock -> Bool
forall blk1 blk2.
(HasHeader blk1, HasHeader blk2, HeaderHash blk1 ~ TestHash,
 HeaderHash blk2 ~ TestHash) =>
WithOrigin blk1 -> WithOrigin blk2 -> Bool
isAncestorOf (TestBlock -> WithOrigin TestBlock
forall t. t -> WithOrigin t
At TestBlock
next) WithOrigin TestBlock
nsBlock
      Bool -> Bool -> Bool
|| TestBlock -> Bool
compensateForScheduleRollback TestBlock
next
      = do
        TraceScheduledBlockFetchServerEvent (NodeState TestBlock) TestBlock
-> WriterT
     [TraceScheduledBlockFetchServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     ()
trace (TraceScheduledBlockFetchServerEvent
   (NodeState TestBlock) TestBlock
 -> WriterT
      [TraceScheduledBlockFetchServerEvent
         (NodeState TestBlock) TestBlock]
      (STM m)
      ())
-> TraceScheduledBlockFetchServerEvent
     (NodeState TestBlock) TestBlock
-> WriterT
     [TraceScheduledBlockFetchServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     ()
forall a b. (a -> b) -> a -> b
$ TestBlock
-> TraceScheduledBlockFetchServerEvent
     (NodeState TestBlock) TestBlock
forall state blk.
blk -> TraceScheduledBlockFetchServerEvent state blk
TraceSendingBlock TestBlock
next
        Maybe (SendBlocks TestBlock)
-> WriterT
     [TraceScheduledBlockFetchServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     (Maybe (SendBlocks TestBlock))
forall a.
a
-> WriterT
     [TraceScheduledBlockFetchServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SendBlocks TestBlock -> Maybe (SendBlocks TestBlock)
forall a. a -> Maybe a
Just (TestBlock -> [TestBlock] -> SendBlocks TestBlock
forall blk. blk -> [blk] -> SendBlocks blk
SendBlock TestBlock
next [TestBlock]
future))

      | Bool
otherwise
      = do
        TraceScheduledBlockFetchServerEvent (NodeState TestBlock) TestBlock
-> WriterT
     [TraceScheduledBlockFetchServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     ()
trace TraceScheduledBlockFetchServerEvent (NodeState TestBlock) TestBlock
forall state blk. TraceScheduledBlockFetchServerEvent state blk
TraceBlockPointIsBehind
        Maybe (SendBlocks TestBlock)
-> WriterT
     [TraceScheduledBlockFetchServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     (Maybe (SendBlocks TestBlock))
forall a.
a
-> WriterT
     [TraceScheduledBlockFetchServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (SendBlocks TestBlock)
forall a. Maybe a
Nothing

    -- Here we encode the conditions for the special situation mentioned above.
    -- These use aliases for @withinFragmentBounds@ to illustrate what we're testing.
    -- The names don't precisely match semantically, but it's difficult to understand the
    -- circumstances otherwise.
    --
    -- The involved points are BP, HP, and @next@, which is the block we're deciding whether to
    -- send or not.
    --
    -- Remember that at this point, we already know that we cannot send @next@ regularly, i.e.
    -- @next@ is not on the chain leading up to BP.
    -- The conditions in which we send @next@ to compensate for rollbacks are:
    --
    -- * @next@ is not on the chain leading up to HP – HP moved to another chain, and
    --
    -- * BP is in the same chain as HP and is not an ancestor of @next@ - BP also moved away from the chain of @next@.
    --
    -- Precondition: @not (isAncestorOf (At next) bp)@
    compensateForScheduleRollback :: TestBlock -> Bool
compensateForScheduleRollback TestBlock
next =
      Bool -> Bool
not (WithOrigin TestBlock -> WithOrigin TestBlock -> Bool
forall blk1 blk2.
(HasHeader blk1, HasHeader blk2, HeaderHash blk1 ~ TestHash,
 HeaderHash blk2 ~ TestHash) =>
WithOrigin blk1 -> WithOrigin blk2 -> Bool
isAncestorOf (TestBlock -> WithOrigin TestBlock
forall t. t -> WithOrigin t
At TestBlock
next) WithOrigin TestBlock
nsHeader)
        Bool -> Bool -> Bool
&& WithOrigin TestBlock -> WithOrigin TestBlock -> Bool
forall blk1 blk2.
(HasHeader blk1, HasHeader blk2, HeaderHash blk1 ~ TestHash,
 HeaderHash blk2 ~ TestHash) =>
WithOrigin blk1 -> WithOrigin blk2 -> Bool
isAncestorOf WithOrigin TestBlock
nsBlock WithOrigin TestBlock
nsHeader
        Bool -> Bool -> Bool
&& Bool -> Bool
not (WithOrigin TestBlock -> WithOrigin TestBlock -> Bool
forall blk1 blk2.
(HasHeader blk1, HasHeader blk2, HeaderHash blk1 ~ TestHash,
 HeaderHash blk2 ~ TestHash) =>
WithOrigin blk1 -> WithOrigin blk2 -> Bool
isAncestorOf WithOrigin TestBlock
nsBlock (TestBlock -> WithOrigin TestBlock
forall t. t -> WithOrigin t
At TestBlock
next))

    trace :: TraceScheduledBlockFetchServerEvent (NodeState TestBlock) TestBlock
-> WriterT
     [TraceScheduledBlockFetchServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     ()
trace = [TraceScheduledBlockFetchServerEvent
   (NodeState TestBlock) TestBlock]
-> WriterT
     [TraceScheduledBlockFetchServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell ([TraceScheduledBlockFetchServerEvent
    (NodeState TestBlock) TestBlock]
 -> WriterT
      [TraceScheduledBlockFetchServerEvent
         (NodeState TestBlock) TestBlock]
      (STM m)
      ())
-> (TraceScheduledBlockFetchServerEvent
      (NodeState TestBlock) TestBlock
    -> [TraceScheduledBlockFetchServerEvent
          (NodeState TestBlock) TestBlock])
-> TraceScheduledBlockFetchServerEvent
     (NodeState TestBlock) TestBlock
-> WriterT
     [TraceScheduledBlockFetchServerEvent
        (NodeState TestBlock) TestBlock]
     (STM m)
     ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TraceScheduledBlockFetchServerEvent (NodeState TestBlock) TestBlock
-> [TraceScheduledBlockFetchServerEvent
      (NodeState TestBlock) TestBlock]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure