diff --git a/eras/alonzo/impl/cardano-ledger-alonzo.cabal b/eras/alonzo/impl/cardano-ledger-alonzo.cabal index 377d65ad2d5..b61e8b9222a 100644 --- a/eras/alonzo/impl/cardano-ledger-alonzo.cabal +++ b/eras/alonzo/impl/cardano-ledger-alonzo.cabal @@ -179,6 +179,7 @@ library testlib Test.Cardano.Ledger.Alonzo.Translation.TranslatableGen Test.Cardano.Ledger.Alonzo.Translation.TranslationInstance Test.Cardano.Ledger.Alonzo.TreeDiff + Test.Cardano.Ledger.Alonzo.TxInfoSpec visibility: public hs-source-dirs: testlib @@ -223,6 +224,7 @@ library testlib microlens-mtl, mtl, plutus-ledger-api, + plutus-tx, serialise, text, time, diff --git a/eras/alonzo/impl/test/Main.hs b/eras/alonzo/impl/test/Main.hs index 26965346028..ef3b6eef0e8 100644 --- a/eras/alonzo/impl/test/Main.hs +++ b/eras/alonzo/impl/test/Main.hs @@ -13,6 +13,7 @@ import qualified Test.Cardano.Ledger.Alonzo.GoldenTranslation as GoldenTranslati import qualified Test.Cardano.Ledger.Alonzo.Imp as Imp import qualified Test.Cardano.Ledger.Alonzo.Imp.TxInfoSpec as TxInfoImp import Test.Cardano.Ledger.Alonzo.ImpTest () +import qualified Test.Cardano.Ledger.Alonzo.TxInfoSpec as TxInfoSpec import Test.Cardano.Ledger.Common import Test.Cardano.Ledger.Core.JSON (roundTripJsonEraSpec) import Test.Cardano.Ledger.Shelley.JSON (roundTripJsonShelleyEraSpec) @@ -35,3 +36,4 @@ main = describe "TxWits" $ do TxWitsSpec.spec @AlonzoEra TxInfoImp.spec + TxInfoSpec.spec @AlonzoEra diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/TxInfoSpec.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/TxInfoSpec.hs new file mode 100644 index 00000000000..2d2aac7b56b --- /dev/null +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/TxInfoSpec.hs @@ -0,0 +1,539 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Test.Cardano.Ledger.Alonzo.TxInfoSpec ( + spec, + txInfoSpec, + txInfoSignersSpec, + txInfoCertsSpec, + EraPlutusTxOut (..), + EraTranslateValidityInterval (..), + -- ** Assertions + expectTxIns, + expectTxOutputs, + expectWithdrawals, + expectFee, + expectMintValue, + expectDatums, + expectTxId, + expectValidityRange, + expectSignatories, +) where + +import Cardano.Ledger.Alonzo.Plutus.Context ( + ContextError, + EraPlutusTxInfo (..), + LedgerTxInfo (..), + PlutusTxInfo, toPlutusTxInfoForPurpose, toPlutusTxCert, + ) +import Cardano.Ledger.Alonzo.Scripts (AsPurpose (..)) +import Cardano.Ledger.Alonzo (AlonzoEra) +import Cardano.Ledger.Alonzo.Plutus.TxInfo (AlonzoContextError (TranslationLogicMissingInput, TimeTranslationPastHorizon), transMultiAsset, transWithdrawals, transTxOut, transValue, transTxWitsDatums, transTxBodyId, transValidityInterval) +import Cardano.Ledger.Alonzo.Core +import Cardano.Ledger.Alonzo.TxWits (TxDats) +import Cardano.Ledger.BaseTypes ( + ProtVer (ProtVer), + StrictMaybe (SJust, SNothing), Inject (inject), + ) +import Data.Proxy (Proxy (..)) +import Cardano.Ledger.Coin (Coin (Coin)) +import qualified GHC.Exts as GHC +import qualified PlutusLedgerApi.V2 as PV2 +import qualified PlutusLedgerApi.V3 as PV3 +import qualified PlutusLedgerApi.V3 as PV4 +import qualified PlutusLedgerApi.V3.MintValue as PV3 +import Cardano.Ledger.Mary.Value (MaryValue(MaryValue), MultiAsset, valueFromList) +import Cardano.Ledger.Plutus.Language (Language (..), SLanguage (..)) +import Cardano.Ledger.State (UTxO (..), txinLookup) +import Cardano.Ledger.TxIn (TxIn (..)) +import Cardano.Slotting.EpochInfo (EpochInfo, fixedEpochInfo, hoistEpochInfo) +import Cardano.Slotting.Slot (EpochSize (..), SlotNo (..)) +import Cardano.Slotting.Time (SystemStart (..), mkSlotLength) +import qualified Data.Map.Strict as Map +import Data.Sequence.Strict (StrictSeq) +import qualified Data.Sequence.Strict as StrictSeq +import qualified Data.Set as Set +import Data.Set (Set) +import qualified Data.Text as Text +import Data.Functor.Identity (Identity) +import Data.Maybe (mapMaybe) +import Cardano.Ledger.Plutus.TxInfo (transAccountAddress, transCoinToLovelace, transKeyHash, transTxIn, transSafeHash) +import Data.Bifunctor (bimap) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Lens.Micro +import qualified PlutusLedgerApi.V1 as PV1 +import Test.Cardano.Ledger.Alonzo.Arbitrary () +import Test.Cardano.Ledger.Common +import qualified PlutusTx.AssocMap as AssocMap + +type family PlutusTxOut (l :: Language) where + PlutusTxOut 'PlutusV1 = PV1.TxOut + PlutusTxOut 'PlutusV2 = PV2.TxOut + PlutusTxOut 'PlutusV3 = PV3.TxOut + PlutusTxOut 'PlutusV4 = PV3.TxOut + +-- | Type class for era- and language-specific output assertion in TxInfo tests. +-- Instances for V1 are defined here; instances for V2/V3/V4 are defined in the +-- Babbage testlib (they require 'BabbageEraTxOut' and 'transTxOutV2'). +class EraPlutusTxOut (l :: Language) era where + toPlutusTxOut :: proxy l -> TxOut era -> Maybe (PlutusTxOut l) + +instance (AlonzoEraTxOut era, Value era ~ MaryValue) => EraPlutusTxOut 'PlutusV1 era where + toPlutusTxOut _ = transTxOut + +-- | Type class for era-specific validity interval translation in tests. +class EraTranslateValidityInterval era where + translateVI :: + EpochInfo (Either Text.Text) -> + SystemStart -> + ValidityInterval -> + Either (ContextError era) PV1.POSIXTimeRange + +instance EraTranslateValidityInterval AlonzoEra where + translateVI = transValidityInterval (Proxy @AlonzoEra) + +spec :: + forall era. + ( EraTx era + , AlonzoEraTxBody era + , AlonzoEraTxWits era + , Value era ~ MaryValue + , EraPlutusTxInfo 'PlutusV1 era + , EraPlutusTxOut 'PlutusV1 era + , EraTranslateValidityInterval era + , Inject (AlonzoContextError era) (ContextError era) + , Arbitrary (TxCert era) + , AtMostEra "Conway" era + ) => + Spec +spec = do + describe "txInfo translation" $ do + txInfoSpec @era SPlutusV1 + txInfoSignersSpec @era SPlutusV1 + txInfoCertsSpec @era SPlutusV1 + +txInfoSpec :: + forall era l. + ( EraTx era + , AlonzoEraTxBody era + , AlonzoEraTxWits era + , Value era ~ MaryValue + , EraPlutusTxInfo l era + , EraPlutusTxOut l era + , EraTranslateValidityInterval era + , Inject (AlonzoContextError era) (ContextError era) + , AtMostEra "Conway" era + ) => + SLanguage l -> + Spec +txInfoSpec slang = do + describe (show slang) $ do + prop "correctly translate tx with alonzo-era features" $ do + inputs <- listOf1 genUtxoEntry + outputs <- listOf1 genTxOut + feeCoin <- arbitrary + mintValue <- arbitrary + wdrls <- arbitrary + validityRange <- arbitrary + signers <- arbitrary + datums <- arbitrary @(TxDats era) + let utxoSet = UTxO $ Map.fromList inputs + txIns = Set.fromList $ fmap fst inputs + txBody = + mkBasicTxBody + & inputsTxBodyL .~ txIns + & outputsTxBodyL .~ StrictSeq.fromList outputs + & feeTxBodyL .~ feeCoin + & mintTxBodyL .~ mintValue + & withdrawalsTxBodyL .~ wdrls + & vldtTxBodyL .~ validityRange + & reqSignerHashesTxBodyL .~ signers + tx = mkBasicTx txBody & witsTxL . datsTxWitsL .~ datums + pure $ + successfulTranslation @era + slang + utxoSet + tx + -- Assertions + $ \_slang txInfo -> do + -- Inputs with Byron addresses (or StakeRefPtr) are silently dropped in Alonzo + expectTxIns slang utxoSet txIns txInfo + + -- Outputs with Byron addresses are also silently dropped in Alonzo. + expectTxOutputs slang outputs txInfo + + -- Assertions on the fee in the TxInfo + expectFee slang feeCoin txInfo + + -- Assertions on the mint value in the TxInfo + expectMintValue slang mintValue txInfo + + -- Assertions on the withdrawals in the TxInfo + expectWithdrawals slang wdrls txInfo + + -- Assertions on the datums in the TxInfo + expectDatums slang (tx ^. witsTxL) txInfo + + -- Assertions on the txId in the TxInfo + expectTxId slang txBody txInfo + + -- Assertions on the validity range in the TxInfo + expectValidityRange @era slang validityRange txInfo + + -- Assertions on the required signatories in the TxInfo + expectSignatories signers slang txInfo + + + prop "translation fails when input not in UTxO" $ do + -- Generate a valid transaction with inputs + inputs <- listOf1 genUtxoEntry + outputs <- listOf1 genTxOut + feeCoin <- arbitrary + + -- Pick one input to exclude from the UTxO + missingInputIdx <- choose (0, length inputs - 1) + let (missingTxIn, _) = inputs !! missingInputIdx + -- Create UTxO without the missing input + utxoSet = UTxO $ Map.fromList $ filter ((/= missingTxIn) . fst) inputs + txIns = Set.fromList $ fmap fst inputs + txBody = + mkBasicTxBody @era + & inputsTxBodyL .~ txIns + & outputsTxBodyL .~ StrictSeq.fromList outputs + & feeTxBodyL .~ feeCoin + tx = mkBasicTx txBody + lti = + LedgerTxInfo + { ltiProtVer = ProtVer (eraProtVerLow @era) 0 + , ltiEpochInfo = ei + , ltiSystemStart = ss + , ltiUTxO = utxoSet + , ltiTx = tx + } + + let expectedError = TranslationLogicMissingInput @era missingTxIn + + pure $ case toPlutusTxInfoForPurpose slang lti (SpendingPurpose AsPurpose) of + Left err -> + err === inject expectedError + Right _ -> + counterexample "Expected translation to fail when input not in UTxO" False + + prop "translation fails for slot past horizon" $ do + inputs <- listOf1 (genUtxoEntry @era) + outputs <- listOf1 genTxOut + feeCoin <- arbitrary + + -- Create an EpochInfo that always fails (simulating a horizon error) + let timeTranslationErrMsg = Text.pack "Slot is past the forecasting horizon" + failingEpochInfo :: EpochInfo (Either Text.Text) + failingEpochInfo = hoistEpochInfo + (\_ -> Left timeTranslationErrMsg) + $ fixedEpochInfo @Identity (EpochSize 100) (mkSlotLength 1) + + -- Any slot will trigger the error with failingEpochInfo + veryFarSlot <- SlotNo <$> arbitrary + let validityRange = ValidityInterval (SJust veryFarSlot) SNothing + utxoSet = UTxO $ Map.fromList inputs + txIns = Set.fromList $ fmap fst inputs + txBody = + mkBasicTxBody + & inputsTxBodyL .~ txIns + & outputsTxBodyL .~ StrictSeq.fromList outputs + & feeTxBodyL .~ feeCoin + & vldtTxBodyL .~ validityRange + tx = mkBasicTx txBody + lti = + LedgerTxInfo + { ltiProtVer = ProtVer (eraProtVerLow @era) 0 + , ltiEpochInfo = failingEpochInfo + , ltiSystemStart = ss + , ltiUTxO = utxoSet + , ltiTx = tx + } + + let expectedError = TimeTranslationPastHorizon @era timeTranslationErrMsg + + pure $ case toPlutusTxInfoForPurpose slang lti (SpendingPurpose AsPurpose) of + Left err -> + err === inject expectedError + Right _ -> + counterexample "Expected translation to fail for slot past horizon" False + +expectTxIns :: + forall era l. + ( AlonzoEraTxBody era + , Value era ~ MaryValue + , EraPlutusTxInfo l era + ) => + SLanguage l -> + UTxO era -> + Set TxIn -> + PlutusTxInfo l -> + Expectation +expectTxIns slang utxoSet txIns txInfo = + case slang of + SPlutusV1 -> do + let expectedInputs = + mapMaybe + (\txIn -> PV1.TxInInfo (transTxIn txIn) <$> (transTxOut @era =<< txinLookup txIn utxoSet)) + (Set.toList txIns) + PV1.txInfoInputs txInfo `shouldBe` expectedInputs + SPlutusV2 -> do + expectedInputs <- traverse (expectRight . toPlutusTxInInfo slang utxoSet) (Set.toList txIns) + PV2.txInfoInputs txInfo `shouldBe` expectedInputs + SPlutusV3 -> do + expectedInputs <- traverse (expectRight . toPlutusTxInInfo slang utxoSet) (Set.toList txIns) + PV3.txInfoInputs txInfo `shouldBe` expectedInputs + SPlutusV4 -> do + expectedInputs <- traverse (expectRight . toPlutusTxInInfo slang utxoSet) (Set.toList txIns) + PV4.txInfoInputs txInfo `shouldBe` expectedInputs + +expectTxOutputs :: + forall era l. + (EraPlutusTxOut l era) => + SLanguage l -> + [TxOut era] -> + PlutusTxInfo l -> + Expectation +expectTxOutputs slang outputs txInfo = do + let expectedOutputs = mapMaybe (toPlutusTxOut slang) outputs + case slang of + SPlutusV1 -> do + PV1.txInfoOutputs txInfo `shouldBe` expectedOutputs + SPlutusV2 -> do + PV2.txInfoOutputs txInfo `shouldBe` expectedOutputs + SPlutusV3 -> do + PV3.txInfoOutputs txInfo `shouldBe` expectedOutputs + SPlutusV4 -> do + PV4.txInfoOutputs txInfo `shouldBe` expectedOutputs + +expectTxCerts :: + forall era l. + ( EraPlutusTxInfo l era + ) => + ProtVer -> + StrictSeq (TxCert era) -> + SLanguage l -> + PlutusTxInfo l -> + Expectation +expectTxCerts pv certs slang txInfo = do + expectedCerts <- traverse (expectRight . toPlutusTxCert @l @era slang pv) $ GHC.toList certs + case slang of + SPlutusV1 -> PV1.txInfoDCert txInfo `shouldBe` expectedCerts + SPlutusV2 -> PV2.txInfoDCert txInfo `shouldBe` expectedCerts + SPlutusV3 -> PV3.txInfoTxCerts txInfo `shouldBe` expectedCerts + SPlutusV4 -> PV4.txInfoTxCerts txInfo `shouldBe` expectedCerts + +expectFee :: + SLanguage l -> + Coin -> + PlutusTxInfo l -> + Expectation +expectFee slang feeCoin txInfo = + case slang of + SPlutusV1 -> + AssocMap.toList (PV1.getValue $ PV1.txInfoFee txInfo) `shouldBe` + AssocMap.toList (PV1.getValue $ transValue $ valueFromList feeCoin []) + SPlutusV2 -> + AssocMap.toList (PV1.getValue $ PV2.txInfoFee txInfo) `shouldBe` + AssocMap.toList (PV1.getValue $ transValue $ valueFromList feeCoin []) + SPlutusV3 -> PV3.txInfoFee txInfo `shouldBe` transCoinToLovelace feeCoin + SPlutusV4 -> PV4.txInfoFee txInfo `shouldBe` transCoinToLovelace feeCoin + +expectMintValue :: + SLanguage l -> + MultiAsset -> + PlutusTxInfo l -> + Expectation +expectMintValue slang mintValue txInfo = + case slang of + SPlutusV1 -> + AssocMap.toList (PV1.getValue $ PV1.txInfoMint txInfo) `shouldBe` + -- PV1 adds an empty ada coin value in the Map, hence why we + -- need to create a 'MaryValue' with 0 Ada explicitly. + AssocMap.toList (PV1.getValue $ transValue $ MaryValue (Coin 0) mintValue) + SPlutusV2 -> + -- PV2 adds an empty ada coin value in the Map, hence why we + -- need to create a 'MaryValue' with 0 Ada explicitly. + AssocMap.toList (PV1.getValue $ PV2.txInfoMint txInfo) `shouldBe` + AssocMap.toList (PV1.getValue $ transValue $ MaryValue (Coin 0) mintValue) + SPlutusV3 -> + PV3.txInfoMint txInfo `shouldBe` + PV3.UnsafeMintValue (PV1.getValue (transMultiAsset mintValue)) + SPlutusV4 -> + PV4.txInfoMint txInfo `shouldBe` + PV3.UnsafeMintValue (PV1.getValue (transMultiAsset mintValue)) + +expectWithdrawals :: + SLanguage l -> + Withdrawals -> + PlutusTxInfo l -> + Expectation +expectWithdrawals slang wdrls txInfo = + case slang of + SPlutusV1 -> PV1.txInfoWdrl txInfo `shouldBe` Map.toList (transWithdrawals wdrls) + SPlutusV2 -> PV2.txInfoWdrl txInfo `shouldBe` AssocMap.unsafeFromList (Map.toList (transWithdrawals wdrls)) + SPlutusV3 -> + AssocMap.toList (PV3.txInfoWdrl txInfo) `shouldBe` + fmap (bimap transAccountAddress transCoinToLovelace) (Map.toList (unWithdrawals wdrls)) + SPlutusV4 -> + AssocMap.toList (PV4.txInfoWdrl txInfo) `shouldBe` + fmap (bimap transAccountAddress transCoinToLovelace) (Map.toList (unWithdrawals wdrls)) + +expectDatums :: + forall era l. + AlonzoEraTxWits era => + SLanguage l -> + TxWits era -> + PlutusTxInfo l -> + Expectation +expectDatums slang wits txInfo = + let datums = transTxWitsDatums wits + in case slang of + SPlutusV1 -> PV1.txInfoData txInfo `shouldBe` datums + SPlutusV2 -> PV2.txInfoData txInfo `shouldBe` AssocMap.unsafeFromList datums + SPlutusV3 -> PV3.txInfoData txInfo `shouldBe` AssocMap.unsafeFromList datums + SPlutusV4 -> PV4.txInfoData txInfo `shouldBe` AssocMap.unsafeFromList datums + +expectTxId :: + forall era lvl l. + ( EraTxBody era + ) => + SLanguage l -> + TxBody lvl era -> + PlutusTxInfo l -> + Expectation +expectTxId slang txBody txInfo = + case slang of + SPlutusV1 -> PV1.txInfoId txInfo `shouldBe` transTxBodyId txBody + SPlutusV2 -> PV2.txInfoId txInfo `shouldBe` transTxBodyId txBody + SPlutusV3 -> PV3.txInfoId txInfo `shouldBe` PV3.TxId (transSafeHash (hashAnnotated @_ @EraIndependentTxBody txBody)) + SPlutusV4 -> PV4.txInfoId txInfo `shouldBe` PV3.TxId (transSafeHash (hashAnnotated @_ @EraIndependentTxBody txBody)) + +expectSignatories :: + forall l. + Set (KeyHash Guard) -> + SLanguage l -> + PlutusTxInfo l -> + Expectation +expectSignatories signers slang txInfo = do + case slang of + SPlutusV1 -> PV1.txInfoSignatories txInfo `shouldBe` fmap transKeyHash (Set.toList signers) + SPlutusV2 -> PV2.txInfoSignatories txInfo `shouldBe` fmap transKeyHash (Set.toList signers) + SPlutusV3 -> PV3.txInfoSignatories txInfo `shouldBe` fmap transKeyHash (Set.toList signers) + SPlutusV4 -> PV4.txInfoSignatories txInfo `shouldBe` fmap transKeyHash (Set.toList signers) + +expectValidityRange :: + forall era l. + EraTranslateValidityInterval era => + SLanguage l -> + ValidityInterval -> + PlutusTxInfo l -> + Expectation +expectValidityRange slang vi txInfo = + case translateVI @era ei ss vi of + Left _ -> pure () -- Won't happen: fixedEpochInfo has no horizon + Right tr -> case slang of + SPlutusV1 -> PV1.txInfoValidRange txInfo `shouldBe` tr + SPlutusV2 -> PV2.txInfoValidRange txInfo `shouldBe` tr + SPlutusV3 -> PV3.txInfoValidRange txInfo `shouldBe` tr + SPlutusV4 -> PV4.txInfoValidRange txInfo `shouldBe` tr + +-- | Standalone property test for V1 certificate translation. Verifies that +-- arbitrary 'TxCert's are correctly reflected in the V1 'TxInfo'. +txInfoCertsSpec :: + forall era l. + ( EraTx era + , EraPlutusTxInfo l era + , Arbitrary (TxCert era) + ) => + SLanguage l -> + Spec +txInfoCertsSpec slang = + prop "correctly translate certificates" $ do + certs <- arbitrary + let pv = ProtVer (eraProtVerLow @era) 0 + txBody = mkBasicTxBody & certsTxBodyL .~ certs + tx = mkBasicTx txBody + pure $ + successfulTranslation @era slang mempty tx $ \_slang txInfo -> + expectTxCerts @era pv certs slang txInfo + +txInfoSignersSpec :: + forall era l. + ( EraTx era + , AlonzoEraTxBody era + , AtMostEra "Conway" era + , EraPlutusTxInfo l era + ) => + SLanguage l -> + Spec +txInfoSignersSpec slang = + prop "correctly translate tx signers" $ do + signers <- arbitrary + let txBody = + mkBasicTxBody + & reqSignerHashesTxBodyL .~ signers + tx = mkBasicTx txBody + pure $ + successfulTranslation @era slang mempty tx $ \_slang txInfo -> + expectSignatories signers slang txInfo + +successfulTranslation :: + forall era l. + ( EraPlutusTxInfo l era + ) => + SLanguage l -> + UTxO era -> + Tx TopTx era -> + (SLanguage l -> PlutusTxInfo l -> Expectation) -> + Expectation +successfulTranslation slang utxo tx f = + let lti = + LedgerTxInfo + { ltiProtVer = ProtVer (eraProtVerLow @era) 0 + , ltiEpochInfo = ei + , ltiSystemStart = ss + , ltiUTxO = utxo + , ltiTx = tx + } + in case toPlutusTxInfoForPurpose slang lti (SpendingPurpose AsPurpose) of + Right txInfo -> f slang txInfo + Left e -> assertFailure $ "no translation error was expected, but got: " <> show e + +ei :: EpochInfo (Either a) +ei = fixedEpochInfo (EpochSize 100) (mkSlotLength 1) + +ss :: SystemStart +ss = SystemStart $ posixSecondsToUTCTime 0 + +genUtxoEntry :: (AlonzoEraTxOut era, Arbitrary (Value era)) => Gen (TxIn, TxOut era) +genUtxoEntry = do + txIn <- arbitrary + txOut <- genTxOut + pure (txIn, txOut) + +genTxOut :: forall era. (AlonzoEraTxOut era, Arbitrary (Value era)) => Gen (TxOut era) +genTxOut = do + let genAddr = + -- Byron addresses are not permitted in later eras + if eraName @era == "Alonzo" + then arbitrary + else Addr <$> arbitrary <*> arbitrary <*> arbitrary + dataHash <- arbitrary + txOut <- + mkBasicTxOut + <$> genAddr + <*> scale (`div` 15) arbitrary + pure $ txOut & dataHashTxOutL .~ dataHash diff --git a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/TxInfoSpec.hs b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/TxInfoSpec.hs index c830e529b3c..37821c543d6 100644 --- a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/TxInfoSpec.hs +++ b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/TxInfoSpec.hs @@ -2,13 +2,24 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} - -module Test.Cardano.Ledger.Babbage.TxInfoSpec (txInfoSpec, spec) where +{-# LANGUAGE UndecidableInstances #-} +-- Orphan instances for 'EraPlutusTxOut (V2/V3/V4) that require +-- 'BabbageEraTxOut', which is unavailable in the Alonzo testlib. +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Cardano.Ledger.Babbage.TxInfoSpec + ( txInfoV1Spec + , txInfoSpec + , spec + , -- ** Assertions + expectReferenceInputs, + ) where import Cardano.Ledger.Alonzo.Plutus.Context ( ContextError, @@ -18,8 +29,15 @@ import Cardano.Ledger.Alonzo.Plutus.Context ( PlutusTxInfo, toPlutusTxInfoForPurpose, ) -import Cardano.Ledger.Alonzo.Plutus.TxInfo (AlonzoContextError (..), TxOutSource (..)) +import Cardano.Ledger.Alonzo.TxWits (TxDats) +import Cardano.Ledger.Alonzo.Plutus.TxInfo ( + AlonzoContextError (..), + TxOutSource (..), + ) +import qualified Cardano.Ledger.Alonzo.Plutus.TxInfo as Alonzo (transValidityInterval) +import Data.Proxy (Proxy (..)) import Cardano.Ledger.Alonzo.Scripts (AsPurpose (..)) +import Cardano.Ledger.Babbage (BabbageEra) import Cardano.Ledger.Babbage.Core import Cardano.Ledger.Babbage.TxInfo ( BabbageContextError (..), @@ -51,12 +69,261 @@ import Lens.Micro import qualified PlutusLedgerApi.V1 as PV1 import qualified PlutusLedgerApi.V2 as PV2 import qualified PlutusLedgerApi.V3 as PV3 +import qualified PlutusLedgerApi.V3 as PV4 import Test.Cardano.Ledger.Alonzo.Arbitrary (alwaysSucceeds) +import qualified Test.Cardano.Ledger.Alonzo.TxInfoSpec as AlonzoTxInfoSpec +import Test.Cardano.Ledger.Alonzo.TxInfoSpec (EraPlutusTxOut (..), EraTranslateValidityInterval (..)) import Test.Cardano.Ledger.Binary.Random (mkDummyHash) import Test.Cardano.Ledger.Common import Test.Cardano.Ledger.Core.KeyPair (KeyPair (..), mkCredential, mkKeyPair) +import Test.Cardano.Ledger.Era () import Test.Cardano.Ledger.Shelley.Examples (exampleByronAddress) +-- --------------------------------------------------------------------------- +-- Orphan instances for Babbage era. +-- --------------------------------------------------------------------------- + +-- | Babbage uses the same validity interval translation as Alonzo. +instance EraTranslateValidityInterval BabbageEra where + translateVI = Alonzo.transValidityInterval (Proxy @BabbageEra) + +-- --------------------------------------------------------------------------- +-- Orphan instances: 'EraPlutusTxOut' for PlutusV2/V3/V4. +-- +-- These cannot live in the Alonzo testlib because they require 'BabbageEraTxOut' +-- and 'transTxOutV2', which are only available in the Babbage package. +-- --------------------------------------------------------------------------- + +instance + ( Value era ~ MaryValue + , BabbageEraTxOut era + , Inject (BabbageContextError era) (ContextError era) + ) => + EraPlutusTxOut 'PlutusV2 era + where + toPlutusTxOut _ txOut = + either (const Nothing) Just $ transTxOutV2 @era (TxOutFromOutput minBound) txOut + +instance + ( Value era ~ MaryValue + , BabbageEraTxOut era + , Inject (BabbageContextError era) (ContextError era) + ) => + EraPlutusTxOut 'PlutusV3 era + where + toPlutusTxOut _ txOut = + either (const Nothing) Just $ transTxOutV2 @era (TxOutFromOutput minBound) txOut + +instance + ( Value era ~ MaryValue + , BabbageEraTxOut era + , Inject (BabbageContextError era) (ContextError era) + ) => + EraPlutusTxOut 'PlutusV4 era + where + toPlutusTxOut _ txOut = + either (const Nothing) Just $ transTxOutV2 @era (TxOutFromOutput minBound) txOut + +spec :: + forall era. + ( EraTx era + , BabbageEraTxBody era + , Value era ~ MaryValue + , Inject (BabbageContextError era) (ContextError era) + , EraPlutusTxInfo 'PlutusV1 era + , EraPlutusTxInfo 'PlutusV2 era + , EraTranslateValidityInterval era + , AtMostEra "Conway" era + , AlonzoEraTxWits era + , Inject (AlonzoContextError era) (ContextError era) + , Arbitrary (TxCert era) + ) => + Spec +spec = + describe "txInfo translation" $ do + txInfoV1Spec @era + AlonzoTxInfoSpec.txInfoSpec @era SPlutusV1 + AlonzoTxInfoSpec.txInfoSpec @era SPlutusV2 + AlonzoTxInfoSpec.txInfoSignersSpec @era SPlutusV1 + AlonzoTxInfoSpec.txInfoSignersSpec @era SPlutusV2 + AlonzoTxInfoSpec.txInfoCertsSpec @era SPlutusV1 + AlonzoTxInfoSpec.txInfoCertsSpec @era SPlutusV2 + txInfoSpec @era SPlutusV2 + +txInfoV1Spec :: + forall era. + ( EraTx era + , BabbageEraTxBody era + , Value era ~ MaryValue + , EraPlutusTxInfo 'PlutusV1 era + , Inject (BabbageContextError era) (ContextError era) + ) => + Spec +txInfoV1Spec = do + let slang = SPlutusV1 + describe (show slang) $ do + -- We include here differences wrt to the previous era + it "translation error on byron txout" $ + expectTranslationError @era slang + (txBare shelleyInput byronOutput) + (inject $ ByronTxOutInContext @era (TxOutFromOutput minBound)) + it "translation error on byron txin" $ + expectTranslationError @era slang + (txBare byronInput shelleyOutput) + (inject $ ByronTxOutInContext @era (TxOutFromInput byronInput)) + it "translation error on unknown txin (logic error)" $ + expectTranslationError @era slang + (txBare unknownInput shelleyOutput) + (inject $ AlonzoContextError $ TranslationLogicMissingInput @era unknownInput) + it "translation error on inline datum in input" $ + expectTranslationError @era slang + (txBare inputWithInlineDatum shelleyOutput) + (inject $ InlineDatumsNotSupported @era (TxOutFromInput inputWithInlineDatum)) + it "translation error on inline datum in output" $ + expectTranslationError @era slang + (txBare shelleyInput inlineDatumOutput) + (inject $ InlineDatumsNotSupported @era (TxOutFromOutput minBound)) + +txInfoSpec :: + forall era l. + ( EraTx era + , EraPlutusTxInfo l era + , EraPlutusTxOut l era + , BabbageEraTxBody era + , AlonzoEraTxWits era + , Value era ~ MaryValue + , Inject (BabbageContextError era) (ContextError era) + , EraTranslateValidityInterval era + , AtMostEra "Conway" era + , Show (PlutusTxInInfo era l) + , Eq (PlutusTxInInfo era l) + ) => + SLanguage l -> + Spec +txInfoSpec lang = + describe (show lang) $ do + it "translation error on byron txout" $ + expectTranslationError @era + lang + (txBare shelleyInput byronOutput) + (inject $ ByronTxOutInContext @era (TxOutFromOutput minBound)) + it "translation error on byron txin" $ + expectTranslationError @era + lang + (txBare byronInput shelleyOutput) + (inject $ ByronTxOutInContext @era (TxOutFromInput byronInput)) + it "translation error on unknown txin (logic error)" $ + expectTranslationError @era + lang + (txBare unknownInput shelleyOutput) + (inject $ AlonzoContextError $ TranslationLogicMissingInput @era unknownInput) + it "use reference input starting in Babbage" $ + successfulTranslation @era + lang + (exampleUTxO lang) + (txRefInput shelleyInputTwo) + hasReferenceInput + -- This test will fail in PlutusV3 because of ReferenceInputsNotDisjointFromInputs + when (plutusLanguage lang == PlutusV2) $ + it "use reference input already present in spending inputs in Babbage" $ + successfulTranslation @era + lang + (exampleUTxO lang) + (txRefInput shelleyInput) + hasReferenceInput + it "use inline datum in input" $ + successfulTranslation @era + lang + (exampleUTxO lang) + (txBare inputWithInlineDatum shelleyOutput) + ( \l txInfo -> do + txInInfo <- expectRight $ toPlutusTxInInfo @_ @era l (exampleUTxO lang) inputWithInlineDatum + expectOneInput @era l txInInfo txInfo + ) + it "use inline datum in output" $ + successfulTranslation @era + lang + (exampleUTxO lang) + (txBare shelleyInput inlineDatumOutput) + (expectOneOutput (translatedOutputEx1 @era)) + it "use reference script in input" $ + successfulTranslation @era + lang + (exampleUTxO lang) + (txBare inputWithRefScript shelleyOutput) + ( \l txInfo -> do + txInInfo <- expectRight $ toPlutusTxInInfo @_ @era l (exampleUTxO lang) inputWithRefScript + expectOneInput @era l txInInfo txInfo + ) + it "use reference script in output" $ + successfulTranslation @era + lang + (exampleUTxO lang) + (txBare shelleyInput $ refScriptOutput lang) + (expectOneOutput (translatedOutputEx2 @era lang)) + prop "correctly translate tx with babbage-era features" $ do + inputs <- listOf1 genShelleyUtxoEntry + refInputs <- listOf1 genShelleyUtxoEntry + outputs <- listOf1 genShelleyTxOut + feeCoin <- arbitrary + mintValue <- arbitrary + wdrls <- arbitrary + datums <- arbitrary @(TxDats era) + validityRange <- arbitrary + signers <- arbitrary + let utxoSet = UTxO $ Map.fromList $ inputs <> refInputs + txIns = Set.fromList $ fmap fst inputs + txRefIns = Set.fromList $ fmap fst refInputs + txBody = + mkBasicTxBody + & inputsTxBodyL .~ txIns + & referenceInputsTxBodyL .~ txRefIns + & outputsTxBodyL .~ StrictSeq.fromList outputs + & feeTxBodyL .~ feeCoin + & mintTxBodyL .~ mintValue + & withdrawalsTxBodyL .~ wdrls + & vldtTxBodyL .~ validityRange + & reqSignerHashesTxBodyL .~ signers + tx = mkBasicTx txBody & witsTxL . datsTxWitsL .~ datums + pure + $ successfulTranslation @era + lang + utxoSet + tx + -- Assertions + $ \slang txInfo -> do + AlonzoTxInfoSpec.expectTxIns slang utxoSet txIns txInfo + + -- Assertions on the transaction reference inputs of the TxInfo + expectReferenceInputs slang utxoSet txRefIns txInfo + + -- Outputs with Byron addresses are also silently dropped in Alonzo. + AlonzoTxInfoSpec.expectTxOutputs slang outputs txInfo + + -- Assertions on the fee in the TxInfo + AlonzoTxInfoSpec.expectFee slang feeCoin txInfo + + -- Assertions on the mint value in the TxInfo + AlonzoTxInfoSpec.expectMintValue slang mintValue txInfo + + -- Assertions on the withdrawals in the TxInfo + AlonzoTxInfoSpec.expectWithdrawals slang wdrls txInfo + + -- Assertions on the datums in the TxInfo + AlonzoTxInfoSpec.expectDatums slang (tx ^. witsTxL) txInfo + + -- Assertions on the txId in the TxInfo + AlonzoTxInfoSpec.expectTxId slang txBody txInfo + + -- Assertions on the validity range in the TxInfo + AlonzoTxInfoSpec.expectValidityRange @era slang validityRange txInfo + + -- Assertions on the required signatories in the TxInfo + AlonzoTxInfoSpec.expectSignatories signers slang txInfo + + -- TODO + -- expectRedeemers slang redeemers txInfo + shelleyAddr :: Addr shelleyAddr = Addr Testnet pk StakeRefNull where @@ -97,35 +364,40 @@ inlineDatumOutput = mkBasicTxOut shelleyAddr (inject $ Coin 3) & datumTxOutL .~ datumEx -refScriptOutput :: (BabbageEraTxOut era, EraPlutusTxInfo 'PlutusV2 era) => TxOut era -refScriptOutput = +refScriptOutput :: forall era l. (BabbageEraTxOut era, EraPlutusTxInfo l era) => SLanguage l -> TxOut era +refScriptOutput _slang = mkBasicTxOut shelleyAddr (inject $ Coin 3) - & referenceScriptTxOutL .~ (SJust $ alwaysSucceeds @'PlutusV2 3) + & referenceScriptTxOutL .~ SJust (alwaysSucceeds @l 3) -- This input is only a "Shelley input" in the sense -- that we attach it to a Shelley output in the UTxO created below. shelleyInput :: TxIn shelleyInput = mkTxInPartial genesisId 2 +shelleyInputTwo :: TxIn +shelleyInputTwo = mkTxInPartial genesisId 3 + inputWithInlineDatum :: TxIn -inputWithInlineDatum = mkTxInPartial genesisId 3 +inputWithInlineDatum = mkTxInPartial genesisId 4 inputWithRefScript :: TxIn -inputWithRefScript = mkTxInPartial genesisId 4 +inputWithRefScript = mkTxInPartial genesisId 5 exampleUTxO :: ( BabbageEraTxOut era - , EraPlutusTxInfo 'PlutusV2 era + , EraPlutusTxInfo l era , Value era ~ MaryValue ) => + SLanguage l -> UTxO era -exampleUTxO = +exampleUTxO slang = UTxO $ Map.fromList [ (byronInput, byronOutput) , (shelleyInput, shelleyOutput) + , (shelleyInputTwo, shelleyOutput) , (inputWithInlineDatum, inlineDatumOutput) - , (inputWithRefScript, refScriptOutput) + , (inputWithRefScript, refScriptOutput slang) ] txb :: @@ -159,7 +431,7 @@ hasReferenceInput slang txInfo = SPlutusV1 -> expectationFailure "PlutusV1 does not have reference inputs" SPlutusV2 -> PV2.txInfoReferenceInputs txInfo `shouldNotBe` mempty SPlutusV3 -> PV3.txInfoReferenceInputs txInfo `shouldNotBe` mempty - SPlutusV4 -> PV3.txInfoReferenceInputs txInfo `shouldNotBe` mempty + SPlutusV4 -> PV4.txInfoReferenceInputs txInfo `shouldNotBe` mempty plutusTxInInfoInputs :: forall era l. HasCallStack => SLanguage l -> PlutusTxInfo l -> [PlutusTxInInfo era l] @@ -168,7 +440,7 @@ plutusTxInInfoInputs slang txInfo = SPlutusV1 -> error "PlutusV1 not supported" SPlutusV2 -> PV2.txInfoInputs txInfo SPlutusV3 -> PV3.txInfoInputs txInfo - SPlutusV4 -> PV3.txInfoInputs txInfo + SPlutusV4 -> PV4.txInfoInputs txInfo expectOneInput :: forall era l. @@ -188,26 +460,47 @@ expectOneOutput o slang txInfo = SPlutusV1 -> expectationFailure "PlutusV1 not supported" SPlutusV2 -> PV2.txInfoOutputs txInfo `shouldBe` [o] SPlutusV3 -> PV3.txInfoOutputs txInfo `shouldBe` [o] - SPlutusV4 -> PV3.txInfoOutputs txInfo `shouldBe` [o] + SPlutusV4 -> PV4.txInfoOutputs txInfo `shouldBe` [o] + +expectReferenceInputs :: + forall era l. + ( EraPlutusTxInfo l era + ) => + SLanguage l -> + UTxO era -> + Set.Set TxIn -> + PlutusTxInfo l -> + Expectation +expectReferenceInputs slang utxoSet txIns txInfo = + case slang of + SPlutusV1 -> expectationFailure "PlutusV1 not supported" + SPlutusV2 -> do + expectedInputs <- traverse (expectRight . toPlutusTxInInfo slang utxoSet) (Set.toList txIns) + PV2.txInfoReferenceInputs txInfo `shouldBe` expectedInputs + SPlutusV3 -> do + expectedInputs <- traverse (expectRight . toPlutusTxInInfo slang utxoSet) (Set.toList txIns) + PV3.txInfoReferenceInputs txInfo `shouldBe` expectedInputs + SPlutusV4 -> do + expectedInputs <- traverse (expectRight . toPlutusTxInInfo slang utxoSet) (Set.toList txIns) + PV4.txInfoReferenceInputs txInfo `shouldBe` expectedInputs successfulTranslation :: forall era l. ( BabbageEraTxOut era , EraPlutusTxInfo l era - , EraPlutusTxInfo 'PlutusV2 era - , Value era ~ MaryValue ) => SLanguage l -> + UTxO era -> Tx TopTx era -> (SLanguage l -> PlutusTxInfo l -> Expectation) -> Expectation -successfulTranslation slang tx f = +successfulTranslation slang utxo tx f = let lti = LedgerTxInfo { ltiProtVer = ProtVer (eraProtVerLow @era) 0 , ltiEpochInfo = ei , ltiSystemStart = ss - , ltiUTxO = exampleUTxO + , ltiUTxO = utxo , ltiTx = tx } in case toPlutusTxInfoForPurpose slang lti (SpendingPurpose AsPurpose) of @@ -218,7 +511,6 @@ expectTranslationError :: forall era l. ( BabbageEraTxOut era , EraPlutusTxInfo l era - , EraPlutusTxInfo 'PlutusV2 era , Value era ~ MaryValue ) => SLanguage l -> @@ -231,7 +523,7 @@ expectTranslationError slang tx expected = { ltiProtVer = ProtVer (eraProtVerLow @era) 0 , ltiEpochInfo = ei , ltiSystemStart = ss - , ltiUTxO = exampleUTxO + , ltiUTxO = exampleUTxO slang , ltiTx = tx } in case toPlutusTxInfoForPurpose slang lti (SpendingPurpose AsPurpose) of @@ -239,17 +531,6 @@ expectTranslationError slang tx expected = assertFailure $ "This translation was expected to fail, but it succeeded: " <> show txInfo Left e -> e `shouldBe` expected -expectV1TranslationError :: - ( BabbageEraTxOut era - , EraPlutusTxInfo 'PlutusV1 era - , EraPlutusTxInfo 'PlutusV2 era - , Value era ~ MaryValue - ) => - Tx TopTx era -> - ContextError era -> - Expectation -expectV1TranslationError = expectTranslationError SPlutusV1 - errorTranslate :: forall era b. (HasCallStack, Show (ContextError era)) => @@ -272,128 +553,35 @@ translatedOutputEx1 = transTxOutV2 @era (TxOutFromOutput minBound) inlineDatumOutput translatedOutputEx2 :: - forall era. - ( BabbageEraTxOut era - , EraPlutusTxInfo 'PlutusV2 era - , Value era ~ MaryValue - , Inject (BabbageContextError era) (ContextError era) - ) => - PV2.TxOut -translatedOutputEx2 = - errorTranslate @era "translatedOutputEx2" $ - transTxOutV2 @era (TxOutFromOutput minBound) refScriptOutput - -txInfoSpecV1 :: - forall era. - ( EraTx era - , BabbageEraTxBody era - , Value era ~ MaryValue - , EraPlutusTxInfo 'PlutusV1 era - , EraPlutusTxInfo 'PlutusV2 era - , Inject (BabbageContextError era) (ContextError era) - ) => - Spec -txInfoSpecV1 = - describe "Plutus V1" $ do - it "translation error on byron txout" $ - expectV1TranslationError @era - (txBare shelleyInput byronOutput) - (inject $ ByronTxOutInContext @era (TxOutFromOutput minBound)) - it "translation error on byron txin" $ - expectV1TranslationError @era - (txBare byronInput shelleyOutput) - (inject $ ByronTxOutInContext @era (TxOutFromInput byronInput)) - it "translation error on unknown txin (logic error)" $ - expectV1TranslationError @era - (txBare unknownInput shelleyOutput) - (inject $ AlonzoContextError $ TranslationLogicMissingInput @era unknownInput) - it "translation error on inline datum in input" $ - expectV1TranslationError @era - (txBare inputWithInlineDatum shelleyOutput) - (inject $ InlineDatumsNotSupported @era (TxOutFromInput inputWithInlineDatum)) - it "translation error on inline datum in output" $ - expectV1TranslationError @era - (txBare shelleyInput inlineDatumOutput) - (inject $ InlineDatumsNotSupported @era (TxOutFromOutput minBound)) - -txInfoSpec :: forall era l. - ( EraTx era + ( BabbageEraTxOut era , EraPlutusTxInfo l era - , EraPlutusTxInfo 'PlutusV2 era - , BabbageEraTxBody era , Value era ~ MaryValue , Inject (BabbageContextError era) (ContextError era) - , Show (PlutusTxInInfo era l) - , Eq (PlutusTxInInfo era l) ) => SLanguage l -> - Spec -txInfoSpec lang = - describe (show lang) $ do - it "translation error on byron txout" $ - expectTranslationError @era - lang - (txBare shelleyInput byronOutput) - (inject $ ByronTxOutInContext @era (TxOutFromOutput minBound)) - it "translation error on byron txin" $ - expectTranslationError @era - lang - (txBare byronInput shelleyOutput) - (inject $ ByronTxOutInContext @era (TxOutFromInput byronInput)) - it "translation error on unknown txin (logic error)" $ - expectTranslationError @era - lang - (txBare unknownInput shelleyOutput) - (inject $ AlonzoContextError $ TranslationLogicMissingInput @era unknownInput) - -- This test will fail in PlutusV3 because of ReferenceInputsNotDisjointFromInputs - when (plutusLanguage lang == PlutusV2) $ - it "use reference input starting in Babbage" $ - successfulTranslation @era - lang - (txRefInput shelleyInput) - hasReferenceInput - it "use inline datum in input" $ - successfulTranslation @era - lang - (txBare inputWithInlineDatum shelleyOutput) - ( \l txInfo -> do - txInInfo <- expectRight $ toPlutusTxInInfo @_ @era l exampleUTxO inputWithInlineDatum - expectOneInput @era l txInInfo txInfo - ) - it "use inline datum in output" $ - successfulTranslation @era - lang - (txBare shelleyInput inlineDatumOutput) - (expectOneOutput (translatedOutputEx1 @era)) - it "use reference script in input" $ - successfulTranslation @era - lang - (txBare inputWithRefScript shelleyOutput) - ( \l txInfo -> do - txInInfo <- expectRight $ toPlutusTxInInfo @_ @era l exampleUTxO inputWithRefScript - expectOneInput @era l txInInfo txInfo - ) - it "use reference script in output" $ - successfulTranslation @era - lang - (txBare shelleyInput refScriptOutput) - (expectOneOutput (translatedOutputEx2 @era)) - -spec :: - forall era. - ( EraTx era - , BabbageEraTxBody era - , Value era ~ MaryValue - , Inject (BabbageContextError era) (ContextError era) - , EraPlutusTxInfo 'PlutusV1 era - , EraPlutusTxInfo 'PlutusV2 era - ) => - Spec -spec = - describe "txInfo translation" $ do - txInfoSpecV1 @era - txInfoSpec @era SPlutusV2 + PV2.TxOut +translatedOutputEx2 slang = + errorTranslate @era "translatedOutputEx2" $ + transTxOutV2 @era (TxOutFromOutput minBound) $ refScriptOutput slang genesisId :: TxId genesisId = TxId (unsafeMakeSafeHash (mkDummyHash (0 :: Int))) + +genShelleyUtxoEntry :: (AlonzoEraTxOut era, Arbitrary (Value era)) => Gen (TxIn, TxOut era) +genShelleyUtxoEntry = do + txIn <- arbitrary + txOut <- genShelleyTxOut + pure (txIn, txOut) + +genShelleyTxOut :: forall era. (AlonzoEraTxOut era, Arbitrary (Value era)) => Gen (TxOut era) +genShelleyTxOut = do + dataHash <- arbitrary + txOut <- + mkBasicTxOut + <$> genShelleyAddr + <*> scale (`div` 15) arbitrary + pure $ txOut & dataHashTxOutL .~ dataHash + +genShelleyAddr :: Gen Addr +genShelleyAddr = Addr <$> arbitrary <*> arbitrary <*> arbitrary diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Spec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Spec.hs index 47d600f5040..6a18fdb4d44 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Spec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Spec.hs @@ -8,6 +8,9 @@ module Test.Cardano.Ledger.Conway.Spec (spec) where +import Cardano.Ledger.Alonzo.Plutus.Context (ContextError) +import Cardano.Ledger.Alonzo.Plutus.TxInfo (AlonzoContextError) +import Cardano.Ledger.BaseTypes (Inject) import Cardano.Ledger.Conway.Core import Cardano.Ledger.Conway.Rules ( ConwayEpochEvent, @@ -19,7 +22,10 @@ import Cardano.Ledger.Shelley.Rules (RupdEvent) import Control.State.Transition (STS (..)) import qualified Test.Cardano.Ledger.Alonzo.Binary.CostModelsSpec as CostModelsSpec import qualified Test.Cardano.Ledger.Alonzo.Binary.TxWitsSpec as TxWitsSpec +import qualified Test.Cardano.Ledger.Alonzo.TxInfoSpec as AlonzoTxInfo +import Test.Cardano.Ledger.Alonzo.TxInfoSpec (EraTranslateValidityInterval) import qualified Test.Cardano.Ledger.Babbage.TxInfoSpec as BabbageTxInfo +import Test.Cardano.Ledger.Conway.TxInfoSpec () -- EraTranslateValidityInterval ConwayEra orphan import Test.Cardano.Ledger.Common import qualified Test.Cardano.Ledger.Conway.Binary.Golden as Golden import qualified Test.Cardano.Ledger.Conway.Binary.Regression as Regression @@ -42,6 +48,9 @@ spec :: , Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era , Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era , Event (EraRule "RUPD" era) ~ RupdEvent + , Inject (AlonzoContextError era) (ContextError era) + , AtMostEra "Conway" era + , EraTranslateValidityInterval era ) => Spec spec = @@ -62,6 +71,17 @@ spec = TxWitsSpec.spec @era Regression.spec @era describe "TxInfo" $ do - BabbageTxInfo.spec @era - describe "PlutusV3" $ + describe "PlutusV1" $ do + BabbageTxInfo.txInfoV1Spec @era + AlonzoTxInfo.txInfoSpec @era SPlutusV1 + AlonzoTxInfo.txInfoSignersSpec @era SPlutusV1 + describe "PlutusV2" $ do + AlonzoTxInfo.txInfoSpec @era SPlutusV2 + AlonzoTxInfo.txInfoSignersSpec @era SPlutusV2 + BabbageTxInfo.txInfoSpec @era SPlutusV2 + describe "PlutusV3" $ do + AlonzoTxInfo.txInfoSpec @era SPlutusV3 + AlonzoTxInfo.txInfoSignersSpec @era SPlutusV3 + AlonzoTxInfo.txInfoSignersSpec @era SPlutusV3 + AlonzoTxInfo.txInfoCertsSpec @era SPlutusV3 BabbageTxInfo.txInfoSpec @era SPlutusV3 diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/TxInfoSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/TxInfoSpec.hs index f0e9eede691..35c485d4f0c 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/TxInfoSpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/TxInfoSpec.hs @@ -6,7 +6,9 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +-- Orphan instance for 'EraTranslateValidityInterval ConwayEra' that uses +-- Conway's open-upper-bound validity interval semantics. +{-# OPTIONS_GHC -Wno-orphans #-} module Test.Cardano.Ledger.Conway.TxInfoSpec (spec) where @@ -21,7 +23,7 @@ import Cardano.Ledger.Conway.Core import Cardano.Ledger.Conway.TxCert import Cardano.Ledger.Conway.TxInfo (transValidityInterval) import Cardano.Ledger.Credential (Credential) -import Cardano.Ledger.Plutus.Language (Language (..)) +import Cardano.Ledger.Plutus.Language (Language (..), SLanguage (..)) import Cardano.Ledger.Slot import Cardano.Slotting.EpochInfo (fixedEpochInfo) import Cardano.Slotting.Time (SystemStart (..), mkSlotLength) @@ -30,12 +32,19 @@ import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import qualified PlutusLedgerApi.V1 as PV1 import qualified PlutusLedgerApi.V2 as PV2 import qualified PlutusLedgerApi.V3 as PV3 +import Test.Cardano.Ledger.Alonzo.TxInfoSpec (EraTranslateValidityInterval (..), txInfoSignersSpec) import Test.Cardano.Ledger.Common import Test.Cardano.Ledger.Conway.Genesis () +-- | Conway uses open upper bounds for validity intervals (since protocol version 9). +instance EraTranslateValidityInterval ConwayEra where + translateVI = + transValidityInterval (Proxy @ConwayEra) + spec :: Spec spec = do describe "TxInfo" $ do + txInfoSignersSpec @ConwayEra SPlutusV1 let trans pv cert = either (error . show) id (toPlutusTxCert @'PlutusV3 @ConwayEra Proxy pv cert) transV9 = trans (ProtVer (natVersion @9) 0) transV10 = trans (ProtVer (natVersion @10) 0) @@ -58,7 +67,8 @@ spec = do expectDeposit coin $ transV10 $ UnRegDepositTxCert cred coin expectNoDeposit $ transV10 $ ConwayTxCertDeleg $ ConwayUnRegCert cred SNothing - it "validity interval's upper bound is open when protocol >= 9" $ + it + "validity interval's upper bound is open when protocol >= 9" transVITimeUpperBoundIsOpen where expectDeposit :: Coin -> PV3.TxCert -> IO ()