Require PlutusV3 scripts to evaluate to BuiltinUnit (#6159)

doc/read-the-docs-site/howtos/Cip57Blueprint.hs

@@ -33,7 +33,7 @@ import GHC.Generics (Generic)
 import PlutusLedgerApi.V3 (BuiltinData, ScriptContext, UnsafeFromData (..))
 import PlutusTx.Blueprint.TH (makeIsDataSchemaIndexed)
 import PlutusTx.Lift (makeLift)
-import PlutusTx.Prelude (check)
+import PlutusTx.Prelude (BuiltinUnit, check)
 
 -- END imports
 -- BEGIN MyParams annotations
@@ -88,7 +88,7 @@ typedValidator MkMyParams{..} datum redeemer _scriptContext =
     R1 -> myBool
     R2 -> myInteger == datum
 
-untypedValidator :: MyParams -> BuiltinData -> BuiltinData -> BuiltinData -> ()
+untypedValidator :: MyParams -> BuiltinData -> BuiltinData -> BuiltinData -> BuiltinUnit
 untypedValidator params datum redeemer scriptContext =
   check $ typedValidator params datum' redeemer' scriptContext'
  where
@@ -162,4 +162,3 @@ writeBlueprintToFile :: FilePath -> IO ()
 writeBlueprintToFile path = writeBlueprint path myContractBlueprint
 
 -- END write blueprint to file
-

doc/read-the-docs-site/tutorials/AuctionValidator.hs

@@ -192,7 +192,12 @@ auctionTypedValidator params (AuctionDatum highestBid) redeemer ctx@(ScriptConte
           Nothing -> PlutusTx.traceError ("Not found: Output paid to highest bidder")
 -- BLOCK8
 {-# INLINEABLE auctionUntypedValidator #-}
-auctionUntypedValidator :: AuctionParams -> BuiltinData -> BuiltinData -> BuiltinData -> ()
+auctionUntypedValidator ::
+  AuctionParams ->
+  BuiltinData ->
+  BuiltinData ->
+  BuiltinData ->
+  PlutusTx.BuiltinUnit
 auctionUntypedValidator params datum redeemer ctx =
   PlutusTx.check
     ( auctionTypedValidator
@@ -204,7 +209,7 @@ auctionUntypedValidator params datum redeemer ctx =
 
 auctionValidatorScript ::
   AuctionParams ->
-  CompiledCode (BuiltinData -> BuiltinData -> BuiltinData -> ())
+  CompiledCode (BuiltinData -> BuiltinData -> BuiltinData -> PlutusTx.BuiltinUnit)
 auctionValidatorScript params =
   $$(PlutusTx.compile [||auctionUntypedValidator||])
     `PlutusTx.unsafeApplyCode` PlutusTx.liftCode plcVersion100 params

doc/read-the-docs-site/tutorials/BasicPolicies.hs

@@ -42,14 +42,14 @@ currencyValueOf (Value m) c = case Map.lookup c m of
 -- BLOCK2
 -- The 'plutus-ledger' package from 'plutus-apps' provides helper functions to automate
 -- some of this boilerplate.
-oneAtATimePolicyUntyped :: BuiltinData -> BuiltinData -> ()
+oneAtATimePolicyUntyped :: BuiltinData -> BuiltinData -> BuiltinUnit
 -- 'check' fails with 'error' if the argument is not 'True'.
 oneAtATimePolicyUntyped r c =
     check $ oneAtATimePolicy (unsafeFromBuiltinData r) (unsafeFromBuiltinData c)
 
 -- We can use 'compile' to turn a minting policy into a compiled Plutus Core program,
 -- just as for validator scripts.
-oneAtATimeCompiled :: CompiledCode (BuiltinData -> BuiltinData -> ())
+oneAtATimeCompiled :: CompiledCode (BuiltinData -> BuiltinData -> BuiltinUnit)
 oneAtATimeCompiled = $$(compile [|| oneAtATimePolicyUntyped ||])
 -- BLOCK3
 singleSignerPolicy :: () -> ScriptContext -> Bool

doc/read-the-docs-site/tutorials/BasicValidators.hs

@@ -61,16 +61,16 @@ beforeEnd (Date d) (Fixed e) = d <= e
 beforeEnd (Date _) Never     = True
 
 -- | Check that the date in the redeemer is before the limit in the datum.
-validateDate :: BuiltinData -> BuiltinData -> BuiltinData -> ()
+validateDate :: BuiltinData -> BuiltinData -> BuiltinData -> BuiltinUnit
 -- The 'check' function takes a 'Bool' and fails if it is false.
 -- This is handy since it's more natural to talk about booleans.
 validateDate datum redeemer _ =
     check $ beforeEnd (unsafeFromBuiltinData datum) (unsafeFromBuiltinData redeemer)
 
-dateValidator :: CompiledCode (BuiltinData -> BuiltinData -> BuiltinData -> ())
+dateValidator :: CompiledCode (BuiltinData -> BuiltinData -> BuiltinData -> BuiltinUnit)
 dateValidator = $$(compile [|| validateDate ||])
 -- BLOCK4
-validatePayment :: BuiltinData -> BuiltinData -> BuiltinData -> ()
+validatePayment :: BuiltinData -> BuiltinData -> BuiltinData -> BuiltinUnit
 validatePayment _ _ ctx =
     let valCtx = unsafeFromBuiltinData ctx
     -- The 'TxInfo' in the validation context is the representation of the

plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/Scripts/RolePayout.hs

@@ -40,7 +40,8 @@ import PlutusLedgerApi.V2 (CurrencySymbol, ScriptContext (scriptContextTxInfo),
 import PlutusLedgerApi.V2.Contexts (valueSpent)
 import PlutusTx (CompiledCode, unsafeFromBuiltinData)
 import PlutusTx.Plugin ()
-import PlutusTx.Prelude as PlutusTxPrelude (Bool (..), BuiltinData, check, toBuiltin, ($), (.))
+import PlutusTx.Prelude as PlutusTxPrelude (Bool (..), BuiltinData, BuiltinUnit, check, toBuiltin,
+                                            ($), (.))
 
 import Cardano.Crypto.Hash qualified as Hash
 import Data.ByteString qualified as BS
@@ -65,7 +66,7 @@ mkRolePayoutValidator (currency, role) _ ctx =
 
 
 -- | Compute the hash of a script.
-hashScript :: CompiledCode (BuiltinData -> BuiltinData -> BuiltinData -> ()) -> ScriptHash
+hashScript :: CompiledCode (BuiltinData -> BuiltinData -> BuiltinData -> BuiltinUnit) -> ScriptHash
 hashScript =
   -- FIXME: Apparently this is the wrong recipe, since its hash disagrees with `cardano-cli`.
   ScriptHash
@@ -78,11 +79,11 @@ hashScript =
 {-# INLINABLE rolePayoutValidator #-}
 
 -- | The Marlowe payout validator.
-rolePayoutValidator :: CompiledCode (BuiltinData -> BuiltinData -> BuiltinData -> ())
+rolePayoutValidator :: CompiledCode (BuiltinData -> BuiltinData -> BuiltinData -> BuiltinUnit)
 rolePayoutValidator =
   $$(PlutusTx.compile [|| rolePayoutValidator' ||])
     where
-      rolePayoutValidator' :: BuiltinData -> BuiltinData -> BuiltinData -> ()
+      rolePayoutValidator' :: BuiltinData -> BuiltinData -> BuiltinData -> BuiltinUnit
       rolePayoutValidator' d r p =
         check
           $ mkRolePayoutValidator

plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/Scripts/Semantics.hs

@@ -67,11 +67,11 @@ import PlutusTx (CompiledCode, makeIsDataIndexed, makeLift, unsafeFromBuiltinDat
 import PlutusTx.Plugin ()
 import PlutusTx.Prelude as PlutusTxPrelude (AdditiveGroup ((-)), AdditiveMonoid (zero),
                                             AdditiveSemigroup ((+)), Bool (..), BuiltinByteString,
-                                            BuiltinData, BuiltinString, Enum (fromEnum), Eq (..),
-                                            Functor (fmap), Integer, Maybe (..), Ord ((>)),
-                                            Semigroup ((<>)), all, any, check, elem, filter, find,
-                                            foldMap, null, otherwise, snd, toBuiltin, ($), (&&),
-                                            (.), (/=), (||))
+                                            BuiltinData, BuiltinString, BuiltinUnit,
+                                            Enum (fromEnum), Eq (..), Functor (fmap), Integer,
+                                            Maybe (..), Ord ((>)), Semigroup ((<>)), all, any,
+                                            check, elem, filter, find, foldMap, null, otherwise,
+                                            snd, toBuiltin, ($), (&&), (.), (/=), (||))
 
 import Cardano.Crypto.Hash qualified as Hash
 import Data.ByteString qualified as BS
@@ -406,7 +406,7 @@ makeIsDataIndexed ''MarloweTxInput [('Input,0),('MerkleizedTxInput,1)]
 
 
 -- | Compute the hash of a script.
-hashScript :: CompiledCode (BuiltinData -> BuiltinData -> BuiltinData -> ()) -> ScriptHash
+hashScript :: CompiledCode (BuiltinData -> BuiltinData -> BuiltinData -> BuiltinUnit) -> ScriptHash
 hashScript =
   -- FIXME: Apparently this is the wrong recipe, since its hash disagrees with `cardano-cli`.
   ScriptHash
@@ -417,10 +417,10 @@ hashScript =
 
 
 -- | The validator for Marlowe semantics.
-marloweValidator :: CompiledCode (BuiltinData -> BuiltinData -> BuiltinData -> ())
+marloweValidator :: CompiledCode (BuiltinData -> BuiltinData -> BuiltinData -> BuiltinUnit)
 marloweValidator =
   let
-    marloweValidator' :: ScriptHash -> BuiltinData -> BuiltinData -> BuiltinData -> ()
+    marloweValidator' :: ScriptHash -> BuiltinData -> BuiltinData -> BuiltinData -> BuiltinUnit
     marloweValidator' rpvh d r p =
       check
         $ mkMarloweValidator rpvh

plutus-ledger-api/changelog.d/20240530_113312_unsafeFixIO_unit.md

@@ -0,0 +1,6 @@
+### Changed
+
+- `evaluateScriptRestricting` and `evaluateScriptCounting` now require Plutus V3
+  scripts to return `BuiltinUnit`, otherwise the evaluation is considered to
+  have failed, and a `InvalidReturnValue` error is thrown. There is no such
+  requirement on Plutus V1 and V2 scripts.

plutus-ledger-api/plutus-ledger-api.cabal

@@ -185,17 +185,22 @@ test-suite plutus-ledger-api-plugin-test
   ghc-options:    -threaded -rtsopts -with-rtsopts=-N
   other-modules:
     Spec.Budget
+    Spec.ReturnUnit.V1
+    Spec.ReturnUnit.V2
+    Spec.ReturnUnit.V3
     Spec.Value
 
   build-depends:
-    , base                                            >=4.9   && <5
+    , base                                                              >=4.9   && <5
     , containers
-    , plutus-core:{plutus-core, plutus-core-testlib}  ^>=1.28
-    , plutus-ledger-api                               ^>=1.28
-    , plutus-tx-plugin                                ^>=1.28
-    , plutus-tx:{plutus-tx, plutus-tx-testlib}        ^>=1.28
+    , mtl
+    , plutus-core:{plutus-core, plutus-core-testlib}                    ^>=1.28
+    , plutus-ledger-api:{plutus-ledger-api, plutus-ledger-api-testlib}  ^>=1.28
+    , plutus-tx-plugin                                                  ^>=1.28
+    , plutus-tx:{plutus-tx, plutus-tx-testlib}                          ^>=1.28
     , prettyprinter
     , tasty
+    , tasty-hunit
 
 -- This is a nightly test, so it is an executable instead of test-suite to avoid
 -- running this in CI.

plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs

@@ -22,6 +22,7 @@ module PlutusLedgerApi.Common.Eval
     ) where
 
 import PlutusCore
+import PlutusCore.Builtin (readKnown)
 import PlutusCore.Data as Plutus
 import PlutusCore.Default
 import PlutusCore.Evaluation.Machine.CostModelInterface as Plutus
@@ -53,6 +54,7 @@ data EvaluationError =
     | CodecError !ScriptDecodeError -- ^ A deserialisation error
     -- 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
+    | InvalidReturnValue -- ^ The script evaluated to a value that is not a valid return value.
     deriving stock (Show, Eq)
 makeClassyPrisms ''EvaluationError
 
@@ -64,6 +66,10 @@ instance Pretty EvaluationError where
     pretty (DeBruijnError e)          = pretty e
     pretty (CodecError e)             = pretty e
     pretty CostModelParameterMismatch = "Cost model parameters were not as we expected"
+    pretty InvalidReturnValue         =
+        "The evaluation finished but the result value is not valid. "
+        <> "Plutus V3 scripts must return BuiltinUnit. "
+        <> "Returning any other value is considered a failure."
 
 -- | A simple toggle indicating whether or not we should accumulate logs during script execution.
 data VerboseMode =
@@ -226,8 +232,7 @@ evaluateScriptRestricting ll pv verbose ectx budget p args = swap $ runWriter @L
     appliedTerm <- mkTermToEvaluate ll pv p args
     let (res, UPLC.RestrictingSt (ExRestrictingBudget final), logs) =
             evaluateTerm (UPLC.restricting $ ExRestrictingBudget budget) pv verbose ectx appliedTerm
-    tell logs
-    liftEither $ first CekError $ void res
+    processLogsAndErrors ll logs res
     pure (budget `minusExBudget` final)
 
 {-| Evaluates a script, returning the minimum budget that the script would need
@@ -249,10 +254,36 @@ evaluateScriptCounting ll pv verbose ectx p args = swap $ runWriter @LogOutput $
     appliedTerm <- mkTermToEvaluate ll pv p args
     let (res, UPLC.CountingSt final, logs) =
             evaluateTerm UPLC.counting pv verbose ectx appliedTerm
-    tell logs
-    liftEither $ first CekError $ void res
+    processLogsAndErrors ll logs res
     pure final
 
+processLogsAndErrors ::
+    forall m.
+    (MonadError EvaluationError m, MonadWriter LogOutput m) =>
+    PlutusLedgerLanguage ->
+    LogOutput ->
+    Either
+        (UPLC.CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
+        (UPLC.Term UPLC.NamedDeBruijn DefaultUni DefaultFun ()) ->
+    m ()
+processLogsAndErrors ll logs res = do
+    tell logs
+    case res of
+        Left e  -> throwError (CekError e)
+        Right v -> unless (isResultValid ll v) (throwError InvalidReturnValue)
+{-# INLINE processLogsAndErrors #-}
+
+isResultValid ::
+    PlutusLedgerLanguage ->
+    UPLC.Term UPLC.NamedDeBruijn DefaultUni DefaultFun () ->
+    Bool
+isResultValid ll res = ll == PlutusV1 || ll == PlutusV2 || isBuiltinUnit res
+    where
+        isBuiltinUnit t = case readKnown t of
+            Right () -> True
+            _        -> False
+{-# INLINE isResultValid #-}
+
 {- Note [Checking the Plutus Core language version]
 Since long ago this check has been in `mkTermToEvaluate`, which makes it a phase 2 failure.
 But this is really far too strict: we can check when deserializing, so it can be a phase 1

plutus-ledger-api/test-plugin/Spec.hs

@@ -1,6 +1,9 @@
 module Main where
 
 import Spec.Budget qualified
+import Spec.ReturnUnit.V1 qualified
+import Spec.ReturnUnit.V2 qualified
+import Spec.ReturnUnit.V3 qualified
 import Spec.Value qualified
 
 import Test.Tasty
@@ -12,4 +15,7 @@ tests :: TestTree
 tests = testGroup "plutus-ledger-api-plugin-test"
     [ Spec.Budget.tests
     , Spec.Value.test_EqValue
+    , Spec.ReturnUnit.V1.tests
+    , Spec.ReturnUnit.V2.tests
+    , Spec.ReturnUnit.V3.tests
     ]

plutus-ledger-api/test-plugin/Spec/ReturnUnit/V1.hs

@@ -0,0 +1,87 @@
+{-# LANGUAGE BangPatterns          #-}
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE GADTs                 #-}
+{-# LANGUAGE LambdaCase            #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NegativeLiterals      #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE PatternSynonyms       #-}
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE ViewPatterns          #-}
+{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:target-version=1.0.0 #-}
+
+module Spec.ReturnUnit.V1 where
+
+import PlutusLedgerApi.Common.Versions
+import PlutusLedgerApi.Test.V1.EvaluationContext qualified as V1
+import PlutusLedgerApi.V1 as V1
+import PlutusPrelude
+import PlutusTx.Builtins qualified as PlutusTx
+import PlutusTx.Code
+import PlutusTx.IsData qualified as PlutusTx
+import PlutusTx.Prelude (BuiltinUnit, check)
+import PlutusTx.TH (compile)
+
+import Test.Tasty (TestName, TestTree, testGroup)
+import Test.Tasty.HUnit
+
+import Control.Monad.Writer
+
+tests :: TestTree
+tests =
+  testGroup
+    "Plutus V1 validators may evaluate to any value"
+    [ expectSuccess "should succeed" good (I 1)
+    , expectSuccess "returns Bool" returnsBool (I 1)
+    , expectSuccess "too many parameters" tooManyParameters (I 1)
+    ]
+
+evalCtx :: V1.EvaluationContext
+evalCtx =
+  fst . unsafeFromRight . runWriterT . V1.mkEvaluationContext $
+    fmap snd V1.costModelParamsForTesting
+
+expectSuccess ::
+  forall a.
+  TestName ->
+  CompiledCode (BuiltinData -> a) ->
+  -- | Script argument
+  Data ->
+  TestTree
+expectSuccess name code arg = testCase name $ case res of
+  Left _  -> assertFailure "fails"
+  Right _ -> pure ()
+  where
+    sScript = serialiseCompiledCode code
+    script = either (error . show) id $ V1.deserialiseScript conwayPV sScript
+    (_, res) = V1.evaluateScriptCounting conwayPV V1.Quiet evalCtx script [arg]
+
+good :: CompiledCode (BuiltinData -> BuiltinUnit)
+good =
+  $$( compile
+        [||
+        \d ->
+          let n = PlutusTx.unsafeFromBuiltinData d
+           in check (PlutusTx.greaterThanInteger n 0)
+        ||]
+    )
+
+returnsBool :: CompiledCode (BuiltinData -> Bool)
+returnsBool =
+  $$( compile
+        [||
+        \d ->
+          let n = PlutusTx.unsafeFromBuiltinData d
+           in PlutusTx.greaterThanInteger n 0
+        ||]
+    )
+
+tooManyParameters :: CompiledCode (BuiltinData -> BuiltinData -> BuiltinUnit)
+tooManyParameters =
+  $$( compile
+        [||
+        \d _ ->
+          let n = PlutusTx.unsafeFromBuiltinData d
+           in check (PlutusTx.greaterThanInteger n 0)
+        ||]
+    )