From 98a9cec88cf106905011480f8a5c1b99c7ec712a Mon Sep 17 00:00:00 2001 From: Jared Corduan Date: Mon, 19 Apr 2021 13:09:55 -0400 Subject: [PATCH 1/2] rename ExUnitsTooSmallUTxO to ExUnitsTooBigUTxO --- alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxo.hs | 10 +++++----- .../Cardano/Ledger/Alonzo/Serialisation/Generators.hs | 2 +- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxo.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxo.hs index f38dd70276..06715d327d 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxo.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxo.hs @@ -188,7 +188,7 @@ data UtxoPredicateFailure era | -- | The UTxO entries which have the wrong kind of script ScriptsNotPaidUTxO !(UTxO era) - | ExUnitsTooSmallUTxO + | ExUnitsTooBigUTxO !ExUnits -- ^ Max EXUnits from the protocol parameters !ExUnits @@ -371,7 +371,7 @@ utxoTransition = do let maxTxEx = getField @"_maxTxExUnits" pp totExunits = getField @"totExunits" tx - pointWiseExUnits (<=) totExunits maxTxEx ?! ExUnitsTooSmallUTxO maxTxEx totExunits + pointWiseExUnits (<=) totExunits maxTxEx ?! ExUnitsTooBigUTxO maxTxEx totExunits -- This does not appear in the Alonzo specification. But the test should be in every Era. -- Bootstrap (i.e. Byron) addresses have variable sized attributes in them. @@ -497,8 +497,8 @@ encFail (FeeNotBalancedUTxO a b) = Sum FeeNotBalancedUTxO 13 !> To a !> To b encFail (ScriptsNotPaidUTxO a) = Sum ScriptsNotPaidUTxO 14 !> To a -encFail (ExUnitsTooSmallUTxO a b) = - Sum ExUnitsTooSmallUTxO 15 !> To a !> To b +encFail (ExUnitsTooBigUTxO a b) = + Sum ExUnitsTooBigUTxO 15 !> To a !> To b encFail (FeeContainsNonADA a) = Sum FeeContainsNonADA 16 !> To a @@ -525,7 +525,7 @@ decFail 11 = SumD TriesToForgeADA decFail 12 = SumD (OutputTooBigUTxO) Arbitrary (UtxoPredicateFailure (AlonzoEra c)) where (OutputTooBigUTxO) <$> arbitrary, FeeNotBalancedUTxO <$> arbitrary <*> arbitrary, ScriptsNotPaidUTxO <$> arbitrary, - ExUnitsTooSmallUTxO <$> arbitrary <*> arbitrary, + ExUnitsTooBigUTxO <$> arbitrary <*> arbitrary, FeeContainsNonADA <$> arbitrary ] From b1d5c98c4aa4c6e2ef1c989243d073cd08f70995 Mon Sep 17 00:00:00 2001 From: Jared Corduan Date: Thu, 1 Apr 2021 08:11:07 -0400 Subject: [PATCH 2/2] Alonzo UTXOW examples --- alonzo/impl/cardano-ledger-alonzo.cabal | 10 +- alonzo/impl/cddl-files/alonzo.cddl | 2 +- alonzo/impl/src/Cardano/Ledger/Alonzo.hs | 3 +- .../src/Cardano/Ledger/Alonzo/Rules/Utxow.hs | 5 +- .../impl/src/Cardano/Ledger/Alonzo/Scripts.hs | 10 +- .../impl/src/Cardano/Ledger/Alonzo/TxInfo.hs | 9 +- .../Ledger/Alonzo/Serialisation/Generators.hs | 3 +- .../Cardano/Ledger/Alonzo/Examples/Utxow.hs | 776 ++++++++++++++++++ .../Ledger/Alonzo/Serialisation/Tripping.hs | 2 +- alonzo/impl/test/test/Tests.hs | 5 +- 10 files changed, 808 insertions(+), 17 deletions(-) create mode 100644 alonzo/impl/test/test/Test/Cardano/Ledger/Alonzo/Examples/Utxow.hs diff --git a/alonzo/impl/cardano-ledger-alonzo.cabal b/alonzo/impl/cardano-ledger-alonzo.cabal index db589b2b5d..eaef583f0c 100644 --- a/alonzo/impl/cardano-ledger-alonzo.cabal +++ b/alonzo/impl/cardano-ledger-alonzo.cabal @@ -72,6 +72,7 @@ library shelley-spec-ledger, small-steps, strict-containers, + text, transformers hs-source-dirs: src @@ -90,7 +91,8 @@ library test plutus-tx, QuickCheck, shelley-spec-ledger-test, - shelley-spec-ledger + shelley-spec-ledger, + text, hs-source-dirs: test/lib @@ -104,6 +106,7 @@ test-suite cardano-ledger-alonzo-test other-modules: Test.Cardano.Ledger.Alonzo.Golden Test.Cardano.Ledger.Alonzo.Serialisation.Tripping + Test.Cardano.Ledger.Alonzo.Examples.Utxow Test.Cardano.Ledger.Alonzo.Serialisation.CDDL build-depends: base16-bytestring, @@ -114,8 +117,13 @@ test-suite cardano-ledger-alonzo-test cardano-ledger-core, cardano-ledger-shelley-ma-test, containers, + data-default-class, + plutus-core, plutus-tx, + plutus-ledger-api, QuickCheck, + small-steps, + small-steps-test, shelley-spec-ledger, shelley-spec-ledger-test, strict-containers, diff --git a/alonzo/impl/cddl-files/alonzo.cddl b/alonzo/impl/cddl-files/alonzo.cddl index 085ca4bd2f..f83872b939 100644 --- a/alonzo/impl/cddl-files/alonzo.cddl +++ b/alonzo/impl/cddl-files/alonzo.cddl @@ -254,7 +254,7 @@ language = 0 ; Plutus v1 costmdls = { * language => cost_model } ; New -cost_model = { * bytes => integer } ; New +cost_model = { * text => integer } ; New transaction_metadatum = { * transaction_metadatum => transaction_metadatum } diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo.hs index 1ddb3db860..c9d185fe06 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo.hs @@ -104,7 +104,8 @@ instance (CC.Crypto c) => Shelley.ValidateScript (AlonzoEra c) where timelock where vhks = Set.map witKeyHash (txwitsVKey' (wits' tx)) - validateScript (PlutusScript _) _tx = False + -- TODO check if instead we should filter plutus scripts before calling + validateScript (PlutusScript _) _tx = True -- To run a PlutusScript use Cardano.Ledger.Alonzo.TxInfo(runPLCScript) -- To run any Alonzo Script use Cardano.Ledger.Alonzo.PlutusScriptApi(evalScripts) diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxow.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxow.hs index e14423a912..2a7f99db61 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxow.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxow.hs @@ -16,7 +16,7 @@ module Cardano.Ledger.Alonzo.Rules.Utxow where -- import Shelley.Spec.Ledger.UTxO(UTxO(..)) import Cardano.Binary (FromCBOR (..), ToCBOR (..)) -import Cardano.Ledger.Alonzo.Data (Data, DataHash) +import Cardano.Ledger.Alonzo.Data (DataHash) import Cardano.Ledger.Alonzo.PParams (PParams) import Cardano.Ledger.Alonzo.PlutusScriptApi (checkScriptData, language, scriptsNeeded) import Cardano.Ledger.Alonzo.Rules.Utxo (AlonzoUTXO) @@ -192,7 +192,6 @@ type ShelleyStyleWitnessNeeds era = -- (in addition to ShelleyStyleWitnessNeeds) type AlonzoStyleAdditions era = ( HasField "datahash" (Core.TxOut era) (StrictMaybe (DataHash (Crypto era))), -- BE SURE AND ADD THESE INSTANCES - HasField "txdatahash" (Core.Tx era) (Map.Map (DataHash (Crypto era)) (Data era)), HasField "wppHash" (Core.TxBody era) (StrictMaybe (WitnessPPDataHash (Crypto era))), HasField "txnetworkid" (Core.TxBody era) (StrictMaybe Network) ) @@ -259,7 +258,7 @@ alonzoStyleWitness = do SJust h <- [getField @"datahash" output], isTwoPhaseScriptAddress @era tx (getField @"address" output) ] - txHashes = domain (getField @"txdatahash" tx) + txHashes = domain (txdats . wits' $ tx) inputHashes = Set.fromList utxoHashes txHashes == inputHashes ?! DataHashSetsDontAgree txHashes inputHashes diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/Scripts.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/Scripts.hs index beb7456b73..73a24efabf 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo/Scripts.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/Scripts.hs @@ -45,12 +45,12 @@ import Cardano.Ledger.Pretty PrettyA (..), ppCoin, ppInteger, - ppLong, ppMap, ppRecord, ppSexp, ppString, ppWord64, + text, ) import Cardano.Ledger.SafeHash ( HashWithCrypto (..), @@ -60,11 +60,11 @@ import Cardano.Ledger.SafeHash import Cardano.Ledger.ShelleyMA.Timelocks import Cardano.Ledger.Val (Val ((<+>), (<×>))) import Control.DeepSeq (NFData (..)) -import Data.ByteString (ByteString) import Data.ByteString.Short (ShortByteString, fromShort) import Data.Coders import Data.Map (Map) import Data.MemoBytes +import Data.Text (Text) import Data.Typeable import Data.Word (Word64, Word8) import GHC.Generics (Generic) @@ -144,7 +144,7 @@ pointWiseExUnits oper (ExUnits m1 s1) (ExUnits m2 s2) = (m1 `oper` m2) && (s1 `o -- Cost Model needs to preserve its serialization bytes as -- it is going to be hashed. Thus we make it a newtype around a MemoBytes -newtype CostModel = CostModelConstr (MemoBytes (Map ByteString Integer)) +newtype CostModel = CostModelConstr (MemoBytes (Map Text Integer)) deriving (Eq, Generic, Show, Ord) deriving newtype (SafeToHash) @@ -153,7 +153,7 @@ newtype CostModel = CostModelConstr (MemoBytes (Map ByteString Integer)) instance HashWithCrypto CostModel CostModel -pattern CostModel :: Map ByteString Integer -> CostModel +pattern CostModel :: Map Text Integer -> CostModel pattern CostModel m <- CostModelConstr (Memo m _) where @@ -274,7 +274,7 @@ instance PrettyA ExUnits where prettyA = ppExUnits ppCostModel :: CostModel -> PDoc ppCostModel (CostModelConstr (Memo m _)) = - ppSexp "CostModel" [ppMap ppLong ppInteger m] + ppSexp "CostModel" [ppMap text ppInteger m] instance PrettyA CostModel where prettyA = ppCostModel diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/TxInfo.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/TxInfo.hs index 685ff82ea0..a582d0ac75 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo/TxInfo.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/TxInfo.hs @@ -42,8 +42,6 @@ import Data.Maybe (mapMaybe) import qualified Data.Set as Set import Data.Typeable (Typeable) import GHC.Records (HasField (..)) --- Import Plutus stuff in the qualified Module P - import qualified Plutus.V1.Ledger.Ada as P (adaSymbol, adaToken) import qualified Plutus.V1.Ledger.Address as P (Address (..)) import qualified Plutus.V1.Ledger.Api as P @@ -52,6 +50,7 @@ import qualified Plutus.V1.Ledger.Api as P ExBudget (..), VerboseMode (..), evaluateScriptRestricting, + validateAndCreateCostModel, validateScript, ) import qualified Plutus.V1.Ledger.Contexts as P @@ -74,6 +73,7 @@ import qualified Plutus.V1.Ledger.Slot as P (SlotRange) import qualified Plutus.V1.Ledger.Tx as P (TxOutRef (..)) import qualified Plutus.V1.Ledger.TxId as P (TxId (..)) import qualified Plutus.V1.Ledger.Value as P (CurrencySymbol (..), TokenName (..), Value (..), singleton, unionWith) +import qualified PlutusCore.Evaluation.Machine.ExBudgetingDefaults as P (defaultCostModel) import qualified PlutusCore.Evaluation.Machine.ExMemory as P (ExCPU (..), ExMemory (..)) import qualified PlutusTx as P (Data (..)) import qualified PlutusTx.IsData.Class as P (IsData (..)) @@ -255,7 +255,10 @@ transDataPair :: (DataHash c, Data era) -> (P.DatumHash, P.Datum) transDataPair (x, y) = (transDataHash' x, P.Datum (getPlutusData y)) transCostModel :: CostModel -> P.CostModel -transCostModel (CostModel _mp) = undefined -- Map.foldlWithKey' (\ans bytes n -> Map.insert (show bytes) n ans) Map.empty mp +transCostModel (CostModel mp) = + case P.validateAndCreateCostModel mp of + Nothing -> P.defaultCostModel -- TODO validation should be before this + Just cm -> cm transExUnits :: ExUnits -> P.ExBudget transExUnits (ExUnits mem steps) = P.ExBudget (P.ExCPU (fromIntegral steps)) (P.ExMemory (fromIntegral mem)) diff --git a/alonzo/impl/test/lib/Test/Cardano/Ledger/Alonzo/Serialisation/Generators.hs b/alonzo/impl/test/lib/Test/Cardano/Ledger/Alonzo/Serialisation/Generators.hs index ceb2c2f708..7a04771415 100644 --- a/alonzo/impl/test/lib/Test/Cardano/Ledger/Alonzo/Serialisation/Generators.hs +++ b/alonzo/impl/test/lib/Test/Cardano/Ledger/Alonzo/Serialisation/Generators.hs @@ -44,6 +44,7 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (mapMaybe) import qualified Data.Set as Set +import qualified Data.Text as T (pack) import qualified PlutusTx as Plutus import Test.Cardano.Ledger.ShelleyMA.Serialisation.Generators (genMintValues) import Test.QuickCheck @@ -192,7 +193,7 @@ instance Arbitrary Prices where arbitrary = Prices <$> arbitrary <*> arbitrary instance Arbitrary CostModel where - arbitrary = CostModel <$> arbitrary + arbitrary = (CostModel . (Map.mapKeys T.pack)) <$> arbitrary instance Arbitrary (PParams era) where arbitrary = diff --git a/alonzo/impl/test/test/Test/Cardano/Ledger/Alonzo/Examples/Utxow.hs b/alonzo/impl/test/test/Test/Cardano/Ledger/Alonzo/Examples/Utxow.hs new file mode 100644 index 0000000000..aaf310a7e3 --- /dev/null +++ b/alonzo/impl/test/test/Test/Cardano/Ledger/Alonzo/Examples/Utxow.hs @@ -0,0 +1,776 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Cardano.Ledger.Alonzo.Examples.Utxow + ( plutusScriptExamples, + utxowExamples, + ) +where + +import Cardano.Ledger.Alonzo (AlonzoEra) +import Cardano.Ledger.Alonzo.Data (Data (..), hashData) +import Cardano.Ledger.Alonzo.Language (Language (..)) +import Cardano.Ledger.Alonzo.PParams (PParams, PParams' (..)) +import Cardano.Ledger.Alonzo.Rules.Utxow (AlonzoUTXOW) +import Cardano.Ledger.Alonzo.Scripts + ( CostModel (..), + ExUnits (..), + Script, + Tag (..), + alwaysFails, + alwaysSucceeds, + ) +import Cardano.Ledger.Alonzo.Tx + ( IsValidating (..), + ValidatedTx (..), + hashWitnessPPData, + ) +import Cardano.Ledger.Alonzo.TxBody (TxBody (..), TxOut (..)) +import Cardano.Ledger.Alonzo.TxWitness + ( RdmrPtr (..), + Redeemers (..), + TxWitness (..), + ) +import Cardano.Ledger.Coin (Coin (..)) +import Cardano.Ledger.Era (ValidateScript (..)) +import Cardano.Ledger.Mary.Value + ( AssetName (..), + PolicyID (..), + Value (..), + ) +import Cardano.Ledger.SafeHash (hashAnnotated) +import Cardano.Ledger.ShelleyMA.Timelocks (ValidityInterval (..)) +import Cardano.Ledger.Val ((<+>)) +import qualified Cardano.Ledger.Val as Val +import Control.State.Transition.Extended hiding (Assertion) +import Control.State.Transition.Trace (checkTrace, (.-), (.->)) +import qualified Data.ByteString.Char8 as BS +import Data.Default.Class (def) +import qualified Data.Map.Strict as Map +import qualified Data.Sequence.Strict as StrictSeq +import qualified Data.Set as Set +import qualified Plutus.V1.Ledger.Api as P + ( EvaluationError (..), + ExBudget (..), + VerboseMode (..), + evaluateScriptRestricting, + ) +import Plutus.V1.Ledger.Examples + ( alwaysFailingNAryFunction, + alwaysSucceedingNAryFunction, + ) +import qualified PlutusCore.Evaluation.Machine.ExBudgetingDefaults as P (defaultCostModel) +import qualified PlutusCore.Evaluation.Machine.ExMemory as P (ExCPU (..), ExMemory (..)) +import qualified PlutusTx as Plutus +import Shelley.Spec.Ledger.Address (Addr (..)) +import Shelley.Spec.Ledger.BaseTypes (Network (..), StrictMaybe (..)) +import Shelley.Spec.Ledger.Credential (Credential (..), StakeCredential, StakeReference (..)) +import Shelley.Spec.Ledger.Keys (GenDelegs (..), KeyPair (..), KeyRole (..), hashKey) +import Shelley.Spec.Ledger.LedgerState (UTxOState (..)) +import Shelley.Spec.Ledger.STS.Utxo (UtxoEnv (..)) +import Shelley.Spec.Ledger.Slot (SlotNo (..)) +import Shelley.Spec.Ledger.TxBody + ( DCert (..), + DelegCert (..), + RewardAcnt (..), + TxIn (..), + Wdrl (..), + ) +import Shelley.Spec.Ledger.UTxO (UTxO (..), makeWitnessVKey, txid) +import Test.Shelley.Spec.Ledger.ConcreteCryptoTypes (C_Crypto) +import Test.Shelley.Spec.Ledger.Generator.EraGen (genesisId) +import Test.Shelley.Spec.Ledger.Utils (applySTSTest, mkKeyPair, runShelleyBase) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, assertBool, testCase, (@?=)) + +type A = AlonzoEra C_Crypto + +-- ======================= +-- Setup the initial state +-- ======================= + +pp :: PParams A +pp = + def + { _costmdls = Map.singleton PlutusV1 (CostModel mempty), + _maxValSize = 1000000000, + _maxTxExUnits = ExUnits 1000000 1000000, + _maxBlockExUnits = ExUnits 1000000 1000000 + } + +utxoEnv :: UtxoEnv A +utxoEnv = + UtxoEnv + (SlotNo 0) + pp + mempty + (GenDelegs mempty) + +-- | Create an address with a given payment script. +scriptAddr :: Script A -> Addr C_Crypto +scriptAddr s = Addr Testnet pCred sCred + where + pCred = ScriptHashObj . hashScript @A $ s + (_ssk, svk) = mkKeyPair @C_Crypto (0, 0, 0, 0, 0) + sCred = StakeRefBase . KeyHashObj . hashKey $ svk + +feeKeys :: KeyPair 'Payment C_Crypto +feeKeys = KeyPair vk sk + where + (sk, vk) = mkKeyPair @C_Crypto (0, 0, 0, 0, 1) + +feeAddr :: Addr C_Crypto +feeAddr = Addr Testnet pCred sCred + where + (_ssk, svk) = mkKeyPair @C_Crypto (0, 0, 0, 0, 2) + pCred = KeyHashObj . hashKey . vKey $ feeKeys + sCred = StakeRefBase . KeyHashObj . hashKey $ svk + +feeOutput :: TxOut A +feeOutput = + TxOut + feeAddr + (Val.inject $ Coin 1000) + SNothing + +initUTxO :: UTxO A +initUTxO = + UTxO $ + Map.fromList + [ (TxIn genesisId 0, alwaysSucceedsOutput), + (TxIn genesisId 1, alwaysFailsOutput), + (TxIn genesisId 2, feeOutput) + ] + +initUtxoSt :: UTxOState A +initUtxoSt = UTxOState initUTxO (Coin 0) (Coin 0) def + +-- ========================================================================= +-- Example 1: Process a SPEND transaction with a succeeding Plutus script. +-- ========================================================================= + +datumExample1 :: Data A +datumExample1 = Data (Plutus.I 0) + +redeemerExample1 :: Data A +redeemerExample1 = Data (Plutus.I 42) + +alwaysSucceedsOutput :: TxOut A +alwaysSucceedsOutput = + TxOut + (scriptAddr $ alwaysSucceeds 3) + (Val.inject $ Coin 5000) + (SJust . hashData $ datumExample1) + +validatingRedeemersEx1 :: Redeemers A +validatingRedeemersEx1 = + Redeemers $ + Map.singleton (RdmrPtr Spend 0) (redeemerExample1, ExUnits 5000 5000) + +outEx1 :: TxOut A +outEx1 = TxOut feeAddr (Val.inject $ Coin 5995) SNothing + +validatingBody :: TxBody A +validatingBody = + TxBody + (Set.singleton $ TxIn genesisId 0) --inputs + (Set.singleton $ TxIn genesisId 2) --txinputs_fee + (StrictSeq.singleton outEx1) --outputs + StrictSeq.empty --txcerts + (Wdrl mempty) --txwdrls + (Coin 5) --txfee + (ValidityInterval SNothing SNothing) --txvldt + SNothing --txUpdates + mempty -- reqSignerHashes + mempty --mint + (hashWitnessPPData pp (Set.singleton PlutusV1) validatingRedeemersEx1) --wppHash + SNothing --adHash + SNothing --network id + +validatingTx :: ValidatedTx A +validatingTx = + ValidatedTx + validatingBody + TxWitness + { txwitsVKey = Set.singleton $ makeWitnessVKey (hashAnnotated validatingBody) feeKeys, + txwitsBoot = mempty, + txscripts = + Map.singleton (hashScript @A $ alwaysSucceeds 3) (alwaysSucceeds 3), + txdats = Map.singleton (hashData datumExample1) datumExample1, + txrdmrs = validatingRedeemersEx1 + } + (IsValidating True) + SNothing + +utxoEx1 :: UTxO A +utxoEx1 = + UTxO $ + Map.fromList + [ (TxIn genesisId 1, alwaysFailsOutput), + (TxIn (txid @A validatingBody) 0, outEx1) + ] + +utxoStEx1 :: UTxOState A +utxoStEx1 = UTxOState utxoEx1 (Coin 0) (Coin 5) def + +-- ====================================================================== +-- Example 2: Process a SPEND transaction with a failing Plutus script. +-- ====================================================================== + +datumExample2 :: Data A +datumExample2 = Data (Plutus.I 0) + +redeemerExample2 :: Data A +redeemerExample2 = Data (Plutus.I 1) + +notValidatingRedeemers :: Redeemers A +notValidatingRedeemers = + Redeemers $ + Map.singleton (RdmrPtr Spend 0) (redeemerExample2, ExUnits 5000 5000) + +alwaysFailsOutput :: TxOut A +alwaysFailsOutput = + TxOut + (scriptAddr $ alwaysFails 0) + (Val.inject $ Coin 3000) + (SJust . hashData $ datumExample2) + +outEx2 :: TxOut A +outEx2 = TxOut feeAddr (Val.inject $ Coin 3995) SNothing + +notValidatingBody :: TxBody A +notValidatingBody = + TxBody + (Set.singleton $ TxIn genesisId 1) --inputs + (Set.singleton $ TxIn genesisId 2) --txinputs_fee + (StrictSeq.singleton outEx2) --outputs + StrictSeq.empty --txcerts + (Wdrl mempty) --txwdrls + (Coin 5) --txfee + (ValidityInterval SNothing SNothing) --txvldt + SNothing --txUpdates + mempty -- reqSignerHashes + mempty --mint + (hashWitnessPPData pp (Set.singleton PlutusV1) notValidatingRedeemers) --wppHash + SNothing --adHash + SNothing --network id + +notValidatingTx :: ValidatedTx A +notValidatingTx = + ValidatedTx + notValidatingBody + TxWitness + { txwitsVKey = Set.singleton $ makeWitnessVKey (hashAnnotated notValidatingBody) feeKeys, + txwitsBoot = mempty, + txscripts = + Map.singleton (hashScript @A $ alwaysFails 0) (alwaysFails 0), + txdats = Map.singleton (hashData datumExample2) datumExample2, + txrdmrs = notValidatingRedeemers + } + (IsValidating False) + SNothing + +utxoEx2 :: UTxO A +utxoEx2 = + UTxO $ + Map.fromList + [ (TxIn genesisId 0, alwaysSucceedsOutput), + (TxIn genesisId 1, alwaysFailsOutput) + ] + +utxoStEx2 :: UTxOState A +utxoStEx2 = UTxOState utxoEx2 (Coin 0) (Coin 1000) def + +-- ========================================================================= +-- Example 3: Process a CERT transaction with a succeeding Plutus script. +-- ========================================================================= + +outEx3 :: TxOut A +outEx3 = TxOut feeAddr (Val.inject $ Coin 995) SNothing + +redeemerExample3 :: Data A +redeemerExample3 = Data (Plutus.I 42) + +validatingRedeemersEx3 :: Redeemers A +validatingRedeemersEx3 = + Redeemers $ + Map.singleton (RdmrPtr Cert 0) (redeemerExample3, ExUnits 5000 5000) + +scriptStakeCredSuceed :: StakeCredential C_Crypto +scriptStakeCredSuceed = ScriptHashObj $ hashScript @A $ alwaysSucceeds 2 + +validatingBodyWithCert :: TxBody A +validatingBodyWithCert = + TxBody + mempty --inputs + (Set.singleton $ TxIn genesisId 2) --txinputs_fee + (StrictSeq.singleton outEx3) --outputs + (StrictSeq.fromList [DCertDeleg (DeRegKey scriptStakeCredSuceed)]) --txcerts + (Wdrl mempty) --txwdrls + (Coin 5) --txfee + (ValidityInterval SNothing SNothing) --txvldt + SNothing --txUpdates + mempty -- reqSignerHashes + mempty --mint + (hashWitnessPPData pp (Set.singleton PlutusV1) validatingRedeemersEx3) --wppHash + SNothing --adHash + SNothing --network id + +validatingTxWithCert :: ValidatedTx A +validatingTxWithCert = + ValidatedTx + validatingBodyWithCert + TxWitness + { txwitsVKey = Set.singleton $ makeWitnessVKey (hashAnnotated validatingBodyWithCert) feeKeys, + txwitsBoot = mempty, + txscripts = + Map.singleton (hashScript @A $ alwaysSucceeds 2) (alwaysSucceeds 2), + txdats = mempty, + txrdmrs = validatingRedeemersEx3 + } + (IsValidating True) + SNothing + +utxoEx3 :: UTxO A +utxoEx3 = + UTxO $ + Map.fromList + [ (TxIn genesisId 0, alwaysSucceedsOutput), + (TxIn genesisId 1, alwaysFailsOutput), + (TxIn (txid @A validatingBodyWithCert) 0, outEx3) + ] + +utxoStEx3 :: UTxOState A +utxoStEx3 = UTxOState utxoEx3 (Coin 0) (Coin 5) def + +-- ===================================================================== +-- Example 4: Process a CERT transaction with a failing Plutus script. +-- ===================================================================== + +outEx4 :: TxOut A +outEx4 = TxOut feeAddr (Val.inject $ Coin 995) SNothing + +redeemerExample4 :: Data A +redeemerExample4 = Data (Plutus.I 0) + +notValidatingRedeemersEx4 :: Redeemers A +notValidatingRedeemersEx4 = + Redeemers $ + Map.singleton (RdmrPtr Cert 0) (redeemerExample4, ExUnits 5000 5000) + +scriptStakeCredFail :: StakeCredential C_Crypto +scriptStakeCredFail = ScriptHashObj $ hashScript @A $ alwaysFails 1 + +notValidatingBodyWithCert :: TxBody A +notValidatingBodyWithCert = + TxBody + mempty --inputs + (Set.singleton $ TxIn genesisId 2) --txinputs_fee + (StrictSeq.singleton outEx4) --outputs + (StrictSeq.fromList [DCertDeleg (DeRegKey scriptStakeCredFail)]) --txcerts + (Wdrl mempty) --txwdrls + (Coin 5) --txfee + (ValidityInterval SNothing SNothing) --txvldt + SNothing --txUpdates + mempty -- reqSignerHashes + mempty --mint + (hashWitnessPPData pp (Set.singleton PlutusV1) notValidatingRedeemersEx4) --wppHash + SNothing --adHash + SNothing --network id + +notValidatingTxWithCert :: ValidatedTx A +notValidatingTxWithCert = + ValidatedTx + notValidatingBodyWithCert + TxWitness + { txwitsVKey = + Set.singleton $ + makeWitnessVKey + (hashAnnotated notValidatingBodyWithCert) + feeKeys, + txwitsBoot = mempty, + txscripts = + Map.singleton (hashScript @A $ alwaysFails 1) (alwaysFails 1), + txdats = mempty, + txrdmrs = notValidatingRedeemersEx4 + } + (IsValidating False) + SNothing + +utxoEx4 :: UTxO A +utxoEx4 = + UTxO $ + Map.fromList + [ (TxIn genesisId 0, alwaysSucceedsOutput), + (TxIn genesisId 1, alwaysFailsOutput) + ] + +utxoStEx4 :: UTxOState A +utxoStEx4 = UTxOState utxoEx4 (Coin 0) (Coin 1000) def + +-- ============================================================================== +-- Example 5: Process a WITHDRAWAL transaction with a succeeding Plutus script. +-- ============================================================================== + +outEx5 :: TxOut A +outEx5 = TxOut feeAddr (Val.inject $ Coin 1995) SNothing + +redeemerExample5 :: Data A +redeemerExample5 = Data (Plutus.I 42) + +validatingRedeemersEx5 :: Redeemers A +validatingRedeemersEx5 = + Redeemers $ + Map.singleton (RdmrPtr Rewrd 0) (redeemerExample5, ExUnits 5000 5000) + +validatingBodyWithWithdrawal :: TxBody A +validatingBodyWithWithdrawal = + TxBody + mempty --inputs + (Set.singleton $ TxIn genesisId 2) --txinputs_fee + (StrictSeq.singleton outEx5) --outputs + StrictSeq.empty + ( Wdrl $ + Map.singleton + (RewardAcnt Testnet scriptStakeCredSuceed) + (Coin 1000) --txwdrls + ) + (Coin 5) --txfee + (ValidityInterval SNothing SNothing) --txvldt + SNothing --txUpdates + mempty -- reqSignerHashes + mempty --mint + (hashWitnessPPData pp (Set.singleton PlutusV1) validatingRedeemersEx5) --wppHash + SNothing --adHash + SNothing --network id + +validatingTxWithWithdrawal :: ValidatedTx A +validatingTxWithWithdrawal = + ValidatedTx + validatingBodyWithWithdrawal + TxWitness + { txwitsVKey = + Set.singleton $ + makeWitnessVKey + (hashAnnotated validatingBodyWithWithdrawal) + feeKeys, + txwitsBoot = mempty, + txscripts = + Map.singleton (hashScript @A $ alwaysSucceeds 2) (alwaysSucceeds 2), + txdats = mempty, + txrdmrs = validatingRedeemersEx5 + } + (IsValidating True) + SNothing + +utxoEx5 :: UTxO A +utxoEx5 = + UTxO $ + Map.fromList + [ (TxIn genesisId 0, alwaysSucceedsOutput), + (TxIn genesisId 1, alwaysFailsOutput), + (TxIn (txid @A validatingBodyWithWithdrawal) 0, outEx5) + ] + +utxoStEx5 :: UTxOState A +utxoStEx5 = UTxOState utxoEx5 (Coin 0) (Coin 5) def + +-- =========================================================================== +-- Example 6: Process a WITHDRAWAL transaction with a failing Plutus script. +-- =========================================================================== + +outEx6 :: TxOut A +outEx6 = TxOut feeAddr (Val.inject $ Coin 1995) SNothing + +redeemerExample6 :: Data A +redeemerExample6 = Data (Plutus.I 0) + +notValidatingRedeemersEx6 :: Redeemers A +notValidatingRedeemersEx6 = + Redeemers $ + Map.singleton (RdmrPtr Rewrd 0) (redeemerExample6, ExUnits 5000 5000) + +notValidatingBodyWithWithdrawal :: TxBody A +notValidatingBodyWithWithdrawal = + TxBody + mempty --inputs + (Set.singleton $ TxIn genesisId 2) --txinputs_fee + (StrictSeq.singleton outEx6) --outputs + StrictSeq.empty + ( Wdrl $ + Map.singleton + (RewardAcnt Testnet scriptStakeCredFail) + (Coin 1000) --txwdrls + ) + (Coin 5) --txfee + (ValidityInterval SNothing SNothing) --txvldt + SNothing --txUpdates + mempty -- reqSignerHashes + mempty --mint + (hashWitnessPPData pp (Set.singleton PlutusV1) notValidatingRedeemersEx6) --wppHash + SNothing --adHash + SNothing --network id + +notValidatingTxWithWithdrawal :: ValidatedTx A +notValidatingTxWithWithdrawal = + ValidatedTx + notValidatingBodyWithWithdrawal + TxWitness + { txwitsVKey = + Set.singleton $ + makeWitnessVKey + (hashAnnotated notValidatingBodyWithWithdrawal) + feeKeys, + txwitsBoot = mempty, + txscripts = + Map.singleton (hashScript @A $ alwaysFails 1) (alwaysFails 1), + txdats = mempty, + txrdmrs = notValidatingRedeemersEx6 + } + (IsValidating False) + SNothing + +utxoEx6 :: UTxO A +utxoEx6 = + UTxO $ + Map.fromList + [ (TxIn genesisId 0, alwaysSucceedsOutput), + (TxIn genesisId 1, alwaysFailsOutput) + ] + +utxoStEx6 :: UTxOState A +utxoStEx6 = UTxOState utxoEx6 (Coin 0) (Coin 1000) def + +-- ============================================================================== +-- Example 7: Process a MINT transaction with a succeeding Plutus script. +-- ============================================================================== + +pidEx7 :: PolicyID C_Crypto +pidEx7 = PolicyID $ hashScript @A $ alwaysSucceeds 2 + +an :: AssetName +an = AssetName $ BS.pack "an" + +mintEx7 :: Value C_Crypto +mintEx7 = + Value 0 $ + Map.singleton pidEx7 (Map.singleton an 1) + +outEx7 :: TxOut A +outEx7 = TxOut feeAddr (mintEx7 <+> (Val.inject $ Coin 995)) SNothing + +redeemerExample7 :: Data A +redeemerExample7 = Data (Plutus.I 42) + +validatingRedeemersEx7 :: Redeemers A +validatingRedeemersEx7 = + Redeemers $ + Map.singleton (RdmrPtr Mint 0) (redeemerExample7, ExUnits 5000 5000) + +validatingBodyWithMint :: TxBody A +validatingBodyWithMint = + TxBody + mempty --inputs + (Set.singleton $ TxIn genesisId 2) --txinputs_fee + (StrictSeq.singleton outEx7) --outputs + StrictSeq.empty + (Wdrl mempty) + (Coin 5) --txfee + (ValidityInterval SNothing SNothing) --txvldt + SNothing --txUpdates + mempty -- reqSignerHashes + mintEx7 --mint + (hashWitnessPPData pp (Set.singleton PlutusV1) validatingRedeemersEx7) --wppHash + SNothing --adHash + SNothing --network id + +validatingTxWithMint :: ValidatedTx A +validatingTxWithMint = + ValidatedTx + validatingBodyWithMint + TxWitness + { txwitsVKey = + Set.singleton $ + makeWitnessVKey + (hashAnnotated validatingBodyWithMint) + feeKeys, + txwitsBoot = mempty, + txscripts = + Map.singleton (hashScript @A $ alwaysSucceeds 2) (alwaysSucceeds 2), + txdats = mempty, + txrdmrs = validatingRedeemersEx7 + } + (IsValidating True) + SNothing + +utxoEx7 :: UTxO A +utxoEx7 = + UTxO $ + Map.fromList + [ (TxIn genesisId 0, alwaysSucceedsOutput), + (TxIn genesisId 1, alwaysFailsOutput), + (TxIn (txid @A validatingBodyWithMint) 0, outEx7) + ] + +utxoStEx7 :: UTxOState A +utxoStEx7 = UTxOState utxoEx7 (Coin 0) (Coin 5) def + +-- ============================================================================== +-- Example 8: Process a MINT transaction with a failing Plutus script. +-- ============================================================================== + +pidEx8 :: PolicyID C_Crypto +pidEx8 = PolicyID $ hashScript @A $ alwaysFails 1 + +mintEx8 :: Value C_Crypto +mintEx8 = + Value 0 $ + Map.singleton pidEx8 (Map.singleton an 1) + +outEx8 :: TxOut A +outEx8 = TxOut feeAddr (mintEx8 <+> (Val.inject $ Coin 995)) SNothing + +redeemerExample8 :: Data A +redeemerExample8 = Data (Plutus.I 0) + +notValidatingRedeemersEx8 :: Redeemers A +notValidatingRedeemersEx8 = + Redeemers $ + Map.singleton (RdmrPtr Mint 0) (redeemerExample8, ExUnits 5000 5000) + +notValidatingBodyWithMint :: TxBody A +notValidatingBodyWithMint = + TxBody + mempty --inputs + (Set.singleton $ TxIn genesisId 2) --txinputs_fee + (StrictSeq.singleton outEx8) --outputs + StrictSeq.empty + (Wdrl mempty) + (Coin 5) --txfee + (ValidityInterval SNothing SNothing) --txvldt + SNothing --txUpdates + mempty -- reqSignerHashes + mintEx8 --mint + (hashWitnessPPData pp (Set.singleton PlutusV1) notValidatingRedeemersEx8) --wppHash + SNothing --adHash + SNothing --network id + +notValidatingTxWithMint :: ValidatedTx A +notValidatingTxWithMint = + ValidatedTx + notValidatingBodyWithMint + TxWitness + { txwitsVKey = + Set.singleton $ + makeWitnessVKey + (hashAnnotated notValidatingBodyWithMint) + feeKeys, + txwitsBoot = mempty, + txscripts = + Map.singleton (hashScript @A $ alwaysFails 1) (alwaysFails 1), + txdats = mempty, + txrdmrs = notValidatingRedeemersEx8 + } + (IsValidating False) + SNothing + +utxoEx8 :: UTxO A +utxoEx8 = + UTxO $ + Map.fromList + [ (TxIn genesisId 0, alwaysSucceedsOutput), + (TxIn genesisId 1, alwaysFailsOutput) + ] + +utxoStEx8 :: UTxOState A +utxoStEx8 = UTxOState utxoEx8 (Coin 0) (Coin 1000) def + +-- ======= +-- Tests +-- ======= + +plutusScriptExamples :: TestTree +plutusScriptExamples = + testGroup + "run plutus script directly" + [ testCase "always true" $ + case P.evaluateScriptRestricting + P.Verbose + P.defaultCostModel + (P.ExBudget (P.ExCPU 1) (P.ExMemory 2)) + (alwaysSucceedingNAryFunction 0) + [] of + (_, Left e) -> assertBool ("This script should have succeeded, but: " <> show e) False + (_, Right _) -> assertBool "" True, + testCase "always false" $ + case P.evaluateScriptRestricting + P.Verbose + P.defaultCostModel + (P.ExBudget (P.ExCPU 1) (P.ExMemory 2)) + (alwaysFailingNAryFunction 0) + [] of + (_, Left (P.CekError _)) -> assertBool "" True -- TODO rule out cost model failure + (_, Left e) -> assertBool ("Not the script failure we expected: " <> show e) False + (_, Right _) -> assertBool "This script should have failed" False + ] + +testUTXOW :: + UTxOState A -> + ValidatedTx A -> + Either [[PredicateFailure (AlonzoUTXOW A)]] (UTxOState A) -> + Assertion +testUTXOW initSt tx (Right expectedSt) = + checkTrace @(AlonzoUTXOW A) runShelleyBase utxoEnv $ + pure initSt .- tx .-> expectedSt +testUTXOW initSt tx predicateFailure@(Left _) = do + let st = runShelleyBase $ applySTSTest @(AlonzoUTXOW A) (TRC (utxoEnv, initSt, tx)) + st @?= predicateFailure + +utxowExamples :: TestTree +utxowExamples = + testGroup + "utxow examples" + [ testCase "validating SPEND script" $ + testUTXOW + initUtxoSt + validatingTx + (Right utxoStEx1), + testCase "not validating SPEND script" $ + testUTXOW + initUtxoSt + notValidatingTx + (Right utxoStEx2), + testCase "validating CERT script" $ + testUTXOW + initUtxoSt + validatingTxWithCert + (Right utxoStEx3), + testCase "not validating CERT script" $ + testUTXOW + initUtxoSt + notValidatingTxWithCert + (Right utxoStEx4), + testCase "validating WITHDRAWAL script" $ + testUTXOW + initUtxoSt + validatingTxWithWithdrawal + (Right utxoStEx5), + testCase "not validating WITHDRAWAL script" $ + testUTXOW + initUtxoSt + notValidatingTxWithWithdrawal + (Right utxoStEx6), + testCase "validating MINT script" $ + testUTXOW + initUtxoSt + validatingTxWithMint + (Right utxoStEx7), + testCase "not validating MINT script" $ + testUTXOW + initUtxoSt + notValidatingTxWithMint + (Right utxoStEx8) + ] diff --git a/alonzo/impl/test/test/Test/Cardano/Ledger/Alonzo/Serialisation/Tripping.hs b/alonzo/impl/test/test/Test/Cardano/Ledger/Alonzo/Serialisation/Tripping.hs index aa00e98c2d..0728763f5c 100644 --- a/alonzo/impl/test/test/Test/Cardano/Ledger/Alonzo/Serialisation/Tripping.hs +++ b/alonzo/impl/test/test/Test/Cardano/Ledger/Alonzo/Serialisation/Tripping.hs @@ -20,7 +20,7 @@ import Cardano.Ledger.Alonzo.TxWitness import qualified Data.ByteString as BS (ByteString) import qualified Data.ByteString.Base16.Lazy as Base16 import qualified Data.ByteString.Lazy.Char8 as BSL -import qualified Language.PlutusTx as Plutus +import qualified PlutusTx as Plutus import Shelley.Spec.Ledger.Metadata (Metadata) import Test.Cardano.Ledger.Alonzo.Serialisation.Generators () import Test.Cardano.Ledger.ShelleyMA.Serialisation.Coders (roundTrip, roundTripAnn) diff --git a/alonzo/impl/test/test/Tests.hs b/alonzo/impl/test/test/Tests.hs index 39c9301447..2d8bb48806 100644 --- a/alonzo/impl/test/test/Tests.hs +++ b/alonzo/impl/test/test/Tests.hs @@ -1,5 +1,6 @@ module Main where +import Test.Cardano.Ledger.Alonzo.Examples.Utxow (plutusScriptExamples, utxowExamples) import Test.Cardano.Ledger.Alonzo.Golden as Golden import qualified Test.Cardano.Ledger.Alonzo.Serialisation.CDDL as CDDL import qualified Test.Cardano.Ledger.Alonzo.Serialisation.Tripping as Tripping @@ -11,7 +12,9 @@ tests = "Alonzo tests" [ Tripping.tests, CDDL.tests 5, - Golden.goldenUTxOEntryMinAda + Golden.goldenUTxOEntryMinAda, + plutusScriptExamples, + utxowExamples ] main :: IO ()