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

-- | 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.Maybe (fromJust, fromMaybe)
import Ouroboros.Consensus.Block
  ( GetHeader
  , HasHeader
  , Point (GenesisPoint)
  , 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 Test.Consensus.BlockTree (BlockTree, isAncestorOf)
import qualified Test.Consensus.BlockTree as BT
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 ()

-- | 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 blk.
  (IOLike m, HasHeader blk, GetHeader blk, Eq blk) =>
  StrictTVar m (Point blk) ->
  BlockTree blk ->
  NodeState blk ->
  STM m (Maybe (RequestNext blk), [TraceScheduledChainSyncServerEvent (NodeState blk) blk])
handlerRequestNext :: forall (m :: * -> *) blk.
(IOLike m, HasHeader blk, GetHeader blk, Eq blk) =>
StrictTVar m (Point blk)
-> BlockTree blk
-> NodeState blk
-> STM
     m
     (Maybe (RequestNext blk),
      [TraceScheduledChainSyncServerEvent (NodeState blk) blk])
handlerRequestNext StrictTVar m (Point blk)
currentIntersection BlockTree blk
blockTree NodeState blk
points =
  WriterT
  [TraceScheduledChainSyncServerEvent (NodeState blk) blk]
  (STM m)
  (Maybe (RequestNext blk))
-> STM
     m
     (Maybe (RequestNext blk),
      [TraceScheduledChainSyncServerEvent (NodeState blk) blk])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT
   [TraceScheduledChainSyncServerEvent (NodeState blk) blk]
   (STM m)
   (Maybe (RequestNext blk))
 -> STM
      m
      (Maybe (RequestNext blk),
       [TraceScheduledChainSyncServerEvent (NodeState blk) blk]))
-> WriterT
     [TraceScheduledChainSyncServerEvent (NodeState blk) blk]
     (STM m)
     (Maybe (RequestNext blk))
-> STM
     m
     (Maybe (RequestNext blk),
      [TraceScheduledChainSyncServerEvent (NodeState blk) blk])
forall a b. (a -> b) -> a -> b
$ do
    intersection <- STM m (Point blk)
-> WriterT
     [TraceScheduledChainSyncServerEvent (NodeState blk) blk]
     (STM m)
     (Point blk)
forall (m :: * -> *) a.
Monad m =>
m a
-> WriterT
     [TraceScheduledChainSyncServerEvent (NodeState blk) blk] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (STM m (Point blk)
 -> WriterT
      [TraceScheduledChainSyncServerEvent (NodeState blk) blk]
      (STM m)
      (Point blk))
-> STM m (Point blk)
-> WriterT
     [TraceScheduledChainSyncServerEvent (NodeState blk) blk]
     (STM m)
     (Point blk)
forall a b. (a -> b) -> a -> b
$ StrictTVar m (Point blk) -> STM m (Point blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Point blk)
currentIntersection
    trace $ TraceLastIntersection intersection
    withHeader intersection (nsHeader points)
 where
  withHeader ::
    Point blk ->
    WithOrigin blk ->
    WriterT
      [TraceScheduledChainSyncServerEvent (NodeState blk) blk]
      (STM m)
      (Maybe (RequestNext blk))
  withHeader :: Point blk
-> WithOrigin blk
-> WriterT
     [TraceScheduledChainSyncServerEvent (NodeState blk) blk]
     (STM m)
     (Maybe (RequestNext blk))
withHeader Point blk
intersection WithOrigin blk
h =
    WriterT
  [TraceScheduledChainSyncServerEvent (NodeState blk) blk]
  (STM m)
  (Maybe (RequestNext blk))
-> ((PathAnchoredAtSource,
     AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk)
    -> WriterT
         [TraceScheduledChainSyncServerEvent (NodeState blk) blk]
         (STM m)
         (Maybe (RequestNext blk)))
-> Maybe
     (PathAnchoredAtSource,
      AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk)
-> WriterT
     [TraceScheduledChainSyncServerEvent (NodeState blk) blk]
     (STM m)
     (Maybe (RequestNext blk))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe WriterT
  [TraceScheduledChainSyncServerEvent (NodeState blk) blk]
  (STM m)
  (Maybe (RequestNext blk))
forall {a}. a
noPathError (PathAnchoredAtSource,
 AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk)
-> WriterT
     [TraceScheduledChainSyncServerEvent (NodeState blk) blk]
     (STM m)
     (Maybe (RequestNext blk))
analysePath (Point blk
-> Point blk
-> BlockTree blk
-> Maybe
     (PathAnchoredAtSource,
      AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk)
forall blk.
HasHeader blk =>
Point blk
-> Point blk
-> BlockTree blk
-> Maybe (PathAnchoredAtSource, AnchoredFragment blk)
BT.findPath Point blk
intersection Point blk
hp BlockTree blk
blockTree)
   where
    hp :: Point blk
hp = Point blk -> (blk -> Point blk) -> WithOrigin blk -> Point blk
forall b t. b -> (t -> b) -> WithOrigin t -> b
withOrigin Point blk
forall {k} (block :: k). Point block
GenesisPoint blk -> Point blk
forall block. HasHeader block => block -> Point block
blockPoint WithOrigin blk
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 blk) blk)
-> WriterT
     [TraceScheduledChainSyncServerEvent (NodeState blk) blk]
     (STM m)
     (Maybe (RequestNext blk))
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 blk
_) | BlockTree blk -> WithOrigin blk -> WithOrigin blk -> Bool
forall blk.
(HasHeader blk, Eq blk) =>
BlockTree blk -> WithOrigin blk -> WithOrigin blk -> Bool
isAncestorOf BlockTree blk
blockTree (NodeState blk -> WithOrigin blk
forall blk. NodeState blk -> WithOrigin blk
nsTip NodeState blk
points) (NodeState blk -> WithOrigin blk
forall blk. NodeState blk -> WithOrigin blk
nsHeader NodeState blk
points) -> do
      TraceScheduledChainSyncServerEvent (NodeState blk) blk
-> WriterT
     [TraceScheduledChainSyncServerEvent (NodeState blk) blk] (STM m) ()
trace TraceScheduledChainSyncServerEvent (NodeState blk) blk
forall state blk. TraceScheduledChainSyncServerEvent state blk
TraceChainIsFullyServed
      Maybe (RequestNext blk)
-> WriterT
     [TraceScheduledChainSyncServerEvent (NodeState blk) blk]
     (STM m)
     (Maybe (RequestNext blk))
forall a.
a
-> WriterT
     [TraceScheduledChainSyncServerEvent (NodeState blk) blk] (STM m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RequestNext blk -> Maybe (RequestNext blk)
forall a. a -> Maybe a
Just RequestNext blk
forall blk. RequestNext blk
AwaitReply)
    (BT.PathAnchoredAtSource Bool
True, AF.Empty Anchor blk
_) -> do
      TraceScheduledChainSyncServerEvent (NodeState blk) blk
-> WriterT
     [TraceScheduledChainSyncServerEvent (NodeState blk) blk] (STM m) ()
trace TraceScheduledChainSyncServerEvent (NodeState blk) blk
forall state blk. TraceScheduledChainSyncServerEvent state blk
TraceIntersectionIsHeaderPoint
      Maybe (RequestNext blk)
-> WriterT
     [TraceScheduledChainSyncServerEvent (NodeState blk) blk]
     (STM m)
     (Maybe (RequestNext blk))
forall a.
a
-> WriterT
     [TraceScheduledChainSyncServerEvent (NodeState blk) blk] (STM m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (RequestNext blk)
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 blk) blk
fragmentAhead@(blk
next AF.:< AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk
_)) -> do
      TraceScheduledChainSyncServerEvent (NodeState blk) blk
-> WriterT
     [TraceScheduledChainSyncServerEvent (NodeState blk) blk] (STM m) ()
trace (TraceScheduledChainSyncServerEvent (NodeState blk) blk
 -> WriterT
      [TraceScheduledChainSyncServerEvent (NodeState blk) blk]
      (STM m)
      ())
-> TraceScheduledChainSyncServerEvent (NodeState blk) blk
-> WriterT
     [TraceScheduledChainSyncServerEvent (NodeState blk) blk] (STM m) ()
forall a b. (a -> b) -> a -> b
$ AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk
-> TraceScheduledChainSyncServerEvent (NodeState blk) blk
forall state blk.
AnchoredFragment blk
-> TraceScheduledChainSyncServerEvent state blk
TraceIntersectionIsStrictAncestorOfHeaderPoint AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk
fragmentAhead
      STM m ()
-> WriterT
     [TraceScheduledChainSyncServerEvent (NodeState blk) blk] (STM m) ()
forall (m :: * -> *) a.
Monad m =>
m a
-> WriterT
     [TraceScheduledChainSyncServerEvent (NodeState blk) blk] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (STM m ()
 -> WriterT
      [TraceScheduledChainSyncServerEvent (NodeState blk) blk]
      (STM m)
      ())
-> STM m ()
-> WriterT
     [TraceScheduledChainSyncServerEvent (NodeState blk) blk] (STM m) ()
forall a b. (a -> b) -> a -> b
$ 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 -> STM m ()) -> Point blk -> STM m ()
forall a b. (a -> b) -> a -> b
$ blk -> Point blk
forall block. HasHeader block => block -> Point block
blockPoint blk
next
      Maybe (RequestNext blk)
-> WriterT
     [TraceScheduledChainSyncServerEvent (NodeState blk) blk]
     (STM m)
     (Maybe (RequestNext blk))
forall a.
a
-> WriterT
     [TraceScheduledChainSyncServerEvent (NodeState blk) blk] (STM m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (RequestNext blk)
 -> WriterT
      [TraceScheduledChainSyncServerEvent (NodeState blk) blk]
      (STM m)
      (Maybe (RequestNext blk)))
-> Maybe (RequestNext blk)
-> WriterT
     [TraceScheduledChainSyncServerEvent (NodeState blk) blk]
     (STM m)
     (Maybe (RequestNext blk))
forall a b. (a -> b) -> a -> b
$ RequestNext blk -> Maybe (RequestNext blk)
forall a. a -> Maybe a
Just (Header blk -> Tip blk -> RequestNext blk
forall blk. Header blk -> Tip blk -> RequestNext blk
RollForward (blk -> Header blk
forall blk. GetHeader blk => blk -> Header blk
getHeader blk
next) (NodeState blk -> Tip blk
forall blk. HasHeader blk => NodeState blk -> Tip blk
nsTipTip NodeState blk
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 blk
_) -> do
      TraceScheduledChainSyncServerEvent (NodeState blk) blk
-> WriterT
     [TraceScheduledChainSyncServerEvent (NodeState blk) blk] (STM m) ()
trace TraceScheduledChainSyncServerEvent (NodeState blk) blk
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 blk)
-> WriterT
     [TraceScheduledChainSyncServerEvent (NodeState blk) blk]
     (STM m)
     (Maybe (RequestNext blk))
forall a.
a
-> WriterT
     [TraceScheduledChainSyncServerEvent (NodeState blk) blk] (STM m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (RequestNext blk)
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 blk) blk
fragment) -> do
      let point :: Point blk
point = AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk -> Point blk
forall block. AnchoredFragment block -> Point block
AF.anchorPoint AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk
fragment
      STM m ()
-> WriterT
     [TraceScheduledChainSyncServerEvent (NodeState blk) blk] (STM m) ()
forall (m :: * -> *) a.
Monad m =>
m a
-> WriterT
     [TraceScheduledChainSyncServerEvent (NodeState blk) blk] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (STM m ()
 -> WriterT
      [TraceScheduledChainSyncServerEvent (NodeState blk) blk]
      (STM m)
      ())
-> STM m ()
-> WriterT
     [TraceScheduledChainSyncServerEvent (NodeState blk) blk] (STM m) ()
forall a b. (a -> b) -> a -> b
$ 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
point
      Maybe (RequestNext blk)
-> WriterT
     [TraceScheduledChainSyncServerEvent (NodeState blk) blk]
     (STM m)
     (Maybe (RequestNext blk))
forall a.
a
-> WriterT
     [TraceScheduledChainSyncServerEvent (NodeState blk) blk] (STM m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (RequestNext blk)
 -> WriterT
      [TraceScheduledChainSyncServerEvent (NodeState blk) blk]
      (STM m)
      (Maybe (RequestNext blk)))
-> Maybe (RequestNext blk)
-> WriterT
     [TraceScheduledChainSyncServerEvent (NodeState blk) blk]
     (STM m)
     (Maybe (RequestNext blk))
forall a b. (a -> b) -> a -> b
$ RequestNext blk -> Maybe (RequestNext blk)
forall a. a -> Maybe a
Just (Point blk -> Tip blk -> RequestNext blk
forall blk. Point blk -> Tip blk -> RequestNext blk
RollBackward Point blk
point Tip blk
tip')

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

  trace :: TraceScheduledChainSyncServerEvent (NodeState blk) blk
-> WriterT
     [TraceScheduledChainSyncServerEvent (NodeState blk) blk] (STM m) ()
trace = [TraceScheduledChainSyncServerEvent (NodeState blk) blk]
-> WriterT
     [TraceScheduledChainSyncServerEvent (NodeState blk) blk] (STM m) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell ([TraceScheduledChainSyncServerEvent (NodeState blk) blk]
 -> WriterT
      [TraceScheduledChainSyncServerEvent (NodeState blk) blk]
      (STM m)
      ())
-> (TraceScheduledChainSyncServerEvent (NodeState blk) blk
    -> [TraceScheduledChainSyncServerEvent (NodeState blk) blk])
-> TraceScheduledChainSyncServerEvent (NodeState blk) blk
-> WriterT
     [TraceScheduledChainSyncServerEvent (NodeState blk) blk] (STM m) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TraceScheduledChainSyncServerEvent (NodeState blk) blk
-> [TraceScheduledChainSyncServerEvent (NodeState blk) blk]
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) =>
  -- | The tree of blocks in this scenario -- aka. the “universe”.
  BlockTree 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.
  ChainRange (Point blk) ->
  -- | The current advertised points (tip point, header point and block point).
  -- They are in the block tree.
  NodeState blk ->
  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 blk.
  (IOLike m, HasHeader blk, Eq blk) =>
  BlockTree blk ->
  [blk] ->
  NodeState blk ->
  STM m (Maybe (SendBlocks blk), [TraceScheduledBlockFetchServerEvent (NodeState blk) blk])
handlerSendBlocks :: forall (m :: * -> *) blk.
(IOLike m, HasHeader blk, Eq blk) =>
BlockTree blk
-> [blk]
-> NodeState blk
-> STM
     m
     (Maybe (SendBlocks blk),
      [TraceScheduledBlockFetchServerEvent (NodeState blk) blk])
handlerSendBlocks BlockTree blk
bt [blk]
blocks NodeState{WithOrigin blk
nsHeader :: forall blk. NodeState blk -> WithOrigin blk
nsHeader :: WithOrigin blk
nsHeader, WithOrigin blk
nsBlock :: WithOrigin blk
nsBlock :: forall blk. NodeState blk -> WithOrigin blk
nsBlock} =
  WriterT
  [TraceScheduledBlockFetchServerEvent (NodeState blk) blk]
  (STM m)
  (Maybe (SendBlocks blk))
-> STM
     m
     (Maybe (SendBlocks blk),
      [TraceScheduledBlockFetchServerEvent (NodeState blk) blk])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT ([blk]
-> WriterT
     [TraceScheduledBlockFetchServerEvent (NodeState blk) blk]
     (STM m)
     (Maybe (SendBlocks blk))
checkDone [blk]
blocks)
 where
  checkDone :: [blk]
-> WriterT
     [TraceScheduledBlockFetchServerEvent (NodeState blk) blk]
     (STM m)
     (Maybe (SendBlocks blk))
checkDone = \case
    [] -> do
      TraceScheduledBlockFetchServerEvent (NodeState blk) blk
-> WriterT
     [TraceScheduledBlockFetchServerEvent (NodeState blk) blk]
     (STM m)
     ()
trace TraceScheduledBlockFetchServerEvent (NodeState blk) blk
forall state blk. TraceScheduledBlockFetchServerEvent state blk
TraceBatchIsDone
      Maybe (SendBlocks blk)
-> WriterT
     [TraceScheduledBlockFetchServerEvent (NodeState blk) blk]
     (STM m)
     (Maybe (SendBlocks blk))
forall a.
a
-> WriterT
     [TraceScheduledBlockFetchServerEvent (NodeState blk) blk] (STM m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SendBlocks blk -> Maybe (SendBlocks blk)
forall a. a -> Maybe a
Just SendBlocks blk
forall blk. SendBlocks blk
BatchDone)
    (blk
next : [blk]
future) ->
      blk
-> [blk]
-> WriterT
     [TraceScheduledBlockFetchServerEvent (NodeState blk) blk]
     (STM m)
     (Maybe (SendBlocks blk))
blocksLeft blk
next [blk]
future

  blocksLeft :: blk
-> [blk]
-> WriterT
     [TraceScheduledBlockFetchServerEvent (NodeState blk) blk]
     (STM m)
     (Maybe (SendBlocks blk))
blocksLeft blk
next [blk]
future
    | BlockTree blk -> WithOrigin blk -> WithOrigin blk -> Bool
forall blk.
(HasHeader blk, Eq blk) =>
BlockTree blk -> WithOrigin blk -> WithOrigin blk -> Bool
isAncestorOf BlockTree blk
bt (blk -> WithOrigin blk
forall t. t -> WithOrigin t
At blk
next) WithOrigin blk
nsBlock
        Bool -> Bool -> Bool
|| blk -> Bool
compensateForScheduleRollback blk
next =
        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
$ blk -> TraceScheduledBlockFetchServerEvent (NodeState blk) blk
forall state blk.
blk -> TraceScheduledBlockFetchServerEvent state blk
TraceSendingBlock blk
next
          Maybe (SendBlocks blk)
-> WriterT
     [TraceScheduledBlockFetchServerEvent (NodeState blk) blk]
     (STM m)
     (Maybe (SendBlocks blk))
forall a.
a
-> WriterT
     [TraceScheduledBlockFetchServerEvent (NodeState blk) blk] (STM m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SendBlocks blk -> Maybe (SendBlocks blk)
forall a. a -> Maybe a
Just (blk -> [blk] -> SendBlocks blk
forall blk. blk -> [blk] -> SendBlocks blk
SendBlock blk
next [blk]
future))
    | Bool
otherwise =
        do
          TraceScheduledBlockFetchServerEvent (NodeState blk) blk
-> WriterT
     [TraceScheduledBlockFetchServerEvent (NodeState blk) blk]
     (STM m)
     ()
trace TraceScheduledBlockFetchServerEvent (NodeState blk) blk
forall state blk. TraceScheduledBlockFetchServerEvent state blk
TraceBlockPointIsBehind
          Maybe (SendBlocks blk)
-> WriterT
     [TraceScheduledBlockFetchServerEvent (NodeState blk) blk]
     (STM m)
     (Maybe (SendBlocks blk))
forall a.
a
-> WriterT
     [TraceScheduledBlockFetchServerEvent (NodeState blk) blk] (STM m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (SendBlocks blk)
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 :: blk -> Bool
compensateForScheduleRollback blk
next =
    Bool -> Bool
not (BlockTree blk -> WithOrigin blk -> WithOrigin blk -> Bool
forall blk.
(HasHeader blk, Eq blk) =>
BlockTree blk -> WithOrigin blk -> WithOrigin blk -> Bool
isAncestorOf BlockTree blk
bt (blk -> WithOrigin blk
forall t. t -> WithOrigin t
At blk
next) WithOrigin blk
nsHeader)
      Bool -> Bool -> Bool
&& BlockTree blk -> WithOrigin blk -> WithOrigin blk -> Bool
forall blk.
(HasHeader blk, Eq blk) =>
BlockTree blk -> WithOrigin blk -> WithOrigin blk -> Bool
isAncestorOf BlockTree blk
bt WithOrigin blk
nsBlock WithOrigin blk
nsHeader
      Bool -> Bool -> Bool
&& Bool -> Bool
not (BlockTree blk -> WithOrigin blk -> WithOrigin blk -> Bool
forall blk.
(HasHeader blk, Eq blk) =>
BlockTree blk -> WithOrigin blk -> WithOrigin blk -> Bool
isAncestorOf BlockTree blk
bt WithOrigin blk
nsBlock (blk -> WithOrigin blk
forall t. t -> WithOrigin t
At blk
next))

  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