Added reporting of the cause of Plutus script failures.

alonzo/impl/src/Cardano/Ledger/Alonzo/PlutusScriptApi.hs

@@ -38,7 +38,7 @@ import Cardano.Ledger.Alonzo.Tx
     txdats',
   )
 import qualified Cardano.Ledger.Alonzo.TxBody as Alonzo (TxBody (..), TxOut (..), vldt')
-import Cardano.Ledger.Alonzo.TxInfo (runPLCScript, txInfo, valContext)
+import Cardano.Ledger.Alonzo.TxInfo (ScriptResult (..), andResult, runPLCScript, txInfo, valContext)
 import Cardano.Ledger.Alonzo.TxWitness (TxWitness (txwitsVKey'), txscripts', unTxDats)
 import Cardano.Ledger.BaseTypes (StrictMaybe (..))
 import qualified Cardano.Ledger.Core as Core
@@ -219,14 +219,16 @@ evalScripts ::
   ) =>
   tx ->
   [(AlonzoScript.Script era, [Data era], ExUnits, CostModel)] ->
-  Bool
-evalScripts _tx [] = True
+  ScriptResult
+evalScripts _tx [] = Passes
 evalScripts tx ((AlonzoScript.TimelockScript timelock, _, _, _) : rest) =
-  evalTimelock vhks (Alonzo.vldt' (getField @"body" tx)) timelock && evalScripts tx rest
+  (lift $ evalTimelock vhks (Alonzo.vldt' (getField @"body" tx)) timelock) `andResult` evalScripts tx rest
   where
     vhks = Set.map witKeyHash (txwitsVKey' (getField @"wits" tx))
+    lift True = Passes
+    lift False = Fails ["Timelock: " ++ show timelock ++ " fails."]
 evalScripts tx ((AlonzoScript.PlutusScript pscript, ds, units, cost) : rest) =
-  runPLCScript cost pscript units (map getPlutusData ds) && evalScripts tx rest
+  runPLCScript cost pscript units (map getPlutusData ds) `andResult` evalScripts tx rest
 
 -- ===================================================================
 -- From Specification, Figure 12 "UTXOW helper functions"

alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs

@@ -34,6 +34,7 @@ import Cardano.Ledger.Alonzo.Tx
     txouts,
   )
 import qualified Cardano.Ledger.Alonzo.TxBody as Alonzo
+import Cardano.Ledger.Alonzo.TxInfo (ScriptResult (..))
 import qualified Cardano.Ledger.Alonzo.TxWitness as Alonzo
 import Cardano.Ledger.BaseTypes
   ( Globals,
@@ -58,6 +59,7 @@ import Data.Foldable (toList)
 import qualified Data.Map.Strict as Map
 import Data.Sequence.Strict (StrictSeq)
 import Data.Set (Set)
+import Data.Text
 import GHC.Generics (Generic)
 import GHC.Records (HasField (..))
 import NoThunks.Class (NoThunks)
@@ -177,8 +179,9 @@ scriptsValidateTransition = do
   ei <- liftSTS $ asks epochInfo
   case collectTwoPhaseScriptInputs ei sysSt pp tx utxo of
     Right sLst ->
-      evalScripts @era tx sLst
-        ?!## ValidationTagMismatch (getField @"isValidating" tx)
+      case evalScripts @era tx sLst of
+        Fails sss -> False ?!## ValidationTagMismatch (getField @"isValidating" tx) (pack (Prelude.unlines sss))
+        Passes -> pure ()
     Left info -> failBecause (CollectErrors info)
   pup' <-
     trans @(Core.EraRule "PPUP" era) $
@@ -220,8 +223,9 @@ scriptsNotValidateTransition = do
   ei <- liftSTS $ asks epochInfo
   case collectTwoPhaseScriptInputs ei sysSt pp tx utxo of
     Right sLst ->
-      not (evalScripts @era tx sLst)
-        ?!## ValidationTagMismatch (getField @"isValidating" tx)
+      case (evalScripts @era tx sLst) of
+        Passes -> False ?!## ValidationTagMismatch (getField @"isValidating" tx) (pack ("Script expected to fail, passes."))
+        Fails _sss -> pure ()
     Left info -> failBecause (CollectErrors info)
   pure $
     us
@@ -232,8 +236,8 @@ scriptsNotValidateTransition = do
 data UtxosPredicateFailure era
   = -- | The 'isValidating' tag on the transaction is incorrect. The tag given
     --   here is that provided on the transaction (whereas evaluation of the
-    --   scripts gives the opposite.)
-    ValidationTagMismatch IsValidating
+    --   scripts gives the opposite.). The Text tries to explain why it failed.
+    ValidationTagMismatch IsValidating Text
   | -- | We could not find all the necessary inputs for a Plutus Script.
     --         Previous PredicateFailure tests should make this impossible, but the
     --         consequences of not detecting this means scripts get dropped, so things
@@ -250,7 +254,7 @@ instance
   ) =>
   ToCBOR (UtxosPredicateFailure era)
   where
-  toCBOR (ValidationTagMismatch v) = encode (Sum ValidationTagMismatch 0 !> To v)
+  toCBOR (ValidationTagMismatch v txt) = encode (Sum ValidationTagMismatch 0 !> To v !> To txt)
   toCBOR (CollectErrors cs) =
     encode (Sum (CollectErrors @era) 1 !> To cs)
   toCBOR (UpdateFailure pf) = encode (Sum (UpdateFailure @era) 2 !> To pf)
@@ -263,7 +267,7 @@ instance
   where
   fromCBOR = decode (Summands "UtxosPredicateFailure" dec)
     where
-      dec 0 = SumD ValidationTagMismatch <! From
+      dec 0 = SumD ValidationTagMismatch <! From <! From
       dec 1 = SumD (CollectErrors @era) <! From
       dec 2 = SumD UpdateFailure <! From
       dec n = Invalid n
@@ -274,11 +278,16 @@ deriving stock instance
   ) =>
   Show (UtxosPredicateFailure era)
 
-deriving stock instance
+instance
   ( Shelley.TransUTxOState Eq era,
     Eq (PredicateFailure (Core.EraRule "PPUP" era))
   ) =>
   Eq (UtxosPredicateFailure era)
+  where
+  (ValidationTagMismatch a _) == (ValidationTagMismatch b _) = a == b -- Do not compare the Text in an Eq check.
+  (CollectErrors x) == (CollectErrors y) = x == y
+  (UpdateFailure x) == (UpdateFailure y) = x == y
+  _ == _ = False
 
 instance
   ( Shelley.TransUTxOState NoThunks era,
@@ -332,13 +341,15 @@ constructValidated globals (UtxoEnv _ pp _ _) st tx =
             ValidatedTx
               (getField @"body" tx)
               (getField @"wits" tx)
-              (IsValidating scriptEvalResult)
+              (IsValidating (lift scriptEvalResult))
               (getField @"auxiliaryData" tx)
        in pure vTx
   where
     utxo = _utxo st
     sysS = systemStart globals
     ei = epochInfo globals
+    lift Passes = True
+    lift (Fails _) = False
 
 --------------------------------------------------------------------------------
 -- 2-phase checks

alonzo/impl/src/Cardano/Ledger/Alonzo/TxInfo.hs

@@ -345,21 +345,30 @@ valContext ::
   Data era
 valContext txinfo sp = Data (P.toData (P.ScriptContext txinfo (transScriptPurpose sp)))
 
+data ScriptResult = Passes | Fails ![String]
+
+andResult :: ScriptResult -> ScriptResult -> ScriptResult
+andResult Passes Passes = Passes
+andResult Passes ans = ans
+andResult ans Passes = ans
+andResult (Fails xs) (Fails ys) = Fails (xs ++ ys)
+
 -- The runPLCScript in the Specification has a slightly different type
 -- than the one in the implementation below. Made necessary by the the type
--- of P.evaluateScriptRestricting which is the interface to Plutus
+-- of P.evaluateScriptRestricting which is the interface to Plutus, and in the impementation
+-- we try to track why a script failed (if it does).
 
 -- | Run a Plutus Script, given the script and the bounds on resources it is allocated.
-runPLCScript :: CostModel -> SBS.ShortByteString -> ExUnits -> [P.Data] -> Bool
+runPLCScript :: CostModel -> SBS.ShortByteString -> ExUnits -> [P.Data] -> ScriptResult
 runPLCScript (CostModel cost) scriptbytestring units ds =
   case P.evaluateScriptRestricting
     P.Quiet
     cost
     (transExUnits units)
     scriptbytestring
     ds of
-    (_, Left _e) -> False -- trace ("\nrunPLC fails "++show _e++"\nData = "++show ds) False
-    (_, Right ()) -> True
+    (_, Left _e) -> Fails ["\nrunPLC fails " ++ show _e ++ "\nData = " ++ show ds]
+    (_, Right ()) -> Passes
 
 validPlutusdata :: P.Data -> Bool
 validPlutusdata (P.Constr _n ds) = all validPlutusdata ds

alonzo/test/lib/Test/Cardano/Ledger/Alonzo/Serialisation/Generators.hs

@@ -43,6 +43,7 @@ import Cardano.Ledger.Shelley.Constraints (UsesScript, UsesValue)
 import Data.Map (Map)
 import qualified Data.Map as Map
 import qualified Data.Set as Set
+import Data.Text (pack)
 import qualified Data.Text as T (pack)
 import Numeric.Natural (Natural)
 import qualified PlutusTx as Plutus
@@ -262,7 +263,7 @@ instance Arbitrary (PParamsUpdate era) where
 instance Mock c => Arbitrary (UtxosPredicateFailure (AlonzoEra c)) where
   arbitrary =
     oneof
-      [ ValidationTagMismatch <$> arbitrary,
+      [ ValidationTagMismatch <$> arbitrary <*> (pack <$> arbitrary),
         UpdateFailure <$> arbitrary
       ]
 

cardano-ledger-test/src/Test/Cardano/Ledger/Examples/TwoPhaseValidation.hs

@@ -1606,18 +1606,20 @@ alonzoUTXOWexamples =
             testUTXOW
               (trustMe False $ validatingTx pf)
               ( Left
-                  [ WrappedShelleyEraFailure
-                      ( UtxoFailure
-                          (UtxosFailure (ValidationTagMismatch (IsValidating False)))
-                      )
+                  [ [ WrappedShelleyEraFailure
+                        ( UtxoFailure
+                            (UtxosFailure (ValidationTagMismatch (IsValidating False) ("Script expected to fail, passes.")))
+                        )
+                    ]
                   ]
               ),
           testCase "invalid transaction marked as valid" $
             testUTXOW
               (trustMe True $ notValidatingTx pf)
               ( Left
-                  [ WrappedShelleyEraFailure
-                      (UtxoFailure (UtxosFailure (ValidationTagMismatch (IsValidating True))))
+                  [ [ WrappedShelleyEraFailure
+                        (UtxoFailure (UtxosFailure (ValidationTagMismatch (IsValidating True) (""))))
+                    ]
                   ]
               ),
           testCase "too many execution units for tx" $