Skip to content

Commit

Permalink
Formatting
Browse files Browse the repository at this point in the history
  • Loading branch information
@jasagredo
jasagredo committed Dec 10, 2024
1 parent 77c0275 commit 9b4061d
Show file tree
Hide file tree
Showing 2 changed files with 5 additions and 207 deletions.
2 changes: 1 addition & 1 deletion ...sensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -53,7 +53,6 @@ import qualified Cardano.Protocol.TPraos.Rules.Prtcl as SL
import qualified Cardano.Protocol.TPraos.Rules.Tickn as SL
import Control.Monad
import Control.Monad.Except (runExcept, throwError)
import Data.Void
import Data.Coerce (coerce)
import qualified Data.Map.Strict as Map
import Data.Maybe (listToMaybe, mapMaybe)
Expand All @@ -64,6 +63,7 @@ import Data.SOP.InPairs (RequiringBoth (..), ignoringBoth)
import qualified Data.SOP.Strict as SOP
import Data.SOP.Tails (Tails (..))
import qualified Data.SOP.Tails as Tails
import Data.Void
import Data.Word
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks)
Expand Down
210 changes: 4 additions & 206 deletions ...s-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -440,7 +440,7 @@ forkBlockForging IS{..} blockForging =

go :: ResourceRegistry m -> SlotNo -> WithEarlyExit m ()
go reg currentSlot = do
trace $ TraceStartLeadershipCheck currentSlot
trace $ TraceStartLeadershipCheck currentSlot

-- Figure out which block to connect to
--
Expand Down Expand Up @@ -524,6 +524,7 @@ forkBlockForging IS{..} blockForging =
ForgeStateUpdateError err -> do
trace $ TraceForgeStateUpdateError currentSlot err
lift $ roforkerClose forker
exitEarly
CannotForge cannotForge -> do
trace $ TraceNodeCannotForge currentSlot cannotForge
lift $ roforkerClose forker
Expand All @@ -538,7 +539,7 @@ forkBlockForging IS{..} blockForging =
trace $ TraceNodeIsLeader currentSlot

-- Tick the ledger state for the 'SlotNo' we're producing a block for
let tickedLedgerState :: Ticked1 (LedgerState blk) DiffMK
let tickedLedgerState :: Ticked (LedgerState blk) DiffMK
tickedLedgerState =
applyChainTick
(configLedger cfg)
Expand Down Expand Up @@ -627,211 +628,8 @@ forkBlockForging IS{..} blockForging =
-- process.
whenJust
(NE.nonEmpty (map (txId . txForgetValidated) txs))
(lift . removeTxs mempool)
exitEarly
||||||| parent of 3794d5a19 (Code review changes)
-- 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
BlockContext{bcBlockNo, bcPrevPoint} <- do
eBlkCtx <- lift $ atomically $
mkCurrentBlockContext currentSlot
<$> ChainDB.getCurrentChain chainDB
case eBlkCtx of
Right blkCtx -> return blkCtx
Left failure -> do
trace failure
exitEarly

trace $ TraceBlockContext currentSlot bcBlockNo bcPrevPoint

-- Get forker corresponding to bcPrevPoint
--
-- This might fail if, in between choosing 'bcPrevPoint' and this call to
-- 'ChainDB.getReadOnlyForkerAtPoint', we switched to a fork where 'bcPrevPoint'
-- is no longer on our chain. When that happens, we simply give up on the
-- chance to produce a block.
forkerEith <- lift $ ChainDB.getReadOnlyForkerAtPoint chainDB reg (SpecificPoint bcPrevPoint)
-- Remember to close this forker before exiting!
forker <- case forkerEith of
Left _ -> do
trace $ TraceNoLedgerState currentSlot bcPrevPoint
(lift . removeTxsEvenIfValid mempool)
exitEarly
Right forker -> pure forker

unticked <- lift $ atomically $ LedgerDB.roforkerGetLedgerState forker

trace $ TraceLedgerState currentSlot bcPrevPoint

-- We require the ticked ledger view in order to construct the ticked
-- 'ChainDepState'.
ledgerView <-
case runExcept $ forecastFor
(ledgerViewForecastAt
(configLedger cfg)
(ledgerState unticked))
currentSlot of
Left err -> do
-- There are so many empty slots between the tip of our chain and the
-- current slot that we cannot get an ledger view anymore In
-- principle, this is no problem; we can still produce a block (we use
-- the ticked ledger state). However, we probably don't /want/ to
-- produce a block in this case; we are most likely missing a blocks
-- on our chain.
trace $ TraceNoLedgerView currentSlot err
lift $ roforkerClose forker
exitEarly
Right lv ->
return lv

trace $ TraceLedgerView currentSlot

-- Tick the 'ChainDepState' for the 'SlotNo' we're producing a block for. We
-- only need the ticked 'ChainDepState' to check the whether we're a leader.
-- This is much cheaper than ticking the entire 'ExtLedgerState'.
let tickedChainDepState :: Ticked (ChainDepState (BlockProtocol blk))
tickedChainDepState =
tickChainDepState
(configConsensus cfg)
ledgerView
currentSlot
(headerStateChainDep (headerState unticked))

-- Check if we are the leader
proof <- do
shouldForge <- lift $
checkShouldForge
blockForging
(contramap (TraceLabelCreds (forgeLabel blockForging))
(forgeStateInfoTracer tracers))
cfg
currentSlot
tickedChainDepState
case shouldForge of
ForgeStateUpdateError err -> do
trace $ TraceForgeStateUpdateError currentSlot err
lift $ roforkerClose forker
exitEarly
CannotForge cannotForge -> do
trace $ TraceNodeCannotForge currentSlot cannotForge
lift $ roforkerClose forker
exitEarly
NotLeader -> do
trace $ TraceNodeNotLeader currentSlot
lift $ roforkerClose forker
exitEarly
ShouldForge p -> return p

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

-- Tick the ledger state for the 'SlotNo' we're producing a block for
let tickedLedgerState :: Ticked1 (LedgerState blk) DiffMK
tickedLedgerState =
applyChainTick
(configLedger cfg)
currentSlot
(ledgerState unticked)

_ <- evaluate tickedLedgerState
trace $ TraceForgeTickedLedgerState currentSlot bcPrevPoint

-- 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.
(mempoolHash, mempoolSlotNo) <- lift $ atomically $ do
snap <- getSnapshot mempool -- only used for its tip-like information
let h :: ChainHash blk
h = castHash $ getTipHash $ snapshotState snap
pure (h, snapshotSlotNo snap)

let readTables = fmap castLedgerTables . roforkerReadTables forker . castLedgerTables

mempoolSnapshot <- lift $ getSnapshotFor
mempool
currentSlot
tickedLedgerState
readTables

lift $ roforkerClose forker

let txs = [ tx | (tx, _, _) <- snapshotTxs mempoolSnapshot ]

-- force the mempool's computation before the tracer event
_ <- evaluate (length txs)
_ <- evaluate mempoolHash

trace $ TraceForgingMempoolSnapshot currentSlot bcPrevPoint mempoolHash mempoolSlotNo

-- Actually produce the block
newBlock <- lift $ Block.forgeBlock
blockForging
cfg
bcBlockNo
currentSlot
(forgetLedgerTables tickedLedgerState)
txs
proof

trace $ TraceForgedBlock
currentSlot
(ledgerTipPoint (ledgerState unticked))
newBlock
(snapshotMempoolSize mempoolSnapshot)

-- Add the block to the chain DB
let noPunish = InvalidBlockPunishment.noPunishment -- no way to punish yourself
-- Make sure that if an async exception is thrown while a block is
-- added to the chain db, we will remove txs from the mempool.

-- 'addBlockAsync' is a non-blocking action, so `mask_` would suffice,
-- but the finalizer is a blocking operation, hence we need to use
-- 'uninterruptibleMask_' to make sure that async exceptions do not
-- interrupt it.
uninterruptibleMask_ $ do
result <- lift $ ChainDB.addBlockAsync chainDB noPunish newBlock
-- Block until we have processed the block
mbCurTip <- lift $ atomically $ ChainDB.blockProcessed result

-- Check whether we adopted our block
when (mbCurTip /= SuccesfullyAddedBlock (blockPoint newBlock)) $ do
isInvalid <- lift $ 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. This can happen for
-- different reasons. In particular, the ledger rules might reject
-- some transactions (which would indicate a bug between the ChainDB
-- and the Mempool, as the latter accepted the transactions as valid
-- whereas the former doesn't), the header might be invalid (which
-- could point to a misconfiguration of the node itself) or the
-- block might exceed the clock skew (which could indicate problems
-- with the system clock).
--
-- Only when the block is invalid because of the transactions, we
-- will remove all the transactions in that block from the mempool
-- as a defensive programming measure. Otherwise we'd run the risk
-- of forging the same invalid block again. This means that we'll
-- throw away some good transactions in the process.
case reason of
ChainDB.InFutureExceedsClockSkew {} -> pure ()
ChainDB.ValidationError err ->
case err of
ExtValidationErrorHeader{} -> pure ()
ExtValidationErrorLedger{} ->
whenJust
(NE.nonEmpty (map (txId . txForgetValidated) txs))
(lift . removeTxs mempool)
exitEarly

-- We successfully produced /and/ adopted a block
--
Expand Down

0 comments on commit 9b4061d

Please sign in to comment.