Add a test for the index lookup function

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

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

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

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 ()

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)