diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index 0f2fd5a2c71..63ff36eb664 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -99,6 +99,7 @@ library Ouroboros.Consensus.Protocol.ModChainSel Ouroboros.Consensus.Protocol.PBFT Ouroboros.Consensus.Protocol.PBFT.ChainState + Ouroboros.Consensus.Protocol.PBFT.ChainState.HeaderHashBytes Ouroboros.Consensus.Protocol.PBFT.Crypto Ouroboros.Consensus.Protocol.Praos Ouroboros.Consensus.Protocol.Signed diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncClient.hs b/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncClient.hs index 6c4cd5bae68..358f97f17e0 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncClient.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncClient.hs @@ -329,10 +329,10 @@ chainSyncClient mkPipelineDecision0 tracer cfg btime -- it is followed by rolling forward again), but we need some -- guarantees that the ChainSync protocol /does/ in fact give us a -- switch-to-fork instead of a true rollback. - (theirFrag, theirChainState) <- - case (,) <$> AF.rollback (castPoint intersection) ourFrag - <*> rewindChainState cfg ourChainState (pointSlot intersection) - of + (theirFrag, theirChainState) <- do + let i = castPoint intersection + case (,) <$> AF.rollback i ourFrag + <*> rewindChainState cfg ourChainState i of Just (c, d) -> return (c, d) -- The @intersection@ is not on the candidate chain, even though -- we sent only points from the candidate chain to find an @@ -634,10 +634,10 @@ chainSyncClient mkPipelineDecision0 tracer cfg btime , theirChainState , ourTip } -> traceException $ do - (theirFrag', theirChainState') <- - case (,) <$> AF.rollback (castPoint intersection) theirFrag - <*> rewindChainState cfg theirChainState (pointSlot intersection) - of + (theirFrag', theirChainState') <- do + let i = castPoint intersection + case (,) <$> AF.rollback i theirFrag + <*> rewindChainState cfg theirChainState i of Just (c, d) -> return (c,d) -- Remember that we use our current chain fragment as the starting -- point for the candidate's chain. Our fragment contained @k@ diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Block.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Block.hs index 7678bf112f9..d560cb4e593 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Block.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Block.hs @@ -50,6 +50,7 @@ import GHC.Generics (Generic) import Codec.CBOR.Decoding (Decoder) import Codec.CBOR.Encoding (Encoding) import qualified Codec.CBOR.Encoding as CBOR +import Codec.Serialise (Serialise (..)) import Cardano.Binary import Cardano.Prelude (NoUnexpectedThunks (..)) @@ -77,7 +78,11 @@ import Ouroboros.Storage.ImmutableDB (BinaryInfo (..), HashInfo (..)) newtype ByronHash = ByronHash { unByronHash :: CC.HeaderHash } deriving stock (Eq, Ord, Show, Generic) deriving newtype (ToCBOR, FromCBOR, Condense) - deriving anyclass NoUnexpectedThunks + deriving anyclass (NoUnexpectedThunks) + +instance Serialise ByronHash where + decode = decodeByronHeaderHash + encode = encodeByronHeaderHash mkByronHash :: ABlockOrBoundaryHdr ByteString -> ByronHash mkByronHash = ByronHash . abobHdrHash diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Forge.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Forge.hs index 6f115050458..3034a9fe0b1 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Forge.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Forge.hs @@ -6,7 +6,7 @@ module Ouroboros.Consensus.Ledger.Byron.Forge ( forgeByronBlock , forgeRegularBlock -- * For testing purposes - , forgeGenesisEBB + , forgeEBB ) where import Control.Monad (void) @@ -50,15 +50,15 @@ forgeByronBlock -> [GenTx ByronBlock] -- ^ Txs to add in the block -> PBftIsLeader PBftCardanoCrypto -- ^ Leader proof ('IsLeader') -> m ByronBlock -forgeByronBlock cfg curSlot curNo prevHash txs isLeader = case prevHash of - GenesisHash -> return $ forgeGenesisEBB cfg curSlot - BlockHash _ -> forgeRegularBlock cfg curSlot curNo prevHash txs isLeader +forgeByronBlock = forgeRegularBlock -forgeGenesisEBB +forgeEBB :: NodeConfig ByronConsensusProtocol - -> SlotNo + -> SlotNo -- ^ Current slot + -> BlockNo -- ^ Current block number + -> ChainHash ByronBlock -- ^ Previous hash -> ByronBlock -forgeGenesisEBB cfg curSlot = +forgeEBB cfg curSlot curNo prevHash = mkByronBlock pbftEpochSlots . CC.Block.ABOBBoundary . reAnnotateBoundary protocolMagicId @@ -69,6 +69,11 @@ forgeGenesisEBB cfg curSlot = , pbftEpochSlots } = pbftExtConfig cfg + prevHeaderHash :: Either CC.Genesis.GenesisHash CC.Block.HeaderHash + prevHeaderHash = case prevHash of + GenesisHash -> Left pbftGenesisHash + BlockHash (ByronHash h) -> Right h + boundaryBlock :: CC.Block.ABoundaryBlock () boundaryBlock = CC.Block.ABoundaryBlock { @@ -80,9 +85,9 @@ forgeGenesisEBB cfg curSlot = boundaryHeader :: CC.Block.ABoundaryHeader () boundaryHeader = CC.Block.mkABoundaryHeader - (Left pbftGenesisHash) + prevHeaderHash epoch - (CC.Common.ChainDifficulty 0) + (coerce curNo) () where CC.Slot.EpochNumber epoch = diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Node.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Node.hs index 7972305da26..a394f0fee57 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Node.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Node.hs @@ -52,7 +52,7 @@ import Ouroboros.Network.Protocol.ChainSync.PipelineDecision (pipelineDecisionLowHighMark) import Ouroboros.Network.Socket (ConnectionId) -import Ouroboros.Consensus.Block (BlockProtocol) +import Ouroboros.Consensus.Block (BlockProtocol, getHeader) import Ouroboros.Consensus.BlockchainTime import Ouroboros.Consensus.ChainSyncClient (ClockSkew (..)) import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState) @@ -244,7 +244,7 @@ mkChainDbArgs tracer registry btime dbPath cfg initLedger , ChainDB.cdbGenesis = return initLedger , ChainDB.cdbAddHdrEnv = nodeAddHeaderEnvelope (Proxy @blk) , ChainDB.cdbDiskPolicy = defaultDiskPolicy secParam - , ChainDB.cdbIsEBB = nodeIsEBB + , ChainDB.cdbIsEBB = nodeIsEBB . getHeader , ChainDB.cdbCheckIntegrity = nodeCheckIntegrity cfg , ChainDB.cdbParamsLgrDB = ledgerDbDefaultParams secParam , ChainDB.cdbNodeConfig = cfg diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/Abstract.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/Abstract.hs index aa6455b7dad..b3d4745b5cb 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/Abstract.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/Abstract.hs @@ -45,7 +45,7 @@ class (ProtocolLedgerView blk, ApplyTx blk) => RunNode blk where nodeBlockMatchesHeader :: Header blk -> blk -> Bool nodeBlockFetchSize :: Header blk -> SizeInBytes - nodeIsEBB :: blk -> Maybe EpochNo + nodeIsEBB :: Header blk -> Maybe EpochNo nodeEpochSize :: Monad m => Proxy blk -> NodeConfig (BlockProtocol blk) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/Byron.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/Byron.hs index 70dde3d9bcb..33f07f37402 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/Byron.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/Byron.hs @@ -16,6 +16,7 @@ import Ouroboros.Network.Magic (NetworkMagic (..)) import Ouroboros.Consensus.BlockchainTime (SystemStart (..)) import Ouroboros.Consensus.Ledger.Byron +import qualified Ouroboros.Consensus.Ledger.Byron.Auxiliary as Aux import Ouroboros.Consensus.Node.Run.Abstract import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.PBFT @@ -30,13 +31,12 @@ instance RunNode ByronBlock where nodeForgeBlock = forgeByronBlock nodeBlockMatchesHeader = verifyBlockMatchesHeader nodeBlockFetchSize = const 2000 -- TODO #593 - nodeIsEBB = \blk -> case byronBlockRaw blk of - Cardano.Block.ABOBBlock _ -> Nothing - Cardano.Block.ABOBBoundary ebb -> Just - . EpochNo - . Cardano.Block.boundaryEpoch - . Cardano.Block.boundaryHeader - $ ebb + nodeIsEBB = \hdr -> case byronHeaderRaw hdr of + Aux.ABOBBlockHdr _ -> Nothing + Aux.ABOBBoundaryHdr bhdr -> Just + . EpochNo + . Cardano.Block.boundaryEpoch + $ bhdr -- The epoch size is fixed and can be derived from @k@ by the ledger -- ('kEpochSlots'). diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Node/Tracers.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Node/Tracers.hs index 0004b4ba67c..643225ab966 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Node/Tracers.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Node/Tracers.hs @@ -103,8 +103,12 @@ showTracers tr = Tracers -- | Trace the forging of a block as a slot leader. data TraceForgeEvent blk tx + -- | The node will soon forge; it is about to read its transactions and + -- current DB. + = TraceForgeAboutToLead SlotNo + -- | The forged block and at which slot it was forged. - = TraceForgeEvent SlotNo blk + | TraceForgeEvent SlotNo blk -- | 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 diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/NodeKernel.hs b/ouroboros-consensus/src/Ouroboros/Consensus/NodeKernel.hs index 7a54b590b34..7f5bcb0c565 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/NodeKernel.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/NodeKernel.hs @@ -54,6 +54,7 @@ import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Mempool import Ouroboros.Consensus.Mempool.TxSeq (TicketNo) +import Ouroboros.Consensus.Node.Run (RunNode (..)) import Ouroboros.Consensus.Node.Tracers import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Util (whenJust) @@ -146,10 +147,9 @@ data NodeArgs m peer blk = NodeArgs { initNodeKernel :: forall m peer blk. ( IOLike m - , ProtocolLedgerView blk + , RunNode blk , NoUnexpectedThunks peer , Ord peer - , ApplyTx blk ) => NodeArgs m peer blk -> m (NodeKernel m peer blk) @@ -297,7 +297,7 @@ data LeaderResult blk = forkBlockProduction :: forall m peer blk. - (IOLike m, ProtocolLedgerView blk, ApplyTx blk) + (IOLike m, RunNode blk) => Word32 -- ^ Max block body size -> InternalState m peer blk -> BlockProduction m blk @@ -311,6 +311,7 @@ forkBlockProduction maxBlockBodySize IS{..} BlockProduction{..} = let withTxs :: (MempoolSnapshot blk TicketNo -> STM m a) -> m a withTxs = withSyncState mempool (TxsForBlockInSlot currentSlot) + trace $ TraceForgeAboutToLead currentSlot leaderResult <- withTxs $ \MempoolSnapshot{snapshotTxsForSize} -> do l@ExtLedgerState{..} <- ChainDB.getCurrentLedger chainDB let txs = map fst (snapshotTxsForSize maxBlockBodySize) @@ -410,7 +411,12 @@ forkBlockProduction maxBlockBodySize IS{..} BlockProduction{..} = GT -> error "prevPointAndBlockNo: block in future" -- The block at the tip has the same slot as the block we're going -- to produce (@slot@), so look at the block before it. - EQ | _ :> hdr' <- c' + EQ + | Just{} <- nodeIsEBB hdr + -- We allow forging a block that is the successor of an EBB in + -- the same slot. + -> (headerPoint hdr, blockNo hdr) + | _ :> hdr' <- c' -> (headerPoint hdr', blockNo hdr') | otherwise -- If there is no block before it, so use genesis. diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Abstract.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Abstract.hs index 07df800d906..ec9c15737c2 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Abstract.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Abstract.hs @@ -42,8 +42,7 @@ import GHC.Stack import Cardano.Prelude (NoUnexpectedThunks) -import Ouroboros.Network.Block (HasHeader (..), SlotNo (..)) -import Ouroboros.Network.Point (WithOrigin) +import Ouroboros.Network.Block (HasHeader (..), Point, SlotNo (..)) import Ouroboros.Consensus.BlockchainTime.SlotLengths import Ouroboros.Consensus.Util.Random @@ -157,7 +156,7 @@ class ( Show (ChainState p) -> hdr -- ^ Tip of the candidate -> Bool - -- | Compare two candidates + -- | Compare two candidates, both of which we prefer to our own chain -- -- PRECONDITION: both candidates must be preferred to our own chain compareCandidates :: CanSelect p hdr => NodeConfig p -> hdr -> hdr -> Ordering @@ -188,10 +187,10 @@ class ( Show (ChainState p) -- blocks. -- -- This function should attempt to rewind the chain state to the state at some - -- given slot, or Origin to rewind to the state with no blocks. + -- given point. -- - -- PRECONDITION: the slot to rewind to must correspond to the slot of a - -- header (or 'Origin') that was previously applied to the chain state using + -- PRECONDITION: the point to rewind to must correspond to a header (or + -- 'GenesisPoint') that was previously applied to the chain state using -- 'applyChainState'. -- -- Rewinding the chain state is intended to be used when switching to a @@ -206,28 +205,21 @@ class ( Show (ChainState p) -- state). For example, rewinding a chain state by @i@ blocks and then -- rewinding that chain state again by @j@ where @i + j > k@ is not possible -- and will yield 'Nothing'. - rewindChainState :: NodeConfig p + rewindChainState :: CanValidate p hdr + => NodeConfig p -> ChainState p - -> WithOrigin SlotNo - -- ^ Slot to rewind to - -- - -- This should be the state at the /end/ of the specified - -- slot (i.e., after the block in that slot, if any, has - -- been applied). + -> Point hdr -- ^ Point to rewind to -> Maybe (ChainState p) -- -- Default chain selection -- - -- The default simply compares length + -- The default preference uses the default comparison. The default comparison + -- simply uses the block number. -- - default preferCandidate :: HasHeader hdr - => NodeConfig p - -> hdr -- ^ Our chain - -> hdr -- ^ Candidate - -> Bool - preferCandidate _ ours cand = blockNo cand > blockNo ours + preferCandidate cfg ours cand = + compareCandidates cfg ours cand == LT default compareCandidates :: HasHeader hdr => NodeConfig p diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs index b1092d6b6bc..8906498c54c 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT.hs @@ -5,6 +5,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -39,6 +40,7 @@ import Control.Monad.Except import Crypto.Random (MonadRandom) import Data.Bimap (Bimap) import qualified Data.Bimap as Bimap +import Data.Proxy (Proxy (..)) import qualified Data.Set as Set import Data.Typeable (Typeable) import Data.Word (Word64) @@ -49,8 +51,10 @@ import qualified Cardano.Chain.Genesis as CC.Genesis import Cardano.Crypto.DSIGN.Class import Cardano.Prelude (NoUnexpectedThunks) -import Ouroboros.Network.Block (HasHeader (..), SlotNo (..)) -import Ouroboros.Network.Point (WithOrigin (At)) +import Ouroboros.Network.Block (pattern BlockPoint, + pattern GenesisPoint, HasHeader (..), HeaderHash, Point, + SlotNo (..)) +import Ouroboros.Network.Point (WithOrigin (..)) import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime @@ -60,6 +64,8 @@ import Ouroboros.Consensus.NodeId (CoreNodeId (..)) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.PBFT.ChainState (PBftChainState) import qualified Ouroboros.Consensus.Protocol.PBFT.ChainState as CS +import Ouroboros.Consensus.Protocol.PBFT.ChainState.HeaderHashBytes + (headerHashBytes) import Ouroboros.Consensus.Protocol.PBFT.Crypto import Ouroboros.Consensus.Util.Condense import Ouroboros.Consensus.Util.Orphans () @@ -91,6 +97,7 @@ instance (PBftCrypto c, Typeable toSign) => NoUnexpectedThunks (PBftFields c toS -- epoch boundary blocks (EBBs), which are unsigned. Of course the intention -- here is that 'headerPBftFields' will return 'Just' for regular blocks. class ( HasHeader hdr + , Serialise (HeaderHash hdr) , Signable (PBftDSIGN c) (OptSigned hdr) , BlockProtocol hdr ~ PBft cfg c ) => HeaderSupportsPBft cfg c hdr where @@ -213,7 +220,7 @@ instance ( PBftCrypto c => OuroborosTag (PBft cfg c) where type ValidationErr (PBft cfg c) = PBftValidationErr c type CanValidate (PBft cfg c) = HeaderSupportsPBft cfg c - type CanSelect (PBft cfg c) = HasHeader + type CanSelect (PBft cfg c) = HeaderSupportsPBft cfg c type NodeState (PBft cfg c) = () -- | We require two things from the ledger state: @@ -244,7 +251,7 @@ instance ( PBftCrypto c applyChainState cfg@PBftNodeConfig{..} lv@(PBftLedgerView dms) (b :: hdr) chainState = case headerPBftFields pbftExtConfig b of Nothing -> do - return $! appendEBB cfg params (blockSlot b) chainState + return $! appendEBB cfg params b chainState Just (PBftFields{..}, signed) -> do -- Check that the issuer signature verifies, and that it's a delegate of a -- genesis key, and that genesis key hasn't voted too many times. @@ -276,6 +283,22 @@ instance ( PBftCrypto c where params = pbftWindowParams cfg + compareCandidates PBftNodeConfig{..} lHdr rHdr = + -- Prefer the highest block number, as it is a proxy for chain length + case blockNo lHdr `compare` blockNo rHdr of + LT -> LT + GT -> GT + -- If the block numbers are the same, check if one of them is an EBB. + -- An EBB has the same block number as the block before it, so the + -- chain ending with an EBB is actually longer than the one ending + -- with a regular block. Note that 'headerPBftFields' returns + -- 'Nothing' for an EBB. + EQ -> + let score hdr = case headerPBftFields pbftExtConfig hdr of + Nothing -> 1 :: Int -- favor EBBs + Just{} -> 0 + in score lHdr `compare` score rHdr + {------------------------------------------------------------------------------- Internal: thin wrapper on top of 'PBftChainState' -------------------------------------------------------------------------------} @@ -338,26 +361,32 @@ append PBftNodeConfig{..} PBftWindowParams{..} = where PBftParams{..} = pbftParams -appendEBB :: PBftCrypto c +appendEBB :: forall cfg c hdr. + (PBftCrypto c, HeaderSupportsPBft cfg c hdr) => NodeConfig (PBft cfg c) -> PBftWindowParams - -> SlotNo + -> hdr -> PBftChainState c -> PBftChainState c -appendEBB PBftNodeConfig{..} PBftWindowParams{..} = +appendEBB PBftNodeConfig{..} PBftWindowParams{..} b = CS.appendEBB pbftSecurityParam windowSize + (blockSlot b) (headerHashBytes (Proxy :: Proxy hdr) (blockHash b)) where PBftParams{..} = pbftParams -rewind :: PBftCrypto c +rewind :: forall cfg c hdr. + (PBftCrypto c, HeaderSupportsPBft cfg c hdr) => NodeConfig (PBft cfg c) -> PBftWindowParams - -> WithOrigin SlotNo + -> Point hdr -> PBftChainState c -> Maybe (PBftChainState c) -rewind PBftNodeConfig{..} PBftWindowParams{..} = - CS.rewind pbftSecurityParam windowSize +rewind PBftNodeConfig{..} PBftWindowParams{..} p = + CS.rewind pbftSecurityParam windowSize p' where PBftParams{..} = pbftParams + p' = case p of + GenesisPoint -> Origin + BlockPoint s hh -> At (s, headerHashBytes (Proxy :: Proxy hdr) hh) {------------------------------------------------------------------------------- Extract necessary context diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT/ChainState.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT/ChainState.hs index 49ed5693926..1dc5f405a3d 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT/ChainState.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT/ChainState.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -26,7 +27,8 @@ module Ouroboros.Consensus.Protocol.PBFT.ChainState ( , countSignedBy , lastSignedSlot -- * Support for tests - , EbbMap (..) + , MaybeEbbInfo (..) + , EbbInfo (..) , PBftSigner(..) , invariant , fromList @@ -59,6 +61,7 @@ import Ouroboros.Network.Point (WithOrigin (..), withOriginFromMaybe, withOriginToMaybe) import Ouroboros.Consensus.Protocol.Abstract +import Ouroboros.Consensus.Protocol.PBFT.ChainState.HeaderHashBytes import Ouroboros.Consensus.Protocol.PBFT.Crypto import Ouroboros.Consensus.Util (repeatedly) @@ -137,34 +140,48 @@ data PBftChainState c = PBftChainState { -- | Cached counts of the signatures in the window , counts :: !(Map (PBftVerKeyHash c) Word64) - -- | Map from slots of relevant epoch boundary blocks (EBBs) to signed - -- slots + -- | Info about a relevant EBB, if any -- -- EBBs are not signed, so the 'preAnchor', 'postAnchor', 'preWindow', -- and 'postWindow' fields are unaffected by EBBs. However, EBBs must - -- also be valid targets for 'rewind', so this field maps each slot that + -- also be valid targets for 'rewind', so this field maps a slot that -- contains an EBB to the preceding signed slot, /if/ that signed slot is -- still a valid target for 'rewind'. -- - -- See INVARIANTs on 'EbbMap'. + -- By assumption, there can be at most one EBB relevant to the @n + k@ + -- window. Current choices that justify this assumption: -- - -- INVARIANT For all @(ebbSlot, mSlot)@ in @'ebbs' (cs :: 'ChainState')@, + -- * The real nodes currently pervasively require that every chain + -- includes at least @k@ signed blocks in every span of @2k@ slots. -- - -- * @mSlot >= anchorSlot cs@; see 'pruneEBBsLT' + -- * The real nodes are currently configured such that epochs to have a + -- duration of @10k@ slots (so EBBs are @10k@ slots apart). -- - -- * @'At' ebbSlot <= tgt@ if @cs@ is the result of a 'rewind' to @tgt@; + -- * The PBFT window size @n@ is currently @k@. + -- + -- * Thus we crucially have that @n + k < 10k@. + -- + -- See INVARIANTs on 'MaybeEbbInfo'. + -- + -- INVARIANT For all @EbbInfo{eiSlot, eiPrevSlot)@ in @'ebbs' (cs :: + -- 'ChainState')@, + -- + -- * @eiPrevSlot >= anchorSlot cs@ or @At eiSlot == anchorSlot cs@; see + -- 'pruneEBBsLT' + -- + -- * @'At' eiSlot <= tgt@ if @cs@ is the result of a 'rewind' to @tgt@; -- see 'pruneEBBsGT' -- - -- * @and [ At s <= mSlot | s <- precedingSignedSlots ]@ + -- * @and [ At s <= eiPrevSlot | s <- precedingSignedSlots ]@ -- - -- * @'rewind' k n ('At' ebbSlot) cs = 'rewind' k n mSlot cs@ + -- * @'rewind' k n ('At' eiSlot) cs = 'rewind' k n eiPrevSlot cs@ -- -- where -- - -- * @precedingSignedSlots = filter (< ebbSlot) signedSlots@ + -- * @precedingSignedSlots = filter (< eiSlot) signedSlots@ -- -- * @signedSlots = 'pbftSignerSlotNo' <$> ('preAnchor' <> 'postAnchor')@ - , ebbs :: !EbbMap + , ebbs :: !MaybeEbbInfo } deriving (Generic) @@ -210,7 +227,8 @@ invariant (SecurityParam k) unless (computeCounts inWindow == counts) $ failure "Cached counts incorrect" - unless (allEbbs $ \_ mSlot -> mSlot >= anchorSlot st) $ + unless (allEbbs $ \slot mSlot -> At slot == anchorSlot st || + mSlot >= anchorSlot st) $ failure "EBB mapped to slot before anchor" unless (allEbbs $ \slot mSlot -> @@ -222,21 +240,16 @@ invariant (SecurityParam k) ) $ failure "EBB does not map to the preceding signature" - -- 'EbbMap''s "Key greater" + -- 'MaybeEbbInfo''s "Key greater" unless (allEbbs $ \slot mSlot -> At slot > mSlot) $ failure "EBB mapped to a simultaneous or future slot" - - -- 'EbbMap''s "Non-descending" - unless (let nonDescending es = and $ zipWith (<=) es (tail es) - in nonDescending $ map snd $ Map.toAscList $ unEbbMap ebbs) $ - failure $ "EBB mappings are not non-descending" where failure :: String -> Except String () failure err = throwError $ err ++ ": " ++ show st - allEbbs p = - Map.null $ - Map.filterWithKey (\slot mSlot -> not (p slot mSlot)) (unEbbMap ebbs) + allEbbs p = case ebbs of + NothingEbbInfo -> True + JustEbbInfo EbbInfo{..} -> p eiSlot eiPrevSlot -- | The 'PBftChainState' tests don't rely on this flag but check the -- invariant manually. This flag is here so that the invariant checks could be @@ -353,15 +366,15 @@ append :: forall c. PBftCrypto c -> PBftChainState c -> PBftChainState c append k n signer@(PBftSigner _ gk) PBftChainState{..} = assertInvariant k n $ + pruneEBBsLT $ PBftChainState { preAnchor = preAnchor' , postAnchor = postAnchor' , preWindow = preWindow' , inWindow = inWindow' , counts = updateCounts counts - -- NOTE: 'pruneEBBsLT' is inlined here to avoid a strange space leak - -- that also goes away with @-O0@, see #1356. - , ebbs = EbbMap $ Map.filter (>= anchorSlot') (unEbbMap ebbs) + -- Will be pruned by the enclosing call to 'pruneEBBsLT' + , ebbs = ebbs } where (preAnchor', postAnchor') = @@ -382,19 +395,19 @@ append k n signer@(PBftSigner _ gk) PBftChainState{..} = , incrementKey gk ) - anchorSlot' = case preAnchor' of - _ :|> anchorSigner -> At (pbftSignerSlotNo anchorSigner) - _otherwise -> Origin - -- | Rewind the state to the specified slot -- -- This matches the semantics of 'rewindChainState' in 'OuroborosTag', in that --- this should be the state at the /end/ of the specified slot (i.e., after the --- block in that slot, if any, has been applied). +-- this should be the state after the given point. -- --- NOTE: It only makes sense to rewind to a slot containing a block that we have --- previously applied (the "genesis block" can be understood as having been --- implicitly applied). +-- NOTE: It only makes sense to rewind to a slot containing a block that we +-- have previously applied (the "genesis block" can be understood as having +-- been implicitly applied). HOWEVER, this function does not check this +-- precondition: it only uses the provided header hash to check if the +-- requested point is an EBB that was previously applied. If the header hash is +-- just random bytes, then the function will assume the target is a signed +-- block in the slot, without trying to confirm the signed block's header hash +-- matches that of the request. -- -- In addition to preserving the invariant, we also have the guarantee that -- rolling back to a point (within @k@) and then reapplying the blocks that were @@ -402,22 +415,25 @@ append k n signer@(PBftSigner _ gk) PBftChainState{..} = rewind :: forall c. PBftCrypto c => SecurityParam -> WindowSize - -> WithOrigin SlotNo + -> WithOrigin (SlotNo, HeaderHashBytes) + -- ^ the target \"point\"; see 'EbbInfo' -> PBftChainState c -> Maybe (PBftChainState c) -rewind k n mSlot cs@PBftChainState{..} = - case rewind_ k n mSlot cs of - Right mbCs' -> pruneEBBsGT mSlot <$> mbCs' - Left mSlot' -> - error $ "rewind: rollback to block not previously applied, " - ++ show (mSlot, mSlot', ebbs) +rewind k n p cs@PBftChainState{..} = case p of + Origin -> go Origin + At (slot, hashBytes) -> case ebbsLookup slot ebbs of + Just EbbInfo{..} + | hashBytes == eiHashBytes -> go eiPrevSlot + _ -> go (At slot) + where + go mSlot = pruneEBBsGT (fst <$> p) <$> rewind_ k n mSlot cs -- | Internal worker for 'rewind' rewind_ :: forall c. PBftCrypto c => SecurityParam -> WindowSize -> WithOrigin SlotNo - -> PBftChainState c -> Either SlotNo (Maybe (PBftChainState c)) -rewind_ k n mSlot cs@PBftChainState{..} = + -> PBftChainState c -> Maybe (PBftChainState c) +rewind_ k n mSlot PBftChainState{..} = case mSlot of At slot -> -- We scan from the right, since block to roll back to likely at end @@ -427,7 +443,7 @@ rewind_ k n mSlot cs@PBftChainState{..} = -- after that slot. (toDiscard, toKeep@(_ :|> x)) -> if slot == pbftSignerSlotNo x - then Right $ Just $ go toDiscard toKeep + then Just $ go toDiscard toKeep else notFound slot -- The slot was not found post-anchor. If the slot matches the last @@ -436,7 +452,7 @@ rewind_ k n mSlot cs@PBftChainState{..} = (toDiscard, Empty) -> case preAnchor of _ :|> x - | slot == pbftSignerSlotNo x -> Right $ Just $ go toDiscard Empty + | slot == pbftSignerSlotNo x -> Just $ go toDiscard Empty | slot < pbftSignerSlotNo x -> rollbackTooFar | otherwise -> notFound slot Empty -> notFound slot @@ -447,18 +463,18 @@ rewind_ k n mSlot cs@PBftChainState{..} = -- have more than @k@ blocks, the pre-anchor will not be empty. Origin -> case preAnchor of - Empty -> Right $ Just $ go postAnchor Empty + Empty -> Just $ go postAnchor Empty _otherwise -> rollbackTooFar where -- If we didn't find a non-EBB, check if the slot was known to have an EBB. -- If so, recur (just once, as long as 'ebbs' is well-formed). - notFound :: SlotNo -> Either SlotNo (Maybe (PBftChainState c)) - notFound slot = case ebbsLookup slot ebbs of - Just mSlot' -> rewind_ k n mSlot' cs - Nothing -> Left slot + notFound :: forall a. SlotNo -> a + notFound slot = + error $ "rewind: rollback to block not previously applied, " + ++ show slot - rollbackTooFar :: Either x (Maybe y) - rollbackTooFar = Right Nothing + rollbackTooFar :: Maybe y + rollbackTooFar = Nothing -- Construct new state, given the remaining post-anchor signatures -- @@ -519,7 +535,7 @@ prune (SecurityParam n) (WindowSize k) (xs, ys) = Conversion -------------------------------------------------------------------------------} -toList :: PBftChainState c -> (WithOrigin SlotNo, StrictSeq (PBftSigner c), EbbMap) +toList :: PBftChainState c -> (WithOrigin SlotNo, StrictSeq (PBftSigner c), MaybeEbbInfo) toList PBftChainState{..} = ( case preAnchor of Empty -> Origin @@ -531,7 +547,7 @@ toList PBftChainState{..} = ( fromList :: PBftCrypto c => SecurityParam -> WindowSize - -> (WithOrigin SlotNo, StrictSeq (PBftSigner c), EbbMap) + -> (WithOrigin SlotNo, StrictSeq (PBftSigner c), MaybeEbbInfo) -> PBftChainState c fromList k n (anchor, signers, ebbs) = assertInvariant k n $ @@ -551,18 +567,24 @@ fromList k n (anchor, signers, ebbs) = serializationFormatVersion1 :: Word8 serializationFormatVersion1 = 1 + +serializationFormatVersion2 :: Word8 +serializationFormatVersion2 = 2 -- CHANGELOG -- -- Version 0 is 2 fields, the anchor and the window. Note that it does not -- have the version marker. -- - -- Version 1 has 4 fields, the version marker, anchor, window, and EbbMap. + -- Version 1 has 4 fields, the version marker, anchor, window, and @~(Map + -- SlotNo (WithOrigin SlotNo))@. + -- + -- Version 2 has 4 fields, the version marker, anchor, window, and @~(Maybe EbbInfo)@. encodePBftChainState :: (PBftCrypto c, Serialise (PBftVerKeyHash c)) => PBftChainState c -> Encoding encodePBftChainState st@PBftChainState{..} = mconcat [ Serialise.encodeListLen 4 - , encode serializationFormatVersion1 + , encode serializationFormatVersion2 , encode (withOriginToMaybe anchor) , encode signers , encode ebbs' @@ -579,14 +601,21 @@ decodePBftChainState k n = Serialise.decodeListLen >>= \case anchor <- withOriginFromMaybe <$> decode signers <- decode return $ fromList k n (anchor, signers, ebbsEmpty) - 4 -> do -- Version is >0 - v <- decode - unless (v == serializationFormatVersion1) $ error $ - "decode list length is 4, but version is not 1: " ++ show v - anchor <- withOriginFromMaybe <$> decode - signers <- decode - ebbs' <- decode - return $ fromList k n (anchor, signers, ebbs') + 4 -> decode >>= \v -> if + | v == serializationFormatVersion1 -> do + anchor <- withOriginFromMaybe <$> decode + signers <- decode + ebbs' <- decode + let _ = ebbs' :: Map SlotNo (WithOrigin SlotNo) + -- NB we discard ebbs' + return $ fromList k n (anchor, signers, ebbsEmpty) + | v == serializationFormatVersion2 -> do + anchor <- withOriginFromMaybe <$> decode + signers <- decode + ebbs' <- decode + return $ fromList k n (anchor, signers, ebbs') + | otherwise -> + error $ "unexpected serialisation format version: " <> show v o -> error $ "unexpected list length: " <> show o instance Serialise (PBftVerKeyHash c) => Serialise (PBftSigner c) where @@ -609,53 +638,90 @@ appendEBB :: forall c. (PBftCrypto c, HasCallStack) => SecurityParam -> WindowSize -> SlotNo + -> HeaderHashBytes -> PBftChainState c -> PBftChainState c -appendEBB k n newEbbSlot cs@PBftChainState{..} = +appendEBB k n newEbbSlot hashBytes cs@PBftChainState{..} = assertInvariant k n $ Exn.assert valid $ - cs{ebbs = ebbsInsert newEbbSlot latestNonEbbSlot ebbs} + cs{ebbs = JustEbbInfo EbbInfo + { eiSlot = newEbbSlot + , eiHashBytes = hashBytes + , eiPrevSlot = latestNonEbbSlot + }} where latestEbbSlot = ebbsMax ebbs latestNonEbbSlot = lastSignedSlot cs valid = At newEbbSlot > max latestEbbSlot latestNonEbbSlot --- | Discard 'ebbs' mappings whose /value/ is before the anchor +-- | Discard 'ebbs' mappings whose 'eiPrevSlot' is before the anchor, except +-- if its 'eiSlot' is equal to the anchor's slot -- -- Called by 'append', since 'ebbs' do not increase how far back the chain --- state can rewind. +-- state can rewind. However, we must retain the EBB that shares a slot with +-- the anchor so that we can fail if we attempt to rewind to it -- if we forget +-- about that EBB, then we won't be able to recognize its hash in the requested +-- rewind point. pruneEBBsLT :: PBftChainState c -> PBftChainState c pruneEBBsLT cs@PBftChainState{..} = - cs{ebbs = EbbMap $ Map.filter (>= anchorSlot cs) (unEbbMap ebbs)} - --- | Discard 'ebbs' mappings whose /key/ is after the given slot + cs{ ebbs = ebbsFilter ebbs $ \EbbInfo{..} -> + eiPrevSlot >= anchorSlot cs || + At eiSlot == anchorSlot cs } +-- NOTE: this INLINE seems redundant but we add it here to avoid a strange +-- space leak that also goes away with @-O0@, see #1356. +{-# INLINE pruneEBBsLT #-} + +-- | Discard 'ebbs' mappings whose 'eiSlot' is after the given slot -- -- Called by 'rewind', since 'rewind'ing to a slot should forget the EBBs it -- precedes. pruneEBBsGT :: WithOrigin SlotNo -> PBftChainState c -> PBftChainState c pruneEBBsGT mSlot cs@PBftChainState{..} = - cs{ ebbs = - EbbMap $ Map.filterWithKey (\s _ -> At s <= mSlot) (unEbbMap ebbs) - } + cs{ ebbs = ebbsFilter ebbs $ \EbbInfo{..} -> At eiSlot <= mSlot } --- | A map from the slots containing an EBB to the preceding signed slot +-- | Info about the latest EBB, if there is one recent enough to be relevant to +-- the chain state -- --- INVARIANT Key greater: For all @(k, v)@, @At k > v@. --- --- INVARIANT Non-descending: For all @(k1, v1)@ and @(k2, v2)@, @k1 < k2@ --- implies @v1 <= v2@. -newtype EbbMap = EbbMap {unEbbMap :: Map SlotNo (WithOrigin SlotNo)} - deriving stock (Generic, Show) - deriving newtype (Eq, Ord, NoUnexpectedThunks, Serialise) - -ebbsEmpty :: EbbMap -ebbsEmpty = EbbMap Map.empty - -ebbsInsert :: SlotNo -> WithOrigin SlotNo -> EbbMap -> EbbMap -ebbsInsert k v = EbbMap . Map.insert k v . unEbbMap +data MaybeEbbInfo + = NothingEbbInfo + | JustEbbInfo !EbbInfo + deriving stock (Eq, Generic, Ord, Show) + deriving anyclass (NoUnexpectedThunks, Serialise) -ebbsMax :: EbbMap -> WithOrigin SlotNo -ebbsMax = maybe Origin (At . fst) . Map.lookupMax . unEbbMap - -ebbsLookup :: SlotNo -> EbbMap -> Maybe (WithOrigin SlotNo) -ebbsLookup k = Map.lookup k . unEbbMap +-- | Info about an EBB +-- +-- The serialised bytes of the EBB's header hash and its latest previous signed +-- slot. We use 'HeaderHashBytes' instead of the EBB's actual @HeaderHash@ +-- because the 'ChainState' type family (which we instantiate as +-- 'PBftChainState') does not take a type argument that to which we can apply +-- @HeaderHash@. This is a compromise. +-- +-- INVARIANT @At 'eiSlot' > 'eiPrevSlot'@ +data EbbInfo = EbbInfo + { eiSlot :: !SlotNo + -- ^ the slot of the EBB + , eiHashBytes :: !HeaderHashBytes + -- ^ the bytes of the serialised header hash of the EBB + , eiPrevSlot :: !(WithOrigin SlotNo) + -- ^ the slot of the latest non-EBB that precedes the EBB + } + deriving stock (Eq, Generic, Ord, Show) + deriving anyclass (NoUnexpectedThunks, Serialise) + +ebbsEmpty :: MaybeEbbInfo +ebbsEmpty = NothingEbbInfo + +ebbsMax :: MaybeEbbInfo -> WithOrigin SlotNo +ebbsMax = \case + NothingEbbInfo -> Origin + JustEbbInfo EbbInfo{..} -> At eiSlot + +ebbsLookup :: SlotNo -> MaybeEbbInfo -> Maybe EbbInfo +ebbsLookup k = \case + NothingEbbInfo -> Nothing + JustEbbInfo ei@EbbInfo{..} -> if eiSlot == k then Just ei else Nothing + +ebbsFilter :: MaybeEbbInfo -> (EbbInfo -> Bool) -> MaybeEbbInfo +ebbsFilter x f = case x of + NothingEbbInfo -> NothingEbbInfo + JustEbbInfo ei -> if f ei then x else NothingEbbInfo diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT/ChainState/HeaderHashBytes.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT/ChainState/HeaderHashBytes.hs new file mode 100644 index 00000000000..fcbbb3f9ec9 --- /dev/null +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT/ChainState/HeaderHashBytes.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | A type in which each value is the byte serialisation of a header hash. +-- +-- This is an implementation detail of +-- "Ouroboros.Consensus.Protocol.PBFT.ChainState". +module Ouroboros.Consensus.Protocol.PBFT.ChainState.HeaderHashBytes ( + HeaderHashBytes, + headerHashBytes, + -- * For testing + mkHeaderHashBytesForTestingOnly, + ) where + +import Codec.Serialise (Serialise (..), serialise) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import GHC.Generics (Generic) + +import Cardano.Prelude (NoUnexpectedThunks) + +import Ouroboros.Network.Block (HeaderHash) + +newtype HeaderHashBytes = HeaderHashBytes BS.ByteString + deriving stock (Generic, Show) + deriving newtype (Eq, Ord, NoUnexpectedThunks, Serialise) + +-- | The safe way to construct 'HeaderHashBytes' +headerHashBytes + :: Serialise (HeaderHash hdr) + => proxy hdr -> HeaderHash hdr -> HeaderHashBytes +headerHashBytes _ = HeaderHashBytes . BSL.toStrict . serialise + +mkHeaderHashBytesForTestingOnly :: BSL.ByteString -> HeaderHashBytes +mkHeaderHashBytesForTestingOnly = HeaderHashBytes . BSL.toStrict diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Praos.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Praos.hs index 405052d13ab..a3b90912882 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Praos.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Praos.hs @@ -58,7 +58,8 @@ import Cardano.Crypto.VRF.Mock (MockVRF) import Cardano.Crypto.VRF.Simple (SimpleVRF) import Cardano.Prelude (NoUnexpectedThunks (..)) -import Ouroboros.Network.Block (HasHeader (..), SlotNo (..)) +import Ouroboros.Network.Block (HasHeader (..), SlotNo (..), + pointSlot) import Ouroboros.Network.Point (WithOrigin (At)) import Ouroboros.Consensus.Block @@ -331,7 +332,7 @@ instance ( PraosCrypto c -- filled; instead we roll back the the block just before it. rewindChainState PraosNodeConfig{..} cs rewindTo = -- This may drop us back to the empty list if we go back to genesis - Just $ dropWhile (\bi -> At (biSlot bi) > rewindTo) cs + Just $ dropWhile (\bi -> At (biSlot bi) > pointSlot rewindTo) cs -- (Standard) Praos uses the standard chain selection rule, so no need to -- override (though see note regarding clock skew). diff --git a/ouroboros-consensus/test-consensus/Test/Consensus/Ledger/Byron.hs b/ouroboros-consensus/test-consensus/Test/Consensus/Ledger/Byron.hs index 02f3233246f..291102e96b2 100644 --- a/ouroboros-consensus/test-consensus/Test/Consensus/Ledger/Byron.hs +++ b/ouroboros-consensus/test-consensus/Test/Consensus/Ledger/Byron.hs @@ -17,6 +17,7 @@ import Control.Monad.Except (runExcept) import qualified Data.Binary.Get as Get import qualified Data.Binary.Put as Put import qualified Data.ByteString.Lazy as Lazy +import qualified Data.ByteString.Lazy.Char8 as Lazy8 import qualified Data.Sequence.Strict as Seq import Cardano.Binary (fromCBOR, toCBOR) @@ -27,18 +28,20 @@ import Cardano.Chain.Slotting (EpochSlots (..)) import qualified Cardano.Chain.Update as CC.Update import Cardano.Crypto (ProtocolMagicId (..)) -import Ouroboros.Network.Block (HeaderHash) +import Ouroboros.Network.Block (HeaderHash, SlotNo) import Ouroboros.Network.Point (WithOrigin (At)) -import Ouroboros.Consensus.Block (Header) +import Ouroboros.Consensus.Block (BlockProtocol, Header) import Ouroboros.Consensus.Ledger.Byron import Ouroboros.Consensus.Ledger.Byron.Auxiliary import qualified Ouroboros.Consensus.Ledger.Byron.DelegationHistory as DH import Ouroboros.Consensus.Mempool.API (ApplyTxErr) import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.Protocol -import Ouroboros.Consensus.Protocol.Abstract (SecurityParam (..)) +import Ouroboros.Consensus.Protocol.Abstract (ChainState, + SecurityParam (..)) import qualified Ouroboros.Consensus.Protocol.PBFT.ChainState as CS +import Ouroboros.Consensus.Protocol.PBFT.ChainState.HeaderHashBytes import Ouroboros.Storage.ImmutableDB (BinaryInfo (..), HashInfo (..)) @@ -46,6 +49,7 @@ import Test.QuickCheck import Test.QuickCheck.Hedgehog (hedgehog) import Test.Tasty import Test.Tasty.Golden +import Test.Tasty.HUnit import Test.Tasty.QuickCheck import qualified Test.Cardano.Chain.Block.Gen as CC @@ -85,6 +89,9 @@ tests = testGroup "Byron" -- Note that for most Byron types, we simply wrap the en/decoders from -- cardano-ledger, which already has golden tests for them. [ test_golden_ChainState + , test_golden_ChainState_backwardsCompat_version0 + , test_golden_ChainState_backwardsCompat_version1 + , test_golden_ChainState_backwardsCompat_version2 , test_golden_LedgerState , test_golden_GenTxId ] @@ -219,22 +226,64 @@ prop_byronHashInfo_hashSize h = Golden tests -------------------------------------------------------------------------------} +-- | Note that we must use the same value for the 'SecurityParam' as for the +-- 'CS.WindowSize', because 'decodeByronChainState' only takes the +-- 'SecurityParam' and uses it as the basis for the 'CS.WindowSize'. +secParam :: SecurityParam +secParam = SecurityParam 2 + +windowSize :: CS.WindowSize +windowSize = CS.WindowSize 2 + +exampleChainStateWithoutEBB, exampleChainStateWithEBB :: ChainState (BlockProtocol ByronBlock) +(exampleChainStateWithoutEBB, exampleChainStateWithEBB) = + (withoutEBB, withEBB) + where + signers = map (`CS.PBftSigner` CC.exampleKeyHash) [1..4] + + withoutEBB = CS.fromList + secParam + windowSize + (At 2, Seq.fromList signers, CS.NothingEbbInfo) + + -- info about an arbitrary hypothetical EBB + exampleEbbSlot :: SlotNo + exampleEbbHeaderHashBytes :: HeaderHashBytes + exampleEbbSlot = 6 + exampleEbbHeaderHashBytes = mkHeaderHashBytesForTestingOnly + (Lazy8.pack "test_golden_ChainState6") + + withEBB = CS.appendEBB secParam windowSize + exampleEbbSlot exampleEbbHeaderHashBytes + withoutEBB + test_golden_ChainState :: TestTree test_golden_ChainState = goldenTestCBOR "ChainState" encodeByronChainState - exampleChainState - "test-consensus/golden/cbor/byron/ChainState" - where - exampleChainState = CS.appendEBB secParam windowSize 6 $ - CS.fromList - secParam - windowSize - (At 3, Seq.fromList signers, CS.EbbMap mempty) - - secParam = SecurityParam 2 - windowSize = CS.WindowSize 3 - signers = map (`CS.PBftSigner` CC.exampleKeyHash) [1..5] + exampleChainStateWithEBB + "test-consensus/golden/cbor/byron/ChainState2" + +test_golden_ChainState_backwardsCompat_version0 :: TestTree +test_golden_ChainState_backwardsCompat_version0 = + testCase "ChainState version 0" $ goldenTestCBORBackwardsCompat + (decodeByronChainState secParam) + exampleChainStateWithoutEBB + "test-consensus/golden/cbor/byron/ChainState0" + +test_golden_ChainState_backwardsCompat_version1 :: TestTree +test_golden_ChainState_backwardsCompat_version1 = + testCase "ChainState version 1" $ goldenTestCBORBackwardsCompat + (decodeByronChainState secParam) + exampleChainStateWithoutEBB + "test-consensus/golden/cbor/byron/ChainState1" + +test_golden_ChainState_backwardsCompat_version2 :: TestTree +test_golden_ChainState_backwardsCompat_version2 = + testCase "ChainState version 2" $ goldenTestCBORBackwardsCompat + (decodeByronChainState secParam) + exampleChainStateWithEBB + "test-consensus/golden/cbor/byron/ChainState2" test_golden_LedgerState :: TestTree test_golden_LedgerState = goldenTestCBOR @@ -267,6 +316,25 @@ goldenTestCBOR name enc a path = where bs = toLazyByteString (enc a) +-- | Check whether we can successfully decode the contents of the given file. +-- This file will typically contain an older serialisation format. +goldenTestCBORBackwardsCompat + :: (Eq a, Show a) + => (forall s. Decoder s a) + -> a + -> FilePath + -> Assertion +goldenTestCBORBackwardsCompat dec a path = do + bytes <- Lazy.readFile path + case deserialiseFromBytes dec bytes of + Left failure + -> assertFailure (show failure) + Right (leftover, a') + | Lazy.null leftover + -> a' @?= a + | otherwise + -> assertFailure $ "Left-over bytes: " <> show leftover + {------------------------------------------------------------------------------- Integrity -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/test-consensus/Test/Consensus/Protocol/PBFT.hs b/ouroboros-consensus/test-consensus/Test/Consensus/Protocol/PBFT.hs index e731cb8f99e..14029be91e3 100644 --- a/ouroboros-consensus/test-consensus/Test/Consensus/Protocol/PBFT.hs +++ b/ouroboros-consensus/test-consensus/Test/Consensus/Protocol/PBFT.hs @@ -2,6 +2,8 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + module Test.Consensus.Protocol.PBFT ( tests -- * Used in the roundtrip tests @@ -12,7 +14,7 @@ import qualified Control.Exception as Exn import Data.Coerce (coerce) import Data.Functor ((<&>)) import Data.List (inits, tails) -import qualified Data.Map.Strict as Map +import Data.Proxy (Proxy (..)) import qualified Data.Sequence.Strict as Seq import Data.Word @@ -22,13 +24,14 @@ import Test.Tasty.QuickCheck import Cardano.Crypto.DSIGN import qualified Cardano.Prelude -import Ouroboros.Network.Block (SlotNo (..)) +import Ouroboros.Network.Block (HeaderHash, SlotNo (..)) import Ouroboros.Network.Point (WithOrigin (..)) import Ouroboros.Consensus.Protocol.Abstract -import Ouroboros.Consensus.Protocol.PBFT.ChainState (EbbMap (..), - PBftChainState) +import Ouroboros.Consensus.Protocol.PBFT.ChainState (EbbInfo (..), + MaybeEbbInfo (..), PBftChainState) import qualified Ouroboros.Consensus.Protocol.PBFT.ChainState as CS +import Ouroboros.Consensus.Protocol.PBFT.ChainState.HeaderHashBytes import Ouroboros.Consensus.Protocol.PBFT.Crypto import Ouroboros.Consensus.Util (lastMaybe, repeatedly) @@ -111,7 +114,7 @@ tests = testGroup "PBftChainState" $ -- The test properties themselves focus on the state @csABb@ defined by: -- -- > csAB = appendInputs (inA <> inB) empty --- > Just csABb = rewind (slotLatestInput (lastInput inA)) csAB +-- > Just csABb = rewind (pointLatestInput (lastInput inA)) csAB -- -- Segment A could be empty or have several times @k@ signed blocks interleaved -- with any number of EBBs. Segment B has @<= k@ signed blocks interleaved with @@ -128,7 +131,7 @@ tests = testGroup "PBftChainState" $ -- In particular, appending a sufficient prefix of segment C will always -- restore the invariants that were not ensured before PR #1307. -- --- * 'testChainRewind': +-- * 'testChainRewindPoint': -- -- Since @csABb@ is fully representative of a realistic state, we will test an -- arbitrary rewind from it. @@ -158,9 +161,9 @@ data TestChainState = TestChainState { , testChainOldState :: PBftChainState PBftMockCrypto -- | The slot of some input within segment A - , testChainRewind :: WithOrigin SlotNo + , testChainRewindPoint :: WithOrigin (SlotNo, HeaderHashBytes) - -- | The inputs in segment A occupying slots @> 'testChainRewind'@ + -- | The inputs in segment A after 'testChainRewindPoint' , testChainRewoundInputs :: Inputs PBftMockCrypto } deriving (Show) @@ -200,7 +203,7 @@ genTestChainState = do -- Generate all the inputs (inA, inB, inC) <- do - inA <- generateInputs genKey numSignersA (LatestInput Nothing) + inA <- generateInputs paramK paramN genKey numSignersA (LatestInput Nothing) -- Segment B must not begin with the same slot that A ended with, -- because rewinds can't split a slot and our tests focus on the result @@ -212,8 +215,8 @@ genTestChainState = do where tick (PBftEBB prev slot) = PBftEBB prev (succ slot) - inB <- generateInputs genKey numSignersB lastInputOfA' - inC <- generateInputs genKey (n + k) (toLastInput inA) + inB <- generateInputs paramK paramN genKey numSignersB lastInputOfA' + inC <- generateInputs paramK paramN genKey (n + k) (toLastInput inA) pure (inA, inB, inC) @@ -230,7 +233,8 @@ genTestChainState = do (signatureInputs inps) (ebbInputs inps) where - inps = snd $ splitAtSigner (numSignersA .- ((n + k) .- numSignersB)) inA + inps = + snd $ splitAtSigner (numSignersA .- ((n + k) .- numSignersB)) inA -- the state before PR #1307 didn't retain as many signatures and -- didn't track EBBs at all @@ -247,29 +251,26 @@ genTestChainState = do , choose (0, numSignersA) -- rollback that might fail (too far) ] - let (mbAPrefix, inSuffixA) = splitAtSigner (numSignersA .- numSignersSuffixA) inA - -- if the rollback succeeds, its new window ends with this signed slot - signedTarget = case mbAPrefix of - Nothing -> Origin - Just (_, x) -> At $ CS.pbftSignerSlotNo x + let (mbAPrefix, inSuffixA) = + splitAtSigner (numSignersA .- numSignersSuffixA) inA + -- if the rollback succeeds, its new window ends with this signed point + signedPoint = case mbAPrefix of + Nothing -> Origin + Just (_, x) -> + At (CS.pbftSignerSlotNo x, headerHashBytesInput (InputSigner x)) - -- Pick a slot to rewind to + -- Pick a point to rewind to -- -- appending the @rewoundInputs@ will undo the rewind to @rewindSlot@ - (rewindSlot, rewoundInputs) <- elements $ + (rewindPoint, rewoundInputs) <- elements $ [ Exn.assert (unInputs inSuffixA == int <> tal) $ - ( maybe signedTarget (At . slotInput) $ lastMaybe int + ( case lastMaybe int of + Nothing -> signedPoint + Just x -> At (slotInput x, headerHashBytesInput x) , Inputs tal ) | (int, tal) <- inits (unInputs inSuffixA) `zip` tails (unInputs inSuffixA) - -- this is ultimately picking a /slot/, so don't split between two - -- inputs that have the same slot - , case ( slotInput <$> lastMaybe int - , slotInput <$> Cardano.Prelude.head tal - ) of - (Just l, Just r) -> l /= r - _ -> True ] pure TestChainState { @@ -281,7 +282,7 @@ genTestChainState = do , testChainInputsA = inA , testChainInputsB = inB , testChainInputsC = inC - , testChainRewind = rewindSlot + , testChainRewindPoint = rewindPoint , testChainRewoundInputs = rewoundInputs } @@ -296,13 +297,19 @@ genMockKey numKeys = VerKeyMockDSIGN <$> choose (1, numKeys) -- -- POSTCONDITION The output contains exactly the specified number of -- 'InputSigner's. +-- +-- POSTCONDITION The 'InputEBB's in the output are separated by at least @n + +-- k@ signed blocks. generateInputs :: forall c. - Gen (PBftVerKeyHash c) + SecurityParam + -> CS.WindowSize + -> Gen (PBftVerKeyHash c) -> Word64 -> LatestInput c -> Gen (Inputs c) -generateInputs genKey = go [] +generateInputs paramK paramN genKey = + \n lastInput -> post <$> go [] n lastInput where go :: [Input c] -> Word64 -> LatestInput c -> Gen (Inputs c) go acc n lastInput = do @@ -333,6 +340,23 @@ generateInputs genKey = go [] key <- genKey pure $ InputSigner $ CS.PBftSigner slot key + -- remove EBBs that come too soon + post :: Inputs c -> Inputs c + post = Inputs . go2 0 . unInputs + where + lim = n + k + where + CS.WindowSize n = paramN + SecurityParam k = paramK + + go2 numSigned = \case + [] -> [] + inp:inps -> case inp of + InputEBB{} + | numSigned < lim -> go2 numSigned inps + | otherwise -> inp : go2 0 inps + InputSigner{} -> inp : go2 (succ numSigned) inps + {------------------------------------------------------------------------------- Labelling -------------------------------------------------------------------------------} @@ -413,7 +437,7 @@ prop_directABb TestChainState{..} = (testChainInputsA <> testChainInputsB) state0 mbState2 = CS.rewind k n - (slotLatestInput $ toLastInput testChainInputsA) + (pointLatestInput $ toLastInput testChainInputsA) state1 in Just testChainState === mbState2 @@ -450,7 +474,7 @@ prop_rewindPreservesInvariant TestChainState{..} = let rewound = CS.rewind testChainStateK testChainStateN - testChainRewind + testChainRewindPoint testChainState in case rewound of Nothing -> label "rollback too far in the past" True @@ -467,7 +491,7 @@ prop_rewindReappendId TestChainState{..} = let rewound = CS.rewind testChainStateK testChainStateN - testChainRewind + testChainRewindPoint testChainState in case rewound of Nothing -> label "rollback too far in the past" True @@ -561,8 +585,9 @@ appendInput -> CS.WindowSize -> Input c -> CS.PBftChainState c -> CS.PBftChainState c -appendInput k n = \case - InputEBB ebb -> CS.appendEBB k n (pbftEbbSlotNo ebb) +appendInput k n inp = case inp of + InputEBB{} -> + CS.appendEBB k n (slotInput inp) (headerHashBytesInput inp) InputSigner signer -> CS.append k n signer appendInputs @@ -573,7 +598,8 @@ appendInputs -> CS.PBftChainState c -> CS.PBftChainState c appendInputs k n = repeatedly (appendInput k n) . unInputs -splitAtSigner :: Word64 -> Inputs c -> (Maybe (Inputs c, CS.PBftSigner c), Inputs c) +splitAtSigner + :: Word64 -> Inputs c -> (Maybe (Inputs c, CS.PBftSigner c), Inputs c) splitAtSigner n (Inputs inps) = coerce $ splitAtJust prjSigner n inps where @@ -607,10 +633,33 @@ fromInputs -> [PBftEBB] -- ^ determines 'CS.ebbs' -> CS.PBftChainState c -fromInputs k n anchor signers ebbs = - CS.fromList k n (anchor, Seq.fromList signers, EbbMap m) +fromInputs k n anchor signers ebbs0 = + CS.fromList k n (anchor, Seq.fromList signers, ebbs2) + where + ebbs1 = + [ mkEbbInfo slot mSlot + | PBftEBB mSlot slot <- ebbs0 + , At slot == anchor || mSlot >= anchor + ] + ebbs2 = case lastMaybe ebbs1 of + Nothing -> NothingEbbInfo + Just ei -> JustEbbInfo ei + + mkEbbInfo slot mSlot = EbbInfo + { eiSlot = slot + , eiHashBytes = headerHashBytesInput $ InputEBB $ PBftEBB mSlot slot + , eiPrevSlot = mSlot + } + +type instance HeaderHash (Input c) = (Bool, SlotNo) + +headerHashBytesInput :: forall c. Input c -> HeaderHashBytes +headerHashBytesInput inp = + headerHashBytes (Proxy :: Proxy (Input c)) (flag, slotInput inp) where - m = Map.fromList [ (slot, mSlot) | PBftEBB mSlot slot <- ebbs ] + flag = case inp of + InputEBB{} -> True + InputSigner{} -> False {------------------------------------------------------------------------------- "The previous input" @@ -623,10 +672,10 @@ toLastInput :: Inputs c -> LatestInput c toLastInput = LatestInput . lastMaybe . unInputs -- | The slot of the latest block -slotLatestInput :: LatestInput c -> WithOrigin SlotNo -slotLatestInput (LatestInput mbInp) = case mbInp of +pointLatestInput :: LatestInput c -> WithOrigin (SlotNo, HeaderHashBytes) +pointLatestInput (LatestInput mbInp) = case mbInp of Nothing -> Origin - Just inp -> At $ slotInput inp + Just inp -> At (slotInput inp, headerHashBytesInput inp) -- | The slot of the latest /signed/ block signedSlotLatestInput :: LatestInput c -> WithOrigin SlotNo diff --git a/ouroboros-consensus/test-consensus/Test/Dynamic/BFT.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/BFT.hs index 6e6f35a13f8..befe0bee0f4 100644 --- a/ouroboros-consensus/test-consensus/Test/Dynamic/BFT.hs +++ b/ouroboros-consensus/test-consensus/Test/Dynamic/BFT.hs @@ -14,6 +14,7 @@ import Ouroboros.Consensus.Protocol import Ouroboros.Consensus.Util.Random import Test.Dynamic.General +import Test.Dynamic.Network (MaybeForgeEBB (..)) import Test.Dynamic.Util import Test.Consensus.BlockchainTime.SlotLengths () @@ -42,4 +43,4 @@ prop_simple_bft_convergence k testOutput = runTestNetwork (\nid -> protocolInfo (ProtocolMockBFT numCoreNodes nid k slotLengths)) - testConfig seed + testConfig NothingForgeEBB seed diff --git a/ouroboros-consensus/test-consensus/Test/Dynamic/General.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/General.hs index 85458579abd..ee1ddeb8664 100644 --- a/ouroboros-consensus/test-consensus/Test/Dynamic/General.hs +++ b/ouroboros-consensus/test-consensus/Test/Dynamic/General.hs @@ -17,7 +17,6 @@ module Test.Dynamic.General ( import Control.Monad (guard) import qualified Data.Map as Map -import Data.Maybe (isJust) import Data.Set (Set) import qualified Data.Set as Set import Data.Word (Word64) @@ -130,10 +129,12 @@ runTestNetwork :: ) => (CoreNodeId -> ProtocolInfo blk) -> TestConfig + -> MaybeForgeEBB blk -> Seed -> TestOutput blk runTestNetwork pInfo TestConfig{numCoreNodes, numSlots, nodeJoinPlan, nodeTopology, slotLengths} + mbForgeEBB seed = runSimOrThrow $ runNodeNetwork numCoreNodes @@ -141,6 +142,7 @@ runTestNetwork pInfo slotLengths nodeJoinPlan nodeTopology + mbForgeEBB pInfo (seedToChaCha seed) @@ -201,8 +203,6 @@ prop_general k TestConfig{numSlots, nodeJoinPlan, nodeTopology} mbSchedule -- -- * the node rejected its own new block (eg 'PBftExceededSignThreshold') -- - -- * the node forged an EBB - -- actualLeaderSchedule :: LeaderSchedule actualLeaderSchedule = foldl (<>) (emptyLeaderSchedule numSlots) $ @@ -232,8 +232,7 @@ prop_general k TestConfig{numSlots, nodeJoinPlan, nodeTopology} mbSchedule let j = nodeIdJoinSlot nodeJoinPlan nid guard $ j <= s - guard $ not $ - isJust (nodeIsEBB b) || Set.member (blockPoint b) invalids + guard $ not $ Set.member (blockPoint b) invalids pure [cid] diff --git a/ouroboros-consensus/test-consensus/Test/Dynamic/LeaderSchedule.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/LeaderSchedule.hs index aa7466d6643..8c213abbd1e 100644 --- a/ouroboros-consensus/test-consensus/Test/Dynamic/LeaderSchedule.hs +++ b/ouroboros-consensus/test-consensus/Test/Dynamic/LeaderSchedule.hs @@ -23,6 +23,7 @@ import Ouroboros.Consensus.Protocol import Ouroboros.Consensus.Util.Random import Test.Dynamic.General +import Test.Dynamic.Network (MaybeForgeEBB (..)) import Test.Dynamic.Util import Test.Dynamic.Util.NodeJoinPlan import Test.Dynamic.Util.NodeTopology @@ -83,7 +84,7 @@ prop_simple_leader_schedule_convergence (\nid -> protocolInfo (ProtocolLeaderSchedule numCoreNodes nid params schedule)) - testConfig seed + testConfig NothingForgeEBB seed {------------------------------------------------------------------------------- Dependent generation and shrinking of leader schedules diff --git a/ouroboros-consensus/test-consensus/Test/Dynamic/Network.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/Network.hs index f7235de1b1a..362abe6d2a2 100644 --- a/ouroboros-consensus/test-consensus/Test/Dynamic/Network.hs +++ b/ouroboros-consensus/test-consensus/Test/Dynamic/Network.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} @@ -15,6 +16,7 @@ -- | Setup network module Test.Dynamic.Network ( runNodeNetwork + , MaybeForgeEBB (..) , TracingConstraints -- * Tracers , MiniProtocolExpectedException (..) @@ -51,6 +53,7 @@ import Network.TypedProtocol.Codec (AnyMessage (..), CodecFailure, import Ouroboros.Network.Block import Ouroboros.Network.MockChain.Chain +import Ouroboros.Network.Point (WithOrigin (..)) import qualified Ouroboros.Network.BlockFetch.Client as BFClient import Ouroboros.Network.Protocol.ChainSync.PipelineDecision @@ -86,7 +89,9 @@ import Ouroboros.Consensus.Util.STM import qualified Ouroboros.Storage.ChainDB as ChainDB import Ouroboros.Storage.ChainDB.Impl (ChainDbArgs (..)) -import Ouroboros.Storage.EpochInfo (EpochInfo, newEpochInfo) +import Ouroboros.Storage.Common (EpochNo (..)) +import Ouroboros.Storage.EpochInfo (EpochInfo, epochInfoFirst, + newEpochInfo) import qualified Ouroboros.Storage.ImmutableDB as ImmDB import qualified Ouroboros.Storage.ImmutableDB.Impl.Index as Index import qualified Ouroboros.Storage.LedgerDB.DiskPolicy as LgrDB @@ -102,6 +107,14 @@ import qualified Test.Util.FS.Sim.MockFS as Mock import Test.Util.FS.Sim.STM (simHasFS) import Test.Util.Tracer +data MaybeForgeEBB blk + = NothingForgeEBB + -- ^ Do not forge EBBs during this test + | JustForgeEBB !(NodeConfig (BlockProtocol blk) -> + SlotNo -> BlockNo -> ChainHash blk -> blk) + -- ^ Forge EBBs during this test using this function @(slot, block no, + -- prevHash)@ + -- | Setup a network of core nodes, where each joins according to the node join -- plan and is interconnected according to the node topology -- @@ -119,11 +132,12 @@ runNodeNetwork :: forall m blk. -> SlotLengths -> NodeJoinPlan -> NodeTopology + -> MaybeForgeEBB blk -> (CoreNodeId -> ProtocolInfo blk) -> ChaChaDRG -> m (TestOutput blk) runNodeNetwork numCoreNodes numSlots slotLengths nodeJoinPlan nodeTopology - pInfo initRNG = withRegistry $ \sharedRegistry -> do + mbForgeEBB pInfo initRNG = withRegistry $ \sharedRegistry -> do -- This shared registry is used for 'newTestBlockchainTime' and the -- network communication threads. Each node will create its own registry -- for its ChainDB. @@ -248,6 +262,41 @@ runNodeNetwork numCoreNodes numSlots slotLengths nodeJoinPlan nodeTopology simChaChaT varDRG id $ testGenTxs numCoreNodes cfg ledger void $ addTxs mempool txs + ebbProducer :: HasCallStack + => BlockchainTime m + -> StrictTVar m SlotNo + -> NodeConfig (BlockProtocol blk) + -> ChainDB.ChainDB m blk + -> EpochInfo m + -> m () + ebbProducer btime nextEbbSlotVar cfg chainDB epochInfo = go 0 + where + go :: EpochNo -> m () + go !epoch = do + -- The first slot in @epoch@ + ebbSlotNo <- epochInfoFirst epochInfo epoch + atomically $ writeTVar nextEbbSlotVar ebbSlotNo + + void $ blockUntilSlot btime ebbSlotNo + + case mbForgeEBB of + NothingForgeEBB -> pure () + JustForgeEBB forgeEBB -> do + (prevSlot, ebbBlockNo, prevHash) <- atomically $ do + p <- ChainDB.getTipPoint chainDB + let mSlot = pointSlot p + let k = SlotNo $ maxRollbacks $ protocolSecurityParam cfg + check $ case mSlot of + Origin -> True + At s -> s >= (ebbSlotNo - min ebbSlotNo (2 * k)) + bno <- ChainDB.getTipBlockNo chainDB + pure (mSlot, bno, pointHash p) + when (prevSlot < At ebbSlotNo) $ do + let ebb = forgeEBB cfg ebbSlotNo ebbBlockNo prevHash + ChainDB.addBlock chainDB ebb + + go (succ epoch) + mkArgs :: BlockchainTime m -> ResourceRegistry m -> NodeConfig (BlockProtocol blk) @@ -293,7 +342,7 @@ runNodeNetwork numCoreNodes numSlots slotLengths nodeJoinPlan nodeTopology , cdbNodeConfig = cfg , cdbEpochInfo = epochInfo , cdbHashInfo = nodeHashInfo (Proxy @blk) - , cdbIsEBB = nodeIsEBB + , cdbIsEBB = nodeIsEBB . getHeader , cdbCheckIntegrity = nodeCheckIntegrity cfg , cdbGenesis = return initLedger , cdbBlockchainTime = btime @@ -365,9 +414,21 @@ runNodeNetwork numCoreNodes numSlots slotLengths nodeJoinPlan nodeTopology nodeInfoDBs (chainDB, _) <- ChainDB.openDBInternal chainDbArgs True + -- We have a thread (see below) that forges EBBs for tests that involve + -- them. This variable holds the slot of the next EBB to be forged. + -- + -- Even if the test doesn't involve EBBs, that thread must advance this + -- variable in order to unblock the node's block production thread. + nextEbbSlotVar <- uncheckedNewTVarM 0 + let nodeArgs = NodeArgs { tracers = nullDebugTracers - { forgeTracer = nodeEventsForges nodeInfoEvents + { forgeTracer = Tracer $ \case + TraceForgeAboutToLead s -> do + atomically $ do + lim <- readTVar nextEbbSlotVar + check $ s < lim + o -> traceWith (nodeEventsForges nodeInfoEvents) o } , registry = registry , maxClockSkew = ClockSkew 1 @@ -405,6 +466,13 @@ runNodeNetwork numCoreNodes numSlots slotLengths nodeJoinPlan nodeTopology (ChainDB.getCurrentLedger chainDB) (getMempool nodeKernel) + void $ forkLinkedThread registry $ ebbProducer + btime + nextEbbSlotVar + pInfoConfig + chainDB + epochInfo + return (nodeKernel, registry, readNodeInfo, LimitedApp app) customProtocolCodecs @@ -505,8 +573,10 @@ directedEdge tr btime nodeapp1 nodeapp2 = hUnexpected e@(Exn.SomeException e') = case fromException e of Just (_ :: Exn.AsyncException) -> throwM e Nothing -> throwM MiniProtocolFatalException - { mpfeType = Typeable.typeOf e' - , mpfeExn = e + { mpfeType = Typeable.typeOf e' + , mpfeExn = e + , mpfeClient = fst nodeapp1 + , mpfeServer = fst nodeapp2 } -- | Spawn threads for all of the mini protocols @@ -833,9 +903,11 @@ data TraceMiniProtocolRestart peer -- 'MiniProtocolExpectedException' -- data MiniProtocolFatalException = MiniProtocolFatalException - { mpfeType :: !Typeable.TypeRep + { mpfeType :: !Typeable.TypeRep -- ^ Including the type explicitly makes it easier for a human to debug - , mpfeExn :: !SomeException + , mpfeExn :: !SomeException + , mpfeClient :: !CoreNodeId + , mpfeServer :: !CoreNodeId } deriving (Show) diff --git a/ouroboros-consensus/test-consensus/Test/Dynamic/PBFT.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/PBFT.hs index 84aeb85dd58..0891de2f6a7 100644 --- a/ouroboros-consensus/test-consensus/Test/Dynamic/PBFT.hs +++ b/ouroboros-consensus/test-consensus/Test/Dynamic/PBFT.hs @@ -15,6 +15,7 @@ import Ouroboros.Consensus.Protocol import Ouroboros.Consensus.Util.Random import Test.Dynamic.General +import Test.Dynamic.Network (MaybeForgeEBB (..)) import Test.Dynamic.Util import Test.Util.Orphans.Arbitrary () @@ -46,4 +47,4 @@ prop_simple_pbft_convergence testOutput = runTestNetwork (\nid -> protocolInfo (ProtocolMockPBFT numCoreNodes nid params)) - testConfig seed + testConfig NothingForgeEBB seed diff --git a/ouroboros-consensus/test-consensus/Test/Dynamic/Praos.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/Praos.hs index bcf7af25fee..430b8a7e98e 100644 --- a/ouroboros-consensus/test-consensus/Test/Dynamic/Praos.hs +++ b/ouroboros-consensus/test-consensus/Test/Dynamic/Praos.hs @@ -17,6 +17,7 @@ import Ouroboros.Consensus.Protocol import Ouroboros.Consensus.Util.Random import Test.Dynamic.General +import Test.Dynamic.Network (MaybeForgeEBB (..)) import Test.Dynamic.Util import Test.Dynamic.Util.NodeJoinPlan import Test.Dynamic.Util.NodeTopology @@ -99,4 +100,4 @@ prop_simple_praos_convergence testOutput@TestOutput{testOutputNodes} = runTestNetwork (\nid -> protocolInfo (ProtocolMockPraos numCoreNodes nid params)) - testConfig seed + testConfig NothingForgeEBB seed diff --git a/ouroboros-consensus/test-consensus/Test/Dynamic/RealPBFT.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/RealPBFT.hs index 4de86413d24..376aca80b55 100644 --- a/ouroboros-consensus/test-consensus/Test/Dynamic/RealPBFT.hs +++ b/ouroboros-consensus/test-consensus/Test/Dynamic/RealPBFT.hs @@ -9,11 +9,13 @@ module Test.Dynamic.RealPBFT ( tests ) where +import Data.Coerce (coerce) import Data.Foldable (find) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe (fromJust) +import Data.Maybe (fromJust, mapMaybe) import Data.Time (Day (..), UTCTime (..)) +import Data.Word (Word64) import Numeric.Search.Range (searchFromTo) import Test.QuickCheck @@ -24,24 +26,31 @@ import Ouroboros.Network.Block (SlotNo (..)) import Ouroboros.Network.MockChain.Chain (Chain) import qualified Ouroboros.Network.MockChain.Chain as Chain +import Ouroboros.Consensus.Block (getHeader) import Ouroboros.Consensus.BlockchainTime import Ouroboros.Consensus.BlockchainTime.Mock -import Ouroboros.Consensus.Ledger.Byron (ByronBlock) +import Ouroboros.Consensus.Ledger.Byron (ByronBlock, forgeEBB) import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.Node.ProtocolInfo.Byron (plcCoreNodeId) +import Ouroboros.Consensus.Node.Run.Abstract (nodeIsEBB) import Ouroboros.Consensus.NodeId import Ouroboros.Consensus.Protocol +import Ouroboros.Consensus.Util.Condense (condense) import Ouroboros.Consensus.Util.Random +import Ouroboros.Storage.Common (EpochNo (..)) + import qualified Cardano.Chain.Common as Common import qualified Cardano.Chain.Delegation as Delegation import qualified Cardano.Chain.Genesis as Genesis +import Cardano.Chain.ProtocolConstants (kEpochSlots) +import Cardano.Chain.Slotting (unEpochSlots) import qualified Cardano.Chain.Update as Update import qualified Cardano.Crypto as Crypto import qualified Test.Cardano.Chain.Genesis.Dummy as Dummy import Test.Dynamic.General -import Test.Dynamic.Network (NodeOutput (..)) +import Test.Dynamic.Network (MaybeForgeEBB (..), NodeOutput (..)) import qualified Test.Dynamic.Ref.RealPBFT as Ref import Test.Dynamic.Util import Test.Dynamic.Util.NodeJoinPlan @@ -51,8 +60,10 @@ import Test.Util.Orphans.Arbitrary () import Test.Util.Shrink (andId, dropId) tests :: TestTree -tests = testGroup "Dynamic chain generation" - [ localOption (QuickCheckTests 10) $ -- each takes about 0.5 seconds! +tests = testGroup "Dynamic chain generation" $ + [ testProperty "trivial join plan is considered deterministic" $ + prop_deterministicPlan + , localOption (QuickCheckTests 10) $ -- each takes about 0.5 seconds! testProperty "check Real PBFT setup" $ \numCoreNodes -> forAll (elements (enumCoreNodes numCoreNodes)) $ \coreNodeId -> @@ -66,7 +77,7 @@ tests = testGroup "Dynamic chain generation" testProperty "addressed by InvalidRollForward exception (PR #773)" $ let ncn = NumCoreNodes 3 in - prop_simple_real_pbft_convergence TestConfig + prop_simple_real_pbft_convergence (SecurityParam 10) TestConfig { numCoreNodes = ncn , numSlots = NumSlots 24 , nodeJoinPlan = NodeJoinPlan $ Map.fromList @@ -86,6 +97,7 @@ tests = testGroup "Dynamic chain generation" -- slot 0 (even though it's already there). That rewind fails if EBBs -- don't affect the PBFT chain state, since its chain state is empty. prop_simple_real_pbft_convergence + (SecurityParam 10) TestConfig { numCoreNodes = ncn , numSlots = NumSlots 2 , nodeJoinPlan = NodeJoinPlan (Map.fromList [(CoreNodeId 0,SlotNo 0),(CoreNodeId 1,SlotNo 1)]) @@ -99,6 +111,7 @@ tests = testGroup "Dynamic chain generation" -- Same as above, except node 0 gets to forge an actual block before node -- 1 tells it to rewind to the EBB. prop_simple_real_pbft_convergence + (SecurityParam 10) TestConfig { numCoreNodes = ncn , numSlots = NumSlots 4 , nodeJoinPlan = NodeJoinPlan (Map.fromList [(CoreNodeId 0,SlotNo {unSlotNo = 0}),(CoreNodeId 1,SlotNo {unSlotNo = 3})]) @@ -107,67 +120,90 @@ tests = testGroup "Dynamic chain generation" } Seed {getSeed = (16817746570690588019,3284322327197424879,14951803542883145318,5227823917971823767,14093715642382269482)} , testProperty "simple Real PBFT convergence" $ - forAllShrink genRealPBFTTestConfig shrinkRealPBFTTestConfig $ \testConfig -> + forAll (SecurityParam <$> elements [5, 10]) $ \k -> + forAllShrink (genRealPBFTTestConfig k) shrinkRealPBFTTestConfig $ \testConfig -> forAll arbitrary $ \seed -> - prop_simple_real_pbft_convergence testConfig seed + prop_simple_real_pbft_convergence k testConfig seed ] where defaultSlotLengths :: SlotLengths defaultSlotLengths = singletonSlotLengths (SlotLength 1) +prop_deterministicPlan :: NumSlots -> NumCoreNodes -> Property +prop_deterministicPlan numSlots numCoreNodes = + property $ + Ref.deterministicPlan numSlots (trivialNodeJoinPlan numCoreNodes) + prop_setup_coreNodeId :: NumCoreNodes -> CoreNodeId -> Property prop_setup_coreNodeId numCoreNodes coreNodeId = - case mkProtocolRealPBFT numCoreNodes coreNodeId genesisConfig genesisSecrets of + case mkProtocolRealPBFT params coreNodeId genesisConfig genesisSecrets of ProtocolRealPBFT _cfg _th _pv _swv (Just plc) -> coreNodeId === plcCoreNodeId plc _ -> counterexample "mkProtocolRealPBFT did not use ProtocolRealPBFT" $ property False where + params :: PBftParams + params = realPBftParams dummyK numCoreNodes + dummyK = SecurityParam 10 -- not really used + genesisConfig :: Genesis.Config genesisSecrets :: Genesis.GeneratedSecrets - (genesisConfig, genesisSecrets) = generateGenesisConfig numCoreNodes + (genesisConfig, genesisSecrets) = generateGenesisConfig params -prop_simple_real_pbft_convergence :: TestConfig +prop_simple_real_pbft_convergence :: SecurityParam + -> TestConfig -> Seed -> Property prop_simple_real_pbft_convergence - testConfig@TestConfig{numCoreNodes, numSlots} seed = + k testConfig@TestConfig{numCoreNodes, numSlots} seed = prop_general k testConfig (Just $ roundRobinLeaderSchedule numCoreNodes numSlots) testOutput .&&. not (all Chain.null finalChains) + .&&. conjoin (map (hasAllEBBs k numSlots) finalChains) where - k = - (SecurityParam . Common.unBlockCount) $ - (Genesis.gdK . Genesis.configGenesisData) $ - genesisConfig - testOutput = runTestNetwork (\nid -> protocolInfo - (mkProtocolRealPBFT numCoreNodes nid + (mkProtocolRealPBFT params nid genesisConfig genesisSecrets)) - testConfig seed + testConfig (JustForgeEBB forgeEBB) seed finalChains :: [Chain ByronBlock] finalChains = Map.elems $ nodeOutputFinalChain <$> testOutputNodes testOutput + params :: PBftParams + params = realPBftParams k numCoreNodes + genesisConfig :: Genesis.Config genesisSecrets :: Genesis.GeneratedSecrets - (genesisConfig, genesisSecrets) = generateGenesisConfig numCoreNodes + (genesisConfig, genesisSecrets) = generateGenesisConfig params +hasAllEBBs :: SecurityParam -> NumSlots -> Chain ByronBlock -> Property +hasAllEBBs k (NumSlots t) c = + counterexample ("Missing or unexpected EBBs in " <> condense c) $ + actual === expected + where + expected :: [EpochNo] + expected = coerce [0 .. hi] + where + hi :: Word64 + hi = if t < 1 then 0 else fromIntegral (t - 1) `div` denom + denom = unEpochSlots $ kEpochSlots $ coerce k -mkProtocolRealPBFT :: NumCoreNodes + actual = mapMaybe (nodeIsEBB . getHeader) $ Chain.toOldestFirst c + +mkProtocolRealPBFT :: PBftParams -> CoreNodeId -> Genesis.Config -> Genesis.GeneratedSecrets -> Protocol ByronBlock -mkProtocolRealPBFT numCoreNodes (CoreNodeId i) +mkProtocolRealPBFT params (CoreNodeId i) genesisConfig genesisSecrets = ProtocolRealPBFT genesisConfig @@ -183,7 +219,7 @@ mkProtocolRealPBFT numCoreNodes (CoreNodeId i) dlgKey dlgCert - PBftParams{pbftSignatureThreshold} = realPBftParams numCoreNodes + PBftParams{pbftSignatureThreshold} = params dlgKey :: Crypto.SigningKey dlgKey = fromJust $ @@ -202,31 +238,32 @@ mkProtocolRealPBFT numCoreNodes (CoreNodeId i) Generating the genesis configuration -------------------------------------------------------------------------------} -realPBftParams :: NumCoreNodes -> PBftParams -realPBftParams numCoreNodes = PBftParams +realPBftParams :: SecurityParam -> NumCoreNodes -> PBftParams +realPBftParams paramK numCoreNodes = PBftParams { pbftNumNodes = n - , pbftSecurityParam = SecurityParam k - , pbftSignatureThreshold = (1 / n) + (1 / k) + , pbftSecurityParam = paramK + , pbftSignatureThreshold = (1 / n) + (1 / k) + epsilon -- crucially: @floor (k * t) >= ceil (k / n)@ , pbftSlotLength = slotLengthFromSec 20 } where + epsilon = 1/10000 -- avoid problematic floating point round-off + n :: Num a => a n = fromIntegral x where NumCoreNodes x = numCoreNodes k :: Num a => a - k = 10 + k = fromIntegral x where SecurityParam x = paramK -- Instead of using 'Dummy.dummyConfig', which hard codes the number of rich -- men (= CoreNodes for us) to 4, we generate a dummy config with the given -- number of rich men. -generateGenesisConfig :: NumCoreNodes -> (Genesis.Config, Genesis.GeneratedSecrets) -generateGenesisConfig numCoreNodes = +generateGenesisConfig :: PBftParams -> (Genesis.Config, Genesis.GeneratedSecrets) +generateGenesisConfig params = either (error . show) id $ Genesis.generateGenesisConfig startTime spec where startTime = UTCTime (ModifiedJulianDay 0) 0 - NumCoreNodes n = numCoreNodes - PBftParams{pbftSecurityParam} = realPBftParams numCoreNodes + PBftParams{pbftNumNodes, pbftSecurityParam} = params spec :: Genesis.GenesisSpec spec = Dummy.dummyGenesisSpec @@ -234,7 +271,7 @@ generateGenesisConfig numCoreNodes = { Genesis.giTestBalance = (Genesis.giTestBalance Dummy.dummyGenesisInitializer) -- The nodes are the richmen - { Genesis.tboRichmen = fromIntegral n } + { Genesis.tboRichmen = fromIntegral pbftNumNodes } } , Genesis.gsK = Common.BlockCount $ maxRollbacks pbftSecurityParam } @@ -258,7 +295,21 @@ genRealPBFTNodeJoinPlan :: PBftParams -> NumSlots -> Gen NodeJoinPlan genRealPBFTNodeJoinPlan params numSlots@(NumSlots t) | n < 0 || t < 1 = error $ "Cannot generate RealPBFT NodeJoinPlan: " ++ show (params, numSlots) - | otherwise = go (NodeJoinPlan Map.empty) Ref.emptyState + | otherwise = + go (NodeJoinPlan Map.empty) Ref.emptyState + `suchThat` Ref.deterministicPlan numSlots + -- This suchThat might loop a few times, but it should always + -- eventually succeed, since the plan where all nodes join immediately + -- satisifies it. + -- + -- In a run of 7000 successful RealPBFT tests, this 'suchThat' retried: + -- + -- 486 retried once + -- 100 retried twice + -- 10 retried 3 times + -- 4 retried 4 times + -- 4 retried 5 times + -- 1 retried 6 times where PBftParams{pbftNumNodes} = params n = fromIntegral pbftNumNodes @@ -326,12 +377,12 @@ genRealPBFTNodeJoinPlan params numSlots@(NumSlots t) Nothing -> 0 Just (CoreNodeId h) -> succ h -genRealPBFTTestConfig :: Gen TestConfig -genRealPBFTTestConfig = do +genRealPBFTTestConfig :: SecurityParam -> Gen TestConfig +genRealPBFTTestConfig k = do numCoreNodes <- arbitrary numSlots <- arbitrary - let params = realPBftParams numCoreNodes + let params = realPBftParams k numCoreNodes nodeJoinPlan <- genRealPBFTNodeJoinPlan params numSlots nodeTopology <- genNodeTopology numCoreNodes diff --git a/ouroboros-consensus/test-consensus/Test/Dynamic/Ref/RealPBFT.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/Ref/RealPBFT.hs index abf74cbe4da..6dc3c8daafe 100644 --- a/ouroboros-consensus/test-consensus/Test/Dynamic/Ref/RealPBFT.hs +++ b/ouroboros-consensus/test-consensus/Test/Dynamic/Ref/RealPBFT.hs @@ -1,6 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} -- | A reference simulator of the RealPBFT protocol under \"ideal -- circumstances\" @@ -11,6 +12,7 @@ module Test.Dynamic.Ref.RealPBFT ( Outcome (..), State (..), advanceUpTo, + deterministicPlan, emptyState, nullState, step, @@ -18,12 +20,15 @@ module Test.Dynamic.Ref.RealPBFT ( ) where import Data.Foldable (Foldable, foldl', toList) +import Data.List (sortOn) import qualified Data.Map as Map import Data.Sequence (Seq) import qualified Data.Sequence as Seq +import Data.Word (Word64) import Ouroboros.Network.Block (SlotNo (..)) +import Ouroboros.Consensus.BlockchainTime.Mock (NumSlots (..)) import Ouroboros.Consensus.NodeId (CoreNodeId (..)) import Ouroboros.Consensus.Protocol.Abstract (SecurityParam (..)) import Ouroboros.Consensus.Protocol.PBFT (PBftParams (..)) @@ -135,19 +140,22 @@ extendOutcome params State{forgers, nomCount, nextSlot, outs} out = State -- | @True@ if the state would violate 'pbftSignatureThreshold' -- -tooMany :: PBftParams -> State -> CoreNodeId -> Bool -tooMany params State{forgers} i = +tooMany :: PBftParams -> State -> Bool +tooMany params st@State{forgers} = not $ - Seq.length forgers < k || count i forgers <= most + Seq.length forgers < k || count i forgers <= pbftLimit params where - PBftParams{pbftSignatureThreshold} = params - k :: forall a. Num a => a k = oneK params - -- how many blocks in the latest k-blocks that a single core node is - -- allowed to have forged - most = floor $ k * pbftSignatureThreshold + i = nextLeader params st + +-- | How many blocks in the latest @k@-blocks that a single core node is +-- allowed to have signed +pbftLimit :: Integral a => PBftParams -> a +pbftLimit params = floor $ oneK params * pbftSignatureThreshold + where + PBftParams{pbftSignatureThreshold} = params -- | @True@ if the state resulted from a sequence of @2k@ slots that had less -- than @k@ 'Nominal' outcomes @@ -186,19 +194,22 @@ saturated params State{outs} = -- step :: PBftParams -> NodeJoinPlan -> State -> State step params nodeJoinPlan st - | maybe True (s <) mbJ = stuck Absent - | Just s == mbJ, not isFirst = stuck Wasted - | tooMany params st' i = stuck Unable - | otherwise = extendOutcome params st' Nominal + | maybe True (s <) mbJ = stuck Absent + | joinLead, not isFirst = stuck Wasted + | tooMany params st' = stuck Unable + | otherwise = extendOutcome params st' Nominal where s = nextSlot st -- @s@'s scheduled leader - i = CoreNodeId $ fromIntegral $ unSlotNo s `mod` oneN params + i = nextLeader params st -- when @i@ joins the network mbJ = Map.lookup i m where NodeJoinPlan m = nodeJoinPlan + -- @i@ is joining and also leading + joinLead = Just s == mbJ + -- whether @i@ would be the first to lead isFirst = nullState st @@ -222,6 +233,11 @@ advanceUpTo params nodeJoinPlan = go Queries -------------------------------------------------------------------------------} +-- | The scheduled leader of 'nextSlot' +nextLeader :: PBftParams -> State -> CoreNodeId +nextLeader params State{nextSlot} = + CoreNodeId $ fromIntegral $ unSlotNo nextSlot `mod` oneN params + -- | Finish an incomplete 'NodeJoinPlan': all remaining nodes join ASAP -- -- Specifically, \"ASAP\" is either when the last already-scheduled node joins @@ -256,3 +272,67 @@ viable params lastSlot nodeJoinPlan st0 = go st0 | otherwise = go st' where st' = step params nodeJoinPlan' st + +-- | This node join plan does not introduce any ambiguity +-- +-- There is currently only one source of ambiguity. Suppose only one slot has +-- been lead, so the net has a single one-block chain. If the second lead slot +-- is lead by a node that also joins in that same slot, then that node will +-- forge its own one-block chain before it synchronizes with the net. This +-- process may continue for the third lead slot, and so on. It necessarily +-- stops in one of two ways: +-- +-- * One of the competing nodes leads for a second time. Because of +-- round-robin, this will be the first leader again. +-- +-- * A new node leads in a slot after its join slot. It will have +-- synchronized with the net and chosen one of the one-block chains. It +-- will forge a block atop that, and then the whole network will choose +-- this new longest chain. This reference simulator, in general, cannot +-- anticipate which of the competing one-block chains this node will have +-- selected, so this case is considered non-deterministic. +-- +-- Once the net contains a chain with more than one-block, there will never be +-- anymore contention. Nodes might still join and immediately forge their own +-- one-block chain, but it will not be competitive with the net's necessarily +-- longer chain. +deterministicPlan :: NumSlots -> NodeJoinPlan -> Bool +deterministicPlan (NumSlots t) (NodeJoinPlan m) = + (t < 1 ||) $ + (checkFromGenesis $ sortOn (\(_, _, l1, _) -> l1) $ map mk (Map.toList m)) + where + n = fromIntegral $ Map.size m :: Word64 + + mk (i, joinSlot) = (i, joinSlot, l1, l1 + SlotNo n) + where + l1 = lead1 (i, joinSlot) + + -- the first slot this node will lead + lead1 (CoreNodeId (fromIntegral -> i), SlotNo joinSlot) = + SlotNo $ joinSlot + d' + where + l = joinSlot `mod` n + d' = (if l > i then n else 0) + i - l + + -- the net has all empty chains + checkFromGenesis = \case + [] -> True + (_, _, _, l2):xs -> checkFromSingle l2 xs + + -- the net has a single one-block chain + checkFromSingle l2 = \case + [] -> True + (_, joinSlot, l1', _):xs + | l2 < l1' -> True + | joinSlot < l1' -> True + | otherwise -> checkFromAtRisk l2 xs + + lastSlot = SlotNo $ t - 1 + + -- the net has multiple one-block chains + checkFromAtRisk l2 = \case + [] -> lastSlot >= l2 + (_, joinSlot, l1', _):xs + | l2 < l1' -> True + | joinSlot < l1' -> False + | otherwise -> checkFromAtRisk l2 xs diff --git a/ouroboros-consensus/test-consensus/golden/cbor/byron/ChainState b/ouroboros-consensus/test-consensus/golden/cbor/byron/ChainState0 similarity index 56% rename from ouroboros-consensus/test-consensus/golden/cbor/byron/ChainState rename to ouroboros-consensus/test-consensus/golden/cbor/byron/ChainState0 index bf42ed8735f..1800a03da8a 100644 --- a/ouroboros-consensus/test-consensus/golden/cbor/byron/ChainState +++ b/ouroboros-consensus/test-consensus/golden/cbor/byron/ChainState0 @@ -1,6 +1,5 @@ -„…‚X΄ΐΰ +‚„‚X΄ΐΰ ŒΤυΉ$œA³^Ρ† \pŠ@΅«¬‚X΄ΐΰ ŒΤυΉ$œA³^Ρ† \pŠ@΅«¬‚X΄ΐΰ ŒΤυΉ$œA³^Ρ† \pŠ@΅«¬‚X΄ΐΰ -ŒΤυΉ$œA³^Ρ† \pŠ@΅«¬‚X΄ΐΰ -ŒΤυΉ$œA³^Ρ† \pŠ@΅«¬‘‚ \ No newline at end of file +ŒΤυΉ$œA³^Ρ† \pŠ@΅«¬ \ No newline at end of file diff --git a/ouroboros-consensus/test-consensus/golden/cbor/byron/ChainState1 b/ouroboros-consensus/test-consensus/golden/cbor/byron/ChainState1 new file mode 100644 index 00000000000..279f191b0bf --- /dev/null +++ b/ouroboros-consensus/test-consensus/golden/cbor/byron/ChainState1 @@ -0,0 +1,5 @@ +„„‚X΄ΐΰ +ŒΤυΉ$œA³^Ρ† \pŠ@΅«¬‚X΄ΐΰ +ŒΤυΉ$œA³^Ρ† \pŠ@΅«¬‚X΄ΐΰ +ŒΤυΉ$œA³^Ρ† \pŠ@΅«¬‚X΄ΐΰ +ŒΤυΉ$œA³^Ρ† \pŠ@΅«¬‘‚ \ No newline at end of file diff --git a/ouroboros-consensus/test-consensus/golden/cbor/byron/ChainState2 b/ouroboros-consensus/test-consensus/golden/cbor/byron/ChainState2 new file mode 100644 index 00000000000..857b9961501 Binary files /dev/null and b/ouroboros-consensus/test-consensus/golden/cbor/byron/ChainState2 differ diff --git a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/ImmDB.hs b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/ImmDB.hs index 745b7f34f9c..bf639e3b4db 100644 --- a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/ImmDB.hs +++ b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/ImmDB.hs @@ -16,11 +16,12 @@ import Control.Tracer (nullTracer) import qualified Cardano.Chain.Update as Update -import Ouroboros.Network.Block (SlotNo (..), blockPoint) +import Ouroboros.Network.Block (BlockNo (..), ChainHash (..), + SlotNo (..), blockPoint) -import Ouroboros.Consensus.Block (BlockProtocol) +import Ouroboros.Consensus.Block (BlockProtocol, getHeader) import Ouroboros.Consensus.Ledger.Byron (ByronBlock) -import Ouroboros.Consensus.Ledger.Byron.Forge (forgeGenesisEBB) +import Ouroboros.Consensus.Ledger.Byron.Forge (forgeEBB) import Ouroboros.Consensus.Node.ProtocolInfo (PBftSignatureThreshold (..), ProtocolInfo (..), protocolInfo) @@ -58,7 +59,7 @@ test_getBlockWithPoint_EBB_at_tip = mbEbb' <- ImmDB.getBlockOrHeaderWithPoint immDB Block (blockPoint ebb) return $ mbEbb' @?= Just ebb where - ebb = forgeGenesisEBB testCfg (SlotNo 0) + ebb = forgeEBB testCfg (SlotNo 0) (BlockNo 0) GenesisHash withImmDB :: IOLike m => (ImmDB m ByronBlock -> m a) -> m a withImmDB k = withRegistry $ \registry -> do @@ -77,7 +78,7 @@ withImmDB k = withRegistry $ \registry -> do , immEpochInfo = epochInfo , immHashInfo = nodeHashInfo (Proxy @ByronBlock) , immValidation = ValidateMostRecentEpoch - , immIsEBB = nodeIsEBB + , immIsEBB = nodeIsEBB . getHeader , immCheckIntegrity = nodeCheckIntegrity testCfg , immAddHdrEnv = nodeAddHeaderEnvelope (Proxy @ByronBlock) , immTracer = nullTracer diff --git a/ouroboros-consensus/tools/db-analyse/Main.hs b/ouroboros-consensus/tools/db-analyse/Main.hs index c6a2047d1ef..b28e8e80517 100644 --- a/ouroboros-consensus/tools/db-analyse/Main.hs +++ b/ouroboros-consensus/tools/db-analyse/Main.hs @@ -26,6 +26,7 @@ import qualified Cardano.Crypto as Crypto import Ouroboros.Network.Block (HasHeader (..), SlotNo (..), genesisPoint) +import Ouroboros.Consensus.Block (getHeader) import Ouroboros.Consensus.Ledger.Byron (ByronBlock, ByronConsensusProtocol, ByronHash) import qualified Ouroboros.Consensus.Ledger.Byron as Byron @@ -263,7 +264,7 @@ withImmDB fp cfg epochInfo = ImmDB.withImmDB args , immEpochInfo = epochInfo , immHashInfo = nodeHashInfo (Proxy @ByronBlock) , immValidation = ValidateMostRecentEpoch - , immIsEBB = nodeIsEBB + , immIsEBB = nodeIsEBB . getHeader , immCheckIntegrity = nodeCheckIntegrity cfg , immAddHdrEnv = nodeAddHeaderEnvelope (Proxy @ByronBlock) }