From e07983b3ddd443e6209fd1293c2e762494b27e72 Mon Sep 17 00:00:00 2001 From: Alex Byaly Date: Mon, 12 Jul 2021 17:08:05 -0500 Subject: [PATCH 1/2] fix ex unit evaluation - round trip test for translating exunits to/from plutus - test whether evaluateTransactionExecutionUnits provides enough exUnits - fixed ex unit translation --- .../impl/src/Cardano/Ledger/Alonzo/Tools.hs | 12 +- .../impl/src/Cardano/Ledger/Alonzo/TxInfo.hs | 10 + alonzo/test/cardano-ledger-alonzo-test.cabal | 3 + .../Test/Cardano/Ledger/Alonzo/Examples.hs | 32 +-- .../test/Test/Cardano/Ledger/Alonzo/Tools.hs | 185 ++++++++++++++++++ alonzo/test/test/Tests.hs | 3 + 6 files changed, 213 insertions(+), 32 deletions(-) create mode 100644 alonzo/test/test/Test/Cardano/Ledger/Alonzo/Tools.hs diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/Tools.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/Tools.hs index 1de2209ff57..daf5fb41806 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo/Tools.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/Tools.hs @@ -22,7 +22,7 @@ import Cardano.Ledger.Alonzo.Scripts ) import Cardano.Ledger.Alonzo.Tx (DataHash, ScriptPurpose (Spending), rdptr) import Cardano.Ledger.Alonzo.TxBody (TxOut (..)) -import Cardano.Ledger.Alonzo.TxInfo (txInfo, valContext) +import Cardano.Ledger.Alonzo.TxInfo (exBudgetToExUnits, txInfo, valContext) import Cardano.Ledger.Alonzo.TxWitness (RdmrPtr (..), unRedeemers, unTxDats) import Cardano.Ledger.BaseTypes (StrictMaybe (..), strictMaybeToMaybe) import qualified Cardano.Ledger.Core as Core @@ -57,20 +57,12 @@ data ScriptFailure c | -- | The execution budget that was calculated by the Plutus -- evaluator is out of bounds. IncompatibleBudget P.ExBudget + deriving (Show) note :: e -> Maybe a -> Either e a note _ (Just x) = Right x note e Nothing = Left e -safeFromInteger :: forall a. (Integral a, Bounded a) => Integer -> Maybe a -safeFromInteger i - | toInteger (minBound :: a) <= i && i <= toInteger (maxBound :: a) = Just $ fromInteger i - | otherwise = Nothing - -exBudgetToExUnits :: P.ExBudget -> Maybe ExUnits -exBudgetToExUnits (P.ExBudget (P.ExCPU cpu) (P.ExMemory memory)) = - ExUnits <$> safeFromInteger (toInteger cpu) <*> safeFromInteger (toInteger memory) - -- | Evaluate the execution budgets needed for all the redeemers in -- a given transaction. If a redeemer is invalid, a failure is returned instead. -- diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/TxInfo.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/TxInfo.hs index f2a9872db6f..5c55d83f378 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo/TxInfo.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/TxInfo.hs @@ -278,6 +278,16 @@ transDataPair (x, y) = (transDataHash' x, P.Datum (getPlutusData y)) transExUnits :: ExUnits -> P.ExBudget transExUnits (ExUnits mem steps) = P.ExBudget (P.ExCPU (fromIntegral steps)) (P.ExMemory (fromIntegral mem)) +exBudgetToExUnits :: P.ExBudget -> Maybe ExUnits +exBudgetToExUnits (P.ExBudget (P.ExCPU steps) (P.ExMemory memory)) = + ExUnits <$> safeFromInteger (toInteger memory) + <*> safeFromInteger (toInteger steps) + where + safeFromInteger :: forall a. (Integral a, Bounded a) => Integer -> Maybe a + safeFromInteger i + | toInteger (minBound :: a) <= i && i <= toInteger (maxBound :: a) = Just $ fromInteger i + | otherwise = Nothing + -- =================================== -- translate Script Purpose diff --git a/alonzo/test/cardano-ledger-alonzo-test.cabal b/alonzo/test/cardano-ledger-alonzo-test.cabal index 1048dc9de47..4410e8e86f9 100644 --- a/alonzo/test/cardano-ledger-alonzo-test.cabal +++ b/alonzo/test/cardano-ledger-alonzo-test.cabal @@ -73,6 +73,7 @@ test-suite cardano-ledger-alonzo-test test other-modules: Test.Cardano.Ledger.Alonzo.Trials + Test.Cardano.Ledger.Alonzo.Tools Test.Cardano.Ledger.Alonzo.Golden Test.Cardano.Ledger.Alonzo.Serialisation.Canonical Test.Cardano.Ledger.Alonzo.Serialisation.Tripping @@ -80,6 +81,7 @@ test-suite cardano-ledger-alonzo-test Test.Cardano.Ledger.Alonzo.Translation Test.Cardano.Ledger.Alonzo.Serialisation.CDDL build-depends: + array, base16-bytestring, bytestring, cardano-binary, @@ -87,6 +89,7 @@ test-suite cardano-ledger-alonzo-test cardano-ledger-alonzo-test, cardano-ledger-shelley-ma, cardano-ledger-core, + cardano-ledger-test, cardano-ledger-shelley-ma-test, cardano-slotting, containers, diff --git a/alonzo/test/test/Test/Cardano/Ledger/Alonzo/Examples.hs b/alonzo/test/test/Test/Cardano/Ledger/Alonzo/Examples.hs index fa86f27fa9d..bccc858c46a 100644 --- a/alonzo/test/test/Test/Cardano/Ledger/Alonzo/Examples.hs +++ b/alonzo/test/test/Test/Cardano/Ledger/Alonzo/Examples.hs @@ -11,19 +11,10 @@ import Cardano.Ledger.Alonzo.Scripts (Script (..)) import Data.ByteString.Short (ShortByteString) import Data.Maybe (fromMaybe) import qualified Plutus.V1.Ledger.Api as P - ( EvaluationError (..), - ExBudget (..), - ExCPU (..), - ExMemory (..), - VerboseMode (..), - defaultCostModelParams, - evaluateScriptRestricting, - ) import Plutus.V1.Ledger.Examples ( alwaysFailingNAryFunction, alwaysSucceedingNAryFunction, ) -import qualified PlutusTx as P import qualified Test.Cardano.Ledger.Alonzo.PlutusScripts as Generated ( evendata3, guessTheNumber2, @@ -39,27 +30,24 @@ data ShouldSucceed = ShouldSucceed | ShouldFail directPlutusTest :: ShouldSucceed -> ShortByteString -> [P.Data] -> Assertion directPlutusTest expectation script ds = - case (expectation, evalWithHugeBudget script ds) of - (ShouldSucceed, (_, Left e)) -> + case (expectation, evalWithTightBudget script ds) of + (ShouldSucceed, Left e) -> assertBool ("This script should have succeeded, but: " <> show e) False - (ShouldSucceed, (_, Right _)) -> + (ShouldSucceed, Right _) -> assertBool "" True - (ShouldFail, (_, Left ((P.CekError _)))) -> + (ShouldFail, Left ((P.CekError _))) -> assertBool "" True -- TODO rule out cost model failure - (ShouldFail, (_, Left e)) -> + (ShouldFail, Left e) -> assertBool ("Not the script failure we expected: " <> show e) False - (ShouldFail, (_, Right _)) -> + (ShouldFail, Right _) -> assertBool "This script should have failed" False where costModel = fromMaybe (error "corrupt default cost model") P.defaultCostModelParams -- Evaluate a script with sufficient budget to run it. - evalWithHugeBudget scr datums = - P.evaluateScriptRestricting - P.Verbose - costModel - (P.ExBudget (P.ExCPU 100000000) (P.ExMemory 10000000)) - scr - datums + evalWithTightBudget :: ShortByteString -> [P.Data] -> Either P.EvaluationError () + evalWithTightBudget scr datums = do + budget <- snd $ P.evaluateScriptCounting P.Quiet costModel scr datums + snd $ P.evaluateScriptRestricting P.Verbose costModel budget scr datums -- | Expects 3 args (data, redeemer, context) guessTheNumber3 :: ShortByteString diff --git a/alonzo/test/test/Test/Cardano/Ledger/Alonzo/Tools.hs b/alonzo/test/test/Test/Cardano/Ledger/Alonzo/Tools.hs new file mode 100644 index 00000000000..6afc4f55add --- /dev/null +++ b/alonzo/test/test/Test/Cardano/Ledger/Alonzo/Tools.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Cardano.Ledger.Alonzo.Tools (tests, testExUnitCalculation) where + +import Cardano.Ledger.Alonzo.Language (Language (..)) +import Cardano.Ledger.Alonzo.PParams (PParams, PParams' (..), ProtVer (..)) +import Cardano.Ledger.Alonzo.Rules.Utxos (UTXOS) +import Cardano.Ledger.Alonzo.Scripts (CostModel, ExUnits (..), defaultCostModel) +import Cardano.Ledger.Alonzo.Tools (evaluateTransactionExecutionUnits) +import Cardano.Ledger.Alonzo.Tx + ( IsValidating (..), + ValidatedTx (..), + ) +import Cardano.Ledger.Alonzo.TxInfo (exBudgetToExUnits, transExUnits) +import Cardano.Ledger.Alonzo.TxWitness (RdmrPtr, Redeemers (..), txrdmrs) +import Cardano.Ledger.Coin (Coin (..)) +import Cardano.Ledger.Keys (GenDelegs (..)) +import Cardano.Ledger.SafeHash (hashAnnotated) +import qualified Cardano.Ledger.Tx as Core +import Cardano.Slotting.EpochInfo (EpochInfo, fixedEpochInfo) +import Cardano.Slotting.Slot (EpochSize (..), SlotNo (..)) +import Cardano.Slotting.Time (SystemStart, mkSlotLength) +import Control.State.Transition.Extended (TRC (..)) +import Data.Array (Array, array) +import Data.Default.Class (Default (..)) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromJust) +import Data.Word (Word64) +import GHC.Records (getField) +import Shelley.Spec.Ledger.LedgerState (UTxOState (..)) +import Shelley.Spec.Ledger.STS.Utxo (UtxoEnv (..)) +import Shelley.Spec.Ledger.UTxO (UTxO, makeWitnessVKey) +import Test.Cardano.Ledger.Examples.TwoPhaseValidation (A, datumExample1, initUTxO, someKeys, testSystemStart, validatingBody, validatingRedeemersEx1) +import Test.Cardano.Ledger.Generic.Proof (Evidence (Mock), Proof (Alonzo)) +import Test.Cardano.Ledger.Generic.Updaters +import Test.Shelley.Spec.Ledger.Utils (applySTSTest, runShelleyBase) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase) +import Test.Tasty.QuickCheck (Gen, Property, chooseBoundedIntegral, counterexample, testProperty) + +tests :: TestTree +tests = + testGroup "ExUnit tools" $ + [ testProperty "Plutus ExUnit translation round-trip" exUnitsTranslationRoundTrip, + testCase "calculate ExUnits" exampleExUnitCalc + ] + +genExUnits :: Gen ExUnits +genExUnits = ExUnits <$> genUnit <*> genUnit + where + genUnit :: Gen Word64 + genUnit = chooseBoundedIntegral (0, 2 ^ (63 :: Word64) - 1) + +-- ExUnits should remain intact when translating to and from the plutus type +exUnitsTranslationRoundTrip :: Gen Property +exUnitsTranslationRoundTrip = do + e <- genExUnits + let result = (exBudgetToExUnits . transExUnits) e + pure $ + counterexample + ( "Before: " <> show (Just e) + <> "\n After: " + <> show result + ) + $ result == Just e + +-- checks plutus script validation against a tx which has had +-- its ex units replaced by the output of evaluateTransactionExecutionUnits +testExUnitCalculation :: + MonadFail m => + Core.Tx A -> + UTxOState A -> + UtxoEnv A -> + EpochInfo m -> + SystemStart -> + Array Language CostModel -> + m () +testExUnitCalculation tx utxoState ue ei ss costmdls = do + tx' <- updateTxExUnits tx utxo ei ss costmdls + _ <- + failLeft $ + runShelleyBase $ + applySTSTest @(UTXOS A) (TRC (ue, utxoState, vtx tx')) + pure () + where + utxo = _utxo utxoState + +exampleExUnitCalc :: IO () +exampleExUnitCalc = + testExUnitCalculation + exampleTx + ustate + uenv + exampleEpochInfo + testSystemStart + costmodels + +exampleTx :: Core.Tx A +exampleTx = + let pf = Alonzo Mock + in newTx + Override + pf + [ Body (validatingBody pf), + Witnesses' + [ AddrWits [makeWitnessVKey (hashAnnotated (validatingBody pf)) (someKeys pf)], + ScriptWits [always 3 pf], + DataWits [datumExample1], + RdmrWits validatingRedeemersEx1 + ] + ] + +exampleEpochInfo :: Monad m => EpochInfo m +exampleEpochInfo = fixedEpochInfo (EpochSize 100) (mkSlotLength 1) + +uenv :: UtxoEnv A +uenv = UtxoEnv (SlotNo 0) pparams mempty (GenDelegs mempty) + +costmodels :: Array Language CostModel +costmodels = array (PlutusV1, PlutusV1) [(PlutusV1, fromJust defaultCostModel)] + +ustate :: UTxOState A +ustate = + UTxOState + { _utxo = initUTxO (Alonzo Mock), + _deposited = Coin 0, + _fees = Coin 0, + _ppups = def + } + +-- Requires ex units, but there are no fees +pparams :: PParams A +pparams = + newPParams + (Alonzo Mock) + [ Costmdls $ Map.singleton PlutusV1 $ fromJust defaultCostModel, + MaxValSize 1000000000, + MaxTxExUnits $ ExUnits 100000000 100000000, + MaxBlockExUnits $ ExUnits 100000000 100000000, + ProtocolVersion $ ProtVer 5 0 + ] + +updateTxExUnits :: + MonadFail m => + Core.Tx A -> + UTxO A -> + EpochInfo m -> + SystemStart -> + Array Language CostModel -> + m (Core.Tx A) +updateTxExUnits tx utxo ei ss costmdls = do + -- rdmrs :: Map RdmrPtr ExUnits + rdmrs <- + traverse failLeft + =<< evaluateTransactionExecutionUnits tx utxo ei ss costmdls + pure (replaceRdmrs tx rdmrs) + +replaceRdmrs :: Core.Tx A -> Map RdmrPtr ExUnits -> Core.Tx A +replaceRdmrs tx rdmrs = tx {Core.wits = wits'} + where + wits' = (Core.wits tx) {txrdmrs = newrdmrs} + newrdmrs = foldr replaceRdmr (txrdmrs (Core.wits tx)) (Map.assocs rdmrs) + + replaceRdmr :: (RdmrPtr, ExUnits) -> Redeemers A -> Redeemers A + replaceRdmr (ptr, ex) x@(Redeemers r) = + case Map.lookup ptr r of + Just (dat, _ex) -> Redeemers $ Map.insert ptr (dat, ex) r + Nothing -> x + +failLeft :: MonadFail m => Show e => Either e a -> m a +failLeft (Right a) = pure a +failLeft (Left e) = fail (show e) + +vtx :: Core.Tx A -> ValidatedTx A +vtx tx = + ValidatedTx + { body = getField @"body" tx, + wits = getField @"wits" tx, + isValidating = IsValidating True, + auxiliaryData = getField @"auxiliaryData" tx + } diff --git a/alonzo/test/test/Tests.hs b/alonzo/test/test/Tests.hs index 6cc2b2c6266..df5ed3d4451 100644 --- a/alonzo/test/test/Tests.hs +++ b/alonzo/test/test/Tests.hs @@ -13,6 +13,7 @@ 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.Canonical as Canonical import qualified Test.Cardano.Ledger.Alonzo.Serialisation.Tripping as Tripping +import qualified Test.Cardano.Ledger.Alonzo.Tools as TOOLS import qualified Test.Cardano.Ledger.Alonzo.Translation as Translation import Test.Cardano.Ledger.Alonzo.Trials (alonzoPropertyTests, fastPropertyTests) import Test.Tasty @@ -35,6 +36,7 @@ mainTests = Translation.tests, Canonical.tests, CDDL.tests 5, + TOOLS.tests, Golden.goldenUTxOEntryMinAda, plutusScriptExamples ] @@ -46,6 +48,7 @@ fastTests = [ Tripping.tests, Translation.tests, CDDL.tests 1, + TOOLS.tests, Golden.goldenUTxOEntryMinAda, plutusScriptExamples ] From d66edb54fe121ea1802ea88a671c784bf5439798 Mon Sep 17 00:00:00 2001 From: Alex Byaly Date: Fri, 16 Jul 2021 08:18:53 -0500 Subject: [PATCH 2/2] rm monadFail --- .../test/Test/Cardano/Ledger/Alonzo/Tools.hs | 21 +++++++++++-------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/alonzo/test/test/Test/Cardano/Ledger/Alonzo/Tools.hs b/alonzo/test/test/Test/Cardano/Ledger/Alonzo/Tools.hs index 6afc4f55add..ea3197fe4fe 100644 --- a/alonzo/test/test/Test/Cardano/Ledger/Alonzo/Tools.hs +++ b/alonzo/test/test/Test/Cardano/Ledger/Alonzo/Tools.hs @@ -39,7 +39,7 @@ import Test.Cardano.Ledger.Generic.Proof (Evidence (Mock), Proof (Alonzo)) import Test.Cardano.Ledger.Generic.Updaters import Test.Shelley.Spec.Ledger.Utils (applySTSTest, runShelleyBase) import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCase) +import Test.Tasty.HUnit (assertFailure, testCase) import Test.Tasty.QuickCheck (Gen, Property, chooseBoundedIntegral, counterexample, testProperty) tests :: TestTree @@ -78,11 +78,12 @@ testExUnitCalculation :: EpochInfo m -> SystemStart -> Array Language CostModel -> + (forall a. String -> m a) -> m () -testExUnitCalculation tx utxoState ue ei ss costmdls = do - tx' <- updateTxExUnits tx utxo ei ss costmdls +testExUnitCalculation tx utxoState ue ei ss costmdls err = do + tx' <- updateTxExUnits tx utxo ei ss costmdls err _ <- - failLeft $ + failLeft err $ runShelleyBase $ applySTSTest @(UTXOS A) (TRC (ue, utxoState, vtx tx')) pure () @@ -98,6 +99,7 @@ exampleExUnitCalc = exampleEpochInfo testSystemStart costmodels + assertFailure exampleTx :: Core.Tx A exampleTx = @@ -151,11 +153,12 @@ updateTxExUnits :: EpochInfo m -> SystemStart -> Array Language CostModel -> + (forall a. String -> m a) -> m (Core.Tx A) -updateTxExUnits tx utxo ei ss costmdls = do +updateTxExUnits tx utxo ei ss costmdls err = do -- rdmrs :: Map RdmrPtr ExUnits rdmrs <- - traverse failLeft + traverse (failLeft err) =<< evaluateTransactionExecutionUnits tx utxo ei ss costmdls pure (replaceRdmrs tx rdmrs) @@ -171,9 +174,9 @@ replaceRdmrs tx rdmrs = tx {Core.wits = wits'} Just (dat, _ex) -> Redeemers $ Map.insert ptr (dat, ex) r Nothing -> x -failLeft :: MonadFail m => Show e => Either e a -> m a -failLeft (Right a) = pure a -failLeft (Left e) = fail (show e) +failLeft :: (Monad m, Show e) => (String -> m a) -> Either e a -> m a +failLeft _ (Right a) = pure a +failLeft err (Left e) = err (show e) vtx :: Core.Tx A -> ValidatedTx A vtx tx =