BBODY rule to use a Block as a signal again

IntersectMBO · Oct 11, 2021 · ef2040e · ef2040e
1 parent f8210c1
commit ef2040e
Show file tree

Hide file tree

Showing 8 changed files with 43 additions and 27 deletions.
diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Bbody.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Bbody.hs
@@ -31,7 +31,7 @@ import qualified Cardano.Ledger.Core as Core
 import Cardano.Ledger.Era (Era (Crypto), SupportsSegWit (..))
 import qualified Cardano.Ledger.Era as Era
 import Cardano.Ledger.Keys (DSignable, Hash, coerceKeyRole)
-import Cardano.Ledger.Shelley.BlockChain (bBodySize, incrBlocks)
+import Cardano.Ledger.Shelley.BlockChain (Block (..), bBodySize, incrBlocks)
 import Cardano.Ledger.Shelley.LedgerState (LedgerState)
 import Cardano.Ledger.Shelley.Rules.Bbody
   ( BbodyEnv (..),
@@ -120,7 +120,7 @@ bbodyTransition ::
   forall (someBBODY :: Type -> Type) era.
   ( -- Conditions that the Abstract someBBODY must meet
     STS (someBBODY era),
-    Signal (someBBODY era) ~ (BHeaderView (Crypto era), TxSeq era),
+    Signal (someBBODY era) ~ (Block BHeaderView era),
     PredicateFailure (someBBODY era) ~ AlonzoBbodyPredFail era,
     BaseM (someBBODY era) ~ ShelleyBase,
     State (someBBODY era) ~ BbodyState era,
@@ -144,7 +144,11 @@ bbodyTransition =
     >>= \( TRC
              ( BbodyEnv pp account,
                BbodyState ls b,
-               (bh, txsSeq)
+               (Block' bh txsSeq _)
+               -- We avoid the Block pattern here in order to
+               -- not inherit the ToCBOR constraint on block headers.
+               -- The BBODY rule uses the BHeaderView for the block
+               -- header, which should not actually ever be serialized.
                )
            ) -> do
         let txs = txSeqTxns txsSeq
@@ -218,7 +222,7 @@ instance
 
   type
     Signal (AlonzoBBODY era) =
-      (BHeaderView (Crypto era), TxSeq era)
+      (Block BHeaderView era)
 
   type Environment (AlonzoBBODY era) = BbodyEnv era
 

diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Validation.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Validation.hs
@@ -31,6 +31,7 @@ import Cardano.Ledger.Era (Crypto, TxSeq)
 import Cardano.Ledger.Serialization (ToCBORGroup)
 import Cardano.Ledger.Shelley (ShelleyEra)
 import Cardano.Ledger.Shelley.API.Protocol (PraosCrypto)
+import Cardano.Ledger.Shelley.BlockChain (Block)
 import Cardano.Ledger.Shelley.LedgerState (NewEpochState)
 import qualified Cardano.Ledger.Shelley.LedgerState as LedgerState
 import Cardano.Ledger.Shelley.PParams (PParams' (..))
@@ -62,7 +63,7 @@ class
     BaseM (Core.EraRule "BBODY" era) ~ ShelleyBase,
     Environment (Core.EraRule "BBODY" era) ~ STS.BbodyEnv era,
     State (Core.EraRule "BBODY" era) ~ STS.BbodyState era,
-    Signal (Core.EraRule "BBODY" era) ~ (BHeaderView (Crypto era), TxSeq era),
+    Signal (Core.EraRule "BBODY" era) ~ (Block BHeaderView era),
     ToCBORGroup (TxSeq era)
   ) =>
   ApplyBlock era
@@ -99,15 +100,15 @@ class
     ApplySTSOpts ep ->
     Globals ->
     NewEpochState era ->
-    (BHeaderView (Crypto era), TxSeq era) ->
+    (Block BHeaderView era) ->
     m (EventReturnType ep (Core.EraRule "BBODY" era) (NewEpochState era))
   default applyBlockOpts ::
     forall ep m.
     (EventReturnTypeRep ep, MonadError (BlockTransitionError era) m) =>
     ApplySTSOpts ep ->
     Globals ->
     NewEpochState era ->
-    (BHeaderView (Crypto era), TxSeq era) ->
+    (Block BHeaderView era) ->
     m (EventReturnType ep (Core.EraRule "BBODY" era) (NewEpochState era))
   applyBlockOpts opts globals state blk =
     liftEither
@@ -136,12 +137,12 @@ class
   reapplyBlock ::
     Globals ->
     NewEpochState era ->
-    (BHeaderView (Crypto era), TxSeq era) ->
+    (Block BHeaderView era) ->
     NewEpochState era
   default reapplyBlock ::
     Globals ->
     NewEpochState era ->
-    (BHeaderView (Crypto era), TxSeq era) ->
+    (Block BHeaderView era) ->
     NewEpochState era
   reapplyBlock globals state blk =
     updateNewEpochState state res
@@ -174,7 +175,7 @@ applyBlock ::
   ) =>
   Globals ->
   NewEpochState era ->
-  (BHeaderView (Crypto era), TxSeq era) ->
+  (Block BHeaderView era) ->
   m (NewEpochState era)
 applyBlock =
   applyBlockOpts $

diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Bbody.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Bbody.hs
@@ -29,7 +29,7 @@ import qualified Cardano.Ledger.Era as Era
 import Cardano.Ledger.Hashes (EraIndependentBlockBody)
 import Cardano.Ledger.Keys (DSignable, Hash, coerceKeyRole)
 import Cardano.Ledger.Serialization (ToCBORGroup)
-import Cardano.Ledger.Shelley.BlockChain (bBodySize, incrBlocks)
+import Cardano.Ledger.Shelley.BlockChain (Block (..), bBodySize, incrBlocks)
 import Cardano.Ledger.Shelley.Constraints (UsesAuxiliary, UsesTxBody)
 import Cardano.Ledger.Shelley.EpochBoundary (BlocksMade)
 import Cardano.Ledger.Shelley.LedgerState
@@ -125,7 +125,7 @@ instance
 
   type
     Signal (BBODY era) =
-      (BHeaderView (Crypto era), Era.TxSeq era)
+      Block BHeaderView era
 
   type Environment (BBODY era) = BbodyEnv era
 
@@ -155,7 +155,11 @@ bbodyTransition =
     >>= \( TRC
              ( BbodyEnv pp account,
                BbodyState ls b,
-               (bhview, txsSeq)
+               (Block' bhview txsSeq _)
+               -- We avoid the Block pattern here in order to
+               -- not inherit the ToCBOR constraint on block headers.
+               -- The BBODY rule uses the BHeaderView for the block
+               -- header, which should not actually ever be serialized.
                )
            ) -> do
         let txs = fromTxSeq @era txsSeq

diff --git a/eras/shelley/test-suite/bench/BenchValidation.hs b/eras/shelley/test-suite/bench/BenchValidation.hs
@@ -57,6 +57,7 @@ import Cardano.Slotting.Slot (withOriginToMaybe)
 import Control.Monad.Except ()
 import Control.State.Transition (STS (State))
 import qualified Control.State.Transition.Trace.Generator.QuickCheck as QC
+import Data.ByteString.Lazy (ByteString)
 import qualified Data.Map as Map
 import Data.Proxy
 import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (Mock)
@@ -108,13 +109,16 @@ genValidateInput n = do
   block <- genBlock ge chainstate
   pure (ValidateInput testGlobals (chainNes chainstate) block)
 
+bogusBlockHash :: ByteString
+bogusBlockHash = error "blocks with a header view should not be hashed"
+
 benchValidate ::
   forall era.
   (Era era, API.ApplyBlock era) =>
   ValidateInput era ->
   IO (NewEpochState era)
 benchValidate (ValidateInput globals state (Block bh txs)) =
-  case API.applyBlock @era globals state (makeHeaderView bh, txs) of
+  case API.applyBlock @era globals state (Block' (makeHeaderView bh) txs bogusBlockHash) of
     Right x -> pure x
     Left x -> error (show x)
 
@@ -131,7 +135,7 @@ applyBlock ::
   Int ->
   Int
 applyBlock (ValidateInput globals state (Block bh txs)) n =
-  case API.applyBlock @era globals state (makeHeaderView bh, txs) of
+  case API.applyBlock @era globals state (Block' (makeHeaderView bh) txs bogusBlockHash) of
     Right x -> seq (rnf x) (n + 1)
     Left x -> error (show x)
 
@@ -140,7 +144,7 @@ benchreValidate ::
   ValidateInput era ->
   NewEpochState era
 benchreValidate (ValidateInput globals state (Block bh txs)) =
-  API.reapplyBlock globals state (makeHeaderView bh, txs)
+  API.reapplyBlock globals state (Block' (makeHeaderView bh) txs bogusBlockHash)
 
 -- ==============================================================
 

diff --git a/eras/shelley/test-suite/cardano-ledger-shelley-test.cabal b/eras/shelley/test-suite/cardano-ledger-shelley-test.cabal
@@ -216,6 +216,7 @@ benchmark mainbench
     Cardano.Ledger.Shelley.Bench.Rewards
 
   build-depends:
+    bytestring,
     cardano-crypto-class,
     cardano-crypto-praos,
     cardano-ledger-core,

diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Trace/Chain.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Trace/Chain.hs
@@ -23,7 +23,7 @@ module Test.Cardano.Ledger.Shelley.Generator.Trace.Chain where
 import Cardano.Ledger.BHeaderView (BHeaderView (..))
 import Cardano.Ledger.BaseTypes (UnitInterval)
 import qualified Cardano.Ledger.Core as Core
-import Cardano.Ledger.Era (Crypto, Era, SupportsSegWit (TxSeq))
+import Cardano.Ledger.Era (Crypto, Era)
 import Cardano.Ledger.Shelley.API
 import Cardano.Ledger.Shelley.Constraints
   ( UsesAuxiliary,
@@ -99,7 +99,7 @@ instance
     Embed (Core.EraRule "BBODY" era) (CHAIN era),
     Environment (Core.EraRule "BBODY" era) ~ BbodyEnv era,
     State (Core.EraRule "BBODY" era) ~ BbodyState era,
-    Signal (Core.EraRule "BBODY" era) ~ (BHeaderView (Crypto era), TxSeq era),
+    Signal (Core.EraRule "BBODY" era) ~ (Block BHeaderView era),
     Embed (Core.EraRule "TICKN" era) (CHAIN era),
     Environment (Core.EraRule "TICKN" era) ~ TicknEnv,
     State (Core.EraRule "TICKN" era) ~ TicknState,

diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/Chain.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/Chain.hs
@@ -239,7 +239,7 @@ instance
     Embed (Core.EraRule "BBODY" era) (CHAIN era),
     Environment (Core.EraRule "BBODY" era) ~ BbodyEnv era,
     State (Core.EraRule "BBODY" era) ~ BbodyState era,
-    Signal (Core.EraRule "BBODY" era) ~ (BHeaderView (Crypto era), Era.TxSeq era),
+    Signal (Core.EraRule "BBODY" era) ~ (Block BHeaderView era),
     Embed (Core.EraRule "TICKN" era) (CHAIN era),
     Environment (Core.EraRule "TICKN" era) ~ TicknEnv,
     State (Core.EraRule "TICKN" era) ~ TicknState,
@@ -282,7 +282,7 @@ chainTransition ::
     Embed (Core.EraRule "BBODY" era) (CHAIN era),
     Environment (Core.EraRule "BBODY" era) ~ BbodyEnv era,
     State (Core.EraRule "BBODY" era) ~ BbodyState era,
-    Signal (Core.EraRule "BBODY" era) ~ (BHeaderView (Crypto era), Era.TxSeq era),
+    Signal (Core.EraRule "BBODY" era) ~ (Block BHeaderView era),
     Embed (Core.EraRule "TICKN" era) (CHAIN era),
     Environment (Core.EraRule "TICKN" era) ~ TicknEnv,
     State (Core.EraRule "TICKN" era) ~ TicknState,
@@ -356,9 +356,10 @@ chainTransition =
                 bh
               )
 
+        let thouShaltNot = error "A block with a header view should never be hashed"
         BbodyState ls' bcur' <-
           trans @(Core.EraRule "BBODY" era) $
-            TRC (BbodyEnv pp' account, BbodyState ls bcur, (bhView, txs))
+            TRC (BbodyEnv pp' account, BbodyState ls bcur, (Block' bhView txs thouShaltNot))
 
         let nes'' = updateNES nes' bcur' ls'
             bhb = bhbody bh

diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/TwoPhaseValidation.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/TwoPhaseValidation.hs
@@ -80,7 +80,7 @@ import Cardano.Ledger.Shelley.API
     ProtVer (..),
     UTxO (..),
   )
-import Cardano.Ledger.Shelley.BlockChain (bBodySize)
+import Cardano.Ledger.Shelley.BlockChain (Block (..), bBodySize)
 import Cardano.Ledger.Shelley.EpochBoundary (BlocksMade (..))
 import Cardano.Ledger.Shelley.LedgerState (UTxOState (..), WitHashes (..))
 import Cardano.Ledger.Shelley.Rules.Bbody (BbodyEnv (..), BbodyPredicateFailure (..), BbodyState (..))
@@ -2000,9 +2000,10 @@ makeNaiveBlock ::
     ToCBORGroup (TxSeq era)
   ) =>
   [Core.Tx era] ->
-  (BHeaderView (Crypto era), TxSeq era)
-makeNaiveBlock txs = (bhView, txs')
+  (Block BHeaderView era)
+makeNaiveBlock txs = (Block' bhView txs' thouShaltNot)
   where
+    thouShaltNot = error "A block with a header view should never be hashed"
     bhView =
       BHeaderView
         { bhviewID = hashKey (vKey coldKeys),
@@ -2013,7 +2014,7 @@ makeNaiveBlock txs = (bhView, txs')
         }
     txs' = (toTxSeq @era) . StrictSeq.fromList $ txs
 
-testAlonzoBlock :: (BHeaderView C_Crypto, TxSeq A)
+testAlonzoBlock :: (Block BHeaderView A)
 testAlonzoBlock =
   makeNaiveBlock
     [ trustMe True $ validatingTx pf,
@@ -2028,7 +2029,7 @@ testAlonzoBlock =
   where
     pf = Alonzo Mock
 
-testAlonzoBadPMDHBlock :: (BHeaderView C_Crypto, TxSeq A)
+testAlonzoBadPMDHBlock :: (Block BHeaderView A)
 testAlonzoBadPMDHBlock = makeNaiveBlock [trustMe True $ poolMDHTooBigTx pf]
   where
     pf = Alonzo Mock
@@ -2067,7 +2068,7 @@ example1BBodyState =
 
 testBBODY ::
   BbodyState A ->
-  (BHeaderView C_Crypto, TxSeq A) ->
+  (Block BHeaderView A) ->
   Either [PredicateFailure (AlonzoBBODY A)] (BbodyState A) ->
   Assertion
 testBBODY initialSt block (Right expectedSt) =