diff --git a/eras/alonzo/impl/CHANGELOG.md b/eras/alonzo/impl/CHANGELOG.md index 8d6ab5ff2c6..fcfe9f9d5ba 100644 --- a/eras/alonzo/impl/CHANGELOG.md +++ b/eras/alonzo/impl/CHANGELOG.md @@ -1,8 +1,8 @@ # Version history for `cardano-ledger-alonzo` -## 1.9.0.1 +## 1.10.0.0 -* +* Rename `bbodyTransition` to `alonzoBbodyTransition` and change its type signature ## 1.9.0.0 diff --git a/eras/alonzo/impl/cardano-ledger-alonzo.cabal b/eras/alonzo/impl/cardano-ledger-alonzo.cabal index 6736765d103..b01ca91f218 100644 --- a/eras/alonzo/impl/cardano-ledger-alonzo.cabal +++ b/eras/alonzo/impl/cardano-ledger-alonzo.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: cardano-ledger-alonzo -version: 1.9.0.0 +version: 1.10.0.0 license: Apache-2.0 maintainer: operations@iohk.io author: IOHK diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Bbody.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Bbody.hs index 79c9ca61000..c687b08ab89 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Bbody.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Bbody.hs @@ -18,7 +18,7 @@ module Cardano.Ledger.Alonzo.Rules.Bbody ( AlonzoBBODY, AlonzoBbodyPredFailure (..), AlonzoBbodyEvent (..), - bbodyTransition, + alonzoBbodyTransition, ) where import Cardano.Ledger.Allegra.Rules (AllegraUtxoPredFailure) @@ -70,7 +70,6 @@ import Control.State.Transition ( trans, (?!), ) -import Data.Kind (Type) import Data.Sequence (Seq) import qualified Data.Sequence.Strict as StrictSeq import Data.Typeable @@ -175,15 +174,15 @@ instance -- ======================================== -- The STS instance -bbodyTransition :: - forall (someBBODY :: Type -> Type) era. - ( STS (someBBODY era) - , Signal (someBBODY era) ~ Block (BHeaderView (EraCrypto era)) era - , PredicateFailure (someBBODY era) ~ AlonzoBbodyPredFailure era - , BaseM (someBBODY era) ~ ShelleyBase - , State (someBBODY era) ~ ShelleyBbodyState era - , Environment (someBBODY era) ~ BbodyEnv era - , Embed (EraRule "LEDGERS" era) (someBBODY era) +alonzoBbodyTransition :: + forall era. + ( STS (EraRule "BBODY" era) + , Signal (EraRule "BBODY" era) ~ Block (BHeaderView (EraCrypto era)) era + , InjectRuleFailure "BBODY" AlonzoBbodyPredFailure era + , BaseM (EraRule "BBODY" era) ~ ShelleyBase + , State (EraRule "BBODY" era) ~ ShelleyBbodyState era + , Environment (EraRule "BBODY" era) ~ BbodyEnv era + , Embed (EraRule "LEDGERS" era) (EraRule "BBODY" era) , Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era , State (EraRule "LEDGERS" era) ~ LedgerState era , Signal (EraRule "LEDGERS" era) ~ Seq (Tx era) @@ -193,8 +192,8 @@ bbodyTransition :: , Tx era ~ AlonzoTx era , AlonzoEraPParams era ) => - TransitionRule (someBBODY era) -bbodyTransition = + TransitionRule (EraRule "BBODY" era) +alonzoBbodyTransition = judgmentContext >>= \( TRC ( BbodyEnv pp account @@ -208,14 +207,18 @@ bbodyTransition = actualBodySize == fromIntegral (bhviewBSize bh) - ?! ShelleyInAlonzoBbodyPredFailure - ( WrongBlockBodySizeBBODY actualBodySize (fromIntegral $ bhviewBSize bh) + ?! injectFailure + ( ShelleyInAlonzoBbodyPredFailure + ( WrongBlockBodySizeBBODY actualBodySize (fromIntegral $ bhviewBSize bh) + ) ) actualBodyHash == bhviewBHash bh - ?! ShelleyInAlonzoBbodyPredFailure - ( InvalidBodyHashBBODY @era actualBodyHash (bhviewBHash bh) + ?! injectFailure + ( ShelleyInAlonzoBbodyPredFailure + ( InvalidBodyHashBBODY @era actualBodyHash (bhviewBHash bh) + ) ) ls' <- @@ -241,7 +244,8 @@ bbodyTransition = let txTotal, ppMax :: ExUnits txTotal = foldMap totExUnits txs ppMax = pp ^. ppMaxBlockExUnitsL - pointWiseExUnits (<=) txTotal ppMax ?! TooManyExUnits txTotal ppMax + pointWiseExUnits (<=) txTotal ppMax + ?! injectFailure (TooManyExUnits txTotal ppMax) pure $ BbodyState @era @@ -254,6 +258,8 @@ bbodyTransition = instance ( DSignable (EraCrypto era) (Hash (EraCrypto era) EraIndependentTxBody) + , EraRule "BBODY" era ~ AlonzoBBODY era + , InjectRuleFailure "BBODY" AlonzoBbodyPredFailure era , Embed (EraRule "LEDGERS" era) (AlonzoBBODY era) , Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era , State (EraRule "LEDGERS" era) ~ LedgerState era @@ -283,7 +289,7 @@ instance type Event (AlonzoBBODY era) = AlonzoBbodyEvent era initialRules = [] - transitionRules = [bbodyTransition @AlonzoBBODY] + transitionRules = [alonzoBbodyTransition @era] instance ( Era era diff --git a/eras/babbage/impl/cardano-ledger-babbage.cabal b/eras/babbage/impl/cardano-ledger-babbage.cabal index 7432c32e26b..2dc3e38cc73 100644 --- a/eras/babbage/impl/cardano-ledger-babbage.cabal +++ b/eras/babbage/impl/cardano-ledger-babbage.cabal @@ -73,7 +73,7 @@ library cardano-crypto-class, cardano-data >=1.2, cardano-ledger-allegra ^>=1.5, - cardano-ledger-alonzo ^>=1.9, + cardano-ledger-alonzo >=1.9 && <1.11, cardano-ledger-binary ^>=1.3, cardano-ledger-core ^>=1.13, cardano-ledger-mary ^>=1.6, diff --git a/eras/conway/impl/CHANGELOG.md b/eras/conway/impl/CHANGELOG.md index ecdd2f9f633..c8e5ea1a69f 100644 --- a/eras/conway/impl/CHANGELOG.md +++ b/eras/conway/impl/CHANGELOG.md @@ -2,6 +2,8 @@ ## 1.16.0.0 +* Add `maxRefScriptSizePerBlock` and `maxRefScriptSizePerTx` to `Cardano.Ledger.Conway.Rules` +* Add `ConwayBBODY` and `ConwayBbodyPredFailure` type for BBody rule * Added `ConwayCommitteeIsUnknown` predicate failure to `ConwayGovCertPredFailure` * Added `ceCurrentCommittee` and `ceCommitteeProposals` to `CertEnv` * Added `certsCurrentCommittee` and `certsCommitteeProposals` to `CertsEnv` diff --git a/eras/conway/impl/cardano-ledger-conway.cabal b/eras/conway/impl/cardano-ledger-conway.cabal index 1deec5554d3..3b153d0dc0d 100644 --- a/eras/conway/impl/cardano-ledger-conway.cabal +++ b/eras/conway/impl/cardano-ledger-conway.cabal @@ -88,7 +88,7 @@ library cardano-data >=1.2.1, cardano-ledger-binary >=1.3.2, cardano-ledger-allegra ^>=1.5, - cardano-ledger-alonzo ^>=1.9, + cardano-ledger-alonzo ^>=1.10, cardano-ledger-babbage ^>=1.8, cardano-ledger-core ^>=1.13.2, cardano-ledger-mary ^>=1.6, @@ -117,6 +117,7 @@ library testlib Test.Cardano.Ledger.Conway.Binary.Regression Test.Cardano.Ledger.Conway.ImpTest Test.Cardano.Ledger.Conway.Imp + Test.Cardano.Ledger.Conway.Imp.BbodySpec Test.Cardano.Ledger.Conway.Imp.EpochSpec Test.Cardano.Ledger.Conway.Imp.EnactSpec Test.Cardano.Ledger.Conway.Imp.GovSpec diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Era.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Era.hs index 014cf7722d1..a82c9d012ca 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Era.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Era.hs @@ -3,6 +3,7 @@ module Cardano.Ledger.Conway.Era ( ConwayEra, + ConwayBBODY, ConwayCERT, ConwayDELEG, ConwayGOVCERT, @@ -19,7 +20,6 @@ module Cardano.Ledger.Conway.Era ( ConwayRATIFY, ) where -import Cardano.Ledger.Alonzo.Rules (AlonzoBBODY) import Cardano.Ledger.Babbage (BabbageEra) import Cardano.Ledger.Core import Cardano.Ledger.Crypto (Crypto) @@ -131,9 +131,9 @@ data ConwayUTXO era type instance EraRule "UTXO" (ConwayEra c) = ConwayUTXO (ConwayEra c) --- Rules inherited from Alonzo +data ConwayBBODY era -type instance EraRule "BBODY" (ConwayEra c) = AlonzoBBODY (ConwayEra c) +type instance EraRule "BBODY" (ConwayEra c) = ConwayBBODY (ConwayEra c) -- Rules inherited from Shelley diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules.hs index dbbd875abc5..42a785f8501 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules.hs @@ -4,6 +4,7 @@ {-# OPTIONS_GHC -Wno-orphans #-} module Cardano.Ledger.Conway.Rules ( + module Cardano.Ledger.Conway.Rules.Bbody, module Cardano.Ledger.Conway.Rules.Cert, module Cardano.Ledger.Conway.Rules.Deleg, module Cardano.Ledger.Conway.Rules.GovCert, @@ -23,7 +24,7 @@ where import Cardano.Ledger.Conway.Core (EraRuleEvent, InjectRuleEvent (..)) import Cardano.Ledger.Conway.Era (ConwayEra) -import Cardano.Ledger.Conway.Rules.Bbody () +import Cardano.Ledger.Conway.Rules.Bbody import Cardano.Ledger.Conway.Rules.Cert import Cardano.Ledger.Conway.Rules.Certs import Cardano.Ledger.Conway.Rules.Deleg diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Bbody.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Bbody.hs index 44bc9916851..572c61a35cc 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Bbody.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Bbody.hs @@ -4,6 +4,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -14,18 +15,42 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} -module Cardano.Ledger.Conway.Rules.Bbody () where +module Cardano.Ledger.Conway.Rules.Bbody ( + ConwayBBODY, + ConwayBbodyPredFailure (..), + maxRefScriptSizePerBlock, +) where import Cardano.Ledger.Allegra.Rules (AllegraUtxoPredFailure) +import Cardano.Ledger.Alonzo.PParams (AlonzoEraPParams) import Cardano.Ledger.Alonzo.Rules ( - AlonzoBbodyEvent, - AlonzoBbodyPredFailure (..), + AlonzoBbodyEvent (..), + AlonzoBbodyPredFailure (ShelleyInAlonzoBbodyPredFailure), AlonzoUtxoPredFailure, AlonzoUtxosPredFailure, AlonzoUtxowPredFailure, + alonzoBbodyTransition, ) +import qualified Cardano.Ledger.Alonzo.Rules as Alonzo (AlonzoBbodyPredFailure (..)) +import Cardano.Ledger.Alonzo.Scripts (ExUnits (..)) +import Cardano.Ledger.Alonzo.Tx (AlonzoTx) +import Cardano.Ledger.Alonzo.TxSeq (AlonzoTxSeq, txSeqTxns) +import Cardano.Ledger.Alonzo.TxWits (AlonzoEraTxWits (..)) +import Cardano.Ledger.BHeaderView (BHeaderView (..)) +import Cardano.Ledger.Babbage.Core (BabbageEraTxBody) import Cardano.Ledger.Babbage.Rules (BabbageUtxoPredFailure, BabbageUtxowPredFailure) -import Cardano.Ledger.Conway.Era (ConwayEra) +import Cardano.Ledger.BaseTypes (ShelleyBase) +import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..)) +import Cardano.Ledger.Binary.Coders ( + Decode (..), + Encode (..), + decode, + encode, + (!>), + ( + Show (ConwayBbodyPredFailure era) -type instance EraRuleFailure "BBODY" (ConwayEra c) = AlonzoBbodyPredFailure (ConwayEra c) +deriving instance + (Era era, Eq (PredicateFailure (EraRule "LEDGERS" era))) => + Eq (ConwayBbodyPredFailure era) + +deriving anyclass instance + (Era era, NoThunks (PredicateFailure (EraRule "LEDGERS" era))) => + NoThunks (ConwayBbodyPredFailure era) + +instance + ( Era era + , EncCBOR (PredicateFailure (EraRule "LEDGERS" era)) + ) => + EncCBOR (ConwayBbodyPredFailure era) + where + encCBOR = + encode . \case + WrongBlockBodySizeBBODY x y -> Sum WrongBlockBodySizeBBODY 0 !> To x !> To y + InvalidBodyHashBBODY x y -> Sum (InvalidBodyHashBBODY @era) 1 !> To x !> To y + LedgersFailure x -> Sum (LedgersFailure @era) 2 !> To x + TooManyExUnits x y -> Sum TooManyExUnits 3 !> To x !> To y + BodyRefScriptsSizeTooBig x y -> Sum BodyRefScriptsSizeTooBig 4 !> To x !> To y + +instance + ( Era era + , DecCBOR (PredicateFailure (EraRule "LEDGERS" era)) + ) => + DecCBOR (ConwayBbodyPredFailure era) + where + decCBOR = decode . Summands "ConwayBbodyPred" $ \case + 0 -> SumD WrongBlockBodySizeBBODY SumD InvalidBodyHashBBODY SumD LedgersFailure SumD TooManyExUnits SumD BodyRefScriptsSizeTooBig Invalid n + +type instance EraRuleFailure "BBODY" (ConwayEra c) = ConwayBbodyPredFailure (ConwayEra c) type instance EraRuleEvent "BBODY" (ConwayEra c) = AlonzoBbodyEvent (ConwayEra c) -instance InjectRuleFailure "BBODY" AlonzoBbodyPredFailure (ConwayEra c) +instance InjectRuleFailure "BBODY" ConwayBbodyPredFailure (ConwayEra c) + +instance InjectRuleFailure "BBODY" AlonzoBbodyPredFailure (ConwayEra c) where + injectFailure = alonzoToConwayBbodyPredFailure instance InjectRuleFailure "BBODY" ShelleyBbodyPredFailure (ConwayEra c) where - injectFailure = ShelleyInAlonzoBbodyPredFailure + injectFailure = shelleyToConwayBbodyPredFailure instance InjectRuleFailure "BBODY" ShelleyLedgersPredFailure (ConwayEra c) where - injectFailure = ShelleyInAlonzoBbodyPredFailure . LedgersFailure + injectFailure = shelleyToConwayBbodyPredFailure . Shelley.LedgersFailure instance InjectRuleFailure "BBODY" ConwayLedgerPredFailure (ConwayEra c) where - injectFailure = ShelleyInAlonzoBbodyPredFailure . LedgersFailure . injectFailure + injectFailure = shelleyToConwayBbodyPredFailure . Shelley.LedgersFailure . injectFailure instance InjectRuleFailure "BBODY" ConwayUtxowPredFailure (ConwayEra c) where - injectFailure = ShelleyInAlonzoBbodyPredFailure . LedgersFailure . injectFailure + injectFailure = shelleyToConwayBbodyPredFailure . Shelley.LedgersFailure . injectFailure instance InjectRuleFailure "BBODY" BabbageUtxowPredFailure (ConwayEra c) where - injectFailure = ShelleyInAlonzoBbodyPredFailure . LedgersFailure . injectFailure + injectFailure = shelleyToConwayBbodyPredFailure . Shelley.LedgersFailure . injectFailure instance InjectRuleFailure "BBODY" AlonzoUtxowPredFailure (ConwayEra c) where - injectFailure = ShelleyInAlonzoBbodyPredFailure . LedgersFailure . injectFailure + injectFailure = shelleyToConwayBbodyPredFailure . Shelley.LedgersFailure . injectFailure instance InjectRuleFailure "BBODY" ShelleyUtxowPredFailure (ConwayEra c) where - injectFailure = ShelleyInAlonzoBbodyPredFailure . LedgersFailure . injectFailure + injectFailure = shelleyToConwayBbodyPredFailure . Shelley.LedgersFailure . injectFailure instance InjectRuleFailure "BBODY" ConwayUtxoPredFailure (ConwayEra c) where - injectFailure = ShelleyInAlonzoBbodyPredFailure . LedgersFailure . injectFailure + injectFailure = shelleyToConwayBbodyPredFailure . Shelley.LedgersFailure . injectFailure instance InjectRuleFailure "BBODY" BabbageUtxoPredFailure (ConwayEra c) where - injectFailure = ShelleyInAlonzoBbodyPredFailure . LedgersFailure . injectFailure + injectFailure = shelleyToConwayBbodyPredFailure . Shelley.LedgersFailure . injectFailure instance InjectRuleFailure "BBODY" AlonzoUtxoPredFailure (ConwayEra c) where - injectFailure = ShelleyInAlonzoBbodyPredFailure . LedgersFailure . injectFailure + injectFailure = shelleyToConwayBbodyPredFailure . Shelley.LedgersFailure . injectFailure instance InjectRuleFailure "BBODY" AlonzoUtxosPredFailure (ConwayEra c) where - injectFailure = ShelleyInAlonzoBbodyPredFailure . LedgersFailure . injectFailure + injectFailure = shelleyToConwayBbodyPredFailure . Shelley.LedgersFailure . injectFailure instance InjectRuleFailure "BBODY" ConwayUtxosPredFailure (ConwayEra c) where - injectFailure = ShelleyInAlonzoBbodyPredFailure . LedgersFailure . injectFailure + injectFailure = shelleyToConwayBbodyPredFailure . Shelley.LedgersFailure . injectFailure instance InjectRuleFailure "BBODY" ShelleyUtxoPredFailure (ConwayEra c) where - injectFailure = ShelleyInAlonzoBbodyPredFailure . LedgersFailure . injectFailure + injectFailure = shelleyToConwayBbodyPredFailure . Shelley.LedgersFailure . injectFailure instance InjectRuleFailure "BBODY" AllegraUtxoPredFailure (ConwayEra c) where - injectFailure = ShelleyInAlonzoBbodyPredFailure . LedgersFailure . injectFailure + injectFailure = shelleyToConwayBbodyPredFailure . Shelley.LedgersFailure . injectFailure instance InjectRuleFailure "BBODY" ConwayCertsPredFailure (ConwayEra c) where - injectFailure = ShelleyInAlonzoBbodyPredFailure . LedgersFailure . injectFailure + injectFailure = shelleyToConwayBbodyPredFailure . Shelley.LedgersFailure . injectFailure instance InjectRuleFailure "BBODY" ConwayCertPredFailure (ConwayEra c) where - injectFailure = ShelleyInAlonzoBbodyPredFailure . LedgersFailure . injectFailure + injectFailure = shelleyToConwayBbodyPredFailure . Shelley.LedgersFailure . injectFailure instance InjectRuleFailure "BBODY" ConwayDelegPredFailure (ConwayEra c) where - injectFailure = ShelleyInAlonzoBbodyPredFailure . LedgersFailure . injectFailure + injectFailure = shelleyToConwayBbodyPredFailure . Shelley.LedgersFailure . injectFailure instance InjectRuleFailure "BBODY" ShelleyPoolPredFailure (ConwayEra c) where - injectFailure = ShelleyInAlonzoBbodyPredFailure . LedgersFailure . injectFailure + injectFailure = shelleyToConwayBbodyPredFailure . Shelley.LedgersFailure . injectFailure instance InjectRuleFailure "BBODY" ConwayGovCertPredFailure (ConwayEra c) where - injectFailure = ShelleyInAlonzoBbodyPredFailure . LedgersFailure . injectFailure + injectFailure = shelleyToConwayBbodyPredFailure . Shelley.LedgersFailure . injectFailure instance InjectRuleFailure "BBODY" ConwayGovPredFailure (ConwayEra c) where - injectFailure = ShelleyInAlonzoBbodyPredFailure . LedgersFailure . injectFailure + injectFailure = shelleyToConwayBbodyPredFailure . Shelley.LedgersFailure . injectFailure + +shelleyToConwayBbodyPredFailure :: + forall era. + ShelleyBbodyPredFailure era -> + ConwayBbodyPredFailure era +shelleyToConwayBbodyPredFailure (Shelley.WrongBlockBodySizeBBODY x y) = WrongBlockBodySizeBBODY x y +shelleyToConwayBbodyPredFailure (Shelley.InvalidBodyHashBBODY x y) = InvalidBodyHashBBODY x y +shelleyToConwayBbodyPredFailure (Shelley.LedgersFailure x) = LedgersFailure x + +alonzoToConwayBbodyPredFailure :: + forall era. + AlonzoBbodyPredFailure era -> + ConwayBbodyPredFailure era +alonzoToConwayBbodyPredFailure (ShelleyInAlonzoBbodyPredFailure x) = shelleyToConwayBbodyPredFailure x +alonzoToConwayBbodyPredFailure (Alonzo.TooManyExUnits x y) = TooManyExUnits x y + +instance + ( DSignable (EraCrypto era) (Hash (EraCrypto era) EraIndependentTxBody) + , Embed (EraRule "LEDGERS" era) (EraRule "BBODY" era) + , Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era + , State (EraRule "LEDGERS" era) ~ LedgerState era + , Signal (EraRule "LEDGERS" era) ~ Seq (AlonzoTx era) + , AlonzoEraTxWits era + , Tx era ~ AlonzoTx era + , Era.TxSeq era ~ AlonzoTxSeq era + , Tx era ~ AlonzoTx era + , EraSegWits era + , AlonzoEraPParams era + , InjectRuleFailure "BBODY" AlonzoBbodyPredFailure era + , InjectRuleFailure "BBODY" ConwayBbodyPredFailure era + , EraRule "BBODY" era ~ ConwayBBODY era + , EraTx era + , BabbageEraTxBody era + ) => + STS (ConwayBBODY era) + where + type + State (ConwayBBODY era) = + ShelleyBbodyState era + + type + Signal (ConwayBBODY era) = + Block (BHeaderView (EraCrypto era)) era + + type Environment (ConwayBBODY era) = BbodyEnv era + + type BaseM (ConwayBBODY era) = ShelleyBase + + type PredicateFailure (ConwayBBODY era) = ConwayBbodyPredFailure era + type Event (ConwayBBODY era) = AlonzoBbodyEvent era + + initialRules = [] + transitionRules = [conwayBbodyTransition @era >> alonzoBbodyTransition @era] + +conwayBbodyTransition :: + forall era. + ( Signal (EraRule "BBODY" era) ~ Block (BHeaderView (EraCrypto era)) era + , State (EraRule "BBODY" era) ~ ShelleyBbodyState era + , State (EraRule "LEDGERS" era) ~ LedgerState era + , Era.TxSeq era ~ AlonzoTxSeq era + , Tx era ~ AlonzoTx era + , InjectRuleFailure "BBODY" AlonzoBbodyPredFailure era + , InjectRuleFailure "BBODY" ConwayBbodyPredFailure era + , EraTx era + , BabbageEraTxBody era + ) => + TransitionRule (EraRule "BBODY" era) +conwayBbodyTransition = do + judgmentContext + >>= \( TRC + ( _ + , state@(BbodyState ls _) + , UnserialisedBlock _ txsSeq + ) + ) -> do + let utxo = utxosUtxo (lsUTxOState ls) + txs = txSeqTxns txsSeq + totalRefScriptSize = + getSum $ foldMap' (Monoid.Sum . txNonDistinctRefScriptsSize utxo) txs + totalRefScriptSize + <= maxRefScriptSizePerBlock + ?! injectFailure + (BodyRefScriptsSizeTooBig totalRefScriptSize maxRefScriptSizePerBlock) + pure state + +instance + ( Era era + , BaseM ledgers ~ ShelleyBase + , ledgers ~ EraRule "LEDGERS" era + , STS ledgers + , DSignable (EraCrypto era) (Hash (EraCrypto era) EraIndependentTxBody) + , Era era + ) => + Embed ledgers (ConwayBBODY era) + where + wrapFailed = LedgersFailure + wrapEvent = ShelleyInAlonzoEvent . LedgersEvent diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs index d1732b43caa..730595a3726 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs @@ -151,7 +151,7 @@ data ConwayLedgerPredFailure era -- coded limit on the total number of bytes of reference scripts that a transaction can -- use. maxRefScriptSizePerTx :: Int -maxRefScriptSizePerTx = 1024 * 1024 -- 1MiB +maxRefScriptSizePerTx = 200 * 1024 -- 200KiB type instance EraRuleFailure "LEDGER" (ConwayEra c) = ConwayLedgerPredFailure (ConwayEra c) diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp.hs index f63616003c8..1932a0af81d 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp.hs @@ -21,6 +21,7 @@ import Cardano.Ledger.Conway.Core import Cardano.Ledger.Conway.Governance (ConwayGovState) import Cardano.Ledger.Conway.PParams (ConwayPParams) import Cardano.Ledger.Conway.Rules ( + ConwayBbodyPredFailure, ConwayEpochEvent, ConwayGovCertPredFailure, ConwayGovPredFailure, @@ -33,6 +34,7 @@ import Data.Functor.Identity import Data.Typeable (Typeable) import qualified Test.Cardano.Ledger.Babbage.Imp as BabbageImp import Test.Cardano.Ledger.Common +import qualified Test.Cardano.Ledger.Conway.Imp.BbodySpec as Bbody import qualified Test.Cardano.Ledger.Conway.Imp.EnactSpec as Enact import qualified Test.Cardano.Ledger.Conway.Imp.EpochSpec as Epoch import qualified Test.Cardano.Ledger.Conway.Imp.GovCertSpec as GovCert @@ -47,6 +49,7 @@ spec :: forall era. ( Arbitrary (TxAuxData era) , ConwayEraImp era + , EraSegWits era , GovState era ~ ConwayGovState era , PParamsHKD Identity era ~ ConwayPParams Identity era , InjectRuleFailure "LEDGER" ConwayGovPredFailure era @@ -61,6 +64,7 @@ spec :: , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era , InjectRuleFailure "LEDGER" ConwayGovCertPredFailure era , InjectRuleFailure "LEDGER" ConwayLedgerPredFailure era + , InjectRuleFailure "BBODY" ConwayBbodyPredFailure era , NFData (Event (EraRule "ENACT" era)) , ToExpr (Event (EraRule "ENACT" era)) , Eq (Event (EraRule "ENACT" era)) @@ -74,6 +78,7 @@ spec = do BabbageImp.spec @era describe "ConwayImpSpec - post bootstrap (protocol version 10)" $ withImpStateWithProtVer @era (natVersion @10) $ do + describe "BBODY" $ Bbody.spec @era describe "ENACT" $ Enact.spec @era describe "EPOCH" $ Epoch.spec @era describe "GOV" $ Gov.spec @era @@ -84,6 +89,7 @@ spec = do describe "LEDGER" $ Ledger.spec @era describe "ConwayImpSpec - bootstrap phase (protocol version 9)" $ withImpState @era $ do + describe "BBODY" $ Bbody.spec @era describe "ENACT" $ Enact.relevantDuringBootstrapSpec @era describe "EPOCH" $ Epoch.relevantDuringBootstrapSpec @era describe "GOV" $ Gov.relevantDuringBootstrapSpec @era diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/BbodySpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/BbodySpec.hs new file mode 100644 index 00000000000..f9e74eb3743 --- /dev/null +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/BbodySpec.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Cardano.Ledger.Conway.Imp.BbodySpec ( + spec, +) where + +import Cardano.Ledger.BHeaderView (BHeaderView (..)) +import Cardano.Ledger.Babbage.Core +import Cardano.Ledger.BaseTypes (BlocksMade (..), ProtVer (..)) +import Cardano.Ledger.Block +import Cardano.Ledger.Coin (Coin (..)) +import Cardano.Ledger.Conway.Rules ( + ConwayBbodyPredFailure (..), + maxRefScriptSizePerBlock, + maxRefScriptSizePerTx, + ) +import Cardano.Ledger.Plutus (SLanguage (..)) +import Cardano.Ledger.SafeHash (originalBytesSize) +import Cardano.Ledger.Shelley.LedgerState +import Cardano.Ledger.Shelley.Rules ( + BbodyEnv (..), + ShelleyBbodyState (..), + ) +import Cardano.Ledger.TxIn +import Control.Monad (forM) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map as Map +import qualified Data.Sequence.Strict as SSeq +import qualified Data.Set as Set +import Lens.Micro ((&), (.~), (^.)) +import Lens.Micro.Mtl (use) +import Test.Cardano.Ledger.Babbage.ImpTest +import Test.Cardano.Ledger.Imp.Common +import Test.Cardano.Ledger.Plutus.Examples (alwaysFailsWithDatum) + +spec :: + forall era. + ( AlonzoEraImp era + , BabbageEraTxBody era + , EraSegWits era + , InjectRuleFailure "BBODY" ConwayBbodyPredFailure era + ) => + SpecWith (ImpTestState era) +spec = describe "BBODY" $ do + it "BodyRefScriptsSizeTooBig" $ do + Just (script :: Script era) <- pure largeScript + let scriptSize = originalBytesSize script + + -- Determine a number of transactions and a number of times the reference script + -- needs to be included as an input in each transaction, + -- in order for the total to exceed the maximum allowed refScript size per block, + -- while the refScript size per individual transaction doesn't exceed maxRefScriptSizePerTx + txScriptCounts <- + genNumAdditionsExceeding + scriptSize + maxRefScriptSizePerTx + maxRefScriptSizePerBlock + + let expectedTotalRefScriptSize = scriptSize * sum txScriptCounts + txs <- do + -- Instead of using the rootTxIn, we are creating an input for each transaction + -- that we subsequently need to submit, + -- so that we can submit them independently of each other. + forM txScriptCounts $ \n -> do + txIn <- mkTxIn + mkTxWithNScripts txIn script n + >>= fixupFees + >>= updateAddrTxWits + + let txSeq = toTxSeq @era $ SSeq.fromList txs + nes <- use impNESL + let ls = nes ^. nesEsL . esLStateL + pp = nes ^. nesEsL . curPParamsEpochStateL + account = nes ^. nesEsL . esAccountStateL + kh <- freshKeyHash + slotNo <- use impLastTickG + let bhView = + BHeaderView + { bhviewID = kh + , bhviewBSize = fromIntegral $ bBodySize (ProtVer (eraProtVerLow @era) 0) txSeq + , bhviewHSize = 0 + , bhviewBHash = hashTxSeq txSeq + , bhviewSlot = slotNo + } + Left predFailures <- + tryRunImpRule @"BBODY" + (BbodyEnv pp account) + (BbodyState ls (BlocksMade Map.empty)) + (UnsafeUnserialisedBlock bhView txSeq) + predFailures + `shouldBe` NE.fromList + [ injectFailure + ( BodyRefScriptsSizeTooBig + expectedTotalRefScriptSize + maxRefScriptSizePerBlock + ) + ] + where + mkTxIn :: ImpTestM era (TxIn (EraCrypto era)) + mkTxIn = do + addr <- freshKeyAddr_ + sendCoinTo addr (Coin 1_000_000) + + largeScript :: Maybe (Script era) + largeScript = do + script <- mkPlutusScript @era $ alwaysFailsWithDatum SPlutusV2 + pure $ fromPlutusScript script + + mkTxWithNScripts :: TxIn (EraCrypto era) -> Script era -> Int -> ImpTestM era (Tx era) + mkTxWithNScripts txIn script n = do + txIns <- replicateM n (produceRefScript script) + pure $ + mkBasicTx $ + mkBasicTxBody + & referenceInputsTxBodyL .~ Set.fromList txIns + & inputsTxBodyL .~ [txIn] + +-- Generate a list of integers such that the sum of their multiples by scale is greater than toExceed +-- and each individual value multiplied by the scale is smaller than maxSingle +genNumAdditionsExceeding :: Int -> Int -> Int -> ImpTestM era [Int] +genNumAdditionsExceeding sc maxSingle toExceed = go 0 [] + where + go tot !acc + | tot > toExceed = return $ reverse acc + | otherwise = do + x <- choose (1, min (toExceed `div` sc) (maxSingle `div` sc)) + let !newTot = tot + x * sc + go newTot (x : acc) diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/LedgerSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/LedgerSpec.hs index 5d60a2a0057..6ab7a71cc98 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/LedgerSpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/LedgerSpec.hs @@ -30,8 +30,7 @@ spec = let script :: Script era script = fromPlutusScript plutusScript size = originalBytesSize script - (q, r) = maxRefScriptSizePerTx `quotRem` size - n = q + signum r + n = maxRefScriptSizePerTx `div` size + 1 txIns <- replicateM n (produceRefScript script) let tx :: Tx era tx = mkBasicTx (mkBasicTxBody & referenceInputsTxBodyL .~ Set.fromList txIns) diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs index 331954a460e..4c68bf4998b 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs @@ -125,8 +125,10 @@ import Cardano.Ledger.Address ( RewardAccount (..), bootstrapKeyHash, ) +import Cardano.Ledger.BHeaderView (BHeaderView) import Cardano.Ledger.BaseTypes import Cardano.Ledger.Binary (DecCBOR, EncCBOR) +import Cardano.Ledger.Block (Block) import Cardano.Ledger.CertState (certDStateL, dsUnifiedL) import Cardano.Ledger.Coin (Coin (..)) import Cardano.Ledger.Core @@ -173,7 +175,11 @@ import Cardano.Ledger.Shelley.LedgerState ( utxosDonationL, utxosUtxoL, ) -import Cardano.Ledger.Shelley.Rules (LedgerEnv (..)) +import Cardano.Ledger.Shelley.Rules ( + BbodyEnv (..), + LedgerEnv (..), + ShelleyBbodyState, + ) import Cardano.Ledger.Shelley.Scripts ( ShelleyEraScript, pattern RequireAllOf, @@ -348,6 +354,13 @@ class , ToExpr (StashedAVVMAddresses era) , NFData (StashedAVVMAddresses era) , Default (StashedAVVMAddresses era) + , -- For BBODY rule + STS (EraRule "BBODY" era) + , BaseM (EraRule "BBODY" era) ~ ShelleyBase + , Environment (EraRule "BBODY" era) ~ BbodyEnv era + , State (EraRule "BBODY" era) ~ ShelleyBbodyState era + , Signal (EraRule "BBODY" era) ~ Block (BHeaderView (EraCrypto era)) era + , State (EraRule "LEDGERS" era) ~ LedgerState era , -- For the LEDGER rule STS (EraRule "LEDGER" era) , BaseM (EraRule "LEDGER" era) ~ ShelleyBase diff --git a/libs/cardano-ledger-api/cardano-ledger-api.cabal b/libs/cardano-ledger-api/cardano-ledger-api.cabal index 3cf66d691e0..62cbe16c35b 100644 --- a/libs/cardano-ledger-api/cardano-ledger-api.cabal +++ b/libs/cardano-ledger-api/cardano-ledger-api.cabal @@ -55,7 +55,7 @@ library aeson >=2.2, bytestring, cardano-ledger-allegra ^>=1.5, - cardano-ledger-alonzo ^>=1.9, + cardano-ledger-alonzo >=1.9 && <1.11, cardano-ledger-babbage ^>=1.8.1, cardano-ledger-binary ^>=1.3, cardano-ledger-conway >=1.13 && <1.17, diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoBBODY.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoBBODY.hs index 41d87db8b21..dc902460c0d 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoBBODY.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoBBODY.hs @@ -30,6 +30,11 @@ import Cardano.Ledger.BaseTypes ( ) import Cardano.Ledger.Block (Block (..)) import Cardano.Ledger.Coin (Coin (..)) +import Cardano.Ledger.Conway.Rules (ConwayCertsPredFailure (..), ConwayLedgerPredFailure (..)) +import qualified Cardano.Ledger.Conway.Rules as Conway ( + ConwayBbodyPredFailure (..), + ConwayCertPredFailure (..), + ) import Cardano.Ledger.Credential ( Credential (..), StakeCredential, @@ -127,7 +132,7 @@ tests = "Generic Tests, testing Alonzo PredicateFailures, in postAlonzo eras." [ alonzoBBODYexamplesP Alonzo , alonzoBBODYexamplesP Babbage - -- alonzoBBODYexamplesP Conway TODO + , alonzoBBODYexamplesP Conway ] alonzoBBODYexamplesP :: @@ -681,7 +686,7 @@ testBBodyState pf = -- ============================== Helper functions =============================== -makeTooBig :: Proof era -> AlonzoBbodyPredFailure era +makeTooBig :: Proof era -> PredicateFailure (EraRule "BBODY" era) makeTooBig proof@Alonzo = ShelleyInAlonzoBbodyPredFailure . LedgersFailure @@ -698,8 +703,13 @@ makeTooBig proof@Babbage = . DelplFailure . PoolFailure $ PoolMedataHashTooBig (coerceKeyRole . hashKey . vKey $ someKeys proof) (hashsize @Mock + 1) --- makeTooBig proof@Conway = --- ShelleyInAlonzoBbodyPredFailure . LedgersFailure . LedgerFailure . ConwayCertsFailure . CertFailure . PoolFailure $ ConwayPoolPredFailure -- FIXME: This needs fixing after POOL rules are implemented for Conway +makeTooBig proof@Conway = + Conway.LedgersFailure + . LedgerFailure + . ConwayCertsFailure + . CertFailure + . Conway.PoolFailure + $ PoolMedataHashTooBig (coerceKeyRole . hashKey . vKey $ someKeys proof) (hashsize @Mock + 1) makeTooBig proof = error ("makeTooBig does not work in era " ++ show proof) coldKeys :: Crypto c => KeyPair 'BlockIssuer c diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/STSTestUtils.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/STSTestUtils.hs index ce83f2aea91..b8f4efb1cd6 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/STSTestUtils.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/STSTestUtils.hs @@ -36,7 +36,6 @@ where import qualified Cardano.Crypto.Hash as CH import Cardano.Ledger.Address (Addr (..)) import Cardano.Ledger.Alonzo.Rules ( - AlonzoBBODY, AlonzoUtxoPredFailure (..), AlonzoUtxosPredFailure (..), AlonzoUtxowPredFailure (..), @@ -103,7 +102,6 @@ import Test.Cardano.Ledger.Shelley.Utils ( ) import Test.Tasty.HUnit (Assertion, assertFailure, (@?=)) --- import Test.Cardano.Ledger.Generic.PrettyCore(pcTx) import Test.Cardano.Ledger.Constrained.Preds.Tx (pcTxWithUTxO) -- ================================================================= @@ -252,7 +250,7 @@ testBBODY :: WitRule "BBODY" era -> ShelleyBbodyState era -> Block (BHeaderView (EraCrypto era)) era -> - Either (NonEmpty (PredicateFailure (AlonzoBBODY era))) (ShelleyBbodyState era) -> + Either (NonEmpty (PredicateFailure (EraRule "BBODY" era))) (ShelleyBbodyState era) -> PParams era -> Assertion testBBODY wit@(BBODY proof) initialSt block expected pparams = diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/PrettyCore.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/PrettyCore.hs index edb2f0ffec4..2aa3095008b 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/PrettyCore.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/PrettyCore.hs @@ -121,6 +121,7 @@ import Cardano.Ledger.Conway.Governance ( ) import Cardano.Ledger.Conway.Rules ( CertEnv (..), + ConwayBbodyPredFailure, ConwayCertsPredFailure (..), ConwayDelegEnv (..), ConwayDelegPredFailure (..), @@ -1662,6 +1663,36 @@ instance Reflect era => PrettyA (ShelleyBbodyPredFailure era) where prettyA = ppBbodyPredicateFailure -- ================ +ppConwayBbodyPredFail :: forall era. Reflect era => ConwayBbodyPredFailure era -> PDoc +ppConwayBbodyPredFail (ConwayRules.BodyRefScriptsSizeTooBig s1 s2) = + ppRecord + "BodyRefScriptsSizeTooBig" + [ ("Computed sum of reference script size", ppInt s1) + , ("Maximum allowed total reference script size", ppInt s2) + ] +ppConwayBbodyPredFail (ConwayRules.TooManyExUnits e1 e2) = + ppRecord + "TooManyExUnits" + [ ("Computed Sum of ExUnits for all plutus scripts", pcExUnits e1) + , ("Maximum allowed by protocal parameters", pcExUnits e2) + ] +ppConwayBbodyPredFail (ConwayRules.WrongBlockBodySizeBBODY x y) = + ppRecord + "WrongBlockBodySizeBBODY" + [ ("actual computed BBody size", ppInt x) + , ("claimed BBody Size in Header", ppInt y) + ] +ppConwayBbodyPredFail (ConwayRules.InvalidBodyHashBBODY h1 h2) = + ppRecord + "(InvalidBodyHashBBODY" + [ ("actual hash", ppHash h1) + , ("claimed hash", ppHash h2) + ] +ppConwayBbodyPredFail (ConwayRules.LedgersFailure x) = + ppSexp "LedgersFailure" [ppLEDGERS @era reify x] + +instance Reflect era => PrettyA (ConwayBbodyPredFailure era) where + prettyA = ppConwayBbodyPredFail ppAlonzoBbodyPredFail :: Reflect era => AlonzoBbodyPredFailure era -> PDoc ppAlonzoBbodyPredFail (ShelleyInAlonzoBbodyPredFailure x) =