View on GitHub
File Changes
                       Ouroboros.Consensus.Util.CBOR
                       Ouroboros.Consensus.Util.Classify
                       Ouroboros.Consensus.Util.Condense
+
                       Ouroboros.Consensus.Util.EarlyExit
                       Ouroboros.Consensus.Util.HList
                       Ouroboros.Consensus.Util.IOLike
                       Ouroboros.Consensus.Util.MonadSTM.NormalForm
import           Ouroboros.Consensus.Ledger.Abstract (AnachronyFailure,
                     ProtocolLedgerView)
import           Ouroboros.Consensus.Mempool.API (ApplyTxErr, GenTx, GenTxId,
-
                     TraceEventMempool)
+
                     MempoolSize, TraceEventMempool)
import           Ouroboros.Consensus.TxSubmission
                     (TraceLocalTxSubmissionServerEvent (..))

                      
-------------------------------------------------------------------------------}

                      
-- | Trace the forging of a block as a slot leader.
+
--
+
-- The flow of trace events here can be visualized as follows:
+
--
+
-- > TraceStartLeadershipCheck
+
-- >          |
+
-- >          +--- TraceNodeNotLeader
+
-- >          |
+
-- >          +--- TraceBlockFromFuture (leadership check failed)
+
-- >          |
+
-- >          +--- TraceNoLedgerState (leadership check failed)
+
-- >          |
+
-- >          +--- TraceNoLedgerView (leadership check failed)-- >
+
-- >          |
+
-- >   TraceNodeIsLeader
+
-- >          |
+
-- >    TraceForgedBlock
+
-- >          |
+
-- >          +--- TraceDidntAdoptBlock
+
-- >          |
+
-- >          +--- TraceForgedInvalidBlock
+
-- >          |
+
-- >  TraceAdoptedBlock
data TraceForgeEvent blk tx
-
  -- | The node will soon forge; it is about to read its transactions and
-
  -- current DB.
-
  = TraceForgeAboutToLead SlotNo
+
  -- | Start of the leadership check
+
  --
+
  -- We record the current slot number.
+
  --
+
  -- This event terminates with one of the following concluding trace messages:
+
  --
+
  -- * TraceNodeNotLeader if we are not the leader
+
  -- * TraceNodeIsLeader if we are the leader
+
  -- * TraceBlockFromFuture (rarely)
+
  -- * TraceNoLedgerState (rarely)
+
  -- * TraceNoLedgerView (rarely)
+
  = TraceStartLeadershipCheck SlotNo

                      
-
  -- | The forged block and at which slot it was forged.
-
  | TraceForgeEvent SlotNo blk
+
  -- | We did the leadership check and concluded we are not the leader
+
  --
+
  -- We record the current slot number
+
  | TraceNodeNotLeader SlotNo

                      
-
  -- | We should have produced a block, but didn't, due to too many missing
-
  -- blocks between the tip of our chain and the current slot
+
  -- | Leadership check failed: we were unable to get the ledger state
+
  -- for the point of the block we want to connect to
+
  --
+
  -- This can happen if after choosing which block to connect to the node
+
  -- switched to a different fork. We expect this to happen only rather rarely,
+
  -- so this certainly merits a warning; if it happens a lot, that merits an
+
  -- investigation.
+
  --
+
  -- We record both the current slot number as well as the point of the block
+
  -- we attempt to connect the new block to (that we requested the ledger state
+
  -- for).
+
  | TraceNoLedgerState SlotNo (Point blk)
+

                      
+
  -- | Leadership check failed: we were unable to get the ledger view for the
+
  -- current slot number
+
  --
+
  -- This will only happen if there are many missing blocks between the tip of
+
  -- our chain and the current slot.
  --
  -- As a sanity check, we record also the failure returned by
  -- 'anachronisticProtocolLedgerView', although we expect this to be
  -- 'TooFarAhead', never 'TooFarBehind'.
-
  | TraceCouldNotForge SlotNo AnachronyFailure
+
  | TraceNoLedgerView SlotNo AnachronyFailure
+

                      
+
  -- | Leadership check failed: the current chain contains a block from a slot
+
  -- /after/ the current slot
+
  --
+
  -- This can only happen if the system is under heavy load.
+
  --
+
  -- We record both the current slot number as well as the slot number of the
+
  -- block at the tip of the chain.
+
  --
+
  -- See also <https://github.com/input-output-hk/ouroboros-network/issues/1462>
+
  | TraceBlockFromFuture SlotNo SlotNo
+

                      
+
  -- | We did the leadership check and concluded we /are/ the leader
+
  --
+
  -- The node will soon forge; it is about to read its transactions and
+
  -- current DB. This will be followed by TraceForgedBlock.
+
  | TraceNodeIsLeader SlotNo
+

                      
+
  -- | We forged a block
+
  --
+
  -- We record the current slot number, the block itself, and the total size
+
  -- of the mempool snapshot at the time we produced the block (which may be
+
  -- significantly larger than the block, due to maximum block size)
+
  --
+
  -- This will be followed by one of three messages:
+
  --
+
  -- * TraceAdoptedBlock (normally)
+
  -- * TraceDidntAdoptBlock (rarely)
+
  -- * TraceForgedInvalidBlock (hopefully never -- this would indicate a bug)
+
  | TraceForgedBlock SlotNo blk MempoolSize

                      
  -- | We adopted the block we produced, we also trace the transactions
  -- that were adopted.
import           Ouroboros.Consensus.Protocol.Abstract
import           Ouroboros.Consensus.Util (whenJust)
import           Ouroboros.Consensus.Util.AnchoredFragment
+
import           Ouroboros.Consensus.Util.EarlyExit
import           Ouroboros.Consensus.Util.IOLike
import           Ouroboros.Consensus.Util.Orphans ()
import           Ouroboros.Consensus.Util.Random
forkBlockProduction maxBlockSizeOverride IS{..} BlockProduction{..} =
    void $ onSlotChange btime $ \currentSlot -> do
      varDRG <- newTVarM =<< (PRNG <$> produceDRG)
-

                      
-
      trace $ TraceForgeAboutToLead currentSlot
-

                      
-
      -- Get current ledger
-
      --
-
      -- NOTE: This is still wrong. If we detect in 'prevPointAndBlockNo'
-
      -- that we should roll back one block, we should also use a different
-
      -- ledger state.
-
      -- <https://github.com/input-output-hk/ouroboros-network/issues/1437>
-
      (extLedger, (prevPoint, prevNo)) <- atomically $ (,)
-
        <$> ChainDB.getCurrentLedger chainDB
-
        <*> (prevPointAndBlockNo currentSlot <$>
-
               ChainDB.getCurrentChain chainDB)
-
      let ledger = ledgerState extLedger
-

                      
-
      -- Check if we are the leader
-
      mIsLeader <-
-
        case anachronisticProtocolLedgerView cfg ledger (At currentSlot) of
-
          Right ledgerView ->
-
            atomically $ runProtocol varDRG $
-
              checkIsLeader
-
                cfg
-
                currentSlot
-
                ledgerView
-
                (ouroborosChainState extLedger)
-
          Left err -> do
-
            -- There are so many empty slots between the tip of our chain and
-
            -- the current slot that we cannot even get an accurate ledger view
-
            -- anymore. This is indicative of a serious problem: we are not
-
            -- receiving blocks. It is /possible/ it's just due to our network
-
            -- connectivity, and we might still get these blocks at some point;
-
            -- but we certainly can't produce a block of our own.
-
            trace $ TraceCouldNotForge currentSlot err
-
            return Nothing
-

                      
-
      case mIsLeader of
-
        Nothing    -> return ()
-
        Just proof -> do
-
          -- Get a snapshot of the mempool that is consistent with the ledger
-
          --
-
          -- NOTE: It is possible that due to adoption of new blocks the
-
          -- /current/ ledger will have changed. This doesn't matter: we will
-
          -- produce a block that fits onto the ledger we got above; if the
-
          -- ledger in the meantime changes, the block we produce here may or
-
          -- may not be adopted, but it won't be invalid.
-
          mempoolSnapshot <- atomically $ getSnapshotFor
-
                                            mempool
-
                                            (TxsForBlockInSlot currentSlot)
-
                                            (ledgerState extLedger)
-

                      
-
          let blockEncOverhead = nodeBlockEncodingOverhead ledger
-
              maxBlockBodySize = case maxBlockSizeOverride of
-
                NoOverride            -> nodeMaxBlockSize ledger - blockEncOverhead
-
                MaxBlockSize mbs      -> mbs - blockEncOverhead
-
                MaxBlockBodySize mbbs -> mbbs
-
              txs = map fst (snapshotTxsForSize mempoolSnapshot maxBlockBodySize)
-

                      
-
          newBlock <- atomically $ runProtocol varDRG $
-
            produceBlock
-
              proof
-
              extLedger
-
              currentSlot
-
              prevPoint
-
              prevNo
-
              txs
-

                      
-
          trace $ TraceForgeEvent currentSlot newBlock
-
          -- Adding a block is synchronous
-
          ChainDB.addBlock chainDB newBlock
-
          -- Check whether we adopted our block
-
          curTip <- atomically $ ChainDB.getTipPoint chainDB
-
          if curTip == blockPoint newBlock then do
-
            trace $ TraceAdoptedBlock currentSlot newBlock txs
-
          else do
-
            isInvalid <- atomically $
-
              ($ blockHash newBlock) . forgetFingerprint <$>
-
              ChainDB.getIsInvalidBlock chainDB
-
            case isInvalid of
-
              Nothing ->
-
                trace $ TraceDidntAdoptBlock currentSlot newBlock
-
              Just reason -> do
-
                trace $ TraceForgedInvalidBlock currentSlot newBlock reason
-
                -- We just produced a block that is invalid according to the
-
                -- ledger in the ChainDB, while the mempool said it is valid.
-
                -- There is an inconsistency between the two!
-
                --
-
                -- Remove all the transactions in that block, otherwise we'll
-
                -- run the risk of forging the same invalid block again. This
-
                -- means that we'll throw away some good transactions in the
-
                -- process.
-
                removeTxs mempool (map txId txs)
+
      withEarlyExit_ $ go currentSlot varDRG
  where
-
    trace :: TraceForgeEvent blk (GenTx blk) -> m ()
-
    trace = traceWith (forgeTracer tracers)
+
    go :: SlotNo -> StrictTVar m PRNG -> WithEarlyExit m ()
+
    go currentSlot varDRG = do
+
        trace $ TraceStartLeadershipCheck currentSlot
+

                      
+
        -- Figure out which block to connect to
+
        --
+
        -- Normally this will be the current block at the tip, but it may
+
        -- be the /previous/ block, if there were multiple slot leaders
+
        (prevPoint, prevNo) <- do
+
          mPrev <- lift $ atomically $ prevPointAndBlockNo currentSlot <$>
+
                     ChainDB.getCurrentChain chainDB
+
          case mPrev of
+
            Right prev       -> return prev
+
            Left  futureSlot -> do
+
              trace $ TraceBlockFromFuture currentSlot futureSlot
+
              exitEarly
+

                      
+
        -- Get ledger state corresponding to prevPoint
+
        --
+
        -- This might fail if, in between choosing 'prevPoint' and this call to
+
        -- 'getPastLedger', we switched to a fork where 'prevPoint' is no longer
+
        -- on our chain. When that happens, we simply give up on the chance to
+
        -- produce a block.
+
        extLedger <- do
+
          mExtLedger <- lift $ ChainDB.getPastLedger chainDB prevPoint
+
          case mExtLedger of
+
            Just l  -> return l
+
            Nothing -> do
+
              trace $ TraceNoLedgerState currentSlot prevPoint
+
              exitEarly
+
        let ledger = ledgerState extLedger
+

                      
+
        -- Check if we are the leader
+
        proof <-
+
          case anachronisticProtocolLedgerView cfg ledger (At currentSlot) of
+
            Right ledgerView -> do
+
              mIsLeader <- lift $ atomically $ runProtocol varDRG $
+
                checkIsLeader
+
                  cfg
+
                  currentSlot
+
                  ledgerView
+
                  (ouroborosChainState extLedger)
+
              case mIsLeader of
+
                Just p  -> return p
+
                Nothing -> do
+
                  trace $ TraceNodeNotLeader currentSlot
+
                  exitEarly
+
            Left err -> do
+
              -- There are so many empty slots between the tip of our chain and
+
              -- the current slot that we cannot even get an accurate ledger
+
              -- view anymore. This is indicative of a serious problem: we are
+
              -- not receiving blocks. It is /possible/ it's just due to our
+
              -- network connectivity, and we might still get these blocks at
+
              -- some point; but we certainly can't produce a block of our own.
+
              trace $ TraceNoLedgerView currentSlot err
+
              exitEarly
+

                      
+
        -- At this point we have established that we are indeed slot leader
+
        trace $ TraceNodeIsLeader currentSlot
+

                      
+
        -- Get a snapshot of the mempool that is consistent with the ledger
+
        --
+
        -- NOTE: It is possible that due to adoption of new blocks the
+
        -- /current/ ledger will have changed. This doesn't matter: we will
+
        -- produce a block that fits onto the ledger we got above; if the
+
        -- ledger in the meantime changes, the block we produce here may or
+
        -- may not be adopted, but it won't be invalid.
+
        mempoolSnapshot <- lift $ atomically $ getSnapshotFor
+
                                                 mempool
+
                                                 (TxsForBlockInSlot currentSlot)
+
                                                 (ledgerState extLedger)
+
        let txs = map fst $ snapshotTxsForSize
+
                              mempoolSnapshot
+
                              (maxBlockBodySize ledger)
+

                      
+
        -- Actually produce the block
+
        newBlock <- lift $ atomically $ runProtocol varDRG $
+
          produceBlock
+
            proof
+
            extLedger
+
            currentSlot
+
            prevPoint
+
            prevNo
+
            txs
+
        trace $ TraceForgedBlock
+
                  currentSlot
+
                  newBlock
+
                  (snapshotMempoolSize mempoolSnapshot)
+

                      
+
        -- Add the block to the chain DB
+
        lift $ ChainDB.addBlock chainDB newBlock
+

                      
+
        -- Check whether we adopted our block
+
{-# LANGUAGE FlexibleContexts           #-}
+
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
{-# LANGUAGE QuantifiedConstraints      #-}
+
{-# LANGUAGE RankNTypes                 #-}
+
{-# LANGUAGE ScopedTypeVariables        #-}
+
{-# LANGUAGE StandaloneDeriving         #-}
+
{-# LANGUAGE TypeApplications           #-}
+
{-# LANGUAGE TypeFamilies               #-}
+
{-# LANGUAGE UndecidableInstances       #-}
+

                      
+
module Ouroboros.Consensus.Util.EarlyExit (
+
    WithEarlyExit -- opaque
+
  , withEarlyExit
+
  , withEarlyExit_
+
  , exitEarly
+
    -- * Re-exports
+
  , lift
+
  ) where
+

                      
+
import           Control.Applicative
+
import           Control.Monad
+
import           Control.Monad.ST (ST)
+
import           Control.Monad.Trans.Class
+
import           Control.Monad.Trans.Maybe
+
import           Data.Function (on)
+
import           Data.Proxy
+

                      
+
import           Cardano.Prelude (NoUnexpectedThunks(..))
+

                      
+
import           Control.Monad.Class.MonadAsync
+
import           Control.Monad.Class.MonadFork
+
import           Control.Monad.Class.MonadST
+
import           Control.Monad.Class.MonadSTM
+
import           Control.Monad.Class.MonadThrow
+
import           Control.Monad.Class.MonadTime
+
import           Control.Monad.Class.MonadTimer
+

                      
+
import           Ouroboros.Consensus.Util ((.:))
+
import           Ouroboros.Consensus.Util.IOLike (IOLike, StrictTVar, StrictMVar)
+

                      
+
{-------------------------------------------------------------------------------
+
  Basic definitions
+
-------------------------------------------------------------------------------}
+

                      
+
newtype WithEarlyExit m a = WithEarlyExit {
+
      unWithEarlyExit :: MaybeT m a
+
    }
+
  deriving ( Functor
+
           , Applicative
+
           , Alternative
+
           , Monad
+
           , MonadTrans
+
           , MonadPlus
+
           )
+

                      
+
-- | Internal only
+
earlyExit :: m (Maybe a) -> WithEarlyExit m a
+
earlyExit = WithEarlyExit . MaybeT
+

                      
+
withEarlyExit :: WithEarlyExit m a -> m (Maybe a)
+
withEarlyExit = runMaybeT . unWithEarlyExit
+

                      
+
withEarlyExit_ :: Functor m => WithEarlyExit m () -> m ()
+
withEarlyExit_ = fmap collapse . withEarlyExit
+

                      
+
collapse :: Maybe () -> ()
+
collapse Nothing   = ()
+
collapse (Just ()) = ()
+

                      
+
exitEarly :: Applicative m => WithEarlyExit m a
+
exitEarly = earlyExit $ pure Nothing
+

                      
+
instance (forall a'. NoUnexpectedThunks (m a'))
+
      => NoUnexpectedThunks (WithEarlyExit m a) where
+
   whnfNoUnexpectedThunks ctxt = whnfNoUnexpectedThunks ctxt . withEarlyExit
+
   showTypeOf _p = "WithEarlyExit " ++ showTypeOf (Proxy @(m a))
+

                      
+
{-------------------------------------------------------------------------------
+
  Special wrapper for STM
+

                      
+
  This is required because MonadSTM requires STM to be injective.
+
-------------------------------------------------------------------------------}
+

                      
+
newtype WrapSTM m a = Wrap { unwrap :: WithEarlyExit (STM m) a }
+

                      
+
unwrapSTM :: WrapSTM m a -> STM m (Maybe a)
+
unwrapSTM = withEarlyExit . unwrap
+

                      
+
wrapSTM :: STM m (Maybe a) -> WrapSTM m a
+
wrapSTM = Wrap . earlyExit
+

                      
+
wrapSTM' :: MonadSTM m => STM m a -> WrapSTM m a
+
wrapSTM' = wrapSTM . fmap Just
+

                      
+
deriving instance MonadSTM m => Functor     (WrapSTM m)
+
deriving instance MonadSTM m => Applicative (WrapSTM m)
+
deriving instance MonadSTM m => Monad       (WrapSTM m)
+
deriving instance MonadSTM m => Alternative (WrapSTM m)
+
deriving instance MonadSTM m => MonadPlus   (WrapSTM m)
+

                      
+
-- These two piggy-back on the instances for WithEarlyExit, below
+
deriving instance (MonadSTM m, MonadCatch (STM m)) => MonadThrow (WrapSTM m)
+
deriving instance (MonadSTM m, MonadCatch (STM m)) => MonadCatch (WrapSTM m)
+

                      
+
{-------------------------------------------------------------------------------
+
  Instances for io-classes
+
-------------------------------------------------------------------------------}
+

                      
+
instance MonadSTM m => MonadSTM (WithEarlyExit m) where
+
  type STM     (WithEarlyExit m) = WrapSTM m -- == WithEarlyExit (STM m)
+
  type TVar    (WithEarlyExit m) = TVar    m
+
  type TMVar   (WithEarlyExit m) = TMVar   m
+
  type TQueue  (WithEarlyExit m) = TQueue  m
+
  type TBQueue (WithEarlyExit m) = TBQueue m
+

                      
+
  atomically      = earlyExit . atomically . unwrapSTM
+

                      
+
  newTVar         = wrapSTM' .  newTVar
+
  readTVar        = wrapSTM' .  readTVar
+
  writeTVar       = wrapSTM' .: writeTVar
+
  retry           = wrapSTM'    retry
+
  orElse          = (wrapSTM .: orElse) `on` unwrapSTM
+
  newTMVar        = wrapSTM' .  newTMVar
+
  newTMVarM       = lift     .  newTMVarM
+
  newEmptyTMVar   = wrapSTM'    newEmptyTMVar
+
  newEmptyTMVarM  = lift        newEmptyTMVarM
+
  takeTMVar       = wrapSTM' .  takeTMVar
+
  tryTakeTMVar    = wrapSTM' .  tryTakeTMVar
+
  putTMVar        = wrapSTM' .: putTMVar
+
  tryPutTMVar     = wrapSTM' .: tryPutTMVar
+
  readTMVar       = wrapSTM' .  readTMVar
+
  tryReadTMVar    = wrapSTM' .  tryReadTMVar
+
  swapTMVar       = wrapSTM' .: swapTMVar
+
  isEmptyTMVar    = wrapSTM' .  isEmptyTMVar
+
  newTQueue       = wrapSTM'    newTQueue
+
  readTQueue      = wrapSTM' .  readTQueue
+
  tryReadTQueue   = wrapSTM' .  tryReadTQueue
+
  writeTQueue     = wrapSTM' .: writeTQueue
+
  isEmptyTQueue   = wrapSTM' .  isEmptyTQueue
+
  newTBQueue      = wrapSTM' .  newTBQueue
+
  readTBQueue     = wrapSTM' .  readTBQueue
+
  tryReadTBQueue  = wrapSTM' .  tryReadTBQueue
+
  writeTBQueue    = wrapSTM' .: writeTBQueue
+
  isEmptyTBQueue  = wrapSTM' .  isEmptyTBQueue
+
  isFullTBQueue   = wrapSTM' .  isFullTBQueue
+

                      
+
instance MonadCatch m => MonadThrow (WithEarlyExit m) where
+
  throwM = lift . throwM
+

                      
+
instance MonadCatch m => MonadCatch (WithEarlyExit m) where
+
  catch act handler = earlyExit $
+
      catch (withEarlyExit act) (withEarlyExit . handler)
+

                      
+
  generalBracket acquire release use = earlyExit $ do
+
      -- This is modelled on the case for ErrorT, except that we don't have
+
      -- to worry about reporting the right error, since we only have @[email protected]
+
      (mb, mc) <- generalBracket
+
                    (withEarlyExit acquire)
+
                    (\mResource exitCase ->
+
                        case (mResource, exitCase) of
+
                          (Nothing, _) ->
+
                            -- resource not acquired
+
                            return Nothing
+
                          (Just resource, ExitCaseSuccess (Just b)) ->
+
                            withEarlyExit $ release resource (ExitCaseSuccess b)
+
                          (Just resource, ExitCaseException e) ->
+
                            withEarlyExit $ release resource (ExitCaseException e)
+
                          (Just resource, _otherwise) ->
+
                            withEarlyExit $ release resource ExitCaseAbort
+
                    )
+
                    (maybe (return Nothing) (withEarlyExit . use))
+
      return $ (,) <$> mb <*> mc
+

                      
+
instance MonadMask m => MonadMask (WithEarlyExit m) where
+
  mask f = earlyExit $
+
    mask $ \unmask ->
+
      withEarlyExit (f (earlyExit . unmask . withEarlyExit))
+

                      
+
  uninterruptibleMask f = earlyExit $
+
    uninterruptibleMask $ \unmask ->
+
      let unmask' :: forall a. WithEarlyExit m a -> WithEarlyExit m a
+
          unmask' = earlyExit . unmask . withEarlyExit
+
      in withEarlyExit (f unmask')
+

                      
+
instance MonadThread m => MonadThread (WithEarlyExit m) where
+
  type ThreadId (WithEarlyExit m) = ThreadId m
+

                      
+
  myThreadId  = lift    myThreadId
+
  labelThread = lift .: labelThread
+

                      
+
instance ( MonadMask  m
+
         , MonadAsync m
+
         , MonadCatch (STM m)
+
         ) => MonadAsync (WithEarlyExit m) where
+
  type Async (WithEarlyExit m) = WithEarlyExit (Async m)
+

                      
+
  async            = lift . (fmap earlyExit . async) . withEarlyExit
+
  asyncThreadId _p = asyncThreadId (Proxy @(WithEarlyExit m))
+
  cancel        a  = lift $ cancel     (withEarlyExit a)
-- | Parameters for the test node net
--
data ThreadNetworkArgs blk = ThreadNetworkArgs
-
  { tnaForgeEBB       :: Maybe (ForgeEBB blk)
-
  , tnaJoinPlan       :: NodeJoinPlan
-
  , tnaNodeInfo       :: CoreNodeId -> ProtocolInfo blk
-
  , tnaNumCoreNodes   :: NumCoreNodes
-
  , tnaNumSlots       :: NumSlots
-
  , tnaRNG            :: ChaChaDRG
-
  , tnaSlotLengths    :: SlotLengths
-
  , tnaTopology       :: NodeTopology
+
  { tnaForgeEBB     :: Maybe (ForgeEBB blk)
+
  , tnaJoinPlan     :: NodeJoinPlan
+
  , tnaNodeInfo     :: CoreNodeId -> ProtocolInfo blk
+
  , tnaNumCoreNodes :: NumCoreNodes
+
  , tnaNumSlots     :: NumSlots
+
  , tnaRNG          :: ChaChaDRG
+
  , tnaSlotLengths  :: SlotLengths
+
  , tnaTopology     :: NodeTopology
  }

                      
-- | Setup a network of core nodes, where each joins according to the node join
      let nodeArgs = NodeArgs
            { tracers             = nullDebugTracers
                { forgeTracer       = Tracer $ \case
-
                    TraceForgeAboutToLead s -> do
+
                    TraceStartLeadershipCheck s -> do
                      atomically $ do
                        lim <- readTVar nextEbbSlotVar
                        check $ s < lim
              , nodeOutputNodeDBs    = nodeInfoDBs
              , nodeOutputForges     =
                  Map.fromList $
-
                  [ (s, b) | TraceForgeEvent s b <- nodeEventsForges ]
+
                  [ (s, b) | TraceForgedBlock s b _ <- nodeEventsForges ]
              , nodeOutputInvalids   = Set.fromList nodeEventsInvalids
              }