*EraBlockHeader typeclasses deprecating BHeaderView

eras/allegra/impl/src/Cardano/Ledger/Allegra.hs

@@ -1,7 +1,9 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -25,16 +27,13 @@ import Cardano.Ledger.Allegra.Translation ()
 import Cardano.Ledger.Allegra.Tx (Tx (..))
 import Cardano.Ledger.Allegra.UTxO ()
 import Cardano.Ledger.Binary (DecCBOR, EncCBOR)
+import Cardano.Ledger.Block (EraBlockHeader)
 import Cardano.Ledger.Shelley.API
 import Cardano.Ledger.Shelley.Rules (ShelleyLedgerPredFailure)
 import Data.Bifunctor (Bifunctor (first))
 import Data.List.NonEmpty (NonEmpty)
 import GHC.Generics (Generic)
 
---------------------------------------------------------------------------------
--- Mempool instances
---------------------------------------------------------------------------------
-
 instance ApplyTx AllegraEra where
   newtype ApplyTxError AllegraEra = AllegraApplyTxError (NonEmpty (ShelleyLedgerPredFailure AllegraEra))
     deriving (Eq, Show)
@@ -43,4 +42,4 @@ instance ApplyTx AllegraEra where
     first AllegraApplyTxError $
       ruleApplyTxValidation @"LEDGER" validationPolicy globals env state tx
 
-instance ApplyBlock AllegraEra
+instance EraBlockHeader h AllegraEra => ApplyBlock h AllegraEra

eras/alonzo/impl/CHANGELOG.md

@@ -2,6 +2,8 @@
 
 ## 1.15.0.0
 
+* Add `validateExUnits`.
+* Change `AlonzoBBODY` `Signal` to `BbodySignal`.
 * Move `TotalDeposits` and `TxUTxODiff` data constructors from `AlonzoUtxosEvent` to `AlonzoUtxoEvent`
 * Add `UtxosEnv`
 * Change `STS` instance of `AlonzoUTXOS`: use `UtxosEnv` as `Environment` and `ShelleyGovState` as `State`

eras/alonzo/impl/src/Cardano/Ledger/Alonzo.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
@@ -36,6 +37,7 @@ import Cardano.Ledger.Alonzo.TxBody (AlonzoTxOut, TxBody (AlonzoTxBody))
 import Cardano.Ledger.Alonzo.TxWits ()
 import Cardano.Ledger.Alonzo.UTxO ()
 import Cardano.Ledger.Binary (DecCBOR, EncCBOR)
+import Cardano.Ledger.Block (EraBlockHeader)
 import Cardano.Ledger.Mary.Value (MaryValue)
 import Cardano.Ledger.Plutus.Data ()
 import Cardano.Ledger.Shelley.API
@@ -44,8 +46,6 @@ import Data.Bifunctor (Bifunctor (first))
 import Data.List.NonEmpty (NonEmpty)
 import GHC.Generics (Generic)
 
--- =====================================================
-
 instance ApplyTx AlonzoEra where
   newtype ApplyTxError AlonzoEra = AlonzoApplyTxError (NonEmpty (ShelleyLedgerPredFailure AlonzoEra))
     deriving (Eq, Show)
@@ -54,4 +54,4 @@ instance ApplyTx AlonzoEra where
     first AlonzoApplyTxError $
       ruleApplyTxValidation @"LEDGER" validationPolicy globals env state tx
 
-instance ApplyBlock AlonzoEra
+instance EraBlockHeader h AlonzoEra => ApplyBlock h AlonzoEra

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Bbody.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
@@ -19,6 +20,7 @@ module Cardano.Ledger.Alonzo.Rules.Bbody (
   AlonzoBbodyPredFailure (..),
   AlonzoBbodyEvent (..),
   alonzoBbodyTransition,
+  validateExUnits,
 ) where
 
 import Cardano.Ledger.Allegra.Rules (AllegraUtxoPredFailure)
@@ -30,16 +32,15 @@ import Cardano.Ledger.Alonzo.Rules.Utxos (AlonzoUtxosPredFailure)
 import Cardano.Ledger.Alonzo.Rules.Utxow (AlonzoUtxowPredFailure)
 import Cardano.Ledger.Alonzo.Scripts (ExUnits (..), pointWiseExUnits)
 import Cardano.Ledger.Alonzo.Tx (totExUnits)
-import Cardano.Ledger.BHeaderView (BHeaderView (..), isOverlaySlot)
-import Cardano.Ledger.BaseTypes (Mismatch (..), Relation (..), ShelleyBase, epochInfoPure)
+import Cardano.Ledger.BaseTypes (Mismatch (..), Relation (..), ShelleyBase)
 import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..))
 import Cardano.Ledger.Binary.Coders
-import Cardano.Ledger.Block (Block (..))
-import Cardano.Ledger.Keys (coerceKeyRole)
+import Cardano.Ledger.Block (Block (..), EraBlockHeader (..))
 import Cardano.Ledger.Shelley.BlockBody (incrBlocks)
 import Cardano.Ledger.Shelley.LedgerState (LedgerState)
 import Cardano.Ledger.Shelley.Rules (
   BbodyEnv (..),
+  BbodySignal (..),
   ShelleyBbodyEvent (..),
   ShelleyBbodyPredFailure (..),
   ShelleyBbodyState (..),
@@ -53,12 +54,15 @@ import Cardano.Ledger.Shelley.Rules (
   ShelleyPpupPredFailure,
   ShelleyUtxoPredFailure,
   ShelleyUtxowPredFailure,
+  validateBodyHash,
+  validateBodySize,
  )
-import Cardano.Ledger.Slot (epochInfoEpoch, epochInfoFirst)
+import Cardano.Ledger.Slot (slotToEpochBoundary)
 import Control.DeepSeq (NFData)
-import Control.Monad.Trans.Reader (asks)
 import Control.State.Transition (
   Embed (..),
+  Rule,
+  RuleType (..),
   STS (..),
   TRC (..),
   TransitionRule,
@@ -73,9 +77,6 @@ import GHC.Generics (Generic)
 import Lens.Micro ((^.))
 import NoThunks.Class (NoThunks (..))
 
--- =======================================
--- A new PredicateFailure type
-
 data AlonzoBbodyPredFailure era
   = ShelleyInAlonzoBbodyPredFailure (ShelleyBbodyPredFailure era)
   | TooManyExUnits (Mismatch RelLTEQ ExUnits)
@@ -166,14 +167,33 @@ instance
       dec 1 = SumD TooManyExUnits <! From
       dec n = Invalid n
 
--- ========================================
--- The STS instance
+-- | Validate that total execution units (all transactions) do not exceed block limit.
+validateExUnits ::
+  forall era.
+  ( AlonzoEraTx era
+  , InjectRuleFailure "BBODY" AlonzoBbodyPredFailure era
+  ) =>
+  StrictSeq.StrictSeq (Tx TopTx era) ->
+  -- | Max block exunits protocol parameter.
+  ExUnits ->
+  Rule (EraRule "BBODY" era) 'Transition ()
+validateExUnits txs ppMax =
+  let txTotal = foldMap totExUnits txs
+   in pointWiseExUnits (<=) txTotal ppMax
+        ?! injectFailure
+          ( TooManyExUnits $
+              Mismatch
+                { mismatchSupplied = txTotal
+                , mismatchExpected = ppMax
+                }
+          )
 
 alonzoBbodyTransition ::
   forall era.
   ( STS (EraRule "BBODY" era)
-  , Signal (EraRule "BBODY" era) ~ Block BHeaderView era
+  , Signal (EraRule "BBODY" era) ~ BbodySignal era
   , InjectRuleFailure "BBODY" AlonzoBbodyPredFailure era
+  , InjectRuleFailure "BBODY" ShelleyBbodyPredFailure era
   , BaseM (EraRule "BBODY" era) ~ ShelleyBase
   , State (EraRule "BBODY" era) ~ ShelleyBbodyState era
   , Environment (EraRule "BBODY" era) ~ BbodyEnv era
@@ -182,97 +202,53 @@ alonzoBbodyTransition ::
   , State (EraRule "LEDGERS" era) ~ LedgerState era
   , Signal (EraRule "LEDGERS" era) ~ Seq (Tx TopTx era)
   , EraBlockBody era
-  , AlonzoEraTxWits era
-  , AlonzoEraPParams era
+  , AlonzoEraTx era
   ) =>
   TransitionRule (EraRule "BBODY" era)
-alonzoBbodyTransition =
-  judgmentContext
-    >>= \( TRC
-             ( BbodyEnv pp account
-               , BbodyState ls b
-               , Block bh txsSeq
-               )
-           ) -> do
-        let txs = txsSeq ^. txSeqBlockBodyL
-            actualBodySize = bBodySize (pp ^. ppProtocolVersionL) txsSeq
-            actualBodyHash = hashBlockBody @era txsSeq
-
-        actualBodySize
-          == fromIntegral (bhviewBSize bh)
-            ?! injectFailure
-              ( ShelleyInAlonzoBbodyPredFailure
-                  ( WrongBlockBodySizeBBODY $
-                      Mismatch
-                        { mismatchSupplied = actualBodySize
-                        , mismatchExpected = fromIntegral $ bhviewBSize bh
-                        }
-                  )
-              )
-
-        actualBodyHash
-          == bhviewBHash bh
-            ?! injectFailure
-              ( ShelleyInAlonzoBbodyPredFailure
-                  ( InvalidBodyHashBBODY @era $
-                      Mismatch
-                        { mismatchSupplied = actualBodyHash
-                        , mismatchExpected = bhviewBHash bh
-                        }
-                  )
-              )
-
-        -- Note that this may not actually be a stake pool - it could be a
-        -- genesis key delegate. However, this would only entail an overhead of
-        -- 7 counts, and it's easier than differentiating here.
-        --
-        -- TODO move this computation inside 'incrBlocks' where it belongs. Here
-        -- we make an assumption that 'incrBlocks' must enforce, better for it
-        -- to be done in 'incrBlocks' where we can see that the assumption is
-        -- enforced.
-        let hkAsStakePool = coerceKeyRole $ bhviewID bh
-            slot = bhviewSlot bh
-        (firstSlotNo, curEpochNo) <- liftSTS $ do
-          ei <- asks epochInfoPure
-          let curEpochNo = epochInfoEpoch ei slot
-          pure (epochInfoFirst ei curEpochNo, curEpochNo)
-
-        ls' <-
-          trans @(EraRule "LEDGERS" era) $
-            TRC (LedgersEnv (bhviewSlot bh) curEpochNo pp account, ls, StrictSeq.fromStrict txs)
-
-        {- ∑(tx ∈ txs)(totExunits tx) ≤ maxBlockExUnits pp  -}
-        let txTotal, ppMax :: ExUnits
-            txTotal = foldMap totExUnits txs
-            ppMax = pp ^. ppMaxBlockExUnitsL
-        pointWiseExUnits (<=) txTotal ppMax
-          ?! injectFailure (TooManyExUnits Mismatch {mismatchSupplied = txTotal, mismatchExpected = ppMax})
-
-        pure $
-          BbodyState @era
-            ls'
-            ( incrBlocks
-                (isOverlaySlot firstSlotNo (pp ^. ppDG) slot)
-                hkAsStakePool
-                b
-            )
+alonzoBbodyTransition = do
+  TRC (BbodyEnv pp account, BbodyState ls blocksMade, BbodySignal blk@Block {blockBody}) <-
+    judgmentContext
+
+  validateBodySize blk (pp ^. ppProtocolVersionL)
+
+  validateBodyHash blk
+
+  let bhSlot = blk ^. blockHeaderSlotL
+
+  (firstSlot, curEpoch) <- liftSTS $ slotToEpochBoundary bhSlot
+
+  let txs = blockBody ^. txSeqBlockBodyL
+
+  ls' <-
+    trans @(EraRule "LEDGERS" era) $
+      TRC
+        ( LedgersEnv bhSlot curEpoch pp account
+        , ls
+        , StrictSeq.fromStrict txs
+        )
+
+  validateExUnits @era txs $ pp ^. ppMaxBlockExUnitsL
+
+  pure $ BbodyState ls' $ incrBlocks blk firstSlot (pp ^. ppDG) blocksMade
 
 instance
   ( EraRule "BBODY" era ~ AlonzoBBODY era
   , InjectRuleFailure "BBODY" AlonzoBbodyPredFailure era
+  , InjectRuleFailure "BBODY" ShelleyBbodyPredFailure era
   , Embed (EraRule "LEDGERS" era) (AlonzoBBODY era)
   , Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era
   , State (EraRule "LEDGERS" era) ~ LedgerState era
   , Signal (EraRule "LEDGERS" era) ~ Seq (Tx TopTx era)
   , AlonzoEraTxWits era
   , EraBlockBody era
   , AlonzoEraPParams era
+  , AlonzoEraTx era
   ) =>
   STS (AlonzoBBODY era)
   where
   type State (AlonzoBBODY era) = ShelleyBbodyState era
 
-  type Signal (AlonzoBBODY era) = Block BHeaderView era
+  type Signal (AlonzoBBODY era) = BbodySignal era
 
   type Environment (AlonzoBBODY era) = BbodyEnv era
 

eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/BbodySpec.hs

@@ -29,7 +29,9 @@ import Test.Cardano.Ledger.Alonzo.ImpTest
 import Test.Cardano.Ledger.Imp.Common
 import Test.Cardano.Ledger.Plutus.Examples
 
-spec :: forall era. AlonzoEraImp era => SpecWith (ImpInit (LedgerSpec era))
+spec ::
+  forall era.
+  AlonzoEraImp era => SpecWith (ImpInit (LedgerSpec era))
 spec = describe "BBODY" $ do
   forM_ (eraLanguages @era) $ \lang ->
     withSLanguage lang $ \slang ->

eras/babbage/impl/src/Cardano/Ledger/Babbage.hs

@@ -1,7 +1,9 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -31,14 +33,13 @@ import Cardano.Ledger.Babbage.TxBody (BabbageTxOut, TxBody (BabbageTxBody))
 import Cardano.Ledger.Babbage.TxInfo ()
 import Cardano.Ledger.Babbage.UTxO ()
 import Cardano.Ledger.Binary (DecCBOR, EncCBOR)
+import Cardano.Ledger.Block (EraBlockHeader)
 import Cardano.Ledger.Shelley.API
 import Cardano.Ledger.Shelley.Rules (ShelleyLedgerPredFailure)
 import Data.Bifunctor (Bifunctor (first))
 import Data.List.NonEmpty (NonEmpty)
 import GHC.Generics (Generic)
 
--- =====================================================
-
 instance ApplyTx BabbageEra where
   newtype ApplyTxError BabbageEra = BabbageApplyTxError (NonEmpty (ShelleyLedgerPredFailure BabbageEra))
     deriving (Eq, Show)
@@ -47,4 +48,4 @@ instance ApplyTx BabbageEra where
     first BabbageApplyTxError $
       ruleApplyTxValidation @"LEDGER" validationPolicy globals env state tx
 
-instance ApplyBlock BabbageEra
+instance EraBlockHeader h BabbageEra => ApplyBlock h BabbageEra

eras/conway/impl/CHANGELOG.md

@@ -2,6 +2,8 @@
 
 ## 1.21.0.0
 
+* Add `validateRefScriptSize`.
+* Change `ConwayBBODY` `Signal` to `BbodySignal`.
 * Add `HeaderProtVerTooHigh` predicate failure.
 * Change `STS` instance of `ConwayUTOXS`: use `PParams` as `Environment`
 * Remove `TotalDeposits` and `TxUTxODiff` data constructors from `ConwayUtxosEvent`

eras/conway/impl/src/Cardano/Ledger/Conway.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
@@ -22,6 +23,7 @@ module Cardano.Ledger.Conway (
 import Cardano.Ledger.Babbage.TxBody ()
 import Cardano.Ledger.BaseTypes (Inject (..))
 import Cardano.Ledger.Binary (DecCBOR, EncCBOR)
+import Cardano.Ledger.Block (EraBlockHeader)
 import Cardano.Ledger.Conway.BlockBody ()
 import Cardano.Ledger.Conway.Era (
   ConwayEra,
@@ -44,8 +46,6 @@ import Data.Bifunctor (Bifunctor (first))
 import Data.List.NonEmpty (NonEmpty)
 import GHC.Generics (Generic)
 
--- =====================================================
-
 instance ApplyTx ConwayEra where
   newtype ApplyTxError ConwayEra = ConwayApplyTxError (NonEmpty (ConwayLedgerPredFailure ConwayEra))
     deriving (Eq, Show)
@@ -54,7 +54,7 @@ instance ApplyTx ConwayEra where
     first ConwayApplyTxError $
       ruleApplyTxValidation @"MEMPOOL" validationPolicy globals env state tx
 
-instance ApplyBlock ConwayEra
+instance EraBlockHeader h ConwayEra => ApplyBlock h ConwayEra
 
 instance RunConwayRatify ConwayEra