diff --git a/doc/read-the-docs-site/howtos/Cip57Blueprint.hs b/doc/read-the-docs-site/howtos/Cip57Blueprint.hs index 4093df6bfba..ebf255e5b2a 100644 --- a/doc/read-the-docs-site/howtos/Cip57Blueprint.hs +++ b/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 - diff --git a/doc/read-the-docs-site/tutorials/AuctionValidator.hs b/doc/read-the-docs-site/tutorials/AuctionValidator.hs index 31bd69e57c0..64b002a3f6d 100644 --- a/doc/read-the-docs-site/tutorials/AuctionValidator.hs +++ b/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 diff --git a/doc/read-the-docs-site/tutorials/BasicPolicies.hs b/doc/read-the-docs-site/tutorials/BasicPolicies.hs index 4bf2565a008..abac078a5c0 100644 --- a/doc/read-the-docs-site/tutorials/BasicPolicies.hs +++ b/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 diff --git a/doc/read-the-docs-site/tutorials/BasicValidators.hs b/doc/read-the-docs-site/tutorials/BasicValidators.hs index 5dde554e8c2..24add791f32 100644 --- a/doc/read-the-docs-site/tutorials/BasicValidators.hs +++ b/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 diff --git a/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/Scripts/RolePayout.hs b/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/Scripts/RolePayout.hs index fd07357efdf..c8658550273 100644 --- a/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/Scripts/RolePayout.hs +++ b/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 diff --git a/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/Scripts/Semantics.hs b/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/Scripts/Semantics.hs index fcf33a09fc6..267a02be430 100644 --- a/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/Scripts/Semantics.hs +++ b/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 diff --git a/plutus-ledger-api/changelog.d/20240530_113312_unsafeFixIO_unit.md b/plutus-ledger-api/changelog.d/20240530_113312_unsafeFixIO_unit.md new file mode 100644 index 00000000000..8b7a314495e --- /dev/null +++ b/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. diff --git a/plutus-ledger-api/plutus-ledger-api.cabal b/plutus-ledger-api/plutus-ledger-api.cabal index 79896e53347..666d1544925 100644 --- a/plutus-ledger-api/plutus-ledger-api.cabal +++ b/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. diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs b/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs index 2e26fd54bd2..ff2c7fe9d49 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs +++ b/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 diff --git a/plutus-ledger-api/test-plugin/Spec.hs b/plutus-ledger-api/test-plugin/Spec.hs index 7ab2b296a3a..d38230a8c9d 100644 --- a/plutus-ledger-api/test-plugin/Spec.hs +++ b/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 ] diff --git a/plutus-ledger-api/test-plugin/Spec/ReturnUnit/V1.hs b/plutus-ledger-api/test-plugin/Spec/ReturnUnit/V1.hs new file mode 100644 index 00000000000..619727868b8 --- /dev/null +++ b/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) + ||] + ) diff --git a/plutus-ledger-api/test-plugin/Spec/ReturnUnit/V2.hs b/plutus-ledger-api/test-plugin/Spec/ReturnUnit/V2.hs new file mode 100644 index 00000000000..a86aaa5a9f5 --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/ReturnUnit/V2.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.V2 where + +import PlutusLedgerApi.Common.Versions +import PlutusLedgerApi.Test.V2.EvaluationContext qualified as V2 +import PlutusLedgerApi.V2 as V2 +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 V2 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 :: V2.EvaluationContext +evalCtx = + fst . unsafeFromRight . runWriterT . V2.mkEvaluationContext $ + fmap snd V2.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 $ V2.deserialiseScript conwayPV sScript + (_, res) = V2.evaluateScriptCounting conwayPV V2.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) + ||] + ) diff --git a/plutus-ledger-api/test-plugin/Spec/ReturnUnit/V3.hs b/plutus-ledger-api/test-plugin/Spec/ReturnUnit/V3.hs new file mode 100644 index 00000000000..6572db090ef --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/ReturnUnit/V3.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} + +module Spec.ReturnUnit.V3 where + +import PlutusLedgerApi.Common.Versions +import PlutusLedgerApi.Test.V3.EvaluationContext qualified as V3 +import PlutusLedgerApi.V3 as V3 +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 V3 validators must evaluate to BuiltinUnit" + [ expectSuccess "should succeed" good (I 1) + , expectFailure "returns Bool" returnsBool (I 1) + , expectFailure "too many parameters" tooManyParameters (I 1) + ] + +evalCtx :: V3.EvaluationContext +evalCtx = + fst . unsafeFromRight . runWriterT . V3.mkEvaluationContext $ + fmap snd V3.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 $ V3.deserialiseScript conwayPV sScript + (_, res) = V3.evaluateScriptCounting conwayPV V3.Quiet evalCtx script arg + +expectFailure :: + forall a. + TestName -> + CompiledCode (BuiltinData -> a) -> + -- | Script argument + Data -> + TestTree +expectFailure name code arg = testCase name $ case res of + Left InvalidReturnValue -> pure () + Left _ -> assertFailure "evaluation failed for a different reason" + Right _ -> assertFailure "evaluation succeeded" + where + sScript = serialiseCompiledCode code + script = either (error . show) id $ V3.deserialiseScript conwayPV sScript + (_, res) = V3.evaluateScriptCounting conwayPV V3.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) + ||] + ) diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Examples.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Examples.hs index 142784da00e..de12bcba2b7 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Examples.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Examples.hs @@ -53,12 +53,17 @@ saltFunction salt b0 = serialiseUPLC $ UPLC.Program () version body integerToByteStringFunction :: SerialisedScript integerToByteStringFunction = serialiseUPLC $ UPLC.Program () PLC.plcVersion110 body - where - body = - UPLC.LamAbs () (UPLC.DeBruijn 0) $ - PLC.mkIterAppNoAnn - (UPLC.Builtin () PLC.IntegerToByteString) - [ PLC.mkConstant @Bool () False - , PLC.mkConstant @Integer () 5 - , PLC.mkConstant @Integer () 1 - ] + where + body = + -- This is run as a Plutus V3 script, so it must return BuiltinUnit + UPLC.LamAbs () (UPLC.DeBruijn 0) $ + UPLC.Apply + () + (UPLC.LamAbs () (UPLC.DeBruijn 0) (PLC.mkConstant () ())) + ( PLC.mkIterAppNoAnn + (UPLC.Builtin () PLC.IntegerToByteString) + [ PLC.mkConstant @Bool () False + , PLC.mkConstant @Integer () 5 + , PLC.mkConstant @Integer () 1 + ] + ) diff --git a/plutus-tx/src/PlutusTx/Prelude.hs b/plutus-tx/src/PlutusTx/Prelude.hs index c31ac38ce51..2c430615079 100644 --- a/plutus-tx/src/PlutusTx/Prelude.hs +++ b/plutus-tx/src/PlutusTx/Prelude.hs @@ -28,6 +28,8 @@ module PlutusTx.Prelude ( module Base, -- * Tracing functions module Trace, + -- * Unit + BI.BuiltinUnit, -- * String BuiltinString, appendString, @@ -140,6 +142,7 @@ import PlutusTx.Builtins (BuiltinBLS12_381_G1_Element, BuiltinBLS12_381_G2_Eleme verifySchnorrSecp256k1Signature) import PlutusTx.Builtins qualified as Builtins +import PlutusTx.Builtins.Internal qualified as BI import PlutusTx.Either as Either import PlutusTx.Enum as Enum import PlutusTx.Eq as Eq @@ -178,8 +181,8 @@ import Prelude qualified as Haskell (return, (=<<), (>>), (>>=)) {-# INLINABLE check #-} -- | Checks a 'Bool' and aborts if it is false. -check :: Bool -> () -check b = if b then () else traceError checkHasFailedError +check :: Bool -> BI.BuiltinUnit +check b = if b then BI.unitval else traceError checkHasFailedError {-# INLINABLE divide #-} -- | Integer division, rounding downwards