Implement BBODY Imp tests for Alonzo

Author: neilmayhew

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/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,84 @@
+{-# LANGUAGE OverloadedLists #-}
+{-# 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.Credential (Credential (..))
+import Cardano.Ledger.Plutus (
+  Data (..),
+  hashPlutusScript,
+  withSLanguage,
+ )
+import Cardano.Ledger.Shelley.LedgerState (curPParamsEpochStateL, nesEsL)
+import qualified Data.Map.Strict as Map
+import Lens.Micro
+import qualified PlutusLedgerApi.Common as P
+import Test.Cardano.Ledger.Alonzo.ImpTest
+import Test.Cardano.Ledger.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" $
+          const $
+            pendingWith "not implemented yet"