Translate all tests from AlonzoBBODY to Imp test

eras/alonzo/impl/cardano-ledger-alonzo.cabal

@@ -161,6 +161,7 @@ library testlib
     Test.Cardano.Ledger.Alonzo.Era
     Test.Cardano.Ledger.Alonzo.Examples
     Test.Cardano.Ledger.Alonzo.Imp
+    Test.Cardano.Ledger.Alonzo.Imp.BbodySpec
     Test.Cardano.Ledger.Alonzo.Imp.UtxoSpec
     Test.Cardano.Ledger.Alonzo.Imp.UtxosSpec
     Test.Cardano.Ledger.Alonzo.Imp.UtxowSpec

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

@@ -47,6 +47,7 @@ import Cardano.Ledger.Binary (
  )
 import Cardano.Ledger.Core
 import Cardano.Ledger.Shelley.BlockBody (auxDataSeqDecoder)
+import Control.DeepSeq (NFData)
 import Control.Monad (unless)
 import Data.ByteString (ByteString)
 import Data.ByteString.Builder (Builder, shortByteString, toLazyByteString)
@@ -88,6 +89,8 @@ data AlonzoBlockBody era = AlonzoBlockBodyInternal
   }
   deriving (Generic)
 
+instance NFData (Tx TopTx era) => NFData (AlonzoBlockBody era)
+
 instance EraBlockBody AlonzoEra where
   type BlockBody AlonzoEra = AlonzoBlockBody AlonzoEra
   mkBasicBlockBody = mkBasicBlockBodyAlonzo

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

@@ -55,6 +55,7 @@ import Cardano.Ledger.Shelley.Rules (
   ShelleyUtxowPredFailure,
  )
 import Cardano.Ledger.Slot (epochInfoEpoch, epochInfoFirst)
+import Control.DeepSeq (NFData)
 import Control.Monad.Trans.Reader (asks)
 import Control.State.Transition (
   Embed (..),
@@ -80,10 +81,16 @@ data AlonzoBbodyPredFailure era
   | TooManyExUnits (Mismatch RelLTEQ ExUnits)
   deriving (Generic)
 
+instance NFData (PredicateFailure (EraRule "LEDGERS" era)) => NFData (AlonzoBbodyPredFailure era)
+
 newtype AlonzoBbodyEvent era
   = ShelleyInAlonzoEvent (ShelleyBbodyEvent era)
   deriving (Generic)
 
+deriving instance
+  Eq (Event (EraRule "LEDGERS" era)) =>
+  Eq (AlonzoBbodyEvent era)
+
 type instance EraRuleFailure "BBODY" AlonzoEra = AlonzoBbodyPredFailure AlonzoEra
 
 instance InjectRuleFailure "BBODY" AlonzoBbodyPredFailure AlonzoEra

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

@@ -10,6 +10,7 @@ module Test.Cardano.Ledger.Alonzo.Imp where
 
 import Cardano.Ledger.Alonzo (AlonzoEra)
 import Cardano.Ledger.Shelley.Core (ShelleyEraTxCert)
+import qualified Test.Cardano.Ledger.Alonzo.Imp.BbodySpec as Bbody
 import qualified Test.Cardano.Ledger.Alonzo.Imp.UtxoSpec as Utxo
 import qualified Test.Cardano.Ledger.Alonzo.Imp.UtxosSpec as Utxos
 import qualified Test.Cardano.Ledger.Alonzo.Imp.UtxowSpec as Utxow
@@ -27,6 +28,7 @@ spec ::
 spec = do
   MaryImp.spec @era
   describe "AlonzoImpSpec" . withEachEraVersion @era $ do
+    Bbody.spec
     Utxo.spec
     Utxos.spec
     Utxow.spec

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

@@ -0,0 +1,112 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Test.Cardano.Ledger.Alonzo.Imp.BbodySpec (spec) where
+
+import Cardano.Ledger.Alonzo.Core
+import Cardano.Ledger.Alonzo.Scripts (eraLanguages)
+import Cardano.Ledger.Alonzo.TxWits (unRedeemersL)
+import Cardano.Ledger.BaseTypes (
+  StrictMaybe (..),
+  textToUrl,
+ )
+import Cardano.Ledger.Credential (Credential (..))
+import Cardano.Ledger.Plutus (
+  Data (..),
+  hashPlutusScript,
+  withSLanguage,
+ )
+import Cardano.Ledger.Shelley.LedgerState (curPParamsEpochStateL, nesEsL)
+import Cardano.Ledger.Shelley.Rules (ShelleyPoolPredFailure (..))
+import Cardano.Ledger.State (PoolMetadata (..), sppMetadataL)
+import Control.Monad.Reader (asks)
+import Control.Monad.State.Strict (get)
+import qualified Data.ByteString as BS
+import qualified Data.Map.Strict as Map
+import Data.Maybe (fromJust)
+import Lens.Micro
+import qualified PlutusLedgerApi.Common as P
+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 = describe "BBODY" $ do
+  forM_ (eraLanguages @era) $ \lang ->
+    withSLanguage lang $ \slang ->
+      describe (show lang) $ do
+        let
+          alwaysSucceedsWithDatumHash = hashPlutusScript $ alwaysSucceedsWithDatum slang :: ScriptHash
+          alwaysFailsWithDatumHash = hashPlutusScript $ alwaysFailsWithDatum slang :: ScriptHash
+          alwaysSucceedsNoDatumHash = hashPlutusScript $ alwaysSucceedsNoDatum slang :: ScriptHash
+          alwaysFailsNoDatumHash = hashPlutusScript $ alwaysFailsNoDatum slang :: ScriptHash
+          evenRedeemerNoDatumHash = hashPlutusScript $ evenRedeemerNoDatum slang :: ScriptHash
+
+        it "succeeds with eight Plutus scripts" $ do
+          rewardAccount <- registerStakeCredential $ ScriptHashObj evenRedeemerNoDatumHash
+          txCert <- genUnRegTxCert $ ScriptHashObj evenRedeemerNoDatumHash
+
+          withTxsInBlock_ $ do
+            impAnn "notValidatingTx" $ do
+              txIn <- produceScript alwaysFailsWithDatumHash
+              submitPhase2Invalid_ $ mkBasicTx $ mkBasicTxBody & inputsTxBodyL .~ [txIn]
+            impAnn "validatingTx" $ do
+              txIn <- produceScript alwaysSucceedsWithDatumHash
+              submitTx_ $ mkBasicTx $ mkBasicTxBody & inputsTxBodyL .~ [txIn]
+
+            impAnn "notValidatingTxWithMint" $ do
+              submitPhase2Invalid_ =<< mkTokenMintingTx alwaysFailsNoDatumHash
+            impAnn "validatingTxWithMint" $ do
+              submitTx_ =<< mkTokenMintingTx alwaysSucceedsNoDatumHash
+
+            maxExUnits <- getsNES $ nesEsL . curPParamsEpochStateL . ppMaxTxExUnitsL
+
+            let dex i = (Data $ P.I i, maxExUnits)
+                rPurpose = mkRewardingPurpose (AsIx 0)
+                cPurpose = mkCertifyingPurpose (AsIx 0)
+
+            impAnn "notValidatingTxWithWithdrawal" $ do
+              submitPhase2Invalid_ $
+                mkBasicTx mkBasicTxBody
+                  & bodyTxL . withdrawalsTxBodyL .~ Withdrawals [(rewardAccount, mempty)]
+                  & witsTxL . rdmrsTxWitsL . unRedeemersL %~ Map.insert rPurpose (dex 1)
+            impAnn "validatingTxWithWithdrawal" $ do
+              submitTx_ $
+                mkBasicTx mkBasicTxBody
+                  & bodyTxL . withdrawalsTxBodyL .~ Withdrawals [(rewardAccount, mempty)]
+                  & witsTxL . rdmrsTxWitsL . unRedeemersL %~ Map.insert rPurpose (dex 0)
+
+            impAnn "notValidatingTxWithCert" $ do
+              submitPhase2Invalid_ $
+                mkBasicTx mkBasicTxBody
+                  & bodyTxL . certsTxBodyL .~ [txCert]
+                  & witsTxL . rdmrsTxWitsL . unRedeemersL %~ Map.insert cPurpose (dex 1)
+            impAnn "validatingTxWithCert" $ do
+              submitTx_ $
+                mkBasicTx mkBasicTxBody
+                  & bodyTxL . certsTxBodyL .~ [txCert]
+                  & witsTxL . rdmrsTxWitsL . unRedeemersL %~ Map.insert cPurpose (dex 0)
+
+        it "fails with bad pool MD hash in Tx" $ do
+          let
+            hashSize = standardHashSize + 1
+            metadata = PoolMetadata (fromJust $ textToUrl 64 "") (BS.replicate hashSize 0)
+
+          poolId <- freshKeyHash
+          rewardAccount <- registerStakeCredential $ ScriptHashObj alwaysSucceedsNoDatumHash
+          poolParams <- freshPoolParams poolId rewardAccount <&> sppMetadataL .~ SJust metadata
+
+          let tx = mkBasicTx $ mkBasicTxBody & certsTxBodyL .~ [RegPoolTxCert poolParams]
+
+          submitFailingTx tx [injectFailure $ PoolMedataHashTooBig poolId hashSize]
+
+          txFixed <- (tx &) =<< asks iteFixup
+          finalState <- get
+
+          failures <- fmap fst . expectLeftDeepExpr =<< tryTxsInBlock [txFixed] finalState
+          failures `shouldBeExpr` [injectFailure $ PoolMedataHashTooBig poolId hashSize]

eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/ImpTest.hs

@@ -426,8 +426,8 @@ instance ShelleyEraImp AlonzoEra where
               }
         , agMaxBlockExUnits =
             ExUnits
-              { exUnitsMem = 50_000_000
-              , exUnitsSteps = 40_000_000_000
+              { exUnitsMem = 200_000_000
+              , exUnitsSteps = 200_000_000_000
               }
         , agMaxValSize = 5000
         , agCollateralPercentage = 150

eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/TreeDiff.hs

@@ -14,6 +14,7 @@ module Test.Cardano.Ledger.Alonzo.TreeDiff (
 ) where
 
 import Cardano.Ledger.Alonzo (AlonzoEra)
+import Cardano.Ledger.Alonzo.BlockBody
 import Cardano.Ledger.Alonzo.Core
 import Cardano.Ledger.Alonzo.PParams
 import Cardano.Ledger.Alonzo.Plutus.Context
@@ -122,6 +123,8 @@ instance ToExpr (AlonzoTxBodyRaw TopTx AlonzoEra) where
 
 instance ToExpr (TxBody TopTx AlonzoEra)
 
+instance ToExpr (Tx TopTx era) => ToExpr (AlonzoBlockBody era)
+
 -- Tx
 instance ToExpr IsValid
 

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

@@ -82,6 +82,7 @@ import Cardano.Ledger.Shelley.Rules (
  )
 import qualified Cardano.Ledger.Shelley.Rules as Shelley (ShelleyBbodyPredFailure (..))
 import Cardano.Ledger.Shelley.UTxO (UTxO (..), txouts, unUTxO)
+import Control.DeepSeq (NFData)
 import Control.State.Transition (
   Embed (..),
   STS (..),
@@ -119,6 +120,10 @@ deriving instance
   (Era era, Eq (PredicateFailure (EraRule "LEDGERS" era))) =>
   Eq (ConwayBbodyPredFailure era)
 
+deriving anyclass instance
+  (Era era, NFData (PredicateFailure (EraRule "LEDGERS" era))) =>
+  NFData (ConwayBbodyPredFailure era)
+
 deriving anyclass instance
   (Era era, NoThunks (PredicateFailure (EraRule "LEDGERS" era))) =>
   NoThunks (ConwayBbodyPredFailure era)