Merge #1353

1353: Generate EBBs more realistically in the RealPBFT consensus test r=nfrisby a=nfrisby

Fixes #966. Fixes #1352.

I'm opening this as a Draft PR because I would like your feedback on the basic schemes before I polish it up. Basic schemes:

  * Issue #966 - Use a new `Tracer` in `Node.Tracers` and a new `TVar` in `Test.Dynamic.Tracer` to ensure that each node has added all EBBs to its `ChainDB` _before_ forging a block when leading. Blocking the traced thread seems like an abuse of `Tracer`s, but I haven't come up with a less invasive option. We also had to update `preferCandidate` to care about length-after-intersection in addition to block number, since it was just ignoring the EBBs we were adding: except the epoch 0 EBB, they'd only be selected once their successor arrived -- but that meant they never got a successor! That in turn required some gymnastics in BlockFetch to ensure we only compare chain fragments that intersect.

  * Nodes always forge an actual block when leading; they never waste their turn forging an EBB.

  * `suchThat` to preclude node join plans that cause unpredictable final chains. The ambiguity is currently limited to at most the first `numCoreNodes` blocks, but that is enough to cause trouble because it could affect the PBft signature threshold, which could subvert the "at least `k` blocks in `2k` slots" invariant established by the RealPBFT `NodeJoinPlan` generator. (I tried to integrate this check into the recursive generator itself, but the inherent non-monotonicity spoils the inductive hypothesis that "at the very least the plan is OK if all remaining nodes ASAP".)

  * Issue #1352 - when the CS client rollsback a candidate fragment and the oldest dropped header has the same slot as the target, then the target is an EBB with an accompanying block in the same slot and so the primary chain state should essentially be rolled back to the preceding slot instead of the EBB's slot. Otherwise we'd retain the block sharing the slot, which the intersection point precedes. We address this by storing the header hash of an EBB in the chain state and taking a `Point` as the target of rewinds. We retain the EBB when rolling back to its slot if its hash matches that of the given `Point`. As an unfortunate compromise, we store the `HeaderHash` as a `ByteString`, since a sufficient argument for `HeaderHash` is not made available by the arguments to the `ChainState` family.

Co-authored-by: Thomas Winant <[email protected]>
Co-authored-by: Nicolas Frisby <[email protected]>

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

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@

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

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 =

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

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)

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').

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

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.

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