genEraDone method discards trace with extra script witness

IntersectMBO · Sep 15, 2022 · 354569e · 354569e
1 parent 4fc32a6
commit 354569e
Show file tree

Hide file tree

Showing 4 changed files with 32 additions and 20 deletions.
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
@@ -34,15 +34,7 @@ import Cardano.Ledger.Alonzo.Scripts as Alonzo
     Prices (..),
     mkCostModel,
   )
-import Cardano.Ledger.Alonzo.Tx
-  ( AlonzoEraTx (..),
-    AlonzoTx (..),
-    IsValid (..),
-    ScriptPurpose (..),
-    hashScriptIntegrity,
-    rdptr,
-    totExUnits,
-  )
+import Cardano.Ledger.Alonzo.Tx (AlonzoEraTx (..), AlonzoTx (..), IsValid (..), ScriptPurpose (..), hashScriptIntegrity, rdptr, totExUnits)
 import Cardano.Ledger.Alonzo.TxBody
   ( AlonzoEraTxBody (..),
     AlonzoTxBody (..),
@@ -76,7 +68,13 @@ import Cardano.Ledger.Mary.Value
 import Cardano.Ledger.Pretty.Alonzo ()
 import Cardano.Ledger.Shelley.PParams (Update)
 import Cardano.Ledger.Shelley.TxBody (DCert, Wdrl)
-import Cardano.Ledger.Shelley.UTxO (EraUTxO (..), UTxO (..), coinBalance)
+import Cardano.Ledger.Shelley.UTxO
+  ( EraUTxO (..),
+    UTxO (..),
+    coinBalance,
+    getScriptsHashesNeeded,
+    getScriptsNeeded,
+  )
 import Cardano.Ledger.ShelleyMA.AuxiliaryData (AllegraTxAuxData (..))
 import Cardano.Ledger.ShelleyMA.Era ()
 import Cardano.Ledger.ShelleyMA.Timelocks (Timelock (..), translateTimelock)
@@ -439,12 +437,26 @@ instance Mock c => EraGen (AlonzoEra c) where
         Nothing -> storageCost 0 pp script
       else storageCost 0 pp script
 
-  genEraDone pp tx =
+  -- For some reason, the EraGen generators occasionally generate an extra script witness.
+  --    There is some evidence that this arises because the script hash appears as the PolicyId
+  --    in a Value. But that is not been verified. Regardless of the cause, we can fix this by
+  --    discarding the trace. Note that this is failure to generate a "random" but valid
+  --    transaction. Discarding the trace adjust for this inadequacy in the generation process.
+  --    This only appears in the Alonzo era, so this "fix" is applied here, in the genEraDone
+  --    method of the EraGen class in the (AlonzoEra c) instance.
+  genEraDone utxo pp tx =
     let theFee = tx ^. bodyTxL . feeTxBodyL -- Coin supplied to pay fees
         minimumFee = getMinFeeTx @(AlonzoEra c) pp tx
+        neededHashes = getScriptsHashesNeeded (getScriptsNeeded utxo (tx ^. bodyTxL))
+        oldScriptWits = tx ^. witsTxL . scriptTxWitsL
+        newWits = oldScriptWits `Map.restrictKeys` neededHashes
      in if minimumFee <= theFee
-          then pure tx
-          else myDiscard "MinFeee violation: genEraDne: AlonzoEraGen.hs"
+          then
+            ( if not (oldScriptWits == newWits)
+                then myDiscard "Random extra scriptwitness: genEraDone: AlonzoEraGen.hs"
+                else pure tx
+            )
+          else myDiscard "MinFeee violation: genEraDone: AlonzoEraGen.hs"
 
   genEraTweakBlock pp txns =
     let txTotal, ppMax :: ExUnits

diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/EraGen.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/EraGen.hs
@@ -268,8 +268,8 @@ class
 
   -- | A final opportunity to tweak things when the generator is done. Possible uses
   --   1) Add tracing when debugging on a per Era basis
-  genEraDone :: PParams era -> Tx era -> Gen (Tx era)
-  genEraDone _pp x = pure x
+  genEraDone :: UTxO era -> PParams era -> Tx era -> Gen (Tx era)
+  genEraDone _utxo _pp x = pure x
 
   -- | A final opportunity to tweak things at the block level. Possible uses
   --   2) Run a test that might decide to 'discard' the test, because we got unlucky, and a rare unfixible condition has occurred.

diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Utxo.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Utxo.hs
@@ -547,7 +547,7 @@ converge
   keySpace
   tx = do
     delta <- genNextDeltaTilFixPoint scriptinfo initialfee keys scripts utxo pparams keySpace tx
-    genEraDone @era pparams (applyDelta utxo scriptinfo pparams neededKeys neededScripts keySpace tx delta)
+    genEraDone @era utxo pparams (applyDelta utxo scriptinfo pparams neededKeys neededScripts keySpace tx delta)
 
 -- | Return up to /k/ random elements from /items/
 -- (instead of the less efficient /take k <$> QC.shuffle items/)

diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Consensus.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Consensus.hs
@@ -933,8 +933,8 @@ ledgerExamplesShelley =
 exampleCoin :: Coin
 exampleCoin = Coin 10
 
-exampleMetadataMap :: Map Word64 Metadatum
-exampleMetadataMap =
+exampleAuxDataMap :: Map Word64 Metadatum
+exampleAuxDataMap =
   Map.fromList
     [ (1, S "string"),
       (2, B "bytes"),
@@ -943,7 +943,7 @@ exampleMetadataMap =
     ]
 
 exampleShelleyTxAuxData :: Core.TxAuxData (ShelleyEra StandardCrypto)
-exampleShelleyTxAuxData = ShelleyTxAuxData exampleMetadataMap
+exampleShelleyTxAuxData = ShelleyTxAuxData SLE.exampleAuxDataMap
 
 -- ======================
 
@@ -959,7 +959,7 @@ ledgerExamplesAllegra =
 exampleAllegraTxAuxData :: MAClass ma c => AllegraTxAuxData (ShelleyMAEra ma c)
 exampleAllegraTxAuxData =
   AllegraTxAuxData
-    exampleMetadataMap
+    exampleAuxDataMap
     (StrictSeq.fromList [exampleScriptMA])
 
 exampleScriptMA :: MAClass ma c => Core.Script (ShelleyMAEra ma c)