Ensure Plutus scripts are not executed when other failures already exist

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

@@ -217,15 +217,14 @@ scriptsNotValidateTransition = do
 
   case collectTwoPhaseScriptInputs (unsafeLinearExtendEpochInfo slot ei) sysSt pp tx utxo of
     Right sLst ->
-      whenFailureFree $
-        when2Phase $
-          case evalScripts @era (getField @"_protocolVersion" pp) tx sLst of
-            Passes _ps ->
-              failBecause $
-                ValidationTagMismatch (getField @"isValid" tx) PassedUnexpectedly
-            Fails ps fs -> do
-              tellEvent (SuccessfulPlutusScriptsEvent ps)
-              tellEvent (FailedPlutusScriptsEvent (scriptFailuresToPlutusDebug fs))
+      when2Phase $
+        case evalScripts @era (getField @"_protocolVersion" pp) tx sLst of
+          Passes _ps ->
+            failBecause $
+              ValidationTagMismatch (getField @"isValid" tx) PassedUnexpectedly
+          Fails ps fs -> do
+            tellEvent (SuccessfulPlutusScriptsEvent ps)
+            tellEvent (FailedPlutusScriptsEvent (scriptFailuresToPlutusDebug fs))
     Left info -> failBecause (CollectErrors info)
 
   let !_ = traceEvent invalidEnd ()

eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxos.hs

@@ -204,11 +204,12 @@ scriptsNo = do
     Right sLst ->
       {- sLst := collectTwoPhaseScriptInputs pp tx utxo -}
       {- isValid tx = evalScripts tx sLst = False -}
-      when2Phase $ case evalScripts @era (getField @"_protocolVersion" pp) tx sLst of
-        Passes _ -> failBecause $ ValidationTagMismatch (getField @"isValid" tx) PassedUnexpectedly
-        Fails ps fs -> do
-          tellEvent (SuccessfulPlutusScriptsEvent ps)
-          tellEvent (FailedPlutusScriptsEvent (scriptFailuresToPlutusDebug fs))
+      whenFailureFree $
+        when2Phase $ case evalScripts @era (getField @"_protocolVersion" pp) tx sLst of
+          Passes _ -> failBecause $ ValidationTagMismatch (getField @"isValid" tx) PassedUnexpectedly
+          Fails ps fs -> do
+            tellEvent (SuccessfulPlutusScriptsEvent ps)
+            tellEvent (FailedPlutusScriptsEvent (scriptFailuresToPlutusDebug fs))
     Left info -> failBecause (CollectErrors info)
 
   () <- pure $! traceEvent invalidEnd ()

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

@@ -68,7 +68,6 @@ import Test.Cardano.Ledger.Examples.TwoPhaseValidation
     freeCostModelV2,
     keyBy,
     testUTXOW,
-    testUTXOWsubset,
     trustMeP,
   )
 import Test.Cardano.Ledger.Generic.Fields
@@ -1074,17 +1073,23 @@ genericBabbageFeatures pf =
             testU
               pf
               (trustMeP pf True $ malformedScriptRefTx pf)
-              (Left [fromUtxowB @era (MalformedReferenceScripts (Set.fromList [hashScript @era $ malformedScript pf "rs"]))]),
+              ( Left
+                  [ fromUtxowB @era $
+                      MalformedReferenceScripts $
+                        Set.singleton
+                          (hashScript @era $ malformedScript pf "rs")
+                  ]
+              ),
           testCase "malformed script witness" $
-            -- TODO replace testUTXOWsubset with testU and figure out why a script which is failing phase 1 validation
-            -- is still being run, ie why are we getting this error as well:
-            -- FromAlonzoUtxoFail (UtxosFailure (ValidationTagMismatch (IsValid True) (FailedUnexpectedly (PlutusFailure ...
-            testUTXOWsubset
-              (UTXOW pf)
-              (initUTxO pf)
-              (pp pf)
+            testU
+              pf
               (trustMeP pf True $ malformedScriptWitTx pf)
-              (Left [fromUtxowB @era (MalformedScriptWitnesses (Set.fromList [hashScript @era $ malformedScript pf "malfoy"]))]),
+              ( Left
+                  [ fromUtxowB @era $
+                      MalformedScriptWitnesses $
+                        Set.singleton (hashScript @era $ malformedScript pf "malfoy")
+                  ]
+              ),
           testCase "inline datum and ref script and redundant script witness" $
             testU
               pf

libs/small-steps/src/Control/State/Transition/Extended.hs

@@ -84,11 +84,11 @@ where
 
 import Control.Exception (Exception (..), throw)
 import Control.Monad (when)
-import Control.Monad.Free.Church
+import Control.Monad.Free.Church (F, MonadFree (wrap), foldF, liftF)
 import Control.Monad.Identity (Identity (..))
 import Control.Monad.State.Class (MonadState (..), modify)
-import Control.Monad.Trans.Class (MonadTrans, lift)
-import Control.Monad.Trans.Except
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
 import Control.Monad.Trans.State.Strict (StateT (..))
 import Data.Bifunctor (Bifunctor (second), first)
 import Data.Coerce (Coercible, coerce)
@@ -102,7 +102,15 @@ import qualified Data.List.NonEmpty as NE
 import Data.Typeable (typeRep)
 import Data.Void (Void)
 import NoThunks.Class (NoThunks (..))
-import Validation
+import Validation (Validation (..), eitherToValidation)
+
+-- | In order to avoid boolean blindness we create specialized type for the
+-- concept of any rule having information about overall state of the nested
+-- clause.
+data IsFailing
+  = Failing
+  | NotFailing
+  deriving (Eq, Show)
 
 data RuleType
   = Initial
@@ -475,14 +483,14 @@ applySTSOpts ::
   RuleContext rtype s ->
   m (EventReturnType ep s (State s, [PredicateFailure s]))
 applySTSOpts ApplySTSOpts {asoAssertions, asoValidation, asoEvents} ctx =
-  let goRule :: RuleInterpreter ep
-      goRule = applyRuleInternal asoEvents asoValidation goSTS
-      goSTS :: STSInterpreter ep
-      goSTS c =
-        runExceptT (applySTSInternal asoEvents asoAssertions goRule c) >>= \case
+  let goRule :: IsFailing -> RuleInterpreter ep
+      goRule isFailing = applyRuleInternal isFailing asoEvents asoValidation goSTS
+      goSTS :: IsFailing -> STSInterpreter ep
+      goSTS isFailing c =
+        runExceptT (applySTSInternal asoEvents asoAssertions (goRule isFailing) c) >>= \case
           Left err -> throw $! AssertionException err
           Right res -> pure $! res
-   in goSTS ctx
+   in goSTS NotFailing ctx
 
 applySTSOptsEither ::
   forall s m rtype ep.
@@ -563,34 +571,38 @@ applySTSIndifferently =
 applyRuleInternal ::
   forall (ep :: EventPolicy) s m rtype.
   (STS s, RuleTypeRep rtype, m ~ BaseM s) =>
+  -- | We need to know if the current STS incurred at least one
+  -- PredicateFailure.  This is necessary because `applyRuleInternal` is called
+  -- recursively through the @goSTS@ argument, which will not have access to any
+  -- of the predicate failures occured in other branches of STS rule execusion tree.
+  IsFailing ->
   SingEP ep ->
   ValidationPolicy ->
   -- | Interpreter for subsystems
-  STSInterpreter ep ->
+  (IsFailing -> STSInterpreter ep) ->
   RuleContext rtype s ->
   Rule s rtype (State s) ->
   m (EventReturnType ep s (State s, [PredicateFailure s]))
-applyRuleInternal ep vp goSTS jc r = do
+applyRuleInternal isAlreadyFailing ep vp goSTS jc r = do
   (s, er) <- flip runStateT ([], []) $ foldF runClause r
   case ep of
     EPDiscard -> pure (s, fst er)
     EPReturn -> pure ((s, fst er), snd er)
   where
-    runClause ::
-      forall f t a.
-      ( f ~ t m,
-        MonadState ([PredicateFailure s], [Event s]) f,
-        MonadTrans t
-      ) =>
-      Clause s rtype a ->
-      t m a
+    isFailing :: StateT ([PredicateFailure s], [Event s]) m IsFailing
+    isFailing =
+      case isAlreadyFailing of
+        Failing -> pure Failing
+        NotFailing -> do
+          isFailingNow <- null . fst <$> get
+          pure $ if isFailingNow then NotFailing else Failing
+    runClause :: Clause s rtype a -> StateT ([PredicateFailure s], [Event s]) m a
     runClause (Lift f next) = next <$> lift f
     runClause (GetCtx next) = pure $ next jc
-    runClause (IfFailureFree yesrule norule) = do
-      failureFree <- null . fst <$> get
-      if failureFree
-        then foldF runClause yesrule
-        else foldF runClause norule
+    runClause (IfFailureFree notFailingRule failingRule) = do
+      isFailing >>= \case
+        Failing -> foldF runClause failingRule
+        NotFailing -> foldF runClause notFailingRule
     runClause (Predicate cond orElse val) =
       case vp of
         ValidateNone -> pure val
@@ -602,7 +614,8 @@ applyRuleInternal ep vp goSTS jc r = do
         then foldF runClause subrule
         else pure val
     runClause (SubTrans (subCtx :: RuleContext _rtype sub) next) = do
-      s <- lift $ goSTS subCtx
+      isFailingNow <- isFailing
+      s <- lift $ goSTS isFailingNow subCtx
       let ss :: State sub
           sfails :: [PredicateFailure sub]
           sevs :: [Event sub]