{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
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 Test.Consensus.BlockTree (BlockTree)
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 ()
import Test.Util.TestBlock (TestBlock, TestHash (TestHash))
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
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'), [])
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
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
trace $ TraceLastIntersection intersection
withHeader intersection (nsHeader 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
(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
(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))
(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
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
(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
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")
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 :: 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
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
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
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