Add witness map to tx build

changelog.md

@@ -17,6 +17,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0
 ### Added
 
 - `Eq` and `Ord` instances for `Operator`
+- `Convex.BuildTx`: Added the option to look at all of a transaction's inputs when building a transaction
 
 ### Deleted
 

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/lib/Convex/CoinSelection.hs

@@ -59,8 +59,8 @@ import           Control.Monad             (when)
 import           Control.Monad.Except      (MonadError (..))
 import           Control.Monad.Trans.Class (MonadTrans (..))
 import           Control.Tracer            (Tracer, natTracer, traceWith)
-import           Convex.BuildTx            (addCollateral, execBuildTx,
-                                            setMinAdaDeposit,
+import           Convex.BuildTx            (addCollateral, buildTxWith,
+                                            execBuildTx, setMinAdaDeposit,
                                             spendPublicKeyOutput)
 import           Convex.Class              (MonadBlockchain (..))
 import qualified Convex.Lenses             as L
@@ -453,7 +453,7 @@ addOwnInput body (Utxos.removeUtxos (spentTxIns body) -> UtxoSet{_utxos})
   | not (Map.null _utxos) =
       -- Select ada-only outputs if possible
       let availableUTxOs = List.sortOn (length . view (L._TxOut . _2 . L._TxOutValue . to C.valueToList) . fst . snd) (Map.toList _utxos)
-      in pure (execBuildTx (spendPublicKeyOutput (fst $ head availableUTxOs)) body)
+      in pure $ buildTxWith (execBuildTx (spendPublicKeyOutput (fst $ head availableUTxOs))) body
   | otherwise = throwError NoWalletUTxOs
 
 -- | Add a collateral input. Throws a 'NoAdaOnlyUTxOsForCollateral' error if a collateral input is required,
@@ -469,7 +469,7 @@ setCollateral body (Utxos.onlyAda -> UtxoSet{_utxos}) =
         -- select the output with the largest amount of Ada
         case listToMaybe $ List.sortOn (Down . C.selectLovelace . view (L._TxOut . _2 . L._TxOutValue) . fst . snd) $ Map.toList _utxos of
           Nothing     -> throwError NoAdaOnlyUTxOsForCollateral
-          Just (k, _) -> pure (execBuildTx (addCollateral k) body)
+          Just (k, _) -> pure $ buildTxWith (execBuildTx (addCollateral k)) body
 
 {-| Whether the transaction runs any plutus scripts
 -}

src/coin-selection/lib/Convex/MockChain/CoinSelection.hs

@@ -16,13 +16,13 @@ import           Cardano.Api.Shelley       (BabbageEra, BuildTx, TxBodyContent,
 import qualified Cardano.Api.Shelley       as C
 import           Control.Monad.Except      (MonadError)
 import           Control.Tracer            (Tracer)
-import           Convex.BuildTx            (execBuildTx, execBuildTx',
+import           Convex.BuildTx            (buildTx, execBuildTx, execBuildTx',
                                             payToAddress, setMinAdaDepositAll)
 import           Convex.Class              (MonadBlockchain (..),
                                             MonadMockchain)
 import           Convex.CoinSelection      (BalanceTxError, TxBalancingMessage)
 import qualified Convex.CoinSelection      as CoinSelection
-import           Convex.Lenses             (emptyTx, emptyTxOut)
+import           Convex.Lenses             (emptyTxOut)
 import qualified Convex.MockChain          as MockChain
 import qualified Convex.MockChain.Defaults as Defaults
 import           Convex.Wallet             (Wallet)
@@ -53,7 +53,7 @@ balanceAndSubmitReturn dbg wallet returnOutput tx = do
 -}
 paymentTo :: (MonadMockchain m, MonadError BalanceTxError m) => Wallet -> Wallet -> m (C.Tx CoinSelection.ERA)
 paymentTo wFrom wTo = do
-  let tx = execBuildTx (payToAddress (Wallet.addressInEra Defaults.networkId wTo) (C.lovelaceToValue 10_000_000)) emptyTx
+  let tx = buildTx $ execBuildTx (payToAddress (Wallet.addressInEra Defaults.networkId wTo) (C.lovelaceToValue 10_000_000))
   balanceAndSubmit mempty wFrom tx
 
 {-| Pay 100 Ada from one of the seed addresses to an @Operator@

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.findIndexSpending 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)
@@ -259,7 +260,7 @@ checkResolveDatumHash = do
 execBuildTxWallet :: (MonadMockchain m, MonadError BalanceTxError m) => Wallet -> BuildTxT m a -> m C.TxId
 execBuildTxWallet wallet action = do
   tx <- execBuildTxT (action >> setMinAdaDepositAll Defaults.bundledProtocolParameters)
-  C.getTxId . C.getTxBody <$> balanceAndSubmit mempty wallet (tx L.emptyTx)
+  C.getTxId . C.getTxBody <$> balanceAndSubmit mempty wallet (BuildTx.buildTx tx)
 
 -- | Balance a transaction using a list of operators
 --   Check that the fees are calculated correctly to spend outputs from different addresses
@@ -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)