Check tx execution cost is within total tx budget fix #255

cardano-scaling · Apr 6, 2022 · 638de6e · 638de6e
1 parent ef0bb53
commit 638de6e
Showing 1 changed file with 49 additions and 35 deletions.
diff --git a/hydra-node/test/Hydra/Chain/Direct/TxSpec.hs b/hydra-node/test/Hydra/Chain/Direct/TxSpec.hs
@@ -24,6 +24,7 @@ import Hydra.Chain.Direct.Contract.Mutation (cardanoCredentialsFor)
 import Hydra.Chain.Direct.Fixture (
   costModels,
   epochInfo,
+  maxTxExecutionUnits,
   pparams,
   systemStart,
   testNetworkId,
@@ -49,7 +50,6 @@ import Hydra.Party (Party, vkey)
 import Plutus.V1.Ledger.Api (toBuiltin, toData)
 import Test.Cardano.Ledger.Alonzo.Serialisation.Generators ()
 import Test.QuickCheck (
-  NonEmptyList (..),
   checkCoverage,
   choose,
   conjoin,
@@ -94,7 +94,8 @@ spec =
                       Left basicFailure ->
                         property False & counterexample ("Basic failure: " <> show basicFailure)
                       Right redeemerReport ->
-                        length commitsUTxO + 1 == length (rights $ Map.elems redeemerReport)
+                        withinTxExecutionBudget redeemerReport
+                          && length commitsUTxO + 1 == length (rights $ Map.elems redeemerReport)
                           & counterexample (prettyRedeemerReport redeemerReport)
                           & counterexample ("Tx: " <> toString (renderTx tx))
 
@@ -132,6 +133,8 @@ spec =
                         & counterexample "Wrong count of spend redeemer(s)"
                     , 1 == length (successfulRedeemersMinting redeemerReport)
                         & counterexample "Wrong count of mint redeemer(s)"
+                    , withinTxExecutionBudget redeemerReport
+                        & counterexample "Total execution budget exceeded"
                     ]
                     & label (show (length inHeadUTxO) <> " UTXO")
                     & label (show (valueSize $ foldMap txOutValue inHeadUTxO) <> " Assets")
@@ -141,39 +144,42 @@ spec =
 
     describe "abortTx" $ do
       prop "validates" $
-        \txIn contestationPeriod (ReasonablySized (NonEmpty parties)) -> forAll (genAbortableOutputs parties) $
-          \(resolvedInitials, resolvedCommits) -> forAll (cardanoCredentialsFor <$> elements parties) $
-            \(signer, _) ->
-              let headUTxO = (txIn :: TxIn, headOutput)
-                  headOutput = mkHeadOutput testNetworkId testPolicyId $ toUTxOContext $ mkTxOutDatum headDatum
-                  headDatum =
-                    Head.Initial
-                      (contestationPeriodFromDiffTime contestationPeriod)
-                      (map (partyFromVerKey . vkey) parties)
-                  initials = Map.fromList (drop2nd <$> resolvedInitials)
-                  initialsUTxO = drop3rd <$> resolvedInitials
-                  commits = Map.fromList (drop2nd <$> resolvedCommits)
-                  commitsUTxO = drop3rd <$> resolvedCommits
-                  utxo = UTxO $ Map.fromList (headUTxO : initialsUTxO <> commitsUTxO)
-                  headInfo = (txIn, headOutput, fromPlutusData $ toData headDatum)
-                  headScript = mkHeadTokenScript testSeedInput
-                  abortableCommits = Map.fromList $ map tripleToPair resolvedCommits
-                  abortableInitials = Map.fromList $ map tripleToPair resolvedInitials
-               in checkCoverage $ case abortTx signer headInfo headScript abortableInitials abortableCommits of
-                    Left OverlappingInputs ->
-                      property (isJust $ txIn `Map.lookup` initials)
-                    Right tx ->
-                      case validateTxScriptsUnlimited utxo tx of
-                        Left basicFailure ->
-                          property False & counterexample ("Basic failure: " <> show basicFailure)
-                        Right redeemerReport ->
-                          -- NOTE: There's 1 redeemer report for the head + 1 for the mint script +
-                          -- 1 for each of either initials or commits
-                          2 + (length initials + length commits) == length (rights $ Map.elems redeemerReport)
-                            & counterexample ("Redeemer report: " <> show redeemerReport)
-                            & counterexample ("Tx: " <> toString (renderTx tx))
-                            & counterexample ("Input utxo: " <> decodeUtf8 (encodePretty utxo))
-                            & cover 80 True "Success"
+        forAll (vectorOf 4 arbitrary) $ \parties ->
+          \txIn contestationPeriod -> forAll (genAbortableOutputs parties) $
+            \(resolvedInitials, resolvedCommits) -> forAll (cardanoCredentialsFor <$> elements parties) $
+              \(signer, _) ->
+                let headUTxO = (txIn :: TxIn, headOutput)
+                    headOutput = mkHeadOutput testNetworkId testPolicyId $ toUTxOContext $ mkTxOutDatum headDatum
+                    headDatum =
+                      Head.Initial
+                        (contestationPeriodFromDiffTime contestationPeriod)
+                        (map (partyFromVerKey . vkey) parties)
+                    initials = Map.fromList (drop2nd <$> resolvedInitials)
+                    initialsUTxO = drop3rd <$> resolvedInitials
+                    commits = Map.fromList (drop2nd <$> resolvedCommits)
+                    commitsUTxO = drop3rd <$> resolvedCommits
+                    utxo = UTxO $ Map.fromList (headUTxO : initialsUTxO <> commitsUTxO)
+                    headInfo = (txIn, headOutput, fromPlutusData $ toData headDatum)
+                    headScript = mkHeadTokenScript testSeedInput
+                    abortableCommits = Map.fromList $ map tripleToPair resolvedCommits
+                    abortableInitials = Map.fromList $ map tripleToPair resolvedInitials
+                 in checkCoverage $ case abortTx signer headInfo headScript abortableInitials abortableCommits of
+                      Left OverlappingInputs ->
+                        property (isJust $ txIn `Map.lookup` initials)
+                      Right tx ->
+                        case validateTxScriptsUnlimited utxo tx of
+                          Left basicFailure ->
+                            property False & counterexample ("Basic failure: " <> show basicFailure)
+                          Right redeemerReport ->
+                            -- NOTE: There's 1 redeemer report for the head + 1 for the mint script +
+                            -- 1 for each of either initials or commits
+                            ( withinTxExecutionBudget redeemerReport
+                                && 2 + (length initials + length commits) == length (rights $ Map.elems redeemerReport)
+                            )
+                              & counterexample ("Redeemer report: " <> show redeemerReport)
+                              & counterexample ("Tx: " <> toString (renderTx tx))
+                              & counterexample ("Input utxo: " <> decodeUtf8 (encodePretty utxo))
+                              & cover 80 True "Success"
 
       prop "cover fee correctly handles redeemers" $
         withMaxSuccess 60 $ \txIn cperiod (party :| parties) cardanoKeys walletUTxO ->
@@ -218,6 +224,14 @@ spec =
                       & counterexample "Failed to construct and observe init tx."
                       & counterexample (toString (renderTx tx))
 
+withinTxExecutionBudget :: Map Ledger.RdmrPtr (Either (Ledger.ScriptFailure StandardCrypto) Ledger.ExUnits) -> Bool
+withinTxExecutionBudget redeemers =
+  let ExecutionUnits mem cpu = foldr addExUnit (ExecutionUnits 0 0) $ rights $ Map.elems redeemers
+      addExUnit (Ledger.ExUnits mem' cpu') (ExecutionUnits mem'' cpu'') =
+        ExecutionUnits (mem' + mem'') (cpu' + cpu'')
+   in mem <= executionMemory maxTxExecutionUnits
+        && cpu <= executionSteps maxTxExecutionUnits
+
 -- | Generate a UTXO representing /commit/ outputs for a given list of `Party`.
 -- FIXME: This function is very complicated and it's hard to understand it after a while
 generateCommitUTxOs :: [Party] -> Gen (Map.Map TxIn (TxOut CtxUTxO, ScriptData))