diff --git a/cardano-simple/src/Cardano/Simple/PlutusLedgerApi/V1/Scripts.hs b/cardano-simple/src/Cardano/Simple/PlutusLedgerApi/V1/Scripts.hs index c0c8eb3..5894a83 100644 --- a/cardano-simple/src/Cardano/Simple/PlutusLedgerApi/V1/Scripts.hs +++ b/cardano-simple/src/Cardano/Simple/PlutusLedgerApi/V1/Scripts.hs @@ -6,6 +6,8 @@ module Cardano.Simple.PlutusLedgerApi.V1.Scripts ( mkValidatorScriptPlutarch, mkMintingPolicyScriptPlutarch, mkStakeValidatorScriptPlutarch, + mkPlutarchTypedScript, + applyPlutarchTypedScript, Script (..), Validator (..), MintingPolicy (..), @@ -13,6 +15,7 @@ module Cardano.Simple.PlutusLedgerApi.V1.Scripts ( ValidatorHash (..), StakeValidatorHash (..), MintingPolicyHash (..), + PlutarchTypedScript (getPlutarchTypedScript), ) where import Prelude qualified as Haskell @@ -20,12 +23,14 @@ import Prelude qualified as Haskell import Codec.CBOR.Decoding as CBOR import Codec.Serialise (Serialise (..), serialise) import Control.DeepSeq (NFData) +import Control.Monad.Except (MonadError (throwError), when) import Data.ByteString.Lazy qualified as BSL +import Data.Eq qualified as GHC import Data.Text (Text) import Flat qualified import Flat.Decoder qualified as Flat import GHC.Generics (Generic) -import Plutarch (ClosedTerm, Config, compile) +import Plutarch (ClosedTerm, Config, compile, (:-->)) import Plutarch.Script qualified as Plutarch import PlutusCore qualified as PLC import PlutusPrelude (over) @@ -78,6 +83,32 @@ mkStakeValidatorScriptPlutarch :: Config -> ClosedTerm a -> Either Text StakeVal mkStakeValidatorScriptPlutarch conf term = StakeValidator . Script . Plutarch.unScript <$> compile conf term +mkPlutarchTypedScript :: Config -> ClosedTerm a -> Either Text (PlutarchTypedScript a) +mkPlutarchTypedScript config term = + PlutarchTypedScript . Script . Plutarch.unScript <$> Plutarch.compile config term + +applyPlutarchTypedScript :: + Config -> + PlutarchTypedScript (a :--> b) -> + ClosedTerm a -> + Either Text (PlutarchTypedScript b) +applyPlutarchTypedScript + config + (PlutarchTypedScript (Script (UPLC.Program _ v1 t1))) + term = do + (Plutarch.Script (UPLC.Program _ v2 t2)) <- Plutarch.compile config term + + when (v1 GHC./= v2) $ throwError "Script versions differ" + + pure $ + PlutarchTypedScript $ + Script $ + UPLC.Program () v1 $ + UPLC.Apply () t1 t2 + +-- | 'PlutarchTypedScript' represents a compiled plutarch script while preserving type of the script +newtype PlutarchTypedScript s = PlutarchTypedScript {getPlutarchTypedScript :: Script} + -- | 'Validator' is a wrapper around 'Script's which are used as validators in transaction outputs. newtype Validator = Validator {getValidator :: Script} deriving stock (Generic) diff --git a/psm/plutus-simple-model.cabal b/psm/plutus-simple-model.cabal index 0c8b40c..3d9e213 100644 --- a/psm/plutus-simple-model.cabal +++ b/psm/plutus-simple-model.cabal @@ -185,6 +185,7 @@ test-suite plutus-simple-model-test Suites.Plutus.Model.Util build-depends: + , cardano-simple , plutus-simple-model , plutus-tx-plugin diff --git a/psm/src/Plutus/Model/Validator/V2.hs b/psm/src/Plutus/Model/Validator/V2.hs index 67708f1..fa6a1d1 100644 --- a/psm/src/Plutus/Model/Validator/V2.hs +++ b/psm/src/Plutus/Model/Validator/V2.hs @@ -9,6 +9,8 @@ module Plutus.Model.Validator.V2 ( toBuiltinValidator, toBuiltinPolicy, toBuiltinStake, + mkTypedValidatorPlutarchTypedScript, + mkTypedPolicyPlutarchTypedScript, ) where import PlutusLedgerApi.V2 @@ -17,7 +19,17 @@ import PlutusTx.Prelude (Bool, (.)) import PlutusTx.Prelude qualified as Plutus import Cardano.Simple.Ledger.Scripts (toV2) -import Cardano.Simple.PlutusLedgerApi.V1.Scripts +import Cardano.Simple.PlutusLedgerApi.V1.Scripts ( + MintingPolicy (MintingPolicy), + PlutarchTypedScript (getPlutarchTypedScript), + Validator (Validator), + mkMintingPolicyScript, + mkMintingPolicyScriptPlutarch, + mkStakeValidatorScript, + mkStakeValidatorScriptPlutarch, + mkValidatorScript, + mkValidatorScriptPlutarch, + ) import Plutarch.Api.V2 (PMintingPolicy, PStakeValidator, PValidator) import Plutus.Model.Validator (TypedPolicy (..), TypedStake (..), TypedValidator (..)) @@ -49,6 +61,14 @@ mkTypedPolicyPlutarch conf term = TypedPolicy . toV2 <$> mkMintingPolicyScriptPl mkTypedStakePlutarch :: Config -> ClosedTerm PStakeValidator -> Either Text (TypedStake redeemer) mkTypedStakePlutarch conf term = TypedStake . toV2 <$> mkStakeValidatorScriptPlutarch conf term +mkTypedValidatorPlutarchTypedScript :: PlutarchTypedScript PValidator -> TypedValidator datum redeemer +mkTypedValidatorPlutarchTypedScript script = + TypedValidator . toV2 . Validator Plutus.$ getPlutarchTypedScript script + +mkTypedPolicyPlutarchTypedScript :: PlutarchTypedScript PMintingPolicy -> TypedPolicy redeemer +mkTypedPolicyPlutarchTypedScript script = + TypedPolicy . toV2 . MintingPolicy Plutus.$ getPlutarchTypedScript script + -- | Coverts to low-level validator representation {-# INLINEABLE toBuiltinValidator #-} toBuiltinValidator :: diff --git a/psm/test/Suites/Plutarch.hs b/psm/test/Suites/Plutarch.hs index ddf05eb..d7d86cf 100644 --- a/psm/test/Suites/Plutarch.hs +++ b/psm/test/Suites/Plutarch.hs @@ -5,6 +5,7 @@ module Suites.Plutarch (tests) where import Plutarch.Prelude import Prelude +import Cardano.Simple.PlutusLedgerApi.V1.Scripts (applyPlutarchTypedScript, mkPlutarchTypedScript) import Control.Monad (void) import Data.Default (def) import Data.Either (fromRight) @@ -12,7 +13,7 @@ import Plutarch.Api.V2 (PValidator) import Plutarch.Monadic qualified as P import Plutus.Model (DatumMode (..), Run (..), TypedValidator (..), adaValue, defaultBabbageV2, mustFail, newUser, payToKey, payToScript, sendTx, signTx, spend, spendScript, userSpend, utxoAt) import Plutus.Model.Contract (testNoErrors) -import Plutus.Model.V2 (mkTypedValidatorPlutarch) +import Plutus.Model.V2 (mkTypedValidatorPlutarch, mkTypedValidatorPlutarchTypedScript) import PlutusLedgerApi.V1 (toBuiltin) import PlutusLedgerApi.V2 (BuiltinByteString) import Test.Tasty (TestTree, testGroup) @@ -21,25 +22,32 @@ tests :: TestTree tests = testGroup "Plutarch" - [ good "Good guess" (testValidator "aa") - , bad "Bad guess" (testValidator "bb") + [ testGroup + "Game version with datums" + [ good "Good guess" (testValidatorWithDatum "aa") + , bad "Bad guess" (testValidatorWithDatum "bb") + ] + , testGroup + "Game version with parametrized validator" + [ good "Good guess" (testValidatorParametrized "aa") + , bad "Bad guess" (testValidatorParametrized "bb") + ] ] where bad msg = good msg . mustFail good = testNoErrors (adaValue 10_000_000) cfg cfg = defaultBabbageV2 -testValidator :: BuiltinByteString -> Run () -testValidator guess = do +pHash :: Term s PByteString +pHash = phexByteStr "961b6dd3ede3cb8ecbaacbd68de040cd78eb2ed5889130cceb4c49268ea4d506" + +testValidator :: GameValidator -> BuiltinByteString -> Run () +testValidator validator guess = do u1 <- newUser (adaValue 1_000_000) u2 <- newUser (adaValue 1_000_000) let amt = adaValue 100 -- magic string is from 'echo -n aa | sha256sum' - datum = - toBuiltin $ - plift $ - phexByteStr - "961b6dd3ede3cb8ecbaacbd68de040cd78eb2ed5889130cceb4c49268ea4d506" + datum = toBuiltin $ plift pHash do -- initialize sp <- spend u1 amt @@ -57,16 +65,56 @@ testValidator guess = do <> payToKey u2 amt void $ sendTx tx -validator :: TypedValidator BuiltinByteString BuiltinByteString -validator = +testValidatorWithDatum :: BuiltinByteString -> Run () +testValidatorWithDatum = testValidator validatorWithDatum + +testValidatorParametrized :: BuiltinByteString -> Run () +testValidatorParametrized = testValidator validatorParametrized + +type GameValidator = TypedValidator BuiltinByteString BuiltinByteString + +validatorWithDatum :: GameValidator +validatorWithDatum = fromRight (error "no validator") $ - mkTypedValidatorPlutarch def gameContractPlutarch + mkTypedValidatorPlutarch def gameContractPlutarchWithDatum + +validatorParametrized :: GameValidator +validatorParametrized = + fromRight (error "no validator") $ do + -- Execution time of `mkTypedValidatorPlutarch` and `mkPlutarchTypedScript` + -- can take up to 2 seconds for large validators. + -- One definitely should avoid calling these functions in every test. + -- It's recommended to compile a validator exactly once + -- to keep low psm tests execution time. + compiledParametrizedScript <- + mkPlutarchTypedScript def gameContractPlutarchParametrized + + -- Once we have access to compiled (parametrized) validator script + -- we can apply it to some parameters which is usually very cheap. + -- This can be done in every test - + -- especially if validator's parameter varies across tests. + validator <- + applyPlutarchTypedScript def compiledParametrizedScript pHash -gameContractPlutarch :: ClosedTerm PValidator -gameContractPlutarch = plam $ \d' r' _ -> popaque $ P.do + pure $ mkTypedValidatorPlutarchTypedScript validator + +-- Datum is used to submit a hash of a puzzle +gameContractPlutarchWithDatum :: ClosedTerm PValidator +gameContractPlutarchWithDatum = plam $ \d' r' _ -> popaque $ P.do (r :: Term s (PAsData PByteString), _) <- ptryFrom r' (d :: Term s (PAsData PByteString), _) <- ptryFrom d' pif (psha2_256 # pfromData r #== pfromData d) (pconstant ()) perror + +-- Script is parametrized by a hash of a puzzle; Datum does not matter +-- The hash is set once and for all. +-- For a new game the term below needs to be applied to a new hash. +gameContractPlutarchParametrized :: ClosedTerm (PByteString :--> PValidator) +gameContractPlutarchParametrized = plam $ \expectedHash _ r' _ -> popaque $ P.do + (r :: Term s (PAsData PByteString), _) <- ptryFrom r' + pif + (psha2_256 # pfromData r #== expectedHash) + (pconstant ()) + perror