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

module Test.Consensus.PeerSimulator.Run (
    SchedulerConfig (..)
  , debugScheduler
  , defaultSchedulerConfig
  , runPointSchedule
  ) where

import           Control.Monad (foldM, forM, void)
import           Control.Monad.Class.MonadTime (MonadTime)
import           Control.Monad.Class.MonadTimer.SI (MonadTimer)
import           Control.ResourceRegistry
import           Control.Tracer (Tracer (..), nullTracer, traceWith)
import           Data.Coerce (coerce)
import           Data.Foldable (for_)
import qualified Data.List.NonEmpty as NonEmpty
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Config (TopLevelConfig (..))
import           Ouroboros.Consensus.Genesis.Governor (gddWatcher)
import           Ouroboros.Consensus.Ledger.SupportsProtocol
                     (LedgerSupportsProtocol)
import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client
                     (CSJConfig (..), CSJEnabledConfig (..), ChainDbView,
                     ChainSyncClientHandle, ChainSyncLoPBucketConfig (..),
                     ChainSyncLoPBucketEnabledConfig (..), viewChainSyncState)
import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client as CSClient
import qualified Ouroboros.Consensus.Node.GsmState as GSM
import           Ouroboros.Consensus.Storage.ChainDB.API
import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB
import           Ouroboros.Consensus.Util.Condense (Condense (..))
import           Ouroboros.Consensus.Util.IOLike
import           Ouroboros.Consensus.Util.STM (forkLinkedWatcher)
import           Ouroboros.Network.AnchoredFragment (AnchoredFragment)
import qualified Ouroboros.Network.AnchoredFragment as AF
import           Ouroboros.Network.BlockFetch (FetchClientRegistry,
                     bracketSyncWithFetchClient, newFetchClientRegistry)
import           Ouroboros.Network.Channel (createConnectedChannels)
import           Ouroboros.Network.ControlMessage (ControlMessage (..),
                     ControlMessageSTM)
import           Ouroboros.Network.Protocol.ChainSync.Codec
import           Ouroboros.Network.Util.ShowProxy (ShowProxy)
import qualified Test.Consensus.PeerSimulator.BlockFetch as BlockFetch
import qualified Test.Consensus.PeerSimulator.ChainSync as ChainSync
import           Test.Consensus.PeerSimulator.Config
import qualified Test.Consensus.PeerSimulator.CSJInvariants as CSJInvariants
import           Test.Consensus.PeerSimulator.NodeLifecycle
import           Test.Consensus.PeerSimulator.Resources
import           Test.Consensus.PeerSimulator.StateDiagram
                     (peerSimStateDiagramSTMTracerDebug)
import           Test.Consensus.PeerSimulator.StateView
import           Test.Consensus.PeerSimulator.Trace
import           Test.Consensus.PointSchedule (BlockFetchTimeout,
                     CSJParams (..), GenesisTest (..), GenesisTestFull,
                     LoPBucketParams (..), PointSchedule (..), peersStates,
                     peersStatesRelative)
import           Test.Consensus.PointSchedule.NodeState (NodeState)
import           Test.Consensus.PointSchedule.Peers (Peer (..), PeerId,
                     getPeerIds)
import           Test.Util.ChainDB
import           Test.Util.Orphans.IOLike ()
import           Test.Util.TestBlock (TestBlock)

-- | Behavior config for the scheduler.
data SchedulerConfig =
  SchedulerConfig {
    -- | Whether to enable timeouts for the ChainSync protocol. The value of
    -- timeouts themselves is defined in 'GenesisTest'.
      SchedulerConfig -> Bool
scEnableChainSyncTimeouts  :: Bool

    -- | Whether to enable timeouts for the BlockFetch protocol. The value of
    -- timeouts themselves is defined in 'GenesisTest'.
    , SchedulerConfig -> Bool
scEnableBlockFetchTimeouts :: Bool

    -- | If 'True', 'Test.Consensus.Genesis.Setup.runTest' will print traces
    -- to stderr.
    --
    -- Use 'debugScheduler' to toggle it conveniently.
    , SchedulerConfig -> Bool
scDebug                    :: Bool

    -- | Whether to trace when running the scheduler.
    , SchedulerConfig -> Bool
scTrace                    :: Bool

    -- | Whether to trace only the current state of the candidates and selection,
    -- which provides a less verbose view of the test progress.
    , SchedulerConfig -> Bool
scTraceState               :: Bool

    -- | Enable Limit on Eagerness (LoE) and the Genesis Density Disconnection
    -- governor (GDD).
    , SchedulerConfig -> Bool
scEnableLoE                :: Bool

    -- | Whether to enable the LoP. The parameters of the LoP come from
    -- 'GenesisTest'.
    , SchedulerConfig -> Bool
scEnableLoP                :: Bool

    -- | Enable node downtime if this is 'Just', using the value as minimum tick
    -- duration to trigger it.
    , SchedulerConfig -> Maybe DiffTime
scDowntime                 :: Maybe DiffTime

    -- | Whether to enable ChainSync Jumping. The parameters come from
    -- 'GenesisTest'.
    , SchedulerConfig -> Bool
scEnableCSJ                :: Bool
  }

-- | Default scheduler config
defaultSchedulerConfig :: SchedulerConfig
defaultSchedulerConfig :: SchedulerConfig
defaultSchedulerConfig =
  SchedulerConfig {
    scEnableChainSyncTimeouts :: Bool
scEnableChainSyncTimeouts = Bool
True,
    scEnableBlockFetchTimeouts :: Bool
scEnableBlockFetchTimeouts = Bool
True,
    scDebug :: Bool
scDebug = Bool
False,
    scTrace :: Bool
scTrace = Bool
True,
    scTraceState :: Bool
scTraceState = Bool
False,
    scEnableLoE :: Bool
scEnableLoE = Bool
False,
    scEnableLoP :: Bool
scEnableLoP = Bool
False,
    scDowntime :: Maybe DiffTime
scDowntime = Maybe DiffTime
forall a. Maybe a
Nothing,
    scEnableCSJ :: Bool
scEnableCSJ = Bool
False
  }

-- | Enable debug tracing during a scheduler test.
debugScheduler :: SchedulerConfig -> SchedulerConfig
debugScheduler :: SchedulerConfig -> SchedulerConfig
debugScheduler SchedulerConfig
conf = SchedulerConfig
conf { scDebug = True }

-- | Run a ChainSync protocol for one peer, consisting of a server and client.
--
-- The connection uses timeouts based on the ASC.
--
-- The client is synchronized with BlockFetch using the supplied 'FetchClientRegistry'.
--
-- Execution is started asynchronously, returning an action that kills the thread,
-- to allow extraction of a potential exception.
startChainSyncConnectionThread ::
  (IOLike m, MonadTimer m, LedgerSupportsProtocol blk, ShowProxy blk, ShowProxy (Header blk)) =>
  ResourceRegistry m ->
  Tracer m (TraceEvent blk) ->
  TopLevelConfig blk ->
  ChainDbView m blk ->
  FetchClientRegistry PeerId (Header blk) blk m ->
  SharedResources m blk ->
  ChainSyncResources m blk ->
  ChainSyncTimeout ->
  ChainSyncLoPBucketConfig ->
  CSJConfig ->
  StateViewTracers blk m ->
  StrictTVar m (Map PeerId (ChainSyncClientHandle m blk)) ->
  m (Thread m (), Thread m ())
startChainSyncConnectionThread :: forall (m :: * -> *) blk.
(IOLike m, MonadTimer m, LedgerSupportsProtocol blk, ShowProxy blk,
 ShowProxy (Header blk)) =>
ResourceRegistry m
-> Tracer m (TraceEvent blk)
-> TopLevelConfig blk
-> ChainDbView m blk
-> FetchClientRegistry PeerId (Header blk) blk m
-> SharedResources m blk
-> ChainSyncResources m blk
-> ChainSyncTimeout
-> ChainSyncLoPBucketConfig
-> CSJConfig
-> StateViewTracers blk m
-> StrictTVar m (Map PeerId (ChainSyncClientHandle m blk))
-> m (Thread m (), Thread m ())
startChainSyncConnectionThread
  ResourceRegistry m
registry
  Tracer m (TraceEvent blk)
tracer
  TopLevelConfig blk
cfg
  ChainDbView m blk
chainDbView
  FetchClientRegistry PeerId (Header blk) blk m
fetchClientRegistry
  SharedResources {PeerId
srPeerId :: PeerId
srPeerId :: forall (m :: * -> *) blk. SharedResources m blk -> PeerId
srPeerId}
  ChainSyncResources {ChainSyncServer (Header blk) (Point blk) (Tip blk) m ()
csrServer :: ChainSyncServer (Header blk) (Point blk) (Tip blk) m ()
csrServer :: forall (m :: * -> *) blk.
ChainSyncResources m blk
-> ChainSyncServer (Header blk) (Point blk) (Tip blk) m ()
csrServer}
  ChainSyncTimeout
chainSyncTimeouts_
  ChainSyncLoPBucketConfig
chainSyncLoPBucketConfig
  CSJConfig
csjConfig
  StateViewTracers blk m
tracers
  StrictTVar m (Map PeerId (ChainSyncClientHandle m blk))
varHandles
  = do
    (Channel
  m (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk)))
clientChannel, Channel
  m (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk)))
serverChannel) <- m (Channel
     m (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))),
   Channel
     m (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))))
forall (m :: * -> *) a. MonadSTM m => m (Channel m a, Channel m a)
createConnectedChannels
    Thread m ()
clientThread <-
      ResourceRegistry m -> String -> m () -> m (Thread m ())
forall (m :: * -> *) a.
(MonadAsync m, MonadFork m, MonadMask m, HasCallStack) =>
ResourceRegistry m -> String -> m a -> m (Thread m a)
forkLinkedThread ResourceRegistry m
registry (String
"ChainSyncClient" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> PeerId -> String
forall a. Condense a => a -> String
condense PeerId
srPeerId) (m () -> m (Thread m ())) -> m () -> m (Thread m ())
forall a b. (a -> b) -> a -> b
$
        FetchClientRegistry PeerId (Header blk) blk m
-> PeerId -> m () -> m ()
forall (m :: * -> *) a peer header block.
(MonadSTM m, MonadFork m, MonadCatch m, Ord peer) =>
FetchClientRegistry peer header block m -> peer -> m a -> m a
bracketSyncWithFetchClient FetchClientRegistry PeerId (Header blk) blk m
fetchClientRegistry PeerId
srPeerId (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
          Tracer m (TraceEvent blk)
-> TopLevelConfig blk
-> ChainDbView m blk
-> PeerId
-> ChainSyncTimeout
-> ChainSyncLoPBucketConfig
-> CSJConfig
-> StateViewTracers blk m
-> StrictTVar m (Map PeerId (ChainSyncClientHandle m blk))
-> Channel
     m (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk)))
-> m ()
forall (m :: * -> *) blk.
(IOLike m, MonadTimer m, LedgerSupportsProtocol blk, ShowProxy blk,
 ShowProxy (Header blk)) =>
Tracer m (TraceEvent blk)
-> TopLevelConfig blk
-> ChainDbView m blk
-> PeerId
-> ChainSyncTimeout
-> ChainSyncLoPBucketConfig
-> CSJConfig
-> StateViewTracers blk m
-> StrictTVar m (Map PeerId (ChainSyncClientHandle m blk))
-> Channel
     m (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk)))
-> m ()
ChainSync.runChainSyncClient Tracer m (TraceEvent blk)
tracer TopLevelConfig blk
cfg ChainDbView m blk
chainDbView PeerId
srPeerId ChainSyncTimeout
chainSyncTimeouts_ ChainSyncLoPBucketConfig
chainSyncLoPBucketConfig CSJConfig
csjConfig StateViewTracers blk m
tracers StrictTVar m (Map PeerId (ChainSyncClientHandle m blk))
varHandles Channel
  m (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk)))
clientChannel
    Thread m ()
serverThread <-
      ResourceRegistry m -> String -> m () -> m (Thread m ())
forall (m :: * -> *) a.
(MonadAsync m, MonadFork m, MonadMask m, HasCallStack) =>
ResourceRegistry m -> String -> m a -> m (Thread m a)
forkLinkedThread ResourceRegistry m
registry (String
"ChainSyncServer" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> PeerId -> String
forall a. Condense a => a -> String
condense PeerId
srPeerId) (m () -> m (Thread m ())) -> m () -> m (Thread m ())
forall a b. (a -> b) -> a -> b
$
        Tracer m (TraceEvent blk)
-> PeerId
-> StateViewTracers blk m
-> ChainSyncServer (Header blk) (Point blk) (Tip blk) m ()
-> Channel
     m (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk)))
-> m ()
forall (m :: * -> *) blk.
(IOLike m, ShowProxy blk, ShowProxy (Header blk)) =>
Tracer m (TraceEvent blk)
-> PeerId
-> StateViewTracers blk m
-> ChainSyncServer (Header blk) (Point blk) (Tip blk) m ()
-> Channel
     m (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk)))
-> m ()
ChainSync.runChainSyncServer Tracer m (TraceEvent blk)
tracer PeerId
srPeerId StateViewTracers blk m
tracers ChainSyncServer (Header blk) (Point blk) (Tip blk) m ()
csrServer Channel
  m (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk)))
serverChannel
    (Thread m (), Thread m ()) -> m (Thread m (), Thread m ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Thread m ()
clientThread, Thread m ()
serverThread)

-- | Start the BlockFetch client, using the supplied 'FetchClientRegistry' to
-- register it for synchronization with the ChainSync client.
startBlockFetchConnectionThread ::
  (IOLike m, MonadTime m, MonadTimer m, HasHeader blk, HasHeader (Header blk), ShowProxy blk) =>
  ResourceRegistry m ->
  Tracer m (TraceEvent blk) ->
  StateViewTracers blk m ->
  FetchClientRegistry PeerId (Header blk) blk m ->
  ControlMessageSTM m ->
  SharedResources m blk ->
  BlockFetchResources m blk ->
  BlockFetchTimeout ->
  m (Thread m (), Thread m ())
startBlockFetchConnectionThread :: forall (m :: * -> *) blk.
(IOLike m, MonadTime m, MonadTimer m, HasHeader blk,
 HasHeader (Header blk), ShowProxy blk) =>
ResourceRegistry m
-> Tracer m (TraceEvent blk)
-> StateViewTracers blk m
-> FetchClientRegistry PeerId (Header blk) blk m
-> ControlMessageSTM m
-> SharedResources m blk
-> BlockFetchResources m blk
-> BlockFetchTimeout
-> m (Thread m (), Thread m ())
startBlockFetchConnectionThread
  ResourceRegistry m
registry
  Tracer m (TraceEvent blk)
tracer
  StateViewTracers blk m
tracers
  FetchClientRegistry PeerId (Header blk) blk m
fetchClientRegistry
  ControlMessageSTM m
controlMsgSTM
  SharedResources {PeerId
srPeerId :: forall (m :: * -> *) blk. SharedResources m blk -> PeerId
srPeerId :: PeerId
srPeerId}
  BlockFetchResources {BlockFetchServer blk (Point blk) m ()
bfrServer :: BlockFetchServer blk (Point blk) m ()
bfrServer :: forall (m :: * -> *) blk.
BlockFetchResources m blk -> BlockFetchServer blk (Point blk) m ()
bfrServer}
  BlockFetchTimeout
blockFetchTimeouts = do
    (Channel m (AnyMessage (BlockFetch blk (Point blk)))
clientChannel, Channel m (AnyMessage (BlockFetch blk (Point blk)))
serverChannel) <- m (Channel m (AnyMessage (BlockFetch blk (Point blk))),
   Channel m (AnyMessage (BlockFetch blk (Point blk))))
forall (m :: * -> *) a. MonadSTM m => m (Channel m a, Channel m a)
createConnectedChannels
    Thread m ()
clientThread <-
      ResourceRegistry m -> String -> m () -> m (Thread m ())
forall (m :: * -> *) a.
(MonadAsync m, MonadFork m, MonadMask m, HasCallStack) =>
ResourceRegistry m -> String -> m a -> m (Thread m a)
forkLinkedThread ResourceRegistry m
registry (String
"BlockFetchClient" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> PeerId -> String
forall a. Condense a => a -> String
condense PeerId
srPeerId) (m () -> m (Thread m ())) -> m () -> m (Thread m ())
forall a b. (a -> b) -> a -> b
$
        Tracer m (TraceEvent blk)
-> PeerId
-> BlockFetchTimeout
-> StateViewTracers blk m
-> FetchClientRegistry PeerId (Header blk) blk m
-> ControlMessageSTM m
-> Channel m (AnyMessage (BlockFetch blk (Point blk)))
-> m ()
forall (m :: * -> *) blk.
(IOLike m, MonadTime m, MonadTimer m, HasHeader blk,
 HasHeader (Header blk), ShowProxy blk) =>
Tracer m (TraceEvent blk)
-> PeerId
-> BlockFetchTimeout
-> StateViewTracers blk m
-> FetchClientRegistry PeerId (Header blk) blk m
-> ControlMessageSTM m
-> Channel m (AnyMessage (BlockFetch blk (Point blk)))
-> m ()
BlockFetch.runBlockFetchClient Tracer m (TraceEvent blk)
tracer PeerId
srPeerId BlockFetchTimeout
blockFetchTimeouts StateViewTracers blk m
tracers FetchClientRegistry PeerId (Header blk) blk m
fetchClientRegistry ControlMessageSTM m
controlMsgSTM Channel m (AnyMessage (BlockFetch blk (Point blk)))
clientChannel
    Thread m ()
serverThread <-
      ResourceRegistry m -> String -> m () -> m (Thread m ())
forall (m :: * -> *) a.
(MonadAsync m, MonadFork m, MonadMask m, HasCallStack) =>
ResourceRegistry m -> String -> m a -> m (Thread m a)
forkLinkedThread ResourceRegistry m
registry (String
"BlockFetchServer" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> PeerId -> String
forall a. Condense a => a -> String
condense PeerId
srPeerId) (m () -> m (Thread m ())) -> m () -> m (Thread m ())
forall a b. (a -> b) -> a -> b
$
        Tracer m (TraceEvent blk)
-> PeerId
-> StateViewTracers blk m
-> BlockFetchServer blk (Point blk) m ()
-> Channel m (AnyMessage (BlockFetch blk (Point blk)))
-> m ()
forall (m :: * -> *) blk.
(IOLike m, ShowProxy blk) =>
Tracer m (TraceEvent blk)
-> PeerId
-> StateViewTracers blk m
-> BlockFetchServer blk (Point blk) m ()
-> Channel m (AnyMessage (BlockFetch blk (Point blk)))
-> m ()
BlockFetch.runBlockFetchServer Tracer m (TraceEvent blk)
tracer PeerId
srPeerId StateViewTracers blk m
tracers BlockFetchServer blk (Point blk) m ()
bfrServer Channel m (AnyMessage (BlockFetch blk (Point blk)))
serverChannel
    (Thread m (), Thread m ()) -> m (Thread m (), Thread m ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Thread m ()
clientThread, Thread m ()
serverThread)

-- | Wait for the given duration, but if the duration is longer than the minimum
-- duration in the live cycle, shutdown the node and restart it after the delay.
smartDelay ::
  (MonadDelay m) =>
  NodeLifecycle blk m ->
  LiveNode blk m ->
  DiffTime ->
  m (LiveNode blk m)
smartDelay :: forall (m :: * -> *) blk.
MonadDelay m =>
NodeLifecycle blk m
-> LiveNode blk m -> DiffTime -> m (LiveNode blk m)
smartDelay NodeLifecycle {Maybe DiffTime
nlMinDuration :: Maybe DiffTime
nlMinDuration :: forall blk (m :: * -> *). NodeLifecycle blk m -> Maybe DiffTime
nlMinDuration, LiveIntervalResult blk -> m (LiveNode blk m)
nlStart :: LiveIntervalResult blk -> m (LiveNode blk m)
nlStart :: forall blk (m :: * -> *).
NodeLifecycle blk m -> LiveIntervalResult blk -> m (LiveNode blk m)
nlStart, LiveNode blk m -> m (LiveIntervalResult blk)
nlShutdown :: LiveNode blk m -> m (LiveIntervalResult blk)
nlShutdown :: forall blk (m :: * -> *).
NodeLifecycle blk m -> LiveNode blk m -> m (LiveIntervalResult blk)
nlShutdown} LiveNode blk m
node DiffTime
duration
  | Just DiffTime
minInterval <- Maybe DiffTime
nlMinDuration, DiffTime
duration DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> DiffTime
minInterval = do
    LiveIntervalResult blk
results <- LiveNode blk m -> m (LiveIntervalResult blk)
nlShutdown LiveNode blk m
node
    DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
duration
    LiveIntervalResult blk -> m (LiveNode blk m)
nlStart LiveIntervalResult blk
results
smartDelay NodeLifecycle blk m
_ LiveNode blk m
node DiffTime
duration = do
  DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
duration
  LiveNode blk m -> m (LiveNode blk m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LiveNode blk m
node

-- | The 'Tick' contains a state update for a specific peer.
-- If the peer has not terminated by protocol rules, this will update its TMVar
-- with the new state, thereby unblocking the handler that's currently waiting
-- for new instructions.
--
-- TODO doc is outdated
dispatchTick :: forall m blk.
  IOLike m =>
  Tracer m (TraceSchedulerEvent blk) ->
  StrictTVar m (Map PeerId (ChainSyncClientHandle m blk)) ->
  Map PeerId (PeerResources m blk) ->
  NodeLifecycle blk m ->
  LiveNode blk m ->
  (Int, (DiffTime, Peer (NodeState blk))) ->
  m (LiveNode blk m)
dispatchTick :: forall (m :: * -> *) blk.
IOLike m =>
Tracer m (TraceSchedulerEvent blk)
-> StrictTVar m (Map PeerId (ChainSyncClientHandle m blk))
-> Map PeerId (PeerResources m blk)
-> NodeLifecycle blk m
-> LiveNode blk m
-> (Int, (DiffTime, Peer (NodeState blk)))
-> m (LiveNode blk m)
dispatchTick Tracer m (TraceSchedulerEvent blk)
tracer StrictTVar m (Map PeerId (ChainSyncClientHandle m blk))
varHandles Map PeerId (PeerResources m blk)
peers NodeLifecycle blk m
lifecycle LiveNode blk m
node (Int
number, (DiffTime
duration, Peer PeerId
pid NodeState blk
state)) =
  case Map PeerId (PeerResources m blk)
peers Map PeerId (PeerResources m blk)
-> PeerId -> Maybe (PeerResources m blk)
forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? PeerId
pid of
    Just PeerResources {NodeState blk -> STM m ()
prUpdateState :: NodeState blk -> STM m ()
prUpdateState :: forall (m :: * -> *) blk.
PeerResources m blk -> NodeState blk -> STM m ()
prUpdateState} -> do
      m ()
traceNewTick
      STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (NodeState blk -> STM m ()
prUpdateState NodeState blk
state)
      LiveNode blk m
newNode <- NodeLifecycle blk m
-> LiveNode blk m -> DiffTime -> m (LiveNode blk m)
forall (m :: * -> *) blk.
MonadDelay m =>
NodeLifecycle blk m
-> LiveNode blk m -> DiffTime -> m (LiveNode blk m)
smartDelay NodeLifecycle blk m
lifecycle LiveNode blk m
node DiffTime
duration
      Tracer m () -> () -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (LiveNode blk m -> Tracer m ()
forall blk (m :: * -> *). LiveNode blk m -> Tracer m ()
lnStateTracer LiveNode blk m
newNode) ()
      LiveNode blk m -> m (LiveNode blk m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LiveNode blk m
newNode
    Maybe (PeerResources m blk)
Nothing -> String -> m (LiveNode blk m)
forall a. HasCallStack => String -> a
error String
"“The impossible happened,” as GHC would say."
  where
    traceNewTick :: m ()
    traceNewTick :: m ()
traceNewTick = do
      AnchoredFragment (Header blk)
currentChain <- STM m (AnchoredFragment (Header blk))
-> m (AnchoredFragment (Header blk))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (AnchoredFragment (Header blk))
 -> m (AnchoredFragment (Header blk)))
-> STM m (AnchoredFragment (Header blk))
-> m (AnchoredFragment (Header blk))
forall a b. (a -> b) -> a -> b
$ ChainDB m blk -> STM m (AnchoredFragment (Header blk))
forall (m :: * -> *) blk.
ChainDB m blk -> STM m (AnchoredFragment (Header blk))
ChainDB.getCurrentChain (LiveNode blk m -> ChainDB m blk
forall blk (m :: * -> *). LiveNode blk m -> ChainDB m blk
lnChainDb LiveNode blk m
node)
      (Maybe (ChainSyncState blk)
csState, [(PeerId, ChainSyncJumpingState m blk)]
jumpingStates) <- STM
  m
  (Maybe (ChainSyncState blk),
   [(PeerId, ChainSyncJumpingState m blk)])
-> m (Maybe (ChainSyncState blk),
      [(PeerId, ChainSyncJumpingState m blk)])
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM
   m
   (Maybe (ChainSyncState blk),
    [(PeerId, ChainSyncJumpingState m blk)])
 -> m (Maybe (ChainSyncState blk),
       [(PeerId, ChainSyncJumpingState m blk)]))
-> STM
     m
     (Maybe (ChainSyncState blk),
      [(PeerId, ChainSyncJumpingState m blk)])
-> m (Maybe (ChainSyncState blk),
      [(PeerId, ChainSyncJumpingState m blk)])
forall a b. (a -> b) -> a -> b
$ do
         Map PeerId (ChainSyncClientHandle m blk)
m <- StrictTVar m (Map PeerId (ChainSyncClientHandle m blk))
-> STM m (Map PeerId (ChainSyncClientHandle m blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Map PeerId (ChainSyncClientHandle m blk))
varHandles
         Maybe (ChainSyncState blk)
csState <- (ChainSyncClientHandle m blk -> STM m (ChainSyncState blk))
-> Maybe (ChainSyncClientHandle m blk)
-> STM m (Maybe (ChainSyncState blk))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (StrictTVar m (ChainSyncState blk) -> STM m (ChainSyncState blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (StrictTVar m (ChainSyncState blk) -> STM m (ChainSyncState blk))
-> (ChainSyncClientHandle m blk
    -> StrictTVar m (ChainSyncState blk))
-> ChainSyncClientHandle m blk
-> STM m (ChainSyncState blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainSyncClientHandle m blk -> StrictTVar m (ChainSyncState blk)
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk -> StrictTVar m (ChainSyncState blk)
CSClient.cschState) (Map PeerId (ChainSyncClientHandle m blk)
m Map PeerId (ChainSyncClientHandle m blk)
-> PeerId -> Maybe (ChainSyncClientHandle m blk)
forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? PeerId
pid)
         [(PeerId, ChainSyncJumpingState m blk)]
jumpingStates <- [(PeerId, ChainSyncClientHandle m blk)]
-> ((PeerId, ChainSyncClientHandle m blk)
    -> STM m (PeerId, ChainSyncJumpingState m blk))
-> STM m [(PeerId, ChainSyncJumpingState m blk)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Map PeerId (ChainSyncClientHandle m blk)
-> [(PeerId, ChainSyncClientHandle m blk)]
forall k a. Map k a -> [(k, a)]
Map.toList Map PeerId (ChainSyncClientHandle m blk)
m) (((PeerId, ChainSyncClientHandle m blk)
  -> STM m (PeerId, ChainSyncJumpingState m blk))
 -> STM m [(PeerId, ChainSyncJumpingState m blk)])
-> ((PeerId, ChainSyncClientHandle m blk)
    -> STM m (PeerId, ChainSyncJumpingState m blk))
-> STM m [(PeerId, ChainSyncJumpingState m blk)]
forall a b. (a -> b) -> a -> b
$ \(PeerId
peer, ChainSyncClientHandle m blk
h) -> do
           ChainSyncJumpingState m blk
st <- StrictTVar m (ChainSyncJumpingState m blk)
-> STM m (ChainSyncJumpingState m blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
CSClient.cschJumping ChainSyncClientHandle m blk
h)
           (PeerId, ChainSyncJumpingState m blk)
-> STM m (PeerId, ChainSyncJumpingState m blk)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PeerId
peer, ChainSyncJumpingState m blk
st)
         (Maybe (ChainSyncState blk),
 [(PeerId, ChainSyncJumpingState m blk)])
-> STM
     m
     (Maybe (ChainSyncState blk),
      [(PeerId, ChainSyncJumpingState m blk)])
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (ChainSyncState blk)
csState, [(PeerId, ChainSyncJumpingState m blk)]
jumpingStates)
      Tracer m (TraceSchedulerEvent blk)
-> TraceSchedulerEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceSchedulerEvent blk)
tracer (TraceSchedulerEvent blk -> m ())
-> TraceSchedulerEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ Int
-> DiffTime
-> Peer (NodeState blk)
-> AnchoredFragment (Header blk)
-> Maybe (AnchoredFragment (Header blk))
-> [(PeerId, ChainSyncJumpingState m blk)]
-> TraceSchedulerEvent blk
forall blk (m :: * -> *).
Int
-> DiffTime
-> Peer (NodeState blk)
-> AnchoredFragment (Header blk)
-> Maybe (AnchoredFragment (Header blk))
-> [(PeerId, ChainSyncJumpingState m blk)]
-> TraceSchedulerEvent blk
TraceNewTick
        Int
number
        DiffTime
duration
        (PeerId -> NodeState blk -> Peer (NodeState blk)
forall a. PeerId -> a -> Peer a
Peer PeerId
pid NodeState blk
state)
        AnchoredFragment (Header blk)
currentChain
        (ChainSyncState blk -> AnchoredFragment (Header blk)
forall blk. ChainSyncState blk -> AnchoredFragment (Header blk)
CSClient.csCandidate (ChainSyncState blk -> AnchoredFragment (Header blk))
-> Maybe (ChainSyncState blk)
-> Maybe (AnchoredFragment (Header blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (ChainSyncState blk)
csState)
        [(PeerId, ChainSyncJumpingState m blk)]
jumpingStates

-- | Iterate over a 'PointSchedule', sending each tick to the associated peer in turn,
-- giving each peer a chunk of computation time, sequentially, until it satisfies the
-- conditions given by the tick.
-- This usually means for the ChainSync server to have sent the target header to the
-- client.
runScheduler ::
  IOLike m =>
  Tracer m (TraceSchedulerEvent blk) ->
  StrictTVar m (Map PeerId (ChainSyncClientHandle m blk)) ->
  PointSchedule blk ->
  Map PeerId (PeerResources m blk) ->
  NodeLifecycle blk m ->
  m (ChainDB m blk, StateViewTracers blk m)
runScheduler :: forall (m :: * -> *) blk.
IOLike m =>
Tracer m (TraceSchedulerEvent blk)
-> StrictTVar m (Map PeerId (ChainSyncClientHandle m blk))
-> PointSchedule blk
-> Map PeerId (PeerResources m blk)
-> NodeLifecycle blk m
-> m (ChainDB m blk, StateViewTracers blk m)
runScheduler Tracer m (TraceSchedulerEvent blk)
tracer StrictTVar m (Map PeerId (ChainSyncClientHandle m blk))
varHandles ps :: PointSchedule blk
ps@PointSchedule{Time
psMinEndTime :: Time
$sel:psMinEndTime:PointSchedule :: forall blk. PointSchedule blk -> Time
psMinEndTime} Map PeerId (PeerResources m blk)
peers lifecycle :: NodeLifecycle blk m
lifecycle@NodeLifecycle {LiveIntervalResult blk -> m (LiveNode blk m)
nlStart :: forall blk (m :: * -> *).
NodeLifecycle blk m -> LiveIntervalResult blk -> m (LiveNode blk m)
nlStart :: LiveIntervalResult blk -> m (LiveNode blk m)
nlStart} = do
  LiveNode blk m
node0 <- LiveIntervalResult blk -> m (LiveNode blk m)
nlStart LiveIntervalResult {lirActive :: Set PeerId
lirActive = Map PeerId (PeerResources m blk) -> Set PeerId
forall k a. Map k a -> Set k
Map.keysSet Map PeerId (PeerResources m blk)
peers, lirPeerResults :: [PeerSimulatorResult blk]
lirPeerResults = []}
  Tracer m (TraceSchedulerEvent blk)
-> TraceSchedulerEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceSchedulerEvent blk)
tracer TraceSchedulerEvent blk
forall blk. TraceSchedulerEvent blk
TraceBeginningOfTime
  LiveNode blk m
nodeEnd <- (LiveNode blk m
 -> (Int, (DiffTime, Peer (NodeState blk))) -> m (LiveNode blk m))
-> LiveNode blk m
-> [(Int, (DiffTime, Peer (NodeState blk)))]
-> m (LiveNode blk m)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM LiveNode blk m
-> (Int, (DiffTime, Peer (NodeState blk))) -> m (LiveNode blk m)
tick LiveNode blk m
node0 ([Int]
-> [(DiffTime, Peer (NodeState blk))]
-> [(Int, (DiffTime, Peer (NodeState blk)))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] (PointSchedule blk -> [(DiffTime, Peer (NodeState blk))]
forall blk. PointSchedule blk -> [(DiffTime, Peer (NodeState blk))]
peersStatesRelative PointSchedule blk
ps))
  let extraDelay :: Maybe DiffTime
extraDelay = case Int
-> [(Time, Peer (NodeState blk))] -> [(Time, Peer (NodeState blk))]
forall a. Int -> [a] -> [a]
take Int
1 ([(Time, Peer (NodeState blk))] -> [(Time, Peer (NodeState blk))])
-> [(Time, Peer (NodeState blk))] -> [(Time, Peer (NodeState blk))]
forall a b. (a -> b) -> a -> b
$ [(Time, Peer (NodeState blk))] -> [(Time, Peer (NodeState blk))]
forall a. [a] -> [a]
reverse ([(Time, Peer (NodeState blk))] -> [(Time, Peer (NodeState blk))])
-> [(Time, Peer (NodeState blk))] -> [(Time, Peer (NodeState blk))]
forall a b. (a -> b) -> a -> b
$ PointSchedule blk -> [(Time, Peer (NodeState blk))]
forall blk. PointSchedule blk -> [(Time, Peer (NodeState blk))]
peersStates PointSchedule blk
ps of
        [(Time
t, Peer (NodeState blk)
_)] -> if Time
t Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
< Time
psMinEndTime
            then DiffTime -> Maybe DiffTime
forall a. a -> Maybe a
Just (DiffTime -> Maybe DiffTime) -> DiffTime -> Maybe DiffTime
forall a b. (a -> b) -> a -> b
$ Time -> Time -> DiffTime
diffTime Time
psMinEndTime Time
t
            else Maybe DiffTime
forall a. Maybe a
Nothing
        [(Time, Peer (NodeState blk))]
_        -> DiffTime -> Maybe DiffTime
forall a. a -> Maybe a
Just (DiffTime -> Maybe DiffTime) -> DiffTime -> Maybe DiffTime
forall a b. (a -> b) -> a -> b
$ Time -> DiffTime
forall a b. Coercible a b => a -> b
coerce Time
psMinEndTime
  LiveNode{ChainDB m blk
lnChainDb :: forall blk (m :: * -> *). LiveNode blk m -> ChainDB m blk
lnChainDb :: ChainDB m blk
lnChainDb, StateViewTracers blk m
lnStateViewTracers :: StateViewTracers blk m
lnStateViewTracers :: forall blk (m :: * -> *). LiveNode blk m -> StateViewTracers blk m
lnStateViewTracers} <-
    m (LiveNode blk m)
-> (DiffTime -> m (LiveNode blk m))
-> Maybe DiffTime
-> m (LiveNode blk m)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (LiveNode blk m -> m (LiveNode blk m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LiveNode blk m
nodeEnd) (NodeLifecycle blk m
-> LiveNode blk m -> DiffTime -> m (LiveNode blk m)
forall (m :: * -> *) blk.
MonadDelay m =>
NodeLifecycle blk m
-> LiveNode blk m -> DiffTime -> m (LiveNode blk m)
smartDelay NodeLifecycle blk m
lifecycle LiveNode blk m
nodeEnd) Maybe DiffTime
extraDelay
  Tracer m (TraceSchedulerEvent blk)
-> TraceSchedulerEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceSchedulerEvent blk)
tracer TraceSchedulerEvent blk
forall blk. TraceSchedulerEvent blk
TraceEndOfTime
  (ChainDB m blk, StateViewTracers blk m)
-> m (ChainDB m blk, StateViewTracers blk m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainDB m blk
lnChainDb, StateViewTracers blk m
lnStateViewTracers)
  where
    tick :: LiveNode blk m
-> (Int, (DiffTime, Peer (NodeState blk))) -> m (LiveNode blk m)
tick = Tracer m (TraceSchedulerEvent blk)
-> StrictTVar m (Map PeerId (ChainSyncClientHandle m blk))
-> Map PeerId (PeerResources m blk)
-> NodeLifecycle blk m
-> LiveNode blk m
-> (Int, (DiffTime, Peer (NodeState blk)))
-> m (LiveNode blk m)
forall (m :: * -> *) blk.
IOLike m =>
Tracer m (TraceSchedulerEvent blk)
-> StrictTVar m (Map PeerId (ChainSyncClientHandle m blk))
-> Map PeerId (PeerResources m blk)
-> NodeLifecycle blk m
-> LiveNode blk m
-> (Int, (DiffTime, Peer (NodeState blk)))
-> m (LiveNode blk m)
dispatchTick Tracer m (TraceSchedulerEvent blk)
tracer StrictTVar m (Map PeerId (ChainSyncClientHandle m blk))
varHandles Map PeerId (PeerResources m blk)
peers NodeLifecycle blk m
lifecycle

-- | Create the shared resource for the LoE if the feature is enabled in the config.
-- This is used by the ChainDB and the GDD governor.
mkLoEVar ::
  IOLike m =>
  SchedulerConfig ->
  m (LoE (StrictTVar m (AnchoredFragment (Header TestBlock))))
mkLoEVar :: forall (m :: * -> *).
IOLike m =>
SchedulerConfig
-> m (LoE (StrictTVar m (AnchoredFragment (Header TestBlock))))
mkLoEVar SchedulerConfig {Bool
scEnableLoE :: SchedulerConfig -> Bool
scEnableLoE :: Bool
scEnableLoE}
  | Bool
scEnableLoE
  = StrictTVar m (AnchoredFragment (Header TestBlock))
-> LoE (StrictTVar m (AnchoredFragment (Header TestBlock)))
forall a. a -> LoE a
LoEEnabled (StrictTVar m (AnchoredFragment (Header TestBlock))
 -> LoE (StrictTVar m (AnchoredFragment (Header TestBlock))))
-> m (StrictTVar m (AnchoredFragment (Header TestBlock)))
-> m (LoE (StrictTVar m (AnchoredFragment (Header TestBlock))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnchoredFragment (Header TestBlock)
-> m (StrictTVar m (AnchoredFragment (Header TestBlock)))
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO (Anchor (Header TestBlock) -> AnchoredFragment (Header TestBlock)
forall v a b. Anchorable v a b => a -> AnchoredSeq v a b
AF.Empty Anchor (Header TestBlock)
forall block. Anchor block
AF.AnchorGenesis)
  | Bool
otherwise
  = LoE (StrictTVar m (AnchoredFragment (Header TestBlock)))
-> m (LoE (StrictTVar m (AnchoredFragment (Header TestBlock))))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoE (StrictTVar m (AnchoredFragment (Header TestBlock)))
forall a. LoE a
LoEDisabled

mkStateTracer ::
  IOLike m =>
  SchedulerConfig ->
  GenesisTest TestBlock s ->
  PeerSimulatorResources m TestBlock ->
  ChainDB m TestBlock ->
  m (Tracer m ())
mkStateTracer :: forall (m :: * -> *) s.
IOLike m =>
SchedulerConfig
-> GenesisTest TestBlock s
-> PeerSimulatorResources m TestBlock
-> ChainDB m TestBlock
-> m (Tracer m ())
mkStateTracer SchedulerConfig
schedulerConfig GenesisTest {BlockTree TestBlock
gtBlockTree :: BlockTree TestBlock
$sel:gtBlockTree:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree} PeerSimulatorResources {StrictTVar m (Map PeerId (ChainSyncClientHandle m TestBlock))
psrHandles :: StrictTVar m (Map PeerId (ChainSyncClientHandle m TestBlock))
psrHandles :: forall (m :: * -> *) blk.
PeerSimulatorResources m blk
-> StrictTVar m (Map PeerId (ChainSyncClientHandle m TestBlock))
psrHandles, Map PeerId (PeerResources m TestBlock)
psrPeers :: Map PeerId (PeerResources m TestBlock)
psrPeers :: forall (m :: * -> *) blk.
PeerSimulatorResources m blk -> Map PeerId (PeerResources m blk)
psrPeers} ChainDB m TestBlock
chainDb
  | SchedulerConfig -> Bool
scTraceState SchedulerConfig
schedulerConfig
  , let getCandidates :: STM m (Map PeerId (AnchoredFragment (Header TestBlock)))
getCandidates = StrictTVar m (Map PeerId (ChainSyncClientHandle m TestBlock))
-> (ChainSyncState TestBlock
    -> AnchoredFragment (Header TestBlock))
-> STM m (Map PeerId (AnchoredFragment (Header TestBlock)))
forall (m :: * -> *) peer blk a.
IOLike m =>
StrictTVar m (Map peer (ChainSyncClientHandle m blk))
-> (ChainSyncState blk -> a) -> STM m (Map peer a)
viewChainSyncState StrictTVar m (Map PeerId (ChainSyncClientHandle m TestBlock))
psrHandles ChainSyncState TestBlock -> AnchoredFragment (Header TestBlock)
forall blk. ChainSyncState blk -> AnchoredFragment (Header blk)
CSClient.csCandidate
        getCurrentChain :: STM m (AnchoredFragment (Header TestBlock))
getCurrentChain = ChainDB m TestBlock -> STM m (AnchoredFragment (Header TestBlock))
forall (m :: * -> *) blk.
ChainDB m blk -> STM m (AnchoredFragment (Header blk))
ChainDB.getCurrentChain ChainDB m TestBlock
chainDb
        getPoints :: STM m (Map PeerId (Maybe (NodeState TestBlock)))
getPoints = (StrictTVar m (Maybe (NodeState TestBlock))
 -> STM m (Maybe (NodeState TestBlock)))
-> Map PeerId (StrictTVar m (Maybe (NodeState TestBlock)))
-> STM m (Map PeerId (Maybe (NodeState TestBlock)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Map PeerId a -> f (Map PeerId b)
traverse StrictTVar m (Maybe (NodeState TestBlock))
-> STM m (Maybe (NodeState TestBlock))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (SharedResources m TestBlock
-> StrictTVar m (Maybe (NodeState TestBlock))
forall (m :: * -> *) blk.
SharedResources m blk -> StrictTVar m (Maybe (NodeState blk))
srCurrentState (SharedResources m TestBlock
 -> StrictTVar m (Maybe (NodeState TestBlock)))
-> (PeerResources m TestBlock -> SharedResources m TestBlock)
-> PeerResources m TestBlock
-> StrictTVar m (Maybe (NodeState TestBlock))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerResources m TestBlock -> SharedResources m TestBlock
forall (m :: * -> *) blk.
PeerResources m blk -> SharedResources m blk
prShared (PeerResources m TestBlock
 -> StrictTVar m (Maybe (NodeState TestBlock)))
-> Map PeerId (PeerResources m TestBlock)
-> Map PeerId (StrictTVar m (Maybe (NodeState TestBlock)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map PeerId (PeerResources m TestBlock)
psrPeers)
  = BlockTree TestBlock
-> STM m (AnchoredFragment (Header TestBlock))
-> STM m (Map PeerId (AnchoredFragment (Header TestBlock)))
-> STM m (Map PeerId (Maybe (NodeState TestBlock)))
-> m (Tracer m ())
forall (m :: * -> *).
IOLike m =>
BlockTree TestBlock
-> STM m (AnchoredFragment (Header TestBlock))
-> STM m (Map PeerId (AnchoredFragment (Header TestBlock)))
-> STM m (Map PeerId (Maybe (NodeState TestBlock)))
-> m (Tracer m ())
peerSimStateDiagramSTMTracerDebug BlockTree TestBlock
gtBlockTree STM m (AnchoredFragment (Header TestBlock))
getCurrentChain STM m (Map PeerId (AnchoredFragment (Header TestBlock)))
getCandidates STM m (Map PeerId (Maybe (NodeState TestBlock)))
getPoints
  | Bool
otherwise
  = Tracer m () -> m (Tracer m ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tracer m ()
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer

-- | Start all threads for ChainSync, BlockFetch and GDD, using the resources
-- for a single live interval.
-- Only start peers that haven't been disconnected in a previous interval,
-- provided by 'LiveIntervalResult'.
startNode ::
  forall m.
  (IOLike m, MonadTime m, MonadTimer m) =>
  SchedulerConfig ->
  GenesisTestFull TestBlock ->
  LiveInterval TestBlock m ->
  m ()
startNode :: forall (m :: * -> *).
(IOLike m, MonadTime m, MonadTimer m) =>
SchedulerConfig
-> GenesisTestFull TestBlock -> LiveInterval TestBlock m -> m ()
startNode SchedulerConfig
schedulerConfig GenesisTestFull TestBlock
genesisTest LiveInterval TestBlock m
interval = do
  let
      handles :: StrictTVar m (Map PeerId (ChainSyncClientHandle m TestBlock))
handles = PeerSimulatorResources m TestBlock
-> StrictTVar m (Map PeerId (ChainSyncClientHandle m TestBlock))
forall (m :: * -> *) blk.
PeerSimulatorResources m blk
-> StrictTVar m (Map PeerId (ChainSyncClientHandle m TestBlock))
psrHandles PeerSimulatorResources m TestBlock
lrPeerSim
      getCandidates :: STM m (Map PeerId (AnchoredFragment (Header TestBlock)))
getCandidates = StrictTVar m (Map PeerId (ChainSyncClientHandle m TestBlock))
-> (ChainSyncState TestBlock
    -> AnchoredFragment (Header TestBlock))
-> STM m (Map PeerId (AnchoredFragment (Header TestBlock)))
forall (m :: * -> *) peer blk a.
IOLike m =>
StrictTVar m (Map peer (ChainSyncClientHandle m blk))
-> (ChainSyncState blk -> a) -> STM m (Map peer a)
viewChainSyncState StrictTVar m (Map PeerId (ChainSyncClientHandle m TestBlock))
handles ChainSyncState TestBlock -> AnchoredFragment (Header TestBlock)
forall blk. ChainSyncState blk -> AnchoredFragment (Header blk)
CSClient.csCandidate
  FetchClientRegistry PeerId (Header TestBlock) TestBlock m
fetchClientRegistry <- m (FetchClientRegistry PeerId (Header TestBlock) TestBlock m)
forall (m :: * -> *) peer header block.
MonadSTM m =>
m (FetchClientRegistry peer header block m)
newFetchClientRegistry
  let chainDbView :: ChainDbView m TestBlock
chainDbView = ChainDB m TestBlock -> ChainDbView m TestBlock
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk) =>
ChainDB m blk -> ChainDbView m blk
CSClient.defaultChainDbView ChainDB m TestBlock
lnChainDb
      activePeers :: Map PeerId (PeerResources m TestBlock)
activePeers = Map PeerId (PeerResources m TestBlock)
-> Set PeerId -> Map PeerId (PeerResources m TestBlock)
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys (PeerSimulatorResources m TestBlock
-> Map PeerId (PeerResources m TestBlock)
forall (m :: * -> *) blk.
PeerSimulatorResources m blk -> Map PeerId (PeerResources m blk)
psrPeers PeerSimulatorResources m TestBlock
lrPeerSim) (LiveIntervalResult TestBlock -> Set PeerId
forall blk. LiveIntervalResult blk -> Set PeerId
lirActive LiveIntervalResult TestBlock
liveResult)
  Map PeerId (PeerResources m TestBlock)
-> (PeerResources m TestBlock -> m (Thread m ())) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Map PeerId (PeerResources m TestBlock)
activePeers ((PeerResources m TestBlock -> m (Thread m ())) -> m ())
-> (PeerResources m TestBlock -> m (Thread m ())) -> m ()
forall a b. (a -> b) -> a -> b
$ \PeerResources {SharedResources m TestBlock
prShared :: forall (m :: * -> *) blk.
PeerResources m blk -> SharedResources m blk
prShared :: SharedResources m TestBlock
prShared, ChainSyncResources m TestBlock
prChainSync :: ChainSyncResources m TestBlock
prChainSync :: forall (m :: * -> *) blk.
PeerResources m blk -> ChainSyncResources m blk
prChainSync, BlockFetchResources m TestBlock
prBlockFetch :: BlockFetchResources m TestBlock
prBlockFetch :: forall (m :: * -> *) blk.
PeerResources m blk -> BlockFetchResources m blk
prBlockFetch} -> do
    let pid :: PeerId
pid = SharedResources m TestBlock -> PeerId
forall (m :: * -> *) blk. SharedResources m blk -> PeerId
srPeerId SharedResources m TestBlock
prShared
    ResourceRegistry m -> String -> m () -> m (Thread m ())
forall (m :: * -> *) a.
(MonadAsync m, MonadFork m, MonadMask m, HasCallStack) =>
ResourceRegistry m -> String -> m a -> m (Thread m a)
forkLinkedThread ResourceRegistry m
lrRegistry (String
"Peer overview " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PeerId -> String
forall a. Show a => a -> String
show PeerId
pid) (m () -> m (Thread m ())) -> m () -> m (Thread m ())
forall a b. (a -> b) -> a -> b
$
      -- The peerRegistry helps ensuring that if any thread fails, then
      -- the registry is closed and all threads related to the peer are
      -- killed.
      (ResourceRegistry m -> m ()) -> m ()
forall (m :: * -> *) a.
(MonadSTM m, MonadMask m, MonadThread m, HasCallStack) =>
(ResourceRegistry m -> m a) -> m a
withRegistry ((ResourceRegistry m -> m ()) -> m ())
-> (ResourceRegistry m -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \ResourceRegistry m
peerRegistry -> do
        (Thread m ()
csClient, Thread m ()
csServer) <-
          ResourceRegistry m
-> Tracer m (TraceEvent TestBlock)
-> TopLevelConfig TestBlock
-> ChainDbView m TestBlock
-> FetchClientRegistry PeerId (Header TestBlock) TestBlock m
-> SharedResources m TestBlock
-> ChainSyncResources m TestBlock
-> ChainSyncTimeout
-> ChainSyncLoPBucketConfig
-> CSJConfig
-> StateViewTracers TestBlock m
-> StrictTVar m (Map PeerId (ChainSyncClientHandle m TestBlock))
-> m (Thread m (), Thread m ())
forall (m :: * -> *) blk.
(IOLike m, MonadTimer m, LedgerSupportsProtocol blk, ShowProxy blk,
 ShowProxy (Header blk)) =>
ResourceRegistry m
-> Tracer m (TraceEvent blk)
-> TopLevelConfig blk
-> ChainDbView m blk
-> FetchClientRegistry PeerId (Header blk) blk m
-> SharedResources m blk
-> ChainSyncResources m blk
-> ChainSyncTimeout
-> ChainSyncLoPBucketConfig
-> CSJConfig
-> StateViewTracers blk m
-> StrictTVar m (Map PeerId (ChainSyncClientHandle m blk))
-> m (Thread m (), Thread m ())
startChainSyncConnectionThread
          ResourceRegistry m
peerRegistry
          Tracer m (TraceEvent TestBlock)
tracer
          TopLevelConfig TestBlock
lrConfig
          ChainDbView m TestBlock
chainDbView
          FetchClientRegistry PeerId (Header TestBlock) TestBlock m
fetchClientRegistry
          SharedResources m TestBlock
prShared
          ChainSyncResources m TestBlock
prChainSync
          ChainSyncTimeout
chainSyncTimeouts_
          ChainSyncLoPBucketConfig
chainSyncLoPBucketConfig
          CSJConfig
csjConfig
          StateViewTracers TestBlock m
lnStateViewTracers
          StrictTVar m (Map PeerId (ChainSyncClientHandle m TestBlock))
handles
        ResourceRegistry m
-> FetchClientRegistry PeerId (Header TestBlock) TestBlock m
-> PeerId
-> m ()
forall (m :: * -> *) peer blk.
(Ord peer, IOLike m) =>
ResourceRegistry m
-> FetchClientRegistry peer (Header blk) blk m -> peer -> m ()
BlockFetch.startKeepAliveThread ResourceRegistry m
peerRegistry FetchClientRegistry PeerId (Header TestBlock) TestBlock m
fetchClientRegistry PeerId
pid
        (Thread m ()
bfClient, Thread m ()
bfServer) <-
          ResourceRegistry m
-> Tracer m (TraceEvent TestBlock)
-> StateViewTracers TestBlock m
-> FetchClientRegistry PeerId (Header TestBlock) TestBlock m
-> ControlMessageSTM m
-> SharedResources m TestBlock
-> BlockFetchResources m TestBlock
-> BlockFetchTimeout
-> m (Thread m (), Thread m ())
forall (m :: * -> *) blk.
(IOLike m, MonadTime m, MonadTimer m, HasHeader blk,
 HasHeader (Header blk), ShowProxy blk) =>
ResourceRegistry m
-> Tracer m (TraceEvent blk)
-> StateViewTracers blk m
-> FetchClientRegistry PeerId (Header blk) blk m
-> ControlMessageSTM m
-> SharedResources m blk
-> BlockFetchResources m blk
-> BlockFetchTimeout
-> m (Thread m (), Thread m ())
startBlockFetchConnectionThread
          ResourceRegistry m
peerRegistry
          Tracer m (TraceEvent TestBlock)
tracer
          StateViewTracers TestBlock m
lnStateViewTracers
          FetchClientRegistry PeerId (Header TestBlock) TestBlock m
fetchClientRegistry
          (ControlMessage -> ControlMessageSTM m
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ControlMessage
Continue)
          SharedResources m TestBlock
prShared
          BlockFetchResources m TestBlock
prBlockFetch
          BlockFetchTimeout
blockFetchTimeouts_
        [Thread m ()] -> m ()
forall (m :: * -> *) a. MonadAsync m => [Thread m a] -> m a
waitAnyThread [Thread m ()
csClient, Thread m ()
csServer, Thread m ()
bfClient, Thread m ()
bfServer]
  -- The block fetch logic needs to be started after the block fetch clients
  -- otherwise, an internal assertion fails because getCandidates yields more
  -- peer fragments than registered clients.
  ResourceRegistry m
-> Tracer m (TraceEvent TestBlock)
-> ChainDB m TestBlock
-> FetchClientRegistry PeerId (Header TestBlock) TestBlock m
-> STM m (Map PeerId (AnchoredFragment (Header TestBlock)))
-> m ()
forall (m :: * -> *).
IOLike m =>
ResourceRegistry m
-> Tracer m (TraceEvent TestBlock)
-> ChainDB m TestBlock
-> FetchClientRegistry PeerId (Header TestBlock) TestBlock m
-> STM m (Map PeerId (AnchoredFragment (Header TestBlock)))
-> m ()
BlockFetch.startBlockFetchLogic ResourceRegistry m
lrRegistry Tracer m (TraceEvent TestBlock)
lrTracer ChainDB m TestBlock
lnChainDb FetchClientRegistry PeerId (Header TestBlock) TestBlock m
fetchClientRegistry STM m (Map PeerId (AnchoredFragment (Header TestBlock)))
getCandidates

  LoE (StrictTVar m (AnchoredFragment (Header TestBlock)))
-> (StrictTVar m (AnchoredFragment (Header TestBlock))
    -> m (Thread m Void))
-> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ LoE (StrictTVar m (AnchoredFragment (Header TestBlock)))
lrLoEVar ((StrictTVar m (AnchoredFragment (Header TestBlock))
  -> m (Thread m Void))
 -> m ())
-> (StrictTVar m (AnchoredFragment (Header TestBlock))
    -> m (Thread m Void))
-> m ()
forall a b. (a -> b) -> a -> b
$ \ StrictTVar m (AnchoredFragment (Header TestBlock))
var -> do
      ResourceRegistry m
-> String
-> Watcher
     m
     (GsmState, GDDStateView m TestBlock PeerId)
     (Map PeerId (StrictMaybe (WithOrigin SlotNo), Bool))
-> m (Thread m Void)
forall (m :: * -> *) a fp.
(IOLike m, Eq fp, HasCallStack) =>
ResourceRegistry m -> String -> Watcher m a fp -> m (Thread m Void)
forkLinkedWatcher ResourceRegistry m
lrRegistry String
"LoE updater background" (Watcher
   m
   (GsmState, GDDStateView m TestBlock PeerId)
   (Map PeerId (StrictMaybe (WithOrigin SlotNo), Bool))
 -> m (Thread m Void))
-> Watcher
     m
     (GsmState, GDDStateView m TestBlock PeerId)
     (Map PeerId (StrictMaybe (WithOrigin SlotNo), Bool))
-> m (Thread m Void)
forall a b. (a -> b) -> a -> b
$
        TopLevelConfig TestBlock
-> Tracer m (TraceGDDEvent PeerId TestBlock)
-> ChainDB m TestBlock
-> STM m GsmState
-> STM m (Map PeerId (ChainSyncClientHandle m TestBlock))
-> StrictTVar m (AnchoredFragment (Header TestBlock))
-> Watcher
     m
     (GsmState, GDDStateView m TestBlock PeerId)
     (Map PeerId (StrictMaybe (WithOrigin SlotNo), Bool))
forall (m :: * -> *) blk peer.
(IOLike m, Ord peer, LedgerSupportsProtocol blk,
 HasHardForkHistory blk) =>
TopLevelConfig blk
-> Tracer m (TraceGDDEvent peer blk)
-> ChainDB m blk
-> STM m GsmState
-> STM m (Map peer (ChainSyncClientHandle m blk))
-> StrictTVar m (AnchoredFragment (Header blk))
-> Watcher
     m
     (GsmState, GDDStateView m blk peer)
     (Map peer (StrictMaybe (WithOrigin SlotNo), Bool))
gddWatcher
          TopLevelConfig TestBlock
lrConfig
          (Tracer m (TraceEvent TestBlock)
-> Tracer m (TraceGDDEvent PeerId TestBlock)
forall (m :: * -> *).
Tracer m (TraceEvent TestBlock)
-> Tracer m (TraceGDDEvent PeerId TestBlock)
mkGDDTracerTestBlock Tracer m (TraceEvent TestBlock)
lrTracer)
          ChainDB m TestBlock
lnChainDb
          (GsmState -> STM m GsmState
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GsmState
GSM.Syncing) -- TODO actually run GSM
          (StrictTVar m (Map PeerId (ChainSyncClientHandle m TestBlock))
-> STM m (Map PeerId (ChainSyncClientHandle m TestBlock))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Map PeerId (ChainSyncClientHandle m TestBlock))
handles)
          StrictTVar m (AnchoredFragment (Header TestBlock))
var

  m (Thread m Void) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Thread m Void) -> m ()) -> m (Thread m Void) -> m ()
forall a b. (a -> b) -> a -> b
$ ResourceRegistry m
-> String
-> Watcher m (View PeerId TestBlock) (View PeerId TestBlock)
-> m (Thread m Void)
forall (m :: * -> *) a fp.
(IOLike m, Eq fp, HasCallStack) =>
ResourceRegistry m -> String -> Watcher m a fp -> m (Thread m Void)
forkLinkedWatcher ResourceRegistry m
lrRegistry String
"CSJ invariants watcher" (Watcher m (View PeerId TestBlock) (View PeerId TestBlock)
 -> m (Thread m Void))
-> Watcher m (View PeerId TestBlock) (View PeerId TestBlock)
-> m (Thread m Void)
forall a b. (a -> b) -> a -> b
$ StrictTVar m (Map PeerId (ChainSyncClientHandle m TestBlock))
-> Watcher m (View PeerId TestBlock) (View PeerId TestBlock)
forall (m :: * -> *) peer blk.
(MonadSTM m, MonadThrow m, Eq peer, Show peer, Typeable peer,
 Typeable blk, StandardHash blk) =>
StrictTVar m (Map peer (ChainSyncClientHandle m blk))
-> Watcher m (View peer blk) (View peer blk)
CSJInvariants.watcher StrictTVar m (Map PeerId (ChainSyncClientHandle m TestBlock))
handles
  where
    LiveResources {ResourceRegistry m
lrRegistry :: ResourceRegistry m
lrRegistry :: forall blk (m :: * -> *). LiveResources blk m -> ResourceRegistry m
lrRegistry, Tracer m (TraceEvent TestBlock)
lrTracer :: Tracer m (TraceEvent TestBlock)
lrTracer :: forall blk (m :: * -> *).
LiveResources blk m -> Tracer m (TraceEvent blk)
lrTracer, TopLevelConfig TestBlock
lrConfig :: TopLevelConfig TestBlock
lrConfig :: forall blk (m :: * -> *). LiveResources blk m -> TopLevelConfig blk
lrConfig, PeerSimulatorResources m TestBlock
lrPeerSim :: PeerSimulatorResources m TestBlock
lrPeerSim :: forall blk (m :: * -> *).
LiveResources blk m -> PeerSimulatorResources m blk
lrPeerSim, LoE (StrictTVar m (AnchoredFragment (Header TestBlock)))
lrLoEVar :: LoE (StrictTVar m (AnchoredFragment (Header TestBlock)))
lrLoEVar :: forall blk (m :: * -> *).
LiveResources blk m
-> LoE (StrictTVar m (AnchoredFragment (Header blk)))
lrLoEVar} = LiveResources TestBlock m
resources

    LiveInterval {
        liResources :: forall blk (m :: * -> *). LiveInterval blk m -> LiveResources blk m
liResources = LiveResources TestBlock m
resources
      , liResult :: forall blk (m :: * -> *).
LiveInterval blk m -> LiveIntervalResult blk
liResult = LiveIntervalResult TestBlock
liveResult
      , liNode :: forall blk (m :: * -> *). LiveInterval blk m -> LiveNode blk m
liNode = LiveNode {ChainDB m TestBlock
lnChainDb :: forall blk (m :: * -> *). LiveNode blk m -> ChainDB m blk
lnChainDb :: ChainDB m TestBlock
lnChainDb, StateViewTracers TestBlock m
lnStateViewTracers :: forall blk (m :: * -> *). LiveNode blk m -> StateViewTracers blk m
lnStateViewTracers :: StateViewTracers TestBlock m
lnStateViewTracers}
      } = LiveInterval TestBlock m
interval

    GenesisTest
      { ChainSyncTimeout
gtChainSyncTimeouts :: ChainSyncTimeout
$sel:gtChainSyncTimeouts:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> ChainSyncTimeout
gtChainSyncTimeouts
      , BlockFetchTimeout
gtBlockFetchTimeouts :: BlockFetchTimeout
$sel:gtBlockFetchTimeouts:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> BlockFetchTimeout
gtBlockFetchTimeouts
      , $sel:gtLoPBucketParams:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> LoPBucketParams
gtLoPBucketParams = LoPBucketParams { Integer
lbpCapacity :: Integer
$sel:lbpCapacity:LoPBucketParams :: LoPBucketParams -> Integer
lbpCapacity, Rational
lbpRate :: Rational
$sel:lbpRate:LoPBucketParams :: LoPBucketParams -> Rational
lbpRate }
      , $sel:gtCSJParams:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> CSJParams
gtCSJParams = CSJParams { SlotNo
csjpJumpSize :: SlotNo
$sel:csjpJumpSize:CSJParams :: CSJParams -> SlotNo
csjpJumpSize }
      } = GenesisTestFull TestBlock
genesisTest

    StateViewTracers{Tracer m (TraceEvent TestBlock)
svtTraceTracer :: Tracer m (TraceEvent TestBlock)
svtTraceTracer :: forall blk (m :: * -> *).
StateViewTracers blk m -> Tracer m (TraceEvent blk)
svtTraceTracer} = StateViewTracers TestBlock m
lnStateViewTracers

    -- FIXME: This type of configuration should move to `Trace.mkTracer`.
    tracer :: Tracer m (TraceEvent TestBlock)
tracer = if SchedulerConfig -> Bool
scTrace SchedulerConfig
schedulerConfig
      then (TraceEvent TestBlock -> m ()) -> Tracer m (TraceEvent TestBlock)
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer (\TraceEvent TestBlock
evt -> Tracer m (TraceEvent TestBlock) -> TraceEvent TestBlock -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceEvent TestBlock)
lrTracer TraceEvent TestBlock
evt m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Tracer m (TraceEvent TestBlock) -> TraceEvent TestBlock -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceEvent TestBlock)
svtTraceTracer TraceEvent TestBlock
evt)
      else Tracer m (TraceEvent TestBlock)
svtTraceTracer

    chainSyncTimeouts_ :: ChainSyncTimeout
chainSyncTimeouts_ =
      if SchedulerConfig -> Bool
scEnableChainSyncTimeouts SchedulerConfig
schedulerConfig
        then ChainSyncTimeout
gtChainSyncTimeouts
        else ChainSyncTimeout
ChainSync.chainSyncNoTimeouts

    chainSyncLoPBucketConfig :: ChainSyncLoPBucketConfig
chainSyncLoPBucketConfig =
      if SchedulerConfig -> Bool
scEnableLoP SchedulerConfig
schedulerConfig
        then ChainSyncLoPBucketEnabledConfig -> ChainSyncLoPBucketConfig
ChainSyncLoPBucketEnabled ChainSyncLoPBucketEnabledConfig { $sel:csbcCapacity:ChainSyncLoPBucketEnabledConfig :: Integer
csbcCapacity = Integer
lbpCapacity, $sel:csbcRate:ChainSyncLoPBucketEnabledConfig :: Rational
csbcRate = Rational
lbpRate }
        else ChainSyncLoPBucketConfig
ChainSyncLoPBucketDisabled

    csjConfig :: CSJConfig
csjConfig =
      if SchedulerConfig -> Bool
scEnableCSJ SchedulerConfig
schedulerConfig
        then CSJEnabledConfig -> CSJConfig
CSJEnabled CSJEnabledConfig { $sel:csjcJumpSize:CSJEnabledConfig :: SlotNo
csjcJumpSize = SlotNo
csjpJumpSize }
        else CSJConfig
CSJDisabled

    blockFetchTimeouts_ :: BlockFetchTimeout
blockFetchTimeouts_ =
      if SchedulerConfig -> Bool
scEnableBlockFetchTimeouts SchedulerConfig
schedulerConfig
        then BlockFetchTimeout
gtBlockFetchTimeouts
        else BlockFetchTimeout
BlockFetch.blockFetchNoTimeouts

-- | Set up all resources related to node start/shutdown.
nodeLifecycle ::
  (IOLike m, MonadTime m, MonadTimer m) =>
  SchedulerConfig ->
  GenesisTestFull TestBlock ->
  Tracer m (TraceEvent TestBlock) ->
  ResourceRegistry m ->
  PeerSimulatorResources m TestBlock ->
  m (NodeLifecycle TestBlock m)
nodeLifecycle :: forall (m :: * -> *).
(IOLike m, MonadTime m, MonadTimer m) =>
SchedulerConfig
-> GenesisTestFull TestBlock
-> Tracer m (TraceEvent TestBlock)
-> ResourceRegistry m
-> PeerSimulatorResources m TestBlock
-> m (NodeLifecycle TestBlock m)
nodeLifecycle SchedulerConfig
schedulerConfig GenesisTestFull TestBlock
genesisTest Tracer m (TraceEvent TestBlock)
lrTracer ResourceRegistry m
lrRegistry PeerSimulatorResources m TestBlock
lrPeerSim = do
  NodeDBs (StrictTMVar m MockFS)
lrCdb <- m (NodeDBs (StrictTMVar m MockFS))
forall (m :: * -> *).
MonadSTM m =>
m (NodeDBs (StrictTMVar m MockFS))
emptyNodeDBs
  LoE (StrictTVar m (AnchoredFragment (Header TestBlock)))
lrLoEVar <- SchedulerConfig
-> m (LoE (StrictTVar m (AnchoredFragment (Header TestBlock))))
forall (m :: * -> *).
IOLike m =>
SchedulerConfig
-> m (LoE (StrictTVar m (AnchoredFragment (Header TestBlock))))
mkLoEVar SchedulerConfig
schedulerConfig
  let
    resources :: LiveResources TestBlock m
resources =
      LiveResources {
          ResourceRegistry m
lrRegistry :: ResourceRegistry m
lrRegistry :: ResourceRegistry m
lrRegistry
        , Tracer m (TraceEvent TestBlock)
lrTracer :: Tracer m (TraceEvent TestBlock)
lrTracer :: Tracer m (TraceEvent TestBlock)
lrTracer
        , lrSTracer :: ChainDB m TestBlock -> m (Tracer m ())
lrSTracer = SchedulerConfig
-> GenesisTestFull TestBlock
-> PeerSimulatorResources m TestBlock
-> ChainDB m TestBlock
-> m (Tracer m ())
forall (m :: * -> *) s.
IOLike m =>
SchedulerConfig
-> GenesisTest TestBlock s
-> PeerSimulatorResources m TestBlock
-> ChainDB m TestBlock
-> m (Tracer m ())
mkStateTracer SchedulerConfig
schedulerConfig GenesisTestFull TestBlock
genesisTest PeerSimulatorResources m TestBlock
lrPeerSim
        , TopLevelConfig TestBlock
lrConfig :: TopLevelConfig TestBlock
lrConfig :: TopLevelConfig TestBlock
lrConfig
        , PeerSimulatorResources m TestBlock
lrPeerSim :: PeerSimulatorResources m TestBlock
lrPeerSim :: PeerSimulatorResources m TestBlock
lrPeerSim
        , NodeDBs (StrictTMVar m MockFS)
lrCdb :: NodeDBs (StrictTMVar m MockFS)
lrCdb :: NodeDBs (StrictTMVar m MockFS)
lrCdb
        , LoE (StrictTVar m (AnchoredFragment (Header TestBlock)))
lrLoEVar :: LoE (StrictTVar m (AnchoredFragment (Header TestBlock)))
lrLoEVar :: LoE (StrictTVar m (AnchoredFragment (Header TestBlock)))
lrLoEVar
        }
  NodeLifecycle TestBlock m -> m (NodeLifecycle TestBlock m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NodeLifecycle {
      nlMinDuration :: Maybe DiffTime
nlMinDuration = SchedulerConfig -> Maybe DiffTime
scDowntime SchedulerConfig
schedulerConfig
    , nlStart :: LiveIntervalResult TestBlock -> m (LiveNode TestBlock m)
nlStart = (LiveInterval TestBlock m -> m ())
-> LiveResources TestBlock m
-> LiveIntervalResult TestBlock
-> m (LiveNode TestBlock m)
forall (m :: * -> *).
IOLike m =>
(LiveInterval TestBlock m -> m ())
-> LiveResources TestBlock m
-> LiveIntervalResult TestBlock
-> m (LiveNode TestBlock m)
lifecycleStart (SchedulerConfig
-> GenesisTestFull TestBlock -> LiveInterval TestBlock m -> m ()
forall (m :: * -> *).
(IOLike m, MonadTime m, MonadTimer m) =>
SchedulerConfig
-> GenesisTestFull TestBlock -> LiveInterval TestBlock m -> m ()
startNode SchedulerConfig
schedulerConfig GenesisTestFull TestBlock
genesisTest) LiveResources TestBlock m
resources
    , nlShutdown :: LiveNode TestBlock m -> m (LiveIntervalResult TestBlock)
nlShutdown = LiveResources TestBlock m
-> LiveNode TestBlock m -> m (LiveIntervalResult TestBlock)
forall (m :: * -> *) blk.
(IOLike m, GetHeader blk) =>
LiveResources blk m -> LiveNode blk m -> m (LiveIntervalResult blk)
lifecycleStop LiveResources TestBlock m
resources
    }
  where
    lrConfig :: TopLevelConfig TestBlock
lrConfig = SecurityParam
-> ForecastRange -> GenesisWindow -> TopLevelConfig TestBlock
defaultCfg SecurityParam
k ForecastRange
gtForecastRange GenesisWindow
gtGenesisWindow

    GenesisTest {
        $sel:gtSecurityParam:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> SecurityParam
gtSecurityParam = SecurityParam
k
      , ForecastRange
gtForecastRange :: ForecastRange
$sel:gtForecastRange:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> ForecastRange
gtForecastRange
      , GenesisWindow
gtGenesisWindow :: GenesisWindow
$sel:gtGenesisWindow:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> GenesisWindow
gtGenesisWindow
      } = GenesisTestFull TestBlock
genesisTest

-- | Construct STM resources, set up ChainSync and BlockFetch threads, and
-- send all ticks in a 'PointSchedule' to all given peers in turn.
runPointSchedule ::
  forall m.
  (IOLike m, MonadTime m, MonadTimer m) =>
  SchedulerConfig ->
  GenesisTestFull TestBlock ->
  Tracer m (TraceEvent TestBlock) ->
  m (StateView TestBlock)
runPointSchedule :: forall (m :: * -> *).
(IOLike m, MonadTime m, MonadTimer m) =>
SchedulerConfig
-> GenesisTestFull TestBlock
-> Tracer m (TraceEvent TestBlock)
-> m (StateView TestBlock)
runPointSchedule SchedulerConfig
schedulerConfig GenesisTestFull TestBlock
genesisTest Tracer m (TraceEvent TestBlock)
tracer0 =
  (ResourceRegistry m -> m (StateView TestBlock))
-> m (StateView TestBlock)
forall (m :: * -> *) a.
(MonadSTM m, MonadMask m, MonadThread m, HasCallStack) =>
(ResourceRegistry m -> m a) -> m a
withRegistry ((ResourceRegistry m -> m (StateView TestBlock))
 -> m (StateView TestBlock))
-> (ResourceRegistry m -> m (StateView TestBlock))
-> m (StateView TestBlock)
forall a b. (a -> b) -> a -> b
$ \ResourceRegistry m
registry -> do
    PeerSimulatorResources m TestBlock
peerSim <- Tracer m (TraceEvent TestBlock)
-> BlockTree TestBlock
-> NonEmpty PeerId
-> m (PeerSimulatorResources m TestBlock)
forall (m :: * -> *).
IOLike m =>
Tracer m (TraceEvent TestBlock)
-> BlockTree TestBlock
-> NonEmpty PeerId
-> m (PeerSimulatorResources m TestBlock)
makePeerSimulatorResources Tracer m (TraceEvent TestBlock)
tracer BlockTree TestBlock
gtBlockTree ([PeerId] -> NonEmpty PeerId
forall a. HasCallStack => [a] -> NonEmpty a
NonEmpty.fromList ([PeerId] -> NonEmpty PeerId) -> [PeerId] -> NonEmpty PeerId
forall a b. (a -> b) -> a -> b
$ Peers (PeerSchedule TestBlock) -> [PeerId]
forall a. Peers a -> [PeerId]
getPeerIds (Peers (PeerSchedule TestBlock) -> [PeerId])
-> Peers (PeerSchedule TestBlock) -> [PeerId]
forall a b. (a -> b) -> a -> b
$ PointSchedule TestBlock -> Peers (PeerSchedule TestBlock)
forall blk. PointSchedule blk -> Peers (PeerSchedule blk)
psSchedule PointSchedule TestBlock
gtSchedule)
    NodeLifecycle TestBlock m
lifecycle <- SchedulerConfig
-> GenesisTestFull TestBlock
-> Tracer m (TraceEvent TestBlock)
-> ResourceRegistry m
-> PeerSimulatorResources m TestBlock
-> m (NodeLifecycle TestBlock m)
forall (m :: * -> *).
(IOLike m, MonadTime m, MonadTimer m) =>
SchedulerConfig
-> GenesisTestFull TestBlock
-> Tracer m (TraceEvent TestBlock)
-> ResourceRegistry m
-> PeerSimulatorResources m TestBlock
-> m (NodeLifecycle TestBlock m)
nodeLifecycle SchedulerConfig
schedulerConfig GenesisTestFull TestBlock
genesisTest Tracer m (TraceEvent TestBlock)
tracer ResourceRegistry m
registry PeerSimulatorResources m TestBlock
peerSim
    (ChainDB m TestBlock
chainDb, StateViewTracers TestBlock m
stateViewTracers) <- Tracer m (TraceSchedulerEvent TestBlock)
-> StrictTVar m (Map PeerId (ChainSyncClientHandle m TestBlock))
-> PointSchedule TestBlock
-> Map PeerId (PeerResources m TestBlock)
-> NodeLifecycle TestBlock m
-> m (ChainDB m TestBlock, StateViewTracers TestBlock m)
forall (m :: * -> *) blk.
IOLike m =>
Tracer m (TraceSchedulerEvent blk)
-> StrictTVar m (Map PeerId (ChainSyncClientHandle m blk))
-> PointSchedule blk
-> Map PeerId (PeerResources m blk)
-> NodeLifecycle blk m
-> m (ChainDB m blk, StateViewTracers blk m)
runScheduler
      ((TraceSchedulerEvent TestBlock -> m ())
-> Tracer m (TraceSchedulerEvent TestBlock)
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((TraceSchedulerEvent TestBlock -> m ())
 -> Tracer m (TraceSchedulerEvent TestBlock))
-> (TraceSchedulerEvent TestBlock -> m ())
-> Tracer m (TraceSchedulerEvent TestBlock)
forall a b. (a -> b) -> a -> b
$ Tracer m (TraceEvent TestBlock) -> TraceEvent TestBlock -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceEvent TestBlock)
tracer (TraceEvent TestBlock -> m ())
-> (TraceSchedulerEvent TestBlock -> TraceEvent TestBlock)
-> TraceSchedulerEvent TestBlock
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TraceSchedulerEvent TestBlock -> TraceEvent TestBlock
forall blk. TraceSchedulerEvent blk -> TraceEvent blk
TraceSchedulerEvent)
      (PeerSimulatorResources m TestBlock
-> StrictTVar m (Map PeerId (ChainSyncClientHandle m TestBlock))
forall (m :: * -> *) blk.
PeerSimulatorResources m blk
-> StrictTVar m (Map PeerId (ChainSyncClientHandle m TestBlock))
psrHandles PeerSimulatorResources m TestBlock
peerSim)
      PointSchedule TestBlock
gtSchedule
      (PeerSimulatorResources m TestBlock
-> Map PeerId (PeerResources m TestBlock)
forall (m :: * -> *) blk.
PeerSimulatorResources m blk -> Map PeerId (PeerResources m blk)
psrPeers PeerSimulatorResources m TestBlock
peerSim)
      NodeLifecycle TestBlock m
lifecycle
    StateViewTracers TestBlock m
-> ChainDB m TestBlock -> m (StateView TestBlock)
forall (m :: * -> *) blk.
IOLike m =>
StateViewTracers blk m -> ChainDB m blk -> m (StateView blk)
snapshotStateView StateViewTracers TestBlock m
stateViewTracers ChainDB m TestBlock
chainDb
  where

    GenesisTest {
        BlockTree TestBlock
$sel:gtBlockTree:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree :: BlockTree TestBlock
gtBlockTree
      , PointSchedule TestBlock
gtSchedule :: PointSchedule TestBlock
$sel:gtSchedule:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> schedule
gtSchedule
      } = GenesisTestFull TestBlock
genesisTest

    -- FIXME: This type of configuration should move to `Trace.mkTracer`.
    tracer :: Tracer m (TraceEvent TestBlock)
tracer = if SchedulerConfig -> Bool
scTrace SchedulerConfig
schedulerConfig then Tracer m (TraceEvent TestBlock)
tracer0 else Tracer m (TraceEvent TestBlock)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer