From 7482b372976ff8d81e36a2b6a06a4ea5468ffd78 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jann=20M=C3=BCller?= Date: Tue, 27 Feb 2024 09:25:52 +0100 Subject: [PATCH] Add a test for the index lookup function --- src/base/lib/Convex/Scripts.hs | 5 +-- .../convex-coin-selection.cabal | 3 ++ src/coin-selection/test/Scripts.hs | 44 +++++++++++++++++-- .../test/Scripts/MatchingIndex.hs | 27 ++++++++++++ src/coin-selection/test/Spec.hs | 14 +++++- 5 files changed, 85 insertions(+), 8 deletions(-) create mode 100644 src/coin-selection/test/Scripts/MatchingIndex.hs diff --git a/src/base/lib/Convex/Scripts.hs b/src/base/lib/Convex/Scripts.hs index b3daf5e1..10ae801d 100644 --- a/src/base/lib/Convex/Scripts.hs +++ b/src/base/lib/Convex/Scripts.hs @@ -17,9 +17,6 @@ module Convex.Scripts( import Cardano.Api (PlutusScript) import qualified Cardano.Api.Shelley as C import Cardano.Ledger.Plutus.Data (Data (..)) -import Codec.Serialise (serialise) -import Data.ByteString.Lazy (toStrict) -import Data.ByteString.Short (toShort) import Ouroboros.Consensus.Shelley.Eras (StandardBabbage) import PlutusLedgerApi.Common (serialiseCompiledCode) import qualified PlutusLedgerApi.V1 as PV1 @@ -28,7 +25,7 @@ import PlutusTx.Code (CompiledCode) {-| Get the 'PlutusScript' of a 'CompiledCode' -} compiledCodeToScript :: CompiledCode a -> PlutusScript lang -compiledCodeToScript = C.PlutusScriptSerialised . toShort . toStrict . serialise . serialiseCompiledCode +compiledCodeToScript = C.PlutusScriptSerialised . serialiseCompiledCode fromScriptData :: PV1.FromData a => C.ScriptData -> Maybe a fromScriptData (C.toPlutusData -> d) = PV1.fromData d diff --git a/src/coin-selection/convex-coin-selection.cabal b/src/coin-selection/convex-coin-selection.cabal index 3f0440a3..9af7eaf2 100644 --- a/src/coin-selection/convex-coin-selection.cabal +++ b/src/coin-selection/convex-coin-selection.cabal @@ -65,6 +65,7 @@ test-suite convex-coin-selection-test Spec.hs other-modules: Scripts + Scripts.MatchingIndex build-depends: base >= 4.14.0, tasty, @@ -83,5 +84,7 @@ test-suite convex-coin-selection-test containers, plutus-ledger-api:{plutus-ledger-api, plutus-ledger-api-testlib}, plutus-ledger-api, + plutus-tx, + plutus-tx-plugin, mtl, transformers \ No newline at end of file diff --git a/src/coin-selection/test/Scripts.hs b/src/coin-selection/test/Scripts.hs index 4a113255..24d99b09 100644 --- a/src/coin-selection/test/Scripts.hs +++ b/src/coin-selection/test/Scripts.hs @@ -1,18 +1,56 @@ +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas -fplugin-opt PlutusTx.Plugin:target-version=1.0.0 #-} -- 1.1.0.0 will be enabled in conway -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} -- | Scripts used for testing module Scripts( v2SpendingScriptSerialised, - v2SpendingScript + v2SpendingScript, + + -- * Matching index scripts + matchingIndexScript, + spendMatchingIndex ) where +import Cardano.Api (TxIn) import qualified Cardano.Api.Shelley as C +import Convex.BuildTx (MonadBuildTx) +import qualified Convex.BuildTx as BuildTx +import Convex.Scripts (compiledCodeToScript, + toHashableScriptData) import PlutusLedgerApi.Common (SerialisedScript) import PlutusLedgerApi.Test.Examples (alwaysSucceedingNAryFunction) +import PlutusTx (BuiltinData, CompiledCode) +import qualified PlutusTx +import qualified Scripts.MatchingIndex as MatchingIndex v2SpendingScript :: C.PlutusScript C.PlutusScriptV2 v2SpendingScript = C.PlutusScriptSerialised $ alwaysSucceedingNAryFunction 3 v2SpendingScriptSerialised :: SerialisedScript v2SpendingScriptSerialised = alwaysSucceedingNAryFunction 3 + +matchingIndexCompiled :: CompiledCode (BuiltinData -> BuiltinData -> BuiltinData -> ()) +matchingIndexCompiled = $$(PlutusTx.compile [|| \d r c -> MatchingIndex.validator d r c ||]) + +{-| Script that passes if the input's index (in the list of transaction inputs) + matches the number passed as the redeemer +-} +matchingIndexScript :: C.PlutusScript C.PlutusScriptV2 +matchingIndexScript = compiledCodeToScript matchingIndexCompiled + +{-| Spend an output locked by 'matchingIndexScript', setting +the redeemer to the index of the input in the final transaction +-} +spendMatchingIndex :: MonadBuildTx m => TxIn -> m () +spendMatchingIndex txi = + let witness lkp = + C.ScriptWitness C.ScriptWitnessForSpending + $ C.PlutusScriptWitness + C.PlutusScriptV2InBabbage + C.PlutusScriptV2 + (C.PScript matchingIndexScript) + (C.ScriptDatumForTxIn $ toHashableScriptData ()) + (toHashableScriptData $ fromIntegral @Int @Integer $ BuildTx.findIndex txi lkp) + (C.ExecutionUnits 0 0) + in BuildTx.setScriptsValid >> BuildTx.addInput txi witness diff --git a/src/coin-selection/test/Scripts/MatchingIndex.hs b/src/coin-selection/test/Scripts/MatchingIndex.hs new file mode 100644 index 00000000..cd3e83ea --- /dev/null +++ b/src/coin-selection/test/Scripts/MatchingIndex.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} +-- A plutus validator that only succeeds if the redeemer is identical to the script's input index +module Scripts.MatchingIndex( + validator +) where + +import PlutusLedgerApi.V2.Contexts (ScriptContext (..), + ScriptPurpose (..), TxInInfo (..), + TxInfo (..)) +import PlutusTx.IsData.Class (UnsafeFromData (unsafeFromBuiltinData)) +import PlutusTx.Prelude (BuiltinData) +import qualified PlutusTx.Prelude as P + +{-# INLINABLE validator #-} +validator :: BuiltinData -> BuiltinData -> BuiltinData -> () +validator _datum (unsafeFromBuiltinData -> idx :: P.Integer) (unsafeFromBuiltinData -> ScriptContext{scriptContextPurpose=Spending txOutRef, scriptContextTxInfo=TxInfo{txInfoInputs}}) = + let isOwnIndex TxInInfo{txInInfoOutRef} = txInInfoOutRef P.== txOutRef + ownIndex = P.findIndex isOwnIndex txInfoInputs + in if ownIndex P.== (P.Just idx) then () else P.traceError "Different indices" +validator _ _ _ = P.error () diff --git a/src/coin-selection/test/Spec.hs b/src/coin-selection/test/Spec.hs index 901eada3..04d21b4e 100644 --- a/src/coin-selection/test/Spec.hs +++ b/src/coin-selection/test/Spec.hs @@ -12,7 +12,7 @@ import Cardano.Ledger.Babbage.Rules (BabbageUtxoPredFailure (..), import Cardano.Ledger.Shelley.API (ApplyTxError (..)) import Cardano.Ledger.Shelley.Rules (ShelleyLedgerPredFailure (..)) import Control.Lens (_3, _4, view, (&), (.~)) -import Control.Monad (void, when) +import Control.Monad (replicateM, void, when) import Control.Monad.Except (MonadError, runExceptT) import Control.Monad.State.Strict (execStateT, modify) import Control.Monad.Trans.Class (MonadTrans (..)) @@ -90,6 +90,7 @@ tests = testGroup "unit tests" , testCase "making payments with tokens" (mockchainSucceeds $ failOnError (mintingPlutus >>= spendTokens)) , testCase "making payments with tokens (2)" (mockchainSucceeds $ failOnError (mintingPlutus >>= spendTokens2)) , testCase "spending a singleton output" (mockchainSucceeds $ failOnError (mintingPlutus >>= spendSingletonOutput)) + , testCase "spend an output locked by the matching index script" (mockchainSucceeds $ failOnError matchingIndex) ] , testGroup "mockchain" [ testCase "resolveDatumHash" (mockchainSucceeds $ failOnError checkResolveDatumHash) @@ -312,3 +313,14 @@ largeTransactionTest = do let protParams = Defaults.protocolParameters & maxTxSize .~ 20304 params' = Defaults.nodeParams & protocolParameters .~ (either (error. show) id (C.convertToLedgerProtocolParameters C.ShelleyBasedEraBabbage protParams)) mockchainSucceedsWith params' (failOnError largeDatumTx) + +matchingIndex :: (MonadMockchain m, MonadError BalanceTxError m) => m () +matchingIndex = do + let txBody = execBuildTx' (payToPlutusV2 Defaults.networkId Scripts.matchingIndexScript () C.NoStakeAddress (C.lovelaceToValue 10_000_000)) + tx = C.TxIn <$> (C.getTxId . C.getTxBody <$> balanceAndSubmit mempty Wallet.w1 txBody) <*> pure (C.TxIx 0) + + -- create three separate tx outputs that are locked by the matching index script + inputs <- replicateM 3 tx + + -- Spend the outputs in a single transaction + void (balanceAndSubmit mempty Wallet.w1 $ execBuildTx' $ traverse_ Scripts.spendMatchingIndex inputs)