Merge pull request #4464 from input-output-hk/bezirg/protocol-fixes

Small fixes after SCP-3509: add runtime checks for allowed builtins

plutus-benchmark/validation/BenchDec.hs

@@ -7,6 +7,8 @@ import Data.ByteString as BS
 import Data.ByteString.Lazy as BSL
 import Data.ByteString.Short (toShort)
 import Plutus.V1.Ledger.Api
+import Plutus.V1.Ledger.Scripts
+import UntypedPlutusCore qualified as UPLC
 
 {-|
 for each data/*.flat validation script, it benchmarks
@@ -21,11 +23,24 @@ main :: IO ()
 main = benchWith mkDecBM
   where
     mkDecBM :: FilePath -> BS.ByteString -> Benchmarkable
-    mkDecBM _file bsFlat =
+    mkDecBM file bsFlat =
         let
-            -- just "envelope" the flat strict-bytestring into a cbor's lazy serialised bytestring
-            bslCBOR :: BSL.ByteString = Serialise.serialise bsFlat
+            UPLC.Program _ v (fullyApplied :: Term) = unsafeUnflat file bsFlat
+
+            -- script arguments are not 64-byte size limited, so we make
+            -- sure to remove them from the fully-applied script, and then decode back just the "unsaturated" script
+            -- See Note [Deserialization size limits]
+            (unsaturated, _args) = peelDataArguments fullyApplied
+
+            -- we then have to re-encode it
+            bslCBOR :: BSL.ByteString = Serialise.serialise (Script $ UPLC.Program () v unsaturated)
             -- strictify and "short" the result cbor to create a real `SerializedScript`
+
             benchScript :: SerializedScript = toShort . BSL.toStrict $ bslCBOR
-        in whnf isScriptWellFormed benchScript
+
+            -- Deserialize using 'FakeNamedDeBruijn' to get the fake names added
+        in whnf (\ s ->
+                     isScriptWellFormed (ProtocolVersion 6 0) s
+                     || error "validation script failed to decode"
+                ) benchScript
 

plutus-benchmark/validation/BenchFull.hs

@@ -11,23 +11,11 @@ import Criterion
 import Data.ByteString as BS
 import Data.ByteString.Lazy as BSL
 import Data.ByteString.Short (toShort)
+import Data.Either
 
-import PlutusCore.Builtin qualified as PLC
-import PlutusCore.Data qualified as PLC
+import PlutusCore.Evaluation.Machine.ExBudget
 import UntypedPlutusCore qualified as UPLC
 
-type Term = UPLC.Term UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun ()
-
--- | If the term is an application of something to some arguments, peel off
--- those arguments which are 'Data' constants.
-peelDataArguments :: Term -> (Term, [PLC.Data])
-peelDataArguments = go []
-    where
-        go acc t@(UPLC.Apply () t' arg) = case PLC.readKnown Nothing arg of
-            Left _  -> (t, acc)
-            Right d -> go (d:acc) t'
-        go acc t = (t, acc)
-
 {-|
 for each data/*.flat validation script, it benchmarks
 the whole time taken from script deserialization to script execution result.
@@ -57,12 +45,16 @@ main = benchWith mkFullBM
             -- strictify and "short" the result cbor to create a real `SerializedScript`
             benchScript :: SerializedScript = toShort . BSL.toStrict $ bslCBOR
 
-        in  whnf (\ script -> snd $ evaluateScriptCounting
+        in  whnf (\ script ->
+                      (isRight $ snd $ evaluateScriptRestricting
                         (ProtocolVersion 6 0)
                         -- no logs
                         Quiet
                         evalCtxForTesting
+                        -- uses restricting(enormous) instead of counting to include the periodic budget-overspent check
+                        (unExRestrictingBudget enormousBudget)
                         script
-                        args
+                        args)
+                      || error "script failed to run"
                  )
             benchScript

plutus-benchmark/validation/Common.hs

@@ -1,11 +1,20 @@
 {-# LANGUAGE TypeApplications #-}
-module Common (benchWith, unsafeUnflat, unsafeEvaluateCekNoEmit', throughCheckScope) where
+module Common (
+    benchWith
+    , unsafeUnflat
+    , unsafeEvaluateCekNoEmit'
+    , throughCheckScope
+    , peelDataArguments
+    , Term
+    ) where
 
 import PlutusBenchmark.Common (getConfig, getDataDir)
 import PlutusBenchmark.NaturalSort
 
 import Control.Monad.Except
 import PlutusCore qualified as PLC
+import PlutusCore.Builtin qualified as PLC
+import PlutusCore.Data qualified as PLC
 import PlutusCore.Evaluation.Machine.Exception
 import UntypedPlutusCore qualified as UPLC
 import UntypedPlutusCore.Check.Scope (checkScope)
@@ -133,3 +142,16 @@ unsafeEvaluateCekNoEmit' =
                 PLC.defaultCekParameters
                 UPLC.restrictingEnormous
                 UPLC.noEmitter
+
+type Term = UPLC.Term UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun ()
+
+-- | If the term is an application of something to some arguments, peel off
+-- those arguments which are 'Data' constants.
+peelDataArguments :: Term -> (Term, [PLC.Data])
+peelDataArguments = go []
+    where
+        go acc t@(UPLC.Apply () t' arg) = case PLC.readKnown Nothing arg of
+            Left _  -> (t, acc)
+            Right d -> go (d:acc) t'
+        go acc t = (t, acc)
+

plutus-ledger-api/src/Plutus/V1/Ledger/Api.hs

@@ -115,7 +115,6 @@ module Plutus.V1.Ledger.Api (
 import Codec.CBOR.Decoding qualified as CBOR
 import Codec.CBOR.Extras
 import Codec.CBOR.Read qualified as CBOR
-import Codec.Serialise qualified as CBOR
 import Control.Monad.Except
 import Control.Monad.Writer
 import Data.Bifunctor
@@ -170,17 +169,16 @@ internally. That means we don't lose anything by exposing all the details: we're
 anything, we're just going to create new versions.
 -}
 
--- | Check if a 'Script' is "valid". At the moment this just means "deserialises correctly", which in particular
--- implies that it is (almost certainly) an encoded script and cannot be interpreted as some other kind of encoded data.
-isScriptWellFormed :: SerializedScript -> Bool
-isScriptWellFormed = isRight . CBOR.deserialiseOrFail @Script . fromStrict . fromShort
+-- | Check if a 'Script' is "valid" according to a protocol version. At the moment this means "deserialises correctly", which in particular
+-- implies that it is (almost certainly) an encoded script and the script does not mention any builtins unavailable in the given protocol version.
+isScriptWellFormed :: ProtocolVersion -> SerializedScript -> Bool
+isScriptWellFormed pv = isRight . CBOR.deserialiseFromBytes (scriptCBORDecoder pv) . fromStrict . fromShort
 
 -- | Errors that can be thrown when evaluating a Plutus script.
 data EvaluationError =
     CekError (UPLC.CekEvaluationException PLC.NamedDeBruijn PLC.DefaultUni PLC.DefaultFun) -- ^ An error from the evaluator itself
     | DeBruijnError PLC.FreeVariableError -- ^ An error in the pre-evaluation step of converting from de-Bruijn indices
     | CodecError CBOR.DeserialiseFailure -- ^ A serialisation error
-    | UnavailableBuiltin ProtocolVersion PLC.DefaultFun
     | IncompatibleVersionError (PLC.Version ()) -- ^ An error indicating a version tag that we don't support
     -- TODO: make this error more informative when we have more information about what went wrong
     | CostModelParameterMismatch -- ^ An error indicating that the cost model parameters didn't match what we expected
@@ -190,7 +188,6 @@ instance Pretty EvaluationError where
     pretty (CekError e)      = prettyClassicDef e
     pretty (DeBruijnError e) = pretty e
     pretty (CodecError e) = viaShow e
-    pretty (UnavailableBuiltin pv f) = "The builtin" <+> pretty f <+> "is not available in protocol version" <+> pretty pv
     pretty (IncompatibleVersionError actual) = "This version of the Plutus Core interface does not support the version indicated by the AST:" <+> pretty actual
     pretty CostModelParameterMismatch = "Cost model parameters were not as we expected"