{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} module Test.Cardano.Ledger.Alonzo.Imp.UtxosSpec (spec) where import Cardano.Ledger.Alonzo.Core import Cardano.Ledger.Alonzo.Plutus.Evaluate (CollectError (NoCostModel)) import Cardano.Ledger.Alonzo.Rules ( AlonzoUtxosPredFailure (..), TagMismatchDescription (..), ) import Cardano.Ledger.Alonzo.Scripts (eraLanguages) import Cardano.Ledger.Alonzo.Tx (IsValid (..)) import Cardano.Ledger.Alonzo.TxWits (Redeemers (..)) import Cardano.Ledger.Plutus.Data (Data (..)) import Cardano.Ledger.Plutus.Language (hashPlutusScript, withSLanguage) import Cardano.Ledger.Shelley.LedgerState (curPParamsEpochStateL, nesEsL) import qualified Data.Map.Strict as Map import qualified Data.Set as Set 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 ( alwaysFailsWithDatum, alwaysSucceedsWithDatum, datumIsWellformed, inputsOutputsAreNotEmptyWithDatum, purposeIsWellformedWithDatum, redeemerSameAsDatum, ) spec :: forall era. ( AlonzoEraImp era , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era ) => SpecWith (ImpTestState era) spec :: forall era. (AlonzoEraImp era, InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era) => SpecWith (ImpTestState era) spec = forall a. HasCallStack => String -> SpecWith a -> SpecWith a describe String "UTXOS" forall a b. (a -> b) -> a -> b $ forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => t a -> (a -> m b) -> m () forM_ (forall era. AlonzoEraScript era => [Language] eraLanguages @era) forall a b. (a -> b) -> a -> b $ \Language lang -> forall a. Language -> (forall (l :: Language). PlutusLanguage l => SLanguage l -> a) -> a withSLanguage Language lang forall a b. (a -> b) -> a -> b $ \SLanguage l slang -> forall a. HasCallStack => String -> SpecWith a -> SpecWith a describe (forall a. Show a => a -> String show Language lang) forall a b. (a -> b) -> a -> b $ do let redeemerSameAsDatumHash :: ScriptHash (EraCrypto era) redeemerSameAsDatumHash = forall c (l :: Language). (Crypto c, PlutusLanguage l) => Plutus l -> ScriptHash c hashPlutusScript forall a b. (a -> b) -> a -> b $ forall (l :: Language). SLanguage l -> Plutus l redeemerSameAsDatum SLanguage l slang alwaysSucceedsWithDatumHash :: ScriptHash (EraCrypto era) alwaysSucceedsWithDatumHash = forall c (l :: Language). (Crypto c, PlutusLanguage l) => Plutus l -> ScriptHash c hashPlutusScript forall a b. (a -> b) -> a -> b $ forall (l :: Language). SLanguage l -> Plutus l alwaysSucceedsWithDatum SLanguage l slang let scripts :: [(String, SLanguage l -> Plutus l)] scripts = [ (String "redeemerSameAsDatum", forall (l :: Language). SLanguage l -> Plutus l redeemerSameAsDatum) , (String "purposeIsWellformedWithDatum", forall (l :: Language). SLanguage l -> Plutus l purposeIsWellformedWithDatum) , (String "datumIsWellformed", forall (l :: Language). SLanguage l -> Plutus l datumIsWellformed) , (String "inputsOutputsAreNotEmptyWithDatum", forall (l :: Language). SLanguage l -> Plutus l inputsOutputsAreNotEmptyWithDatum) ] forall a. HasCallStack => String -> SpecWith a -> SpecWith a describe String "Spending scripts with a Datum" forall a b. (a -> b) -> a -> b $ do forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => t a -> (a -> m b) -> m () forM_ [(String, SLanguage l -> Plutus l)] scripts forall a b. (a -> b) -> a -> b $ \(String name, SLanguage l -> Plutus l script) -> do forall a. (HasCallStack, Example a) => String -> a -> SpecWith (Arg a) it String name forall a b. (a -> b) -> a -> b $ do let sHash :: ScriptHash (EraCrypto era) sHash = forall c (l :: Language). (Crypto c, PlutusLanguage l) => Plutus l -> ScriptHash c hashPlutusScript (SLanguage l -> Plutus l script SLanguage l slang) TxIn (EraCrypto era) txIn0 <- forall era. (ShelleyEraImp era, HasCallStack) => ScriptHash (EraCrypto era) -> ImpTestM era (TxIn (EraCrypto era)) produceScript ScriptHash (EraCrypto era) sHash forall era. (HasCallStack, ShelleyEraImp era) => String -> Tx era -> ImpTestM era () submitTxAnn_ String "Submit a transaction that consumes the script output" forall a b. (a -> b) -> a -> b $ forall era. EraTx era => TxBody era -> Tx era mkBasicTx forall era. EraTxBody era => TxBody era mkBasicTxBody forall a b. a -> (a -> b) -> b & forall era. EraTx era => Lens' (Tx era) (TxBody era) bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c . forall era. EraTxBody era => Lens' (TxBody era) (Set (TxIn (EraCrypto era))) inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t .~ forall a. a -> Set a Set.singleton TxIn (EraCrypto era) txIn0 forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era () passEpoch forall a. (HasCallStack, Example a) => String -> a -> SpecWith (Arg a) it String "Valid transaction marked as invalid" forall a b. (a -> b) -> a -> b $ do let tx :: Tx era tx = forall era. EraTx era => TxBody era -> Tx era mkBasicTx forall era. EraTxBody era => TxBody era mkBasicTxBody forall a b. a -> (a -> b) -> b & forall era. AlonzoEraTx era => Lens' (Tx era) IsValid isValidTxL forall s t a b. ASetter s t a b -> b -> s -> t .~ Bool -> IsValid IsValid Bool False forall era. (HasCallStack, ShelleyEraImp era) => Tx era -> NonEmpty (PredicateFailure (EraRule "LEDGER" era)) -> ImpTestM era () submitFailingTx Tx era tx [forall (rule :: Symbol) (t :: * -> *) era. InjectRuleFailure rule t era => t era -> EraRuleFailure rule era injectFailure (forall era. IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure era ValidationTagMismatch (Bool -> IsValid IsValid Bool False) TagMismatchDescription PassedUnexpectedly)] forall a. (HasCallStack, Example a) => String -> a -> SpecWith (Arg a) it String "Invalid transaction marked as valid" forall a b. (a -> b) -> a -> b $ do TxIn (EraCrypto era) txIn <- forall era. (ShelleyEraImp era, HasCallStack) => ScriptHash (EraCrypto era) -> ImpTestM era (TxIn (EraCrypto era)) produceScript forall b c a. (b -> c) -> (a -> b) -> a -> c . forall c (l :: Language). (Crypto c, PlutusLanguage l) => Plutus l -> ScriptHash c hashPlutusScript forall a b. (a -> b) -> a -> b $ forall (l :: Language). SLanguage l -> Plutus l alwaysFailsWithDatum SLanguage l slang forall era. (HasCallStack, AlonzoEraImp era, InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era) => Tx era -> ImpTestM era () submitPhase2Invalid_ forall a b. (a -> b) -> a -> b $ forall era. EraTx era => TxBody era -> Tx era mkBasicTx forall era. EraTxBody era => TxBody era mkBasicTxBody forall a b. a -> (a -> b) -> b & forall era. EraTx era => Lens' (Tx era) (TxBody era) bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c . forall era. EraTxBody era => Lens' (TxBody era) (Set (TxIn (EraCrypto era))) inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t .~ [TxIn (EraCrypto era) txIn] forall a. (HasCallStack, Example a) => String -> a -> SpecWith (Arg a) it String "Invalid plutus script fails in phase 2" forall a b. (a -> b) -> a -> b $ do TxIn (EraCrypto era) txIn0 <- forall era. (ShelleyEraImp era, HasCallStack) => ScriptHash (EraCrypto era) -> ImpTestM era (TxIn (EraCrypto era)) produceScript ScriptHash (EraCrypto era) redeemerSameAsDatumHash ExUnits exUnits <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a getsNES forall a b. (a -> b) -> a -> b $ forall era. Lens' (NewEpochState era) (EpochState era) nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c . forall era. EraGov era => Lens' (EpochState era) (PParams era) curPParamsEpochStateL forall b c a. (b -> c) -> (a -> b) -> a -> c . forall era. AlonzoEraPParams era => Lens' (PParams era) ExUnits ppMaxTxExUnitsL forall era. (HasCallStack, ShelleyEraImp era) => String -> Tx era -> ImpTestM era () submitTxAnn_ String "Submitting consuming transaction" forall a b. (a -> b) -> a -> b $ forall era. EraTx era => TxBody era -> Tx era mkBasicTx forall era. EraTxBody era => TxBody era mkBasicTxBody forall a b. a -> (a -> b) -> b & forall era. EraTx era => Lens' (Tx era) (TxBody era) bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c . forall era. EraTxBody era => Lens' (TxBody era) (Set (TxIn (EraCrypto era))) inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t .~ forall a. a -> Set a Set.singleton TxIn (EraCrypto era) txIn0 forall a b. a -> (a -> b) -> b & forall era. AlonzoEraTx era => Lens' (Tx era) IsValid isValidTxL forall s t a b. ASetter s t a b -> b -> s -> t .~ Bool -> IsValid IsValid Bool False forall a b. a -> (a -> b) -> b & forall era. EraTx era => Lens' (Tx era) (TxWits era) witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c . forall era. AlonzoEraTxWits era => Lens' (TxWits era) (Redeemers era) rdmrsTxWitsL forall s t a b. ASetter s t a b -> b -> s -> t .~ forall era. AlonzoEraScript era => Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era Redeemers ( forall k a. k -> a -> Map k a Map.singleton (forall era (f :: * -> * -> *). AlonzoEraScript era => f Word32 (TxIn (EraCrypto era)) -> PlutusPurpose f era mkSpendingPurpose forall a b. (a -> b) -> a -> b $ forall ix it. ix -> AsIx ix it AsIx Word32 0) (forall era. Era era => Data -> Data era Data forall a b. (a -> b) -> a -> b $ Integer -> Data P.I Integer 32, ExUnits exUnits) ) forall a. HasCallStack => String -> SpecWith a -> SpecWith a describe String "Scripts pass in phase 2" forall a b. (a -> b) -> a -> b $ do let scripts' :: [(String, SLanguage l -> Plutus l)] scripts' = forall a. Int -> [a] -> [a] drop Int 1 [(String, SLanguage l -> Plutus l)] scripts forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => t a -> (a -> m b) -> m () forM_ [(String, SLanguage l -> Plutus l)] scripts' forall a b. (a -> b) -> a -> b $ \(String name, SLanguage l -> Plutus l script) -> do forall a. (HasCallStack, Example a) => String -> a -> SpecWith (Arg a) it String name forall a b. (a -> b) -> a -> b $ do let sHash :: ScriptHash (EraCrypto era) sHash = forall c (l :: Language). (Crypto c, PlutusLanguage l) => Plutus l -> ScriptHash c hashPlutusScript (SLanguage l -> Plutus l script SLanguage l slang) TxIn (EraCrypto era) txIn0 <- forall era. (ShelleyEraImp era, HasCallStack) => ScriptHash (EraCrypto era) -> ImpTestM era (TxIn (EraCrypto era)) produceScript ScriptHash (EraCrypto era) sHash forall era. (HasCallStack, ShelleyEraImp era) => String -> Tx era -> ImpTestM era () submitTxAnn_ String "Submitting consuming transaction" forall a b. (a -> b) -> a -> b $ forall era. EraTx era => TxBody era -> Tx era mkBasicTx forall era. EraTxBody era => TxBody era mkBasicTxBody forall a b. a -> (a -> b) -> b & forall era. EraTx era => Lens' (Tx era) (TxBody era) bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c . forall era. EraTxBody era => Lens' (TxBody era) (Set (TxIn (EraCrypto era))) inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t .~ forall a. a -> Set a Set.singleton TxIn (EraCrypto era) txIn0 forall a. (HasCallStack, Example a) => String -> a -> SpecWith (Arg a) it String "No cost model" forall a b. (a -> b) -> a -> b $ do TxIn (EraCrypto era) txIn <- forall era. (ShelleyEraImp era, HasCallStack) => ScriptHash (EraCrypto era) -> ImpTestM era (TxIn (EraCrypto era)) produceScript ScriptHash (EraCrypto era) alwaysSucceedsWithDatumHash let tx :: Tx era tx = forall era. EraTx era => TxBody era -> Tx era mkBasicTx forall era. EraTxBody era => TxBody era mkBasicTxBody forall a b. a -> (a -> b) -> b & forall era. EraTx era => Lens' (Tx era) (TxBody era) bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c . forall era. EraTxBody era => Lens' (TxBody era) (Set (TxIn (EraCrypto era))) inputsTxBodyL forall a s t. Monoid a => ASetter s t a a -> a -> s -> t <>~ [TxIn (EraCrypto era) txIn] forall era. ShelleyEraImp era => (PParams era -> PParams era) -> ImpTestM era () modifyPParams forall a b. (a -> b) -> a -> b $ forall era. AlonzoEraPParams era => Lens' (PParams era) CostModels ppCostModelsL forall s t a b. ASetter s t a b -> b -> s -> t .~ forall a. Monoid a => a mempty forall era. (HasCallStack, ShelleyEraImp era) => Tx era -> NonEmpty (PredicateFailure (EraRule "LEDGER" era)) -> ImpTestM era () submitFailingTx Tx era tx [forall (rule :: Symbol) (t :: * -> *) era. InjectRuleFailure rule t era => t era -> EraRuleFailure rule era injectFailure (forall era. [CollectError era] -> AlonzoUtxosPredFailure era CollectErrors [forall era. Language -> CollectError era NoCostModel Language lang])]