Merge pull request #4541 from IntersectMBO/nm/alonzo-test-regression

Fix failing tests in `cardano-ledger-alonzo-test`
IntersectMBO · Aug 30, 2024 · 43ea4ab · 43ea4ab
2 parents 41d3220 + c6404b1
commit 43ea4ab
Show file tree

Hide file tree

Showing 20 changed files with 195 additions and 214 deletions.
diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Plutus/Evaluate.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Plutus/Evaluate.hs
@@ -65,7 +65,7 @@ import Data.MapExtras (fromElems)
 import Data.Maybe (mapMaybe)
 import qualified Data.Set as Set
 import Data.Text (Text)
-import Debug.Trace (traceEvent)
+import qualified Debug.Trace as Debug
 import GHC.Generics
 import Lens.Micro
 import NoThunks.Class (NoThunks)
@@ -244,14 +244,14 @@ evalPlutusScriptsWithLogs (plutusWithContext : rest) =
           [ "[LEDGER][PLUTUS_SCRIPT]"
           , "BEGIN"
           ]
-      !res = traceEvent beginMsg $ runPlutusScriptWithLogs plutusWithContext
+      !res = Debug.traceEvent beginMsg $ runPlutusScriptWithLogs plutusWithContext
       endMsg =
         intercalate
           ","
           [ "[LEDGER][PLUTUS_SCRIPT]"
           , "END"
           ]
-   in traceEvent endMsg res <> evalPlutusScriptsWithLogs rest
+   in Debug.traceEvent endMsg res <> evalPlutusScriptsWithLogs rest
 
 -- | Script failures that can be returned by 'evalTxExUnitsWithLogs'.
 data TransactionScriptFailure era

diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs
@@ -99,7 +99,7 @@ import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
 import qualified Data.List.NonEmpty as NE
 import Data.MapExtras (extractKeys)
 import Data.Text (Text)
-import Debug.Trace (traceEvent)
+import qualified Debug.Trace as Debug
 import GHC.Generics (Generic)
 import Lens.Micro
 import NoThunks.Class (NoThunks)
@@ -259,7 +259,7 @@ alonzoEvalScriptsTxValid = do
   let txBody = tx ^. bodyTxL
       genDelegs = dsGenDelegs (certDState certState)
 
-  () <- pure $! traceEvent validBegin ()
+  () <- pure $! Debug.traceEvent validBegin ()
 
   scriptsTransition slot pp tx utxo $ \case
     Fails _ps fs ->
@@ -269,7 +269,7 @@ alonzoEvalScriptsTxValid = do
           (FailedUnexpectedly (scriptFailureToFailureDescription <$> fs))
     Passes ps -> mapM_ (tellEvent . SuccessfulPlutusScriptsEvent) (nonEmpty ps)
 
-  () <- pure $! traceEvent validEnd ()
+  () <- pure $! Debug.traceEvent validEnd ()
 
   ppup' <-
     trans @(EraRule "PPUP" era) $
@@ -297,7 +297,7 @@ alonzoEvalScriptsTxInvalid = do
   TRC (UtxoEnv slot pp _, us@(UTxOState utxo _ fees _ _ _), tx) <- judgmentContext
   let txBody = tx ^. bodyTxL
 
-  () <- pure $! traceEvent invalidBegin ()
+  () <- pure $! Debug.traceEvent invalidBegin ()
 
   scriptsTransition slot pp tx utxo $ \case
     Passes _ps ->
@@ -307,7 +307,7 @@ alonzoEvalScriptsTxInvalid = do
       mapM_ (tellEvent . SuccessfulPlutusScriptsEvent) (nonEmpty ps)
       tellEvent (FailedPlutusScriptsEvent (scriptFailurePlutus <$> fs))
 
-  () <- pure $! traceEvent invalidEnd ()
+  () <- pure $! Debug.traceEvent invalidEnd ()
 
   {- utxoKeep = txBody ^. collateralInputsTxBodyL ⋪ utxo -}
   {- utxoDel  = txBody ^. collateralInputsTxBodyL ◁ utxo -}

diff --git a/eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/AlonzoEraGen.hs b/eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/AlonzoEraGen.hs
@@ -54,6 +54,7 @@ import Cardano.Ledger.Alonzo.TxWits (
   AlonzoTxWits (..),
   Redeemers (..),
   TxDats (..),
+  nullRedeemers,
  )
 import Cardano.Ledger.Alonzo.UTxO (AlonzoScriptsNeeded (..))
 import Cardano.Ledger.AuxiliaryData (AuxiliaryDataHash)
@@ -92,8 +93,10 @@ import Data.Proxy (Proxy (..))
 import Data.Ratio ((%))
 import Data.Sequence.Strict (StrictSeq ((:|>)))
 import qualified Data.Sequence.Strict as Seq (fromList)
-import Data.Set as Set
+import Data.Set (Set)
+import qualified Data.Set as Set
 import Lens.Micro
+import Lens.Micro.Extras (view)
 import Numeric.Natural (Natural)
 import qualified PlutusLedgerApi.Common as P (Data (..))
 import System.Random
@@ -316,9 +319,8 @@ genAlonzoPParamsUpdate constants pp = do
   coinPerWord <- genM (CoinPerWord . Coin <$> choose (1, 5))
   let genPrice = unsafeBoundRational . (% 100) <$> choose (0, 200)
   prices <- genM (Prices <$> genPrice <*> genPrice)
-  let maxTxExUnits = SNothing
-  -- maxTxExUnits <- genM (ExUnits <$> (choose (100, 5000)) <*> (choose (100, 5000)))
-  maxBlockExUnits <- genM (ExUnits <$> genNatural 100 5000 <*> genNatural 100 5000)
+  maxTxExUnits <- genM genMaxTxExUnits
+  maxBlockExUnits <- genM genMaxBlockExUnits
   -- Not too small for maxValSize, if this is too small then any Tx with Value
   -- that has lots of policyIds will fail. The Shelley Era uses hard coded 4000
   maxValSize <- genM (genNatural 4000 5000)
@@ -349,12 +351,8 @@ genAlonzoPParams constants = do
       prices = Prices minBound minBound
   coinPerWord <- CoinPerWord . Coin <$> choose (1, 5)
   -- prices <- Prices <$> (Coin <$> choose (100, 5000)) <*> (Coin <$> choose (100, 5000))
-  let maxTxExUnits = ExUnits (5 * bigMem + 1) (5 * bigStep + 1)
-  -- maxTxExUnits <- ExUnits <$> (choose (100, 5000)) <*> (choose (100, 5000))
-  maxBlockExUnits <-
-    ExUnits
-      <$> genNatural (20 * bigMem + 1) (30 * bigMem + 1)
-      <*> genNatural (20 * bigStep + 1) (30 * bigStep + 1)
+  maxTxExUnits <- genMaxTxExUnits
+  maxBlockExUnits <- genMaxBlockExUnits
   maxValSize <- genNatural 4000 10000 -- This can't be too small. Shelley uses Hard coded 4000
   let alonzoUpgrade =
         UpgradeAlonzoPParams
@@ -375,30 +373,54 @@ bigMem = 50000
 bigStep :: Natural
 bigStep = 99999
 
+genMaxTxExUnits :: Gen ExUnits
+genMaxTxExUnits =
+  ExUnits
+    -- Accommodate the maximum number of scripts in a transaction
+    <$> genNatural (10 * bigMem + 1) (20 * bigMem + 1)
+    <*> genNatural (10 * bigStep + 1) (20 * bigStep + 1)
+
+genMaxBlockExUnits :: Gen ExUnits
+genMaxBlockExUnits =
+  ExUnits
+    -- Accommodate the maximum number of scripts in all transactions in a block
+    <$> genNatural (60 * bigMem + 1) (100 * bigMem + 1)
+    <*> genNatural (60 * bigStep + 1) (100 * bigStep + 1)
+
 instance Mock c => EraGen (AlonzoEra c) where
   genEraAuxiliaryData = genAux
   genGenesisValue = maryGenesisValue
   genEraTwoPhase3Arg = phase2scripts3Arg
   genEraTwoPhase2Arg = phase2scripts2Arg
 
   genEraTxBody = genAlonzoTxBody
-  updateEraTxBody utxo pp witnesses txb coinx txin txout = new
+  updateEraTxBody utxo pp witnesses txb coinx txin txout =
+    txb
+      { atbInputs = newInputs
+      , atbCollateral = newCollaterals
+      , atbTxFee = coinx
+      , atbOutputs = newOutputs
+      , -- The witnesses may have changed, recompute the scriptIntegrityHash.
+        atbScriptIntegrityHash =
+          hashScriptIntegrity
+            langViews
+            (witnesses ^. rdmrsTxWitsL)
+            (witnesses ^. datsTxWitsL)
+      }
     where
       langs = langsUsed @(AlonzoEra c) (witnesses ^. scriptTxWitsL)
       langViews = Set.map (getLanguageView pp) langs
-      new =
-        txb
-          { atbInputs = atbInputs txb <> txin
-          , atbCollateral = atbCollateral txb <> Set.filter (okAsCollateral utxo) txin -- In Alonzo, extra inputs also are added to collateral
-          , atbTxFee = coinx
-          , atbOutputs = atbOutputs txb :|> txout
-          , -- The witnesses may have changed, recompute the scriptIntegrityHash.
-            atbScriptIntegrityHash =
-              hashScriptIntegrity
-                langViews
-                (witnesses ^. rdmrsTxWitsL)
-                (witnesses ^. datsTxWitsL)
-          }
+      requiredCollateral = ceiling $ fromIntegral (pp ^. ppCollateralPercentageL) * unCoin coinx % 100
+      potentialCollateral = Set.filter (okAsCollateral utxo) txin
+      txInAmounts = List.sortOn snd . Map.toList . Map.map (unCoin . view coinTxOutL) . unUTxO . txInsFilter utxo
+      takeUntilSum s = map fst . takeUntil ((s >=) . snd) . scanl1 (\(_, s') (x, n) -> (x, s' + n))
+      takeUntil p xs = let (y, n) = span p xs in y ++ take 1 n
+      newCollaterals =
+        if nullRedeemers (witnesses ^. rdmrsTxWitsL)
+          then mempty
+          else Set.fromList . takeUntilSum requiredCollateral $ txInAmounts potentialCollateral
+      newInputs = atbInputs txb <> txin
+      newOutputs = atbOutputs txb :|> txout
 
   addInputs txb txin = txb {atbInputs = atbInputs txb <> txin}
 
@@ -469,16 +491,21 @@ instance Mock c => EraGen (AlonzoEra c) where
           then
             if oldScriptWits == newWits
               then pure tx
-              else myDiscard "Random extra scriptwitness: genEraDone: AlonzoEraGen.hs"
-          else myDiscard "MinFee violation: genEraDone: AlonzoEraGen.hs"
+              else myDiscard $ "Random extra scriptwitness: genEraDone: " <> show newWits
+          else myDiscard $ "MinFee violation: genEraDone: " <> show theFee
 
   genEraTweakBlock pp txns =
     let txTotal, ppMax :: ExUnits
         txTotal = foldMap totExUnits txns
         ppMax = pp ^. ppMaxBlockExUnitsL
      in if pointWiseExUnits (<=) txTotal ppMax
           then pure txns
-          else myDiscard "TotExUnits violation: genEraTweakBlock: AlonzoEraGen.hs"
+          else
+            myDiscard $
+              "TotExUnits violation: genEraTweakBlock: "
+                <> show (unWrapExUnits txTotal)
+                <> " instead of "
+                <> show (unWrapExUnits ppMax)
 
   hasFailedScripts tx = IsValid False == tx ^. isValidTxL
 

diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxos.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxos.hs
@@ -76,7 +76,7 @@ import Control.State.Transition.Extended
 import Data.List.NonEmpty (nonEmpty)
 import qualified Data.Map.Strict as Map
 import Data.MapExtras (extractKeys)
-import Debug.Trace (traceEvent)
+import qualified Debug.Trace as Debug
 import Lens.Micro
 
 type instance EraRuleFailure "UTXOS" (BabbageEra c) = AlonzoUtxosPredFailure (BabbageEra c)
@@ -230,9 +230,9 @@ babbageEvalScriptsTxValid = do
     trans @(EraRule "PPUP" era) $
       TRC (PPUPEnv slot pp genDelegs, pup, txBody ^. updateTxBodyL)
 
-  () <- pure $! traceEvent validBegin ()
+  () <- pure $! Debug.traceEvent validBegin ()
   expectScriptsToPass pp tx utxo
-  () <- pure $! traceEvent validEnd ()
+  () <- pure $! Debug.traceEvent validEnd ()
 
   updateUTxOState
     pp
@@ -266,7 +266,7 @@ babbageEvalScriptsTxInvalid = do
   sysSt <- liftSTS $ asks systemStart
   ei <- liftSTS $ asks epochInfo
 
-  () <- pure $! traceEvent invalidBegin ()
+  () <- pure $! Debug.traceEvent invalidBegin ()
 
   case collectPlutusScriptsWithContext ei sysSt pp tx utxo of
     Right sLst ->
@@ -283,7 +283,7 @@ babbageEvalScriptsTxInvalid = do
             tellEvent (injectEvent $ FailedPlutusScriptsEvent (scriptFailurePlutus <$> fs))
     Left info -> failBecause (injectFailure $ CollectErrors info)
 
-  () <- pure $! traceEvent invalidEnd ()
+  () <- pure $! Debug.traceEvent invalidEnd ()
 
   {- utxoKeep = txBody ^. collateralInputsTxBodyL ⋪ utxo -}
   {- utxoDel  = txBody ^. collateralInputsTxBodyL ◁ utxo -}

diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Utxos.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Utxos.hs
@@ -66,7 +66,7 @@ import Cardano.Ledger.UTxO (EraUTxO (..), UTxO)
 import Control.DeepSeq (NFData)
 import Control.State.Transition.Extended
 import Data.List.NonEmpty (NonEmpty)
-import Debug.Trace (traceEvent)
+import qualified Debug.Trace as Debug
 import GHC.Generics (Generic)
 import Lens.Micro
 import NoThunks.Class (NoThunks)
@@ -286,9 +286,9 @@ conwayEvalScriptsTxValid = do
     judgmentContext
   let txBody = tx ^. bodyTxL
 
-  () <- pure $! traceEvent validBegin ()
+  () <- pure $! Debug.traceEvent validBegin ()
   expectScriptsToPass pp tx utxo
-  () <- pure $! traceEvent validEnd ()
+  () <- pure $! Debug.traceEvent validEnd ()
 
   utxos' <-
     updateUTxOState

diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Constants.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Constants.hs
@@ -55,16 +55,16 @@ data Constants = Constants
   -- ^ minimal number of genesis UTxO outputs
   , maxGenesisUTxOouts :: Int
   -- ^ maximal number of genesis UTxO outputs
-  , maxCertsPerTx :: Word64
-  -- ^ maximal number of certificates per transaction
-  , maxTxsPerBlock :: Word64
-  -- ^ maximal number of Txs per block
-  , maxNumKeyPairs :: Word64
-  -- ^ maximal numbers of generated keypairs
   , minGenesisOutputVal :: Integer
   -- ^ minimal coin value for generated genesis outputs
   , maxGenesisOutputVal :: Integer
   -- ^ maximal coin value for generated genesis outputs
+  , maxCertsPerTx :: Word64
+  -- ^ maximal number of certificates per transaction
+  , maxTxsPerBlock :: Word64
+  -- ^ maximal number of Txs per block
+  , numKeyPairs :: Word64
+  -- ^ Number of generated keypairs
   , numBaseScripts :: Int
   -- ^ Number of base scripts from which multi sig scripts are built.
   , numSimpleScripts :: Int
@@ -120,13 +120,13 @@ defaultConstants =
     , frequencyKeyCredDelegation = 2
     , frequencyTxUpdates = 10
     , frequencyTxWithMetadata = 10
-    , minGenesisUTxOouts = 10
-    , maxGenesisUTxOouts = 100
-    , maxCertsPerTx = 3
-    , maxTxsPerBlock = 10
-    , maxNumKeyPairs = 150
+    , minGenesisUTxOouts = 100
+    , maxGenesisUTxOouts = 150
     , minGenesisOutputVal = 1000000
     , maxGenesisOutputVal = 100000000
+    , maxCertsPerTx = 3
+    , maxTxsPerBlock = 10
+    , numKeyPairs = 200 -- Must be >= maxGenesisUTxOouts
     , numBaseScripts = 3
     , numSimpleScripts = 20
     , frequencyNoWithdrawals = 75
@@ -143,6 +143,6 @@ defaultConstants =
     , maxTreasury = 10000000
     , minReserves = 1000000
     , maxReserves = 10000000
-    , genTxStableUtxoSize = 100
+    , genTxStableUtxoSize = 125 -- Needs to be between minGenesisUTxOouts and maxGenesisUTxOouts
     , genTxUtxoIncrement = 3
     }
diff --git a/eras/shelley/test-suite/cardano-ledger-shelley-test.cabal b/eras/shelley/test-suite/cardano-ledger-shelley-test.cabal
@@ -86,7 +86,6 @@ library
         containers,
         data-default-class,
         deepseq,
-        hashable,
         microlens,
         mtl,
         nothunks,

diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Block.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Block.hs
@@ -37,6 +37,7 @@ import Cardano.Protocol.TPraos.Rules.Overlay (OBftSlot (..), lookupInOverlaySche
 import Cardano.Protocol.TPraos.Rules.Prtcl (PrtclState (..))
 import Cardano.Protocol.TPraos.Rules.Tickn (TicknState (..))
 import Cardano.Slotting.Slot (WithOrigin (..))
+import Control.Monad (unless)
 import Control.SetAlgebra (dom, eval)
 import Data.Coerce (coerce)
 import Data.Foldable (toList)
@@ -62,6 +63,7 @@ import Test.Cardano.Ledger.Shelley.Generator.Core (
  )
 import Test.Cardano.Ledger.Shelley.Generator.EraGen (EraGen (..), MinLEDGER_STS)
 import Test.Cardano.Ledger.Shelley.Generator.Trace.Ledger ()
+import Test.Cardano.Ledger.Shelley.Generator.Utxo (myDiscard)
 import Test.Cardano.Ledger.Shelley.Rules.Chain (ChainState (..))
 import Test.Cardano.Ledger.Shelley.Utils (
   epochFromSlotNo,
@@ -73,7 +75,7 @@ import Test.Cardano.Ledger.Shelley.Utils (
 import Test.Cardano.Protocol.TPraos.Create (VRFKeyPair (..))
 import Test.Control.State.Transition.Trace.Generator.QuickCheck (sigGen)
 import qualified Test.Control.State.Transition.Trace.Generator.QuickCheck as QC
-import Test.QuickCheck (Gen, discard)
+import Test.QuickCheck (Gen)
 import qualified Test.QuickCheck as QC (choose)
 
 -- ======================================================
@@ -178,9 +180,19 @@ genBlockWithTxGen
         <*> pure (fromIntegral (m * fromIntegral maxKESIterations))
         <*> pure oCert
     let hView = makeHeaderView (bheader theBlock)
-    if bhviewBSize hView <= pp ^. ppMaxBBSizeL && bhviewHSize hView <= fromIntegral (pp ^. ppMaxBHSizeL)
-      then pure theBlock
-      else discard
+    unless (bhviewBSize hView <= pp ^. ppMaxBBSizeL) $
+      myDiscard $
+        "genBlockWithTxGen: bhviewBSize too large"
+          <> show (bhviewBSize hView)
+          <> " vs "
+          <> show (pp ^. ppMaxBBSizeL)
+    unless (bhviewHSize hView <= fromIntegral (pp ^. ppMaxBHSizeL)) $
+      myDiscard $
+        "genBlockWithTxGen: bhviewHSize too large"
+          <> show (bhviewHSize hView)
+          <> " vs "
+          <> show (pp ^. ppMaxBHSizeL)
+    pure theBlock
     where
       -- This is safe to take form the original chain state, since we only tick
       -- it forward; no new blocks will have been applied.