From e3ab11a9aafd25485653559bf39ddc38710740c8 Mon Sep 17 00:00:00 2001 From: Nicholas Clarke Date: Tue, 3 May 2022 17:25:07 +0200 Subject: [PATCH] Only evaluate Plutus scripts in static checks. Initially, Plutus scripts were evaluated using the following: ``` evalScripts @era tx sLst ?!## ValidationTagMismatch (getField @"isValid" tx) ``` However, as of #2386, additional reporting was added to Plutus script failure, and this was changed to the following: ``` case evalScripts @era tx sLst of Fails sss -> False ?!## ValidationTagMismatch (getField @"isValidating" tx) (pack (Prelude.unlines sss)) Passes -> pure () ``` The problem here: `evalScripts` is no longer gated by the `?!##` operator; it must be evaulated at least to WHNF in order to match the `Fails` constructor. This means that when reapplying transactions in the mempool (as well as when replaying blocks), we are always running all Plutus scripts. The current semantics for using "labeled" predicates is insufficient to solve this, since we cannot carry out additional actions (such as emitting events) inside the predicate. As such, we introduce additional functionality in the STS system to allow gating sections of rules (which do not result in a return value) with labels. For the sake of consistency, the existing `labeledPred` function et al are updated to make use of this new feature. The entire call to `evalScripts` is now gated by a `nonStatic` label, and hence will not be evaulated in any `reapply` scenario. --- .../src/Cardano/Ledger/Alonzo/Rules/Utxos.hs | 29 +++++----- .../src/Cardano/Ledger/Babbage/Rules/Utxos.hs | 21 +++---- .../Cardano/Ledger/Rules/ValidationMode.hs | 6 +- .../src/Control/State/Transition/Extended.hs | 55 +++++++++++-------- 4 files changed, 63 insertions(+), 48 deletions(-) diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs index 7b45994cebc..1a7616ca448 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs @@ -5,6 +5,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -24,7 +25,7 @@ module Cardano.Ledger.Alonzo.Rules.Utxos invalidBegin, invalidEnd, UtxosEvent (..), - (?!##), + when2Phase, ConcreteAlonzo, FailureDescription (..), scriptFailuresToPredicateFailure, @@ -81,6 +82,7 @@ import qualified Data.Compact.SplitMap as SplitMap import Data.Foldable (toList) import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map import Data.Sequence.Strict (StrictSeq) import Data.Set (Set) @@ -192,10 +194,10 @@ scriptsValidateTransition = do case collectTwoPhaseScriptInputs ei sysSt pp tx utxo of Right sLst -> - case evalScripts @era (getField @"_protocolVersion" pp) tx sLst of + when2Phase $ case evalScripts @era (getField @"_protocolVersion" pp) tx sLst of Fails _ps fs -> - False - ?!## ValidationTagMismatch + failBecause $ + ValidationTagMismatch (getField @"isValid" tx) (FailedUnexpectedly (scriptFailuresToPredicateFailure fs)) Passes ps -> tellEvent (SuccessfulPlutusScriptsEvent ps) @@ -229,11 +231,14 @@ scriptsNotValidateTransition = do case collectTwoPhaseScriptInputs ei sysSt pp tx utxo of Right sLst -> whenFailureFree $ - case evalScripts @era (getField @"_protocolVersion" pp) tx sLst of - Passes _ps -> False ?!## 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 () @@ -437,10 +442,8 @@ lbl2Phase = "2phase" -- | Construct a 2-phase predicate check. -- -- Note that 2-phase predicate checks are by definition static. -(?!##) :: Bool -> PredicateFailure sts -> Rule sts ctx () -(?!##) = labeledPred [lblStatic, lbl2Phase] - -infix 1 ?!## +when2Phase :: Rule sts ctx () -> Rule sts ctx () +when2Phase = labeled $ lblStatic NE.:| [lbl2Phase] -- ========================================================= -- Inject instances diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxos.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxos.hs index 5cd4176c0d3..ca03acfe140 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxos.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxos.hs @@ -26,7 +26,7 @@ import Cardano.Ledger.Alonzo.Rules.Utxos scriptFailuresToPredicateFailure, validBegin, validEnd, - (?!##), + when2Phase, ) import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo import Cardano.Ledger.Alonzo.Tx (IsValid (..)) @@ -168,13 +168,14 @@ scriptsYes = do Right sLst -> {- isValid tx = evalScripts tx sLst = True -} whenFailureFree $ - case evalScripts @era (getField @"_protocolVersion" pp) tx sLst of - Fails _ fs -> - False - ?!## ValidationTagMismatch - (getField @"isValid" tx) - (FailedUnexpectedly (scriptFailuresToPredicateFailure fs)) - Passes _ -> pure () + when2Phase $ + case evalScripts @era (getField @"_protocolVersion" pp) tx sLst of + Fails _ fs -> + failBecause $ + ValidationTagMismatch + (getField @"isValid" tx) + (FailedUnexpectedly (scriptFailuresToPredicateFailure fs)) + Passes _ -> pure () Left info -> failBecause (CollectErrors info) let !_ = traceEvent validEnd () @@ -203,8 +204,8 @@ scriptsNo = do Right sLst -> {- sLst := collectTwoPhaseScriptInputs pp tx utxo -} {- isValid tx = evalScripts tx sLst = False -} - case evalScripts @era (getField @"_protocolVersion" pp) tx sLst of - Passes _ -> False ?!## ValidationTagMismatch (getField @"isValid" tx) PassedUnexpectedly + 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)) diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Rules/ValidationMode.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Rules/ValidationMode.hs index af258bcff84..560f4590c1e 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Rules/ValidationMode.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Rules/ValidationMode.hs @@ -80,7 +80,7 @@ lblStatic = "static" -- The choice of '#' as a postfix here is made because often these are crypto -- checks. (?!#) :: Bool -> PredicateFailure sts -> Rule sts ctx () -(?!#) = labeledPred [lblStatic] +(?!#) = labeledPred $ lblStatic NE.:| [] infix 1 ?!# @@ -89,7 +89,7 @@ infix 1 ?!# -- The choice of '#' as a postfix here is made because often these are crypto -- checks. (?!#:) :: Either e () -> (e -> PredicateFailure sts) -> Rule sts ctx () -(?!#:) = labeledPredE [lblStatic] +(?!#:) = labeledPredE $ lblStatic NE.:| [] infix 1 ?!#: @@ -130,7 +130,7 @@ runTest :: Inject t (PredicateFailure sts) => Test t -> Rule sts ctx () runTest = validateTrans inject runTestOnSignal :: Inject t (PredicateFailure sts) => Test t -> Rule sts ctx () -runTestOnSignal = validateTransLabeled inject [lblStatic] +runTestOnSignal = validateTransLabeled inject $ lblStatic NE.:| [] runTestMaybe :: InjectMaybe t (PredicateFailure sts) => Test t -> Rule sts ctx () runTestMaybe = validate . mapMaybeValidation injectMaybe diff --git a/libs/small-steps/src/Control/State/Transition/Extended.hs b/libs/small-steps/src/Control/State/Transition/Extended.hs index 05c9b5a3657..aed69010159 100644 --- a/libs/small-steps/src/Control/State/Transition/Extended.hs +++ b/libs/small-steps/src/Control/State/Transition/Extended.hs @@ -45,6 +45,7 @@ module Control.State.Transition.Extended SingEP (..), EventPolicy (..), EventReturnType, + labeled, labeledPred, labeledPredE, ifFailureFree, @@ -314,12 +315,18 @@ data Clause sts (rtype :: RuleType) a where a -> Clause sts rtype a Predicate :: - [Label] -> Validation (NonEmpty e) a -> -- Type of failure to return if the predicate fails (e -> PredicateFailure sts) -> a -> Clause sts rtype a + -- | Label part of a rule. The interpreter may be configured to only run parts + -- of rules governed by (or by the lack of) certain labels. + Label :: + NonEmpty Label -> + Rule sts rtype a -> + a -> + Clause sts rtype a IfFailureFree :: Rule sts rtype a -> Rule sts rtype a -> Clause sts rtype a deriving instance Functor (Clause sts rtype) @@ -341,7 +348,7 @@ validateTrans :: (e -> PredicateFailure sts) -> Validation (NonEmpty e) () -> Rule sts ctx () -validateTrans t v = liftF $ Predicate [] v t () +validateTrans t v = liftF $ Predicate v t () -- | Same as `validation`, except with ability to translate opaque failures -- into `PredicateFailure`s with a help of supplied function. @@ -349,18 +356,20 @@ validateTransLabeled :: -- | Transformation function for all errors (e -> PredicateFailure sts) -> -- | Supply a list of labels to be used as filters when STS is executed - [Label] -> + NonEmpty Label -> -- | Actual validations to be executed Validation (NonEmpty e) () -> Rule sts ctx () -validateTransLabeled t labels v = liftF $ Predicate labels v t () +validateTransLabeled t labels v = liftF $ Label labels (liftF $ Predicate v t ()) () -- | Oh noes! -- -- This takes a condition (a boolean expression) and a failure and results in -- a clause which will throw that failure if the condition fails. (?!) :: Bool -> PredicateFailure sts -> Rule sts ctx () -(?!) = labeledPred [] +(?!) cond onFail = + liftF $ + Predicate (if cond then Success () else Failure (() :| [])) (const onFail) () infix 1 ?! @@ -371,27 +380,27 @@ failBecause = (False ?!) -- -- We interpret this as "What?" "No!" "Because:" (?!:) :: Either e () -> (e -> PredicateFailure sts) -> Rule sts ctx () -(?!:) = labeledPredE [] +(?!:) cond onFail = + liftF $ + Predicate (eitherToValidation $ first pure cond) onFail () -- | Labeled predicate. This may be used to control which predicates are run -- using 'ValidateSuchThat'. -labeledPred :: [Label] -> Bool -> PredicateFailure sts -> Rule sts ctx () -labeledPred lbls cond orElse = - liftF $ - Predicate - lbls - (if cond then Success () else Failure (() :| [])) - (const orElse) - () +labeledPred :: NonEmpty Label -> Bool -> PredicateFailure sts -> Rule sts ctx () +labeledPred lbls cond orElse = labeled lbls (cond ?! orElse) -- | Labeled predicate with an explanation labeledPredE :: - [Label] -> + NonEmpty Label -> Either e () -> (e -> PredicateFailure sts) -> Rule sts ctx () -labeledPredE lbls cond orElse = - liftF $ Predicate lbls (eitherToValidation $ first pure cond) orElse () +labeledPredE lbls cond orElse = labeled lbls (cond ?!: orElse) + +-- | Labeled clause. This will only be executed if the interpreter is set to +-- execute clauses with this label. +labeled :: NonEmpty Label -> Rule sts ctx () -> Rule sts ctx () +labeled lbls subrule = liftF $ Label lbls subrule () trans :: Embed sub super => RuleContext rtype sub -> Rule super rtype (State sub) @@ -582,11 +591,13 @@ applyRuleInternal ep vp goSTS jc r = do if failureFree then foldF runClause yesrule else foldF runClause norule - runClause (Predicate lbls cond orElse val) = - if validateIf lbls - then case cond of - Success x -> pure x - Failure errs -> modify (first (map orElse (reverse (NE.toList errs)) <>)) >> pure val + runClause (Predicate cond orElse val) = + case cond of + Success x -> pure x + Failure errs -> modify (first (map orElse (reverse (NE.toList errs)) <>)) >> pure val + runClause (Label lbls subrule val) = + if validateIf (NE.toList lbls) + then foldF runClause subrule else pure val runClause (SubTrans (subCtx :: RuleContext _rtype sub) next) = do s <- lift $ goSTS subCtx