{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Test.Consensus.PeerSimulator.ScheduledBlockFetchServer
( BlockFetch (..)
, BlockFetchServerHandlers (..)
, ScheduledBlockFetchServer (..)
, SendBlocks (..)
, runScheduledBlockFetchServer
) where
import Control.Tracer
import Ouroboros.Consensus.Block (Point)
import Ouroboros.Consensus.Util.IOLike (IOLike, MonadSTM (STM))
import Ouroboros.Network.BlockFetch.ClientState (ChainRange)
import Ouroboros.Network.Protocol.BlockFetch.Server
import Test.Consensus.PeerSimulator.ScheduledServer
( ScheduledServer (..)
, awaitOnlineState
, runHandler
)
import Test.Consensus.PeerSimulator.Trace
import Test.Consensus.PointSchedule.NodeState (NodeState)
import Test.Consensus.PointSchedule.Peers (PeerId)
data SendBlocks blk
= SendBlock blk [blk]
| BatchDone
data BlockFetch blk
=
StartBatch [blk]
|
NoBlocks
deriving (BlockFetch blk -> BlockFetch blk -> Bool
(BlockFetch blk -> BlockFetch blk -> Bool)
-> (BlockFetch blk -> BlockFetch blk -> Bool)
-> Eq (BlockFetch blk)
forall blk. Eq blk => BlockFetch blk -> BlockFetch blk -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall blk. Eq blk => BlockFetch blk -> BlockFetch blk -> Bool
== :: BlockFetch blk -> BlockFetch blk -> Bool
$c/= :: forall blk. Eq blk => BlockFetch blk -> BlockFetch blk -> Bool
/= :: BlockFetch blk -> BlockFetch blk -> Bool
Eq, Int -> BlockFetch blk -> ShowS
[BlockFetch blk] -> ShowS
BlockFetch blk -> String
(Int -> BlockFetch blk -> ShowS)
-> (BlockFetch blk -> String)
-> ([BlockFetch blk] -> ShowS)
-> Show (BlockFetch blk)
forall blk. Show blk => Int -> BlockFetch blk -> ShowS
forall blk. Show blk => [BlockFetch blk] -> ShowS
forall blk. Show blk => BlockFetch blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall blk. Show blk => Int -> BlockFetch blk -> ShowS
showsPrec :: Int -> BlockFetch blk -> ShowS
$cshow :: forall blk. Show blk => BlockFetch blk -> String
show :: BlockFetch blk -> String
$cshowList :: forall blk. Show blk => [BlockFetch blk] -> ShowS
showList :: [BlockFetch blk] -> ShowS
Show)
data BlockFetchServerHandlers m state blk
= BlockFetchServerHandlers
{ forall (m :: * -> *) state blk.
BlockFetchServerHandlers m state blk
-> ChainRange (Point blk)
-> state
-> STM
m
(Maybe (BlockFetch blk),
[TraceScheduledBlockFetchServerEvent state blk])
bfshBlockFetch ::
ChainRange (Point blk) ->
state ->
STM m (Maybe (BlockFetch blk), [TraceScheduledBlockFetchServerEvent state blk])
, forall (m :: * -> *) state blk.
BlockFetchServerHandlers m state blk
-> [blk]
-> state
-> STM
m
(Maybe (SendBlocks blk),
[TraceScheduledBlockFetchServerEvent state blk])
bfshSendBlocks ::
[blk] ->
state ->
STM m (Maybe (SendBlocks blk), [TraceScheduledBlockFetchServerEvent state blk])
}
data ScheduledBlockFetchServer m state blk
= ScheduledBlockFetchServer
{ forall (m :: * -> *) state blk.
ScheduledBlockFetchServer m state blk
-> ScheduledServer m state blk
sbfsServer :: ScheduledServer m state blk
, forall (m :: * -> *) state blk.
ScheduledBlockFetchServer m state blk
-> Tracer m (TraceScheduledBlockFetchServerEvent state blk)
sbfsTracer :: Tracer m (TraceScheduledBlockFetchServerEvent state blk)
, forall (m :: * -> *) state blk.
ScheduledBlockFetchServer m state blk
-> BlockFetchServerHandlers m state blk
sbfsHandlers :: BlockFetchServerHandlers m state blk
}
scheduledBlockFetchServer ::
forall m state blk.
IOLike m =>
ScheduledBlockFetchServer m state blk ->
BlockFetchServer blk (Point blk) m ()
scheduledBlockFetchServer :: forall (m :: * -> *) state blk.
IOLike m =>
ScheduledBlockFetchServer m state blk
-> BlockFetchServer blk (Point blk) m ()
scheduledBlockFetchServer ScheduledBlockFetchServer{ScheduledServer m state blk
sbfsServer :: forall (m :: * -> *) state blk.
ScheduledBlockFetchServer m state blk
-> ScheduledServer m state blk
sbfsServer :: ScheduledServer m state blk
sbfsServer, Tracer m (TraceScheduledBlockFetchServerEvent state blk)
sbfsTracer :: forall (m :: * -> *) state blk.
ScheduledBlockFetchServer m state blk
-> Tracer m (TraceScheduledBlockFetchServerEvent state blk)
sbfsTracer :: Tracer m (TraceScheduledBlockFetchServerEvent state blk)
sbfsTracer, BlockFetchServerHandlers m state blk
sbfsHandlers :: forall (m :: * -> *) state blk.
ScheduledBlockFetchServer m state blk
-> BlockFetchServerHandlers m state blk
sbfsHandlers :: BlockFetchServerHandlers m state blk
sbfsHandlers} =
BlockFetchServer blk (Point blk) m ()
server
where
server :: BlockFetchServer blk (Point blk) m ()
server = (ChainRange (Point blk)
-> m (BlockFetchBlockSender blk (Point blk) m ()))
-> () -> BlockFetchServer blk (Point blk) m ()
forall point (m :: * -> *) block a.
(ChainRange point -> m (BlockFetchBlockSender block point m a))
-> a -> BlockFetchServer block point m a
BlockFetchServer ChainRange (Point blk)
-> m (BlockFetchBlockSender blk (Point blk) m ())
blockFetch ()
BlockFetchServerHandlers{ChainRange (Point blk)
-> state
-> STM
m
(Maybe (BlockFetch blk),
[TraceScheduledBlockFetchServerEvent state blk])
bfshBlockFetch :: forall (m :: * -> *) state blk.
BlockFetchServerHandlers m state blk
-> ChainRange (Point blk)
-> state
-> STM
m
(Maybe (BlockFetch blk),
[TraceScheduledBlockFetchServerEvent state blk])
bfshBlockFetch :: ChainRange (Point blk)
-> state
-> STM
m
(Maybe (BlockFetch blk),
[TraceScheduledBlockFetchServerEvent state blk])
bfshBlockFetch, [blk]
-> state
-> STM
m
(Maybe (SendBlocks blk),
[TraceScheduledBlockFetchServerEvent state blk])
bfshSendBlocks :: forall (m :: * -> *) state blk.
BlockFetchServerHandlers m state blk
-> [blk]
-> state
-> STM
m
(Maybe (SendBlocks blk),
[TraceScheduledBlockFetchServerEvent state blk])
bfshSendBlocks :: [blk]
-> state
-> STM
m
(Maybe (SendBlocks blk),
[TraceScheduledBlockFetchServerEvent state blk])
bfshSendBlocks} = BlockFetchServerHandlers m state blk
sbfsHandlers
blockFetch :: ChainRange (Point blk)
-> m (BlockFetchBlockSender blk (Point blk) m ())
blockFetch ChainRange (Point blk)
range =
ScheduledServer m state blk
-> String
-> (state
-> STM
m
(Maybe (BlockFetch blk),
[TraceScheduledBlockFetchServerEvent state blk]))
-> Tracer m (TraceScheduledBlockFetchServerEvent state blk)
-> (BlockFetch blk
-> m (BlockFetchBlockSender blk (Point blk) m ()))
-> m (BlockFetchBlockSender blk (Point blk) m ())
forall (m :: * -> *) state blk msg traceMsg h.
IOLike m =>
ScheduledServer m state blk
-> String
-> (state -> STM m (Maybe msg, [traceMsg]))
-> Tracer m traceMsg
-> (msg -> m h)
-> m h
runHandler ScheduledServer m state blk
sbfsServer String
"BlockFetch" (ChainRange (Point blk)
-> state
-> STM
m
(Maybe (BlockFetch blk),
[TraceScheduledBlockFetchServerEvent state blk])
bfshBlockFetch ChainRange (Point blk)
range) Tracer m (TraceScheduledBlockFetchServerEvent state blk)
sbfsTracer ((BlockFetch blk -> m (BlockFetchBlockSender blk (Point blk) m ()))
-> m (BlockFetchBlockSender blk (Point blk) m ()))
-> (BlockFetch blk
-> m (BlockFetchBlockSender blk (Point blk) m ()))
-> m (BlockFetchBlockSender blk (Point blk) m ())
forall a b. (a -> b) -> a -> b
$ \case
StartBatch [blk]
blocks -> do
BlockFetchBlockSender blk (Point blk) m ()
-> m (BlockFetchBlockSender blk (Point blk) m ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BlockFetchBlockSender blk (Point blk) m ()
-> m (BlockFetchBlockSender blk (Point blk) m ()))
-> BlockFetchBlockSender blk (Point blk) m ()
-> m (BlockFetchBlockSender blk (Point blk) m ())
forall a b. (a -> b) -> a -> b
$ m (BlockFetchSendBlocks blk (Point blk) m ())
-> BlockFetchBlockSender blk (Point blk) m ()
forall (m :: * -> *) block point a.
m (BlockFetchSendBlocks block point m a)
-> BlockFetchBlockSender block point m a
SendMsgStartBatch ([blk] -> m (BlockFetchSendBlocks blk (Point blk) m ())
sendBlocks [blk]
blocks)
BlockFetch blk
NoBlocks -> do
TraceScheduledBlockFetchServerEvent state blk -> m ()
trace (TraceScheduledBlockFetchServerEvent state blk -> m ())
-> TraceScheduledBlockFetchServerEvent state blk -> m ()
forall a b. (a -> b) -> a -> b
$ TraceScheduledBlockFetchServerEvent state blk
forall state blk. TraceScheduledBlockFetchServerEvent state blk
TraceNoBlocks
BlockFetchBlockSender blk (Point blk) m ()
-> m (BlockFetchBlockSender blk (Point blk) m ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m (BlockFetchServer blk (Point blk) m ())
-> BlockFetchBlockSender blk (Point blk) m ()
forall (m :: * -> *) block point a.
m (BlockFetchServer block point m a)
-> BlockFetchBlockSender block point m a
SendMsgNoBlocks (BlockFetchServer blk (Point blk) m ()
server BlockFetchServer blk (Point blk) m ()
-> m state -> m (BlockFetchServer blk (Point blk) m ())
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ScheduledServer m state blk -> m state
forall (m :: * -> *) state blk.
IOLike m =>
ScheduledServer m state blk -> m state
awaitOnlineState ScheduledServer m state blk
sbfsServer))
sendBlocks :: [blk] -> m (BlockFetchSendBlocks blk (Point blk) m ())
sendBlocks [blk]
bs =
ScheduledServer m state blk
-> String
-> (state
-> STM
m
(Maybe (SendBlocks blk),
[TraceScheduledBlockFetchServerEvent state blk]))
-> Tracer m (TraceScheduledBlockFetchServerEvent state blk)
-> (SendBlocks blk
-> m (BlockFetchSendBlocks blk (Point blk) m ()))
-> m (BlockFetchSendBlocks blk (Point blk) m ())
forall (m :: * -> *) state blk msg traceMsg h.
IOLike m =>
ScheduledServer m state blk
-> String
-> (state -> STM m (Maybe msg, [traceMsg]))
-> Tracer m traceMsg
-> (msg -> m h)
-> m h
runHandler ScheduledServer m state blk
sbfsServer String
"SendBlocks" ([blk]
-> state
-> STM
m
(Maybe (SendBlocks blk),
[TraceScheduledBlockFetchServerEvent state blk])
bfshSendBlocks [blk]
bs) Tracer m (TraceScheduledBlockFetchServerEvent state blk)
sbfsTracer ((SendBlocks blk -> m (BlockFetchSendBlocks blk (Point blk) m ()))
-> m (BlockFetchSendBlocks blk (Point blk) m ()))
-> (SendBlocks blk
-> m (BlockFetchSendBlocks blk (Point blk) m ()))
-> m (BlockFetchSendBlocks blk (Point blk) m ())
forall a b. (a -> b) -> a -> b
$ \case
SendBlock blk
blk [blk]
blks -> BlockFetchSendBlocks blk (Point blk) m ()
-> m (BlockFetchSendBlocks blk (Point blk) m ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (blk
-> m (BlockFetchSendBlocks blk (Point blk) m ())
-> BlockFetchSendBlocks blk (Point blk) m ()
forall block (m :: * -> *) point a.
block
-> m (BlockFetchSendBlocks block point m a)
-> BlockFetchSendBlocks block point m a
SendMsgBlock blk
blk ([blk] -> m (BlockFetchSendBlocks blk (Point blk) m ())
sendBlocks [blk]
blks))
SendBlocks blk
BatchDone -> BlockFetchSendBlocks blk (Point blk) m ()
-> m (BlockFetchSendBlocks blk (Point blk) m ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m (BlockFetchServer blk (Point blk) m ())
-> BlockFetchSendBlocks blk (Point blk) m ()
forall (m :: * -> *) block point a.
m (BlockFetchServer block point m a)
-> BlockFetchSendBlocks block point m a
SendMsgBatchDone (BlockFetchServer blk (Point blk) m ()
-> m (BlockFetchServer blk (Point blk) m ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BlockFetchServer blk (Point blk) m ()
server))
trace :: TraceScheduledBlockFetchServerEvent state blk -> m ()
trace = Tracer m (TraceScheduledBlockFetchServerEvent state blk)
-> TraceScheduledBlockFetchServerEvent state blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceScheduledBlockFetchServerEvent state blk)
sbfsTracer
runScheduledBlockFetchServer ::
IOLike m =>
PeerId ->
STM m () ->
STM m (Maybe (NodeState blk)) ->
Tracer m (TraceEvent blk) ->
BlockFetchServerHandlers m (NodeState blk) blk ->
BlockFetchServer blk (Point blk) m ()
runScheduledBlockFetchServer :: forall (m :: * -> *) blk.
IOLike m =>
PeerId
-> STM m ()
-> STM m (Maybe (NodeState blk))
-> Tracer m (TraceEvent blk)
-> BlockFetchServerHandlers m (NodeState blk) blk
-> BlockFetchServer blk (Point blk) m ()
runScheduledBlockFetchServer PeerId
ssPeerId STM m ()
ssTickStarted STM m (Maybe (NodeState blk))
ssCurrentState Tracer m (TraceEvent blk)
tracer BlockFetchServerHandlers m (NodeState blk) blk
sbfsHandlers =
ScheduledBlockFetchServer m (NodeState blk) blk
-> BlockFetchServer blk (Point blk) m ()
forall (m :: * -> *) state blk.
IOLike m =>
ScheduledBlockFetchServer m state blk
-> BlockFetchServer blk (Point blk) m ()
scheduledBlockFetchServer
ScheduledBlockFetchServer
{ sbfsServer :: ScheduledServer m (NodeState blk) blk
sbfsServer =
ScheduledServer
{ PeerId
ssPeerId :: PeerId
ssPeerId :: PeerId
ssPeerId
, STM m ()
ssTickStarted :: STM m ()
ssTickStarted :: STM m ()
ssTickStarted
, STM m (Maybe (NodeState blk))
ssCurrentState :: STM m (Maybe (NodeState blk))
ssCurrentState :: STM m (Maybe (NodeState blk))
ssCurrentState
, ssCommonTracer :: Tracer m (TraceScheduledServerHandlerEvent (NodeState blk) blk)
ssCommonTracer =
(TraceScheduledServerHandlerEvent (NodeState blk) blk -> m ())
-> Tracer m (TraceScheduledServerHandlerEvent (NodeState blk) blk)
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer (Tracer m (TraceEvent blk) -> TraceEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceEvent blk)
tracer (TraceEvent blk -> m ())
-> (TraceScheduledServerHandlerEvent (NodeState blk) blk
-> TraceEvent blk)
-> TraceScheduledServerHandlerEvent (NodeState blk) blk
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerId
-> TraceScheduledBlockFetchServerEvent (NodeState blk) blk
-> TraceEvent blk
forall blk.
PeerId
-> TraceScheduledBlockFetchServerEvent (NodeState blk) blk
-> TraceEvent blk
TraceScheduledBlockFetchServerEvent PeerId
ssPeerId (TraceScheduledBlockFetchServerEvent (NodeState blk) blk
-> TraceEvent blk)
-> (TraceScheduledServerHandlerEvent (NodeState blk) blk
-> TraceScheduledBlockFetchServerEvent (NodeState blk) blk)
-> TraceScheduledServerHandlerEvent (NodeState blk) blk
-> TraceEvent blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TraceScheduledServerHandlerEvent (NodeState blk) blk
-> TraceScheduledBlockFetchServerEvent (NodeState blk) blk
forall state blk.
TraceScheduledServerHandlerEvent state blk
-> TraceScheduledBlockFetchServerEvent state blk
TraceHandlerEventBF)
}
, sbfsTracer :: Tracer m (TraceScheduledBlockFetchServerEvent (NodeState blk) blk)
sbfsTracer = (TraceScheduledBlockFetchServerEvent (NodeState blk) blk -> m ())
-> Tracer
m (TraceScheduledBlockFetchServerEvent (NodeState blk) blk)
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer (Tracer m (TraceEvent blk) -> TraceEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceEvent blk)
tracer (TraceEvent blk -> m ())
-> (TraceScheduledBlockFetchServerEvent (NodeState blk) blk
-> TraceEvent blk)
-> TraceScheduledBlockFetchServerEvent (NodeState blk) blk
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerId
-> TraceScheduledBlockFetchServerEvent (NodeState blk) blk
-> TraceEvent blk
forall blk.
PeerId
-> TraceScheduledBlockFetchServerEvent (NodeState blk) blk
-> TraceEvent blk
TraceScheduledBlockFetchServerEvent PeerId
ssPeerId)
, BlockFetchServerHandlers m (NodeState blk) blk
sbfsHandlers :: BlockFetchServerHandlers m (NodeState blk) blk
sbfsHandlers :: BlockFetchServerHandlers m (NodeState blk) blk
sbfsHandlers
}