{-# LANGUAGE NamedFieldPuns #-}

-- | Data types and resource allocating constructors for the concurrency
-- primitives used by ChainSync and BlockFetch in the handlers that implement
-- the block tree analysis specific to our peer simulator.
module Test.Consensus.PeerSimulator.Resources (
    BlockFetchResources (..)
  , ChainSyncResources (..)
  , PeerResources (..)
  , PeerSimulatorResources (..)
  , SharedResources (..)
  , makeChainSyncResources
  , makePeerResources
  , makePeerSimulatorResources
  ) where

import           Control.Concurrent.Class.MonadSTM.Strict (atomically, dupTChan,
                     newBroadcastTChan, readTChan, writeTChan)
import           Control.Tracer (Tracer)
import           Data.Foldable (toList)
import           Data.List.NonEmpty (NonEmpty)
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Traversable (for)
import           Ouroboros.Consensus.Block (WithOrigin (Origin))
import           Ouroboros.Consensus.Block.Abstract (Header, Point (..))
import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client
                     (ChainSyncClientHandle)
import           Ouroboros.Consensus.Util.IOLike (IOLike, MonadSTM (STM),
                     StrictTVar, readTVar, uncheckedNewTVarM, writeTVar)
import qualified Ouroboros.Network.AnchoredFragment as AF
import           Ouroboros.Network.Block (Tip (..))
import           Ouroboros.Network.Protocol.BlockFetch.Server (BlockFetchServer)
import           Ouroboros.Network.Protocol.ChainSync.Server
                     (ChainSyncServer (..))
import           Test.Consensus.BlockTree (BlockTree)
import           Test.Consensus.PeerSimulator.Handlers
import           Test.Consensus.PeerSimulator.ScheduledBlockFetchServer
                     (BlockFetchServerHandlers (..),
                     runScheduledBlockFetchServer)
import           Test.Consensus.PeerSimulator.ScheduledChainSyncServer
import           Test.Consensus.PeerSimulator.Trace (TraceEvent)
import           Test.Consensus.PointSchedule.NodeState
import           Test.Consensus.PointSchedule.Peers (PeerId)
import           Test.Util.Orphans.IOLike ()
import           Test.Util.TestBlock (TestBlock)

-- | Resources used by both ChainSync and BlockFetch for a single peer.
data SharedResources m blk =
  SharedResources {
    -- | The name of the peer.
    forall (m :: * -> *) blk. SharedResources m blk -> PeerId
srPeerId       :: PeerId,

    -- | The block tree in which the test is taking place. In combination to
    -- 'csssCurrentIntersection' and the current point schedule tick, it allows
    -- to define which blocks to serve to the client.
    forall (m :: * -> *) blk. SharedResources m blk -> BlockTree blk
srBlockTree    :: BlockTree blk,

    -- | The currently active schedule point.
    --
    -- This is 'Maybe' because we cannot wait for the initial state otherwise.
    forall (m :: * -> *) blk.
SharedResources m blk -> StrictTVar m (Maybe (NodeState blk))
srCurrentState :: StrictTVar m (Maybe (NodeState blk)),

    forall (m :: * -> *) blk.
SharedResources m blk -> Tracer m (TraceEvent blk)
srTracer       :: Tracer m (TraceEvent blk)
  }

-- | The data used by the point scheduler to interact with the mocked protocol handler in
-- "Test.Consensus.PeerSimulator.ScheduledChainSyncServer".
data ChainSyncResources m blk =
  ChainSyncResources {
    -- | The current known intersection with the chain of the client.
    forall (m :: * -> *) blk.
ChainSyncResources m blk -> StrictTVar m (Point blk)
csrCurrentIntersection :: StrictTVar m (Point blk),

    -- | The final server passed to typed-protocols.
    forall (m :: * -> *) blk.
ChainSyncResources m blk
-> ChainSyncServer (Header blk) (Point blk) (Tip blk) m ()
csrServer :: ChainSyncServer (Header blk) (Point blk) (Tip blk) m (),

    -- | This action blocks while this peer is inactive in the point schedule.
    forall (m :: * -> *) blk. ChainSyncResources m blk -> STM m ()
csrTickStarted :: STM m ()
  }

-- | The data used by the point scheduler to interact with the mocked protocol handler in
-- "Test.Consensus.PeerSimulator.BlockFetch".
data BlockFetchResources m blk =
  BlockFetchResources {
    -- | The final server passed to typed-protocols.
    forall (m :: * -> *) blk.
BlockFetchResources m blk -> BlockFetchServer blk (Point blk) m ()
bfrServer      :: BlockFetchServer blk (Point blk) m (),

    -- | This action blocks while this peer is inactive in the point schedule.
    forall (m :: * -> *) blk. BlockFetchResources m blk -> STM m ()
bfrTickStarted :: STM m ()
  }

-- | The totality of resources used by a single peer in ChainSync and BlockFetch and by
-- the scheduler to interact with it.
data PeerResources m blk =
  PeerResources {
    -- | Resources used by ChainSync and BlockFetch.
    forall (m :: * -> *) blk.
PeerResources m blk -> SharedResources m blk
prShared      :: SharedResources m blk,

    -- | Resources used by ChainSync only.
    forall (m :: * -> *) blk.
PeerResources m blk -> ChainSyncResources m blk
prChainSync   :: ChainSyncResources m blk,

    -- | Resources used by BlockFetch only.
    forall (m :: * -> *) blk.
PeerResources m blk -> BlockFetchResources m blk
prBlockFetch  :: BlockFetchResources m blk,

    -- | An action used by the scheduler to update the peer's advertised points and
    -- resume processing for the ChainSync and BlockFetch servers.
    forall (m :: * -> *) blk.
PeerResources m blk -> NodeState blk -> STM m ()
prUpdateState :: NodeState blk -> STM m ()
  }

-- | Resources for the peer simulator.
data PeerSimulatorResources m blk =
  PeerSimulatorResources {
    -- | Resources for individual peers.
    forall (m :: * -> *) blk.
PeerSimulatorResources m blk -> Map PeerId (PeerResources m blk)
psrPeers   :: Map PeerId (PeerResources m blk),

    -- | Handles to interact with the ChainSync client of each peer.
    -- See 'ChainSyncClientHandle' for more details.
    forall (m :: * -> *) blk.
PeerSimulatorResources m blk
-> StrictTVar m (Map PeerId (ChainSyncClientHandle m TestBlock))
psrHandles :: StrictTVar m (Map PeerId (ChainSyncClientHandle m TestBlock))
  }

-- | Create 'ChainSyncServerHandlers' for our default implementation using 'NodeState'.
makeChainSyncServerHandlers ::
  (IOLike m) =>
  StrictTVar m (Point TestBlock) ->
  BlockTree TestBlock ->
  ChainSyncServerHandlers m (NodeState TestBlock) TestBlock
makeChainSyncServerHandlers :: forall (m :: * -> *).
IOLike m =>
StrictTVar m (Point TestBlock)
-> BlockTree TestBlock
-> ChainSyncServerHandlers m (NodeState TestBlock) TestBlock
makeChainSyncServerHandlers StrictTVar m (Point TestBlock)
currentIntersection BlockTree TestBlock
blockTree =
  ChainSyncServerHandlers {
    csshFindIntersection :: [Point TestBlock]
-> NodeState TestBlock
-> STM
     m
     (Maybe (FindIntersect TestBlock),
      [TraceScheduledChainSyncServerEvent
         (NodeState TestBlock) TestBlock])
csshFindIntersection = StrictTVar m (Point TestBlock)
-> BlockTree TestBlock
-> [Point TestBlock]
-> NodeState TestBlock
-> STM
     m
     (Maybe (FindIntersect TestBlock),
      [TraceScheduledChainSyncServerEvent
         (NodeState TestBlock) TestBlock])
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 TestBlock)
currentIntersection BlockTree TestBlock
blockTree,
    csshRequestNext :: NodeState TestBlock
-> STM
     m
     (Maybe (RequestNext TestBlock),
      [TraceScheduledChainSyncServerEvent
         (NodeState TestBlock) TestBlock])
csshRequestNext = StrictTVar m (Point TestBlock)
-> BlockTree TestBlock
-> NodeState TestBlock
-> STM
     m
     (Maybe (RequestNext TestBlock),
      [TraceScheduledChainSyncServerEvent
         (NodeState TestBlock) TestBlock])
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
  }

-- | Create all the resources used exclusively by the ChainSync handlers, and
-- the ChainSync protocol server that uses the handlers to interface with the
-- typed-protocols engine.
--
-- TODO move server construction to Run?
makeChainSyncResources ::
  (IOLike m) =>
  STM m () ->
  SharedResources m TestBlock ->
  m (ChainSyncResources m TestBlock)
makeChainSyncResources :: forall (m :: * -> *).
IOLike m =>
STM m ()
-> SharedResources m TestBlock
-> m (ChainSyncResources m TestBlock)
makeChainSyncResources STM m ()
csrTickStarted SharedResources {PeerId
srPeerId :: forall (m :: * -> *) blk. SharedResources m blk -> PeerId
srPeerId :: PeerId
srPeerId, Tracer m (TraceEvent TestBlock)
srTracer :: forall (m :: * -> *) blk.
SharedResources m blk -> Tracer m (TraceEvent blk)
srTracer :: Tracer m (TraceEvent TestBlock)
srTracer, BlockTree TestBlock
srBlockTree :: forall (m :: * -> *) blk. SharedResources m blk -> BlockTree blk
srBlockTree :: BlockTree TestBlock
srBlockTree, StrictTVar m (Maybe (NodeState TestBlock))
srCurrentState :: forall (m :: * -> *) blk.
SharedResources m blk -> StrictTVar m (Maybe (NodeState blk))
srCurrentState :: StrictTVar m (Maybe (NodeState TestBlock))
srCurrentState} = do
  StrictTVar m (Point TestBlock)
csrCurrentIntersection <- Point TestBlock -> m (StrictTVar m (Point TestBlock))
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
uncheckedNewTVarM (Point TestBlock -> m (StrictTVar m (Point TestBlock)))
-> Point TestBlock -> m (StrictTVar m (Point TestBlock))
forall a b. (a -> b) -> a -> b
$ WithOrigin (Block SlotNo (HeaderHash TestBlock)) -> Point TestBlock
forall {k} (block :: k).
WithOrigin (Block SlotNo (HeaderHash block)) -> Point block
AF.Point WithOrigin (Block SlotNo (HeaderHash TestBlock))
WithOrigin (Block SlotNo TestHash)
forall t. WithOrigin t
Origin
  let
    handlers :: ChainSyncServerHandlers m (NodeState TestBlock) TestBlock
handlers = StrictTVar m (Point TestBlock)
-> BlockTree TestBlock
-> ChainSyncServerHandlers m (NodeState TestBlock) TestBlock
forall (m :: * -> *).
IOLike m =>
StrictTVar m (Point TestBlock)
-> BlockTree TestBlock
-> ChainSyncServerHandlers m (NodeState TestBlock) TestBlock
makeChainSyncServerHandlers StrictTVar m (Point TestBlock)
csrCurrentIntersection BlockTree TestBlock
srBlockTree
    csrServer :: ChainSyncServer
  (Header TestBlock) (Point TestBlock) (Tip TestBlock) m ()
csrServer = PeerId
-> STM m ()
-> STM m (Maybe (NodeState TestBlock))
-> Tracer m (TraceEvent TestBlock)
-> ChainSyncServerHandlers m (NodeState TestBlock) TestBlock
-> ChainSyncServer
     (Header TestBlock) (Point TestBlock) (Tip TestBlock) m ()
forall (m :: * -> *) blk.
IOLike m =>
PeerId
-> STM m ()
-> STM m (Maybe (NodeState blk))
-> Tracer m (TraceEvent blk)
-> ChainSyncServerHandlers m (NodeState blk) blk
-> ChainSyncServer (Header blk) (Point blk) (Tip blk) m ()
runScheduledChainSyncServer PeerId
srPeerId STM m ()
csrTickStarted (StrictTVar m (Maybe (NodeState TestBlock))
-> STM m (Maybe (NodeState TestBlock))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Maybe (NodeState TestBlock))
srCurrentState) Tracer m (TraceEvent TestBlock)
srTracer ChainSyncServerHandlers m (NodeState TestBlock) TestBlock
handlers
  ChainSyncResources m TestBlock
-> m (ChainSyncResources m TestBlock)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ChainSyncResources {STM m ()
csrTickStarted :: STM m ()
csrTickStarted :: STM m ()
csrTickStarted, ChainSyncServer
  (Header TestBlock) (Point TestBlock) (Tip TestBlock) m ()
csrServer :: ChainSyncServer
  (Header TestBlock) (Point TestBlock) (Tip TestBlock) m ()
csrServer :: ChainSyncServer
  (Header TestBlock) (Point TestBlock) (Tip TestBlock) m ()
csrServer, StrictTVar m (Point TestBlock)
csrCurrentIntersection :: StrictTVar m (Point TestBlock)
csrCurrentIntersection :: StrictTVar m (Point TestBlock)
csrCurrentIntersection}

makeBlockFetchResources ::
  IOLike m =>
  STM m () ->
  SharedResources m TestBlock ->
  BlockFetchResources m TestBlock
makeBlockFetchResources :: forall (m :: * -> *).
IOLike m =>
STM m ()
-> SharedResources m TestBlock -> BlockFetchResources m TestBlock
makeBlockFetchResources STM m ()
bfrTickStarted SharedResources {PeerId
srPeerId :: forall (m :: * -> *) blk. SharedResources m blk -> PeerId
srPeerId :: PeerId
srPeerId, Tracer m (TraceEvent TestBlock)
srTracer :: forall (m :: * -> *) blk.
SharedResources m blk -> Tracer m (TraceEvent blk)
srTracer :: Tracer m (TraceEvent TestBlock)
srTracer, BlockTree TestBlock
srBlockTree :: forall (m :: * -> *) blk. SharedResources m blk -> BlockTree blk
srBlockTree :: BlockTree TestBlock
srBlockTree, StrictTVar m (Maybe (NodeState TestBlock))
srCurrentState :: forall (m :: * -> *) blk.
SharedResources m blk -> StrictTVar m (Maybe (NodeState blk))
srCurrentState :: StrictTVar m (Maybe (NodeState TestBlock))
srCurrentState} =
  BlockFetchResources {
    STM m ()
bfrTickStarted :: STM m ()
bfrTickStarted :: STM m ()
bfrTickStarted,
    BlockFetchServer TestBlock (Point TestBlock) m ()
bfrServer :: BlockFetchServer TestBlock (Point TestBlock) m ()
bfrServer :: BlockFetchServer TestBlock (Point TestBlock) m ()
bfrServer
  }
  where
    handlers :: BlockFetchServerHandlers m (NodeState TestBlock) TestBlock
handlers = BlockFetchServerHandlers {
      bfshBlockFetch :: ChainRange (Point TestBlock)
-> NodeState TestBlock
-> STM
     m
     (Maybe (BlockFetch TestBlock),
      [TraceScheduledBlockFetchServerEvent
         (NodeState TestBlock) TestBlock])
bfshBlockFetch = BlockTree TestBlock
-> ChainRange (Point TestBlock)
-> NodeState TestBlock
-> STM
     m
     (Maybe (BlockFetch TestBlock),
      [TraceScheduledBlockFetchServerEvent
         (NodeState TestBlock) TestBlock])
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 TestBlock
srBlockTree,
      bfshSendBlocks :: [TestBlock]
-> NodeState TestBlock
-> STM
     m
     (Maybe (SendBlocks TestBlock),
      [TraceScheduledBlockFetchServerEvent
         (NodeState TestBlock) TestBlock])
bfshSendBlocks = [TestBlock]
-> NodeState TestBlock
-> STM
     m
     (Maybe (SendBlocks TestBlock),
      [TraceScheduledBlockFetchServerEvent
         (NodeState TestBlock) TestBlock])
forall (m :: * -> *).
IOLike m =>
[TestBlock]
-> NodeState TestBlock
-> STM
     m
     (Maybe (SendBlocks TestBlock),
      [TraceScheduledBlockFetchServerEvent
         (NodeState TestBlock) TestBlock])
handlerSendBlocks
    }
    bfrServer :: BlockFetchServer TestBlock (Point TestBlock) m ()
bfrServer =
      PeerId
-> STM m ()
-> STM m (Maybe (NodeState TestBlock))
-> Tracer m (TraceEvent TestBlock)
-> BlockFetchServerHandlers m (NodeState TestBlock) TestBlock
-> BlockFetchServer TestBlock (Point TestBlock) m ()
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
srPeerId STM m ()
bfrTickStarted (StrictTVar m (Maybe (NodeState TestBlock))
-> STM m (Maybe (NodeState TestBlock))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Maybe (NodeState TestBlock))
srCurrentState)
        Tracer m (TraceEvent TestBlock)
srTracer BlockFetchServerHandlers m (NodeState TestBlock) TestBlock
handlers

-- | Create the concurrency transactions for communicating the begin of a peer's
-- tick and its new state to the ChainSync and BlockFetch servers.
--
-- We use a 'TChan' with two consumers and return only an action that takes a
-- 'NodeState', which should be called by the scheduler in each of this peer's
-- ticks.
--
-- The action writes the new state (converted to 'Maybe') to the shared TVar,
-- and publishes an item to the channel _only if_ the state is 'NodeOnline'.
--
-- If the peer's servers block on the channel whenever they have exhausted the
-- possible actions for a tick, the scheduler will be resumed.
-- When the scheduler then calls the update action in this peer's next tick,
-- both consumers will be unblocked and able to fetch the new state from the
-- TVar.
updateState ::
  IOLike m =>
  StrictTVar m (Maybe (NodeState TestBlock)) ->
  m (NodeState TestBlock -> STM m (), STM m (), STM m ())
updateState :: forall (m :: * -> *).
IOLike m =>
StrictTVar m (Maybe (NodeState TestBlock))
-> m (NodeState TestBlock -> STM m (), STM m (), STM m ())
updateState StrictTVar m (Maybe (NodeState TestBlock))
srCurrentState =
  STM m (NodeState TestBlock -> STM m (), STM m (), STM m ())
-> m (NodeState TestBlock -> STM m (), STM m (), STM m ())
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (NodeState TestBlock -> STM m (), STM m (), STM m ())
 -> m (NodeState TestBlock -> STM m (), STM m (), STM m ()))
-> STM m (NodeState TestBlock -> STM m (), STM m (), STM m ())
-> m (NodeState TestBlock -> STM m (), STM m (), STM m ())
forall a b. (a -> b) -> a -> b
$ do
    StrictTChan m ()
publisher <- STM m (StrictTChan m ())
forall (m :: * -> *) a. MonadSTM m => STM m (StrictTChan m a)
newBroadcastTChan
    StrictTChan m ()
consumer1 <- StrictTChan m () -> STM m (StrictTChan m ())
forall (m :: * -> *) a.
MonadSTM m =>
StrictTChan m a -> STM m (StrictTChan m a)
dupTChan StrictTChan m ()
publisher
    StrictTChan m ()
consumer2 <- StrictTChan m () -> STM m (StrictTChan m ())
forall (m :: * -> *) a.
MonadSTM m =>
StrictTChan m a -> STM m (StrictTChan m a)
dupTChan StrictTChan m ()
publisher
    let
      newState :: NodeState TestBlock -> STM m ()
newState NodeState TestBlock
points = do
        StrictTVar m (Maybe (NodeState TestBlock))
-> Maybe (NodeState TestBlock) -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (Maybe (NodeState TestBlock))
srCurrentState (Maybe (NodeState TestBlock) -> STM m ())
-> STM m (Maybe (NodeState TestBlock)) -> STM m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
            -- REVIEW: Is it ok to only unblock the peer when it is online?
            -- So far we've handled Nothing in the ChainSync server by skipping the tick.
            StrictTChan m () -> () -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTChan m a -> a -> STM m ()
writeTChan StrictTChan m ()
publisher ()
            Maybe (NodeState TestBlock) -> STM m (Maybe (NodeState TestBlock))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NodeState TestBlock -> Maybe (NodeState TestBlock)
forall a. a -> Maybe a
Just NodeState TestBlock
points)
    (NodeState TestBlock -> STM m (), STM m (), STM m ())
-> STM m (NodeState TestBlock -> STM m (), STM m (), STM m ())
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NodeState TestBlock -> STM m ()
newState, StrictTChan m () -> STM m ()
forall (m :: * -> *) a. MonadSTM m => StrictTChan m a -> STM m a
readTChan StrictTChan m ()
consumer1, StrictTChan m () -> STM m ()
forall (m :: * -> *) a. MonadSTM m => StrictTChan m a -> STM m a
readTChan StrictTChan m ()
consumer2)

-- | Create all concurrency resources and the ChainSync protocol server used
-- for a single peer.
--
-- A peer performs BlockFetch and ChainSync using a state of
-- type 'NodeState' that is updated by a separate scheduler, waking up
-- the protocol handlers to process messages until the conditions of the new
-- state are satisfied.
--
-- TODO pass BFR and CSR to runScheduled... rather than passing the individual resources in and storing the result
makePeerResources ::
  IOLike m =>
  Tracer m (TraceEvent TestBlock) ->
  BlockTree TestBlock ->
  PeerId ->
  m (PeerResources m TestBlock)
makePeerResources :: forall (m :: * -> *).
IOLike m =>
Tracer m (TraceEvent TestBlock)
-> BlockTree TestBlock -> PeerId -> m (PeerResources m TestBlock)
makePeerResources Tracer m (TraceEvent TestBlock)
srTracer BlockTree TestBlock
srBlockTree PeerId
srPeerId = do
  StrictTVar m (Maybe (NodeState TestBlock))
srCurrentState <- Maybe (NodeState TestBlock)
-> m (StrictTVar m (Maybe (NodeState TestBlock)))
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
uncheckedNewTVarM Maybe (NodeState TestBlock)
forall a. Maybe a
Nothing
  (NodeState TestBlock -> STM m ()
prUpdateState, STM m ()
csrTickStarted, STM m ()
bfrTickStarted) <- StrictTVar m (Maybe (NodeState TestBlock))
-> m (NodeState TestBlock -> STM m (), STM m (), STM m ())
forall (m :: * -> *).
IOLike m =>
StrictTVar m (Maybe (NodeState TestBlock))
-> m (NodeState TestBlock -> STM m (), STM m (), STM m ())
updateState StrictTVar m (Maybe (NodeState TestBlock))
srCurrentState
  let prShared :: SharedResources m TestBlock
prShared = SharedResources {Tracer m (TraceEvent TestBlock)
srTracer :: Tracer m (TraceEvent TestBlock)
srTracer :: Tracer m (TraceEvent TestBlock)
srTracer, BlockTree TestBlock
srBlockTree :: BlockTree TestBlock
srBlockTree :: BlockTree TestBlock
srBlockTree, PeerId
srPeerId :: PeerId
srPeerId :: PeerId
srPeerId, StrictTVar m (Maybe (NodeState TestBlock))
srCurrentState :: StrictTVar m (Maybe (NodeState TestBlock))
srCurrentState :: StrictTVar m (Maybe (NodeState TestBlock))
srCurrentState}
      prBlockFetch :: BlockFetchResources m TestBlock
prBlockFetch = STM m ()
-> SharedResources m TestBlock -> BlockFetchResources m TestBlock
forall (m :: * -> *).
IOLike m =>
STM m ()
-> SharedResources m TestBlock -> BlockFetchResources m TestBlock
makeBlockFetchResources STM m ()
bfrTickStarted SharedResources m TestBlock
prShared
  ChainSyncResources m TestBlock
prChainSync <- STM m ()
-> SharedResources m TestBlock
-> m (ChainSyncResources m TestBlock)
forall (m :: * -> *).
IOLike m =>
STM m ()
-> SharedResources m TestBlock
-> m (ChainSyncResources m TestBlock)
makeChainSyncResources STM m ()
csrTickStarted SharedResources m TestBlock
prShared
  PeerResources m TestBlock -> m (PeerResources m TestBlock)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PeerResources {SharedResources m TestBlock
prShared :: SharedResources m TestBlock
prShared :: SharedResources m TestBlock
prShared, ChainSyncResources m TestBlock
prChainSync :: ChainSyncResources m TestBlock
prChainSync :: ChainSyncResources m TestBlock
prChainSync, BlockFetchResources m TestBlock
prBlockFetch :: BlockFetchResources m TestBlock
prBlockFetch :: BlockFetchResources m TestBlock
prBlockFetch, NodeState TestBlock -> STM m ()
prUpdateState :: NodeState TestBlock -> STM m ()
prUpdateState :: NodeState TestBlock -> STM m ()
prUpdateState}

-- | Create resources for all given peers operating on the given block tree.
makePeerSimulatorResources ::
  IOLike m =>
  Tracer m (TraceEvent TestBlock) ->
  BlockTree TestBlock ->
  NonEmpty PeerId ->
  m (PeerSimulatorResources m TestBlock)
makePeerSimulatorResources :: forall (m :: * -> *).
IOLike m =>
Tracer m (TraceEvent TestBlock)
-> BlockTree TestBlock
-> NonEmpty PeerId
-> m (PeerSimulatorResources m TestBlock)
makePeerSimulatorResources Tracer m (TraceEvent TestBlock)
tracer BlockTree TestBlock
blockTree NonEmpty PeerId
peers = do
  NonEmpty (PeerId, PeerResources m TestBlock)
resources <- NonEmpty PeerId
-> (PeerId -> m (PeerId, PeerResources m TestBlock))
-> m (NonEmpty (PeerId, PeerResources m TestBlock))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for NonEmpty PeerId
peers ((PeerId -> m (PeerId, PeerResources m TestBlock))
 -> m (NonEmpty (PeerId, PeerResources m TestBlock)))
-> (PeerId -> m (PeerId, PeerResources m TestBlock))
-> m (NonEmpty (PeerId, PeerResources m TestBlock))
forall a b. (a -> b) -> a -> b
$ \ PeerId
peerId -> do
    PeerResources m TestBlock
peerResources <- Tracer m (TraceEvent TestBlock)
-> BlockTree TestBlock -> PeerId -> m (PeerResources m TestBlock)
forall (m :: * -> *).
IOLike m =>
Tracer m (TraceEvent TestBlock)
-> BlockTree TestBlock -> PeerId -> m (PeerResources m TestBlock)
makePeerResources Tracer m (TraceEvent TestBlock)
tracer BlockTree TestBlock
blockTree PeerId
peerId
    (PeerId, PeerResources m TestBlock)
-> m (PeerId, PeerResources m TestBlock)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PeerId
peerId, PeerResources m TestBlock
peerResources)
  StrictTVar m (Map PeerId (ChainSyncClientHandle m TestBlock))
psrHandles <- Map PeerId (ChainSyncClientHandle m TestBlock)
-> m (StrictTVar
        m (Map PeerId (ChainSyncClientHandle m TestBlock)))
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
uncheckedNewTVarM Map PeerId (ChainSyncClientHandle m TestBlock)
forall a. Monoid a => a
mempty
  PeerSimulatorResources m TestBlock
-> m (PeerSimulatorResources m TestBlock)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PeerSimulatorResources {psrPeers :: Map PeerId (PeerResources m TestBlock)
psrPeers = [(PeerId, PeerResources m TestBlock)]
-> Map PeerId (PeerResources m TestBlock)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(PeerId, PeerResources m TestBlock)]
 -> Map PeerId (PeerResources m TestBlock))
-> [(PeerId, PeerResources m TestBlock)]
-> Map PeerId (PeerResources m TestBlock)
forall a b. (a -> b) -> a -> b
$ NonEmpty (PeerId, PeerResources m TestBlock)
-> [(PeerId, PeerResources m TestBlock)]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (PeerId, PeerResources m TestBlock)
resources, StrictTVar m (Map PeerId (ChainSyncClientHandle m TestBlock))
psrHandles :: StrictTVar m (Map PeerId (ChainSyncClientHandle m TestBlock))
psrHandles :: StrictTVar m (Map PeerId (ChainSyncClientHandle m TestBlock))
psrHandles}