diff --git a/changelog.md b/changelog.md index 7a3a0475..b76afb74 100644 --- a/changelog.md +++ b/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 diff --git a/src/base/lib/Convex/BuildTx.hs b/src/base/lib/Convex/BuildTx.hs index 56b43588..3e46621a 100644 --- a/src/base/lib/Convex/BuildTx.hs +++ b/src/base/lib/Convex/BuildTx.hs @@ -1,12 +1,23 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} {-| Building transactions -} module Convex.BuildTx( + -- * Tx Builder + TxBuilder(..), + -- ** Looking at transaction inputs + TransactionInputs(..), + lookupIndexSpending, + lookupIndexReference, + findIndexSpending, + findIndexReference, + buildTx, + buildTxWith, -- * Effect MonadBuildTx(..), BuildTxT(..), @@ -17,16 +28,18 @@ module Convex.BuildTx( execBuildTx', evalBuildTxT, - TxBuild, -- * Building transactions + addInput, + addReference, + addCollateral, + addAuxScript, + prependTxOut, + addOutput, + setScriptsValid, + addRequiredSignature, + + -- ** Variations of @addInput@ spendPublicKeyOutput, - payToAddress, - payToAddressTxOut, - payToPublicKey, - payToScriptHash, - payToPlutusV1, - payToPlutusV2, - payToPlutusV2InlineDatum, spendPlutusV1, spendPlutusV2, spendPlutusV2Ref, @@ -34,19 +47,27 @@ module Convex.BuildTx( spendPlutusV2RefWithoutInRef, spendPlutusV2RefWithoutInRefInlineDatum, spendPlutusV2InlineDatum, - mintPlutusV1, - mintPlutusV2, - mintPlutusV2Ref, + + -- ** Adding outputs + payToAddress, + payToAddressTxOut, + payToPublicKey, + payToScriptHash, + payToPlutusV1, + payToPlutusV2, + payToPlutusV2InlineDatum, payToPlutusV2Inline, payToPlutusV2InlineWithInlineDatum, payToPlutusV2InlineWithDatum, - addReference, - addCollateral, - addAuxScript, + + -- ** Minting and burning tokens + mintPlutusV1, + mintPlutusV2, + mintPlutusV2Ref, + + -- ** Utilities assetValue, - setScriptsValid, - addRequiredSignature, - prependTxOut, + -- * Minimum Ada deposit minAdaDeposit, setMinAdaDeposit, @@ -56,9 +77,13 @@ module Convex.BuildTx( import Cardano.Api.Shelley (Hash, HashableScriptData, NetworkId, PaymentKey, PlutusScript, PlutusScriptV1, - PlutusScriptV2, ScriptHash) + PlutusScriptV2, ScriptHash, + TxBodyContent (..), WitCtxTxIn, + Witness) import qualified Cardano.Api.Shelley as C -import Control.Lens (_1, _2, at, mapped, over, set, (&)) +import Control.Lens (_1, _2, at, mapped, over, set, + view, (&)) +import qualified Control.Lens as L import Control.Monad.Except (MonadError (..)) import qualified Control.Monad.State as LazyState import Control.Monad.State.Class (MonadState (..)) @@ -76,55 +101,123 @@ import Convex.MonadLog (MonadLog (..), MonadLogIgnoreT, import Convex.Scripts (toHashableScriptData) import Data.Functor.Identity (Identity (..)) import Data.List (nub) +import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (fromMaybe) +import Data.Set (Set) +import qualified Data.Set as Set import qualified PlutusLedgerApi.V1 as Plutus -newtype BTX = BTX{ unBtx :: C.TxBodyContent C.BuildTx C.BabbageEra -> C.TxBodyContent C.BuildTx C.BabbageEra } +{-| A map of all inputs of the final transaction produced by a @TxBuilder@ +-} +-- TOOO: This is essentially a subset of @TxBodyContent BuildTx@. Maybe we should +-- just make the entire @TxBodyContent BuildTx@ available to 'addInput'? +data TransactionInputs = TransactionInputs + { txiSpendingInputs :: Map C.TxIn (Witness WitCtxTxIn C.BabbageEra) -- ^ Inputs spent by the final transaction + , txiReferenceInputs :: Set C.TxIn -- ^ Reference inputs used by the final transaction + } + +mkTxInputs :: C.TxBodyContent C.BuildTx C.BabbageEra -> TransactionInputs +mkTxInputs TxBodyContent{txIns, txInsReference} = + TransactionInputs + { txiSpendingInputs = Map.fromList (fmap (view L._BuildTxWith) <$> txIns) + , txiReferenceInputs = Set.fromList (view L._TxInsReference txInsReference) + } + +{-| Look up the index of the @TxIn@ in the list of spending inputs +-} +lookupIndexSpending :: C.TxIn -> TransactionInputs -> Maybe Int +lookupIndexSpending txi = Map.lookupIndex txi . txiSpendingInputs + +{-| Look up the index of the @TxIn@ in the list of reference inputs +-} +lookupIndexReference :: C.TxIn -> TransactionInputs -> Maybe Int +lookupIndexReference txi = Set.lookupIndex txi . txiReferenceInputs + +{-| Look up the index of the @TxIn@ in the list of spending inputs +-} +findIndexSpending :: C.TxIn -> TransactionInputs -> Int +findIndexSpending txi = Map.findIndex txi . txiSpendingInputs + +{-| Look up the index of the @TxIn@ in the list of reference inputs +-} +findIndexReference :: C.TxIn -> TransactionInputs -> Int +findIndexReference txi = Set.findIndex txi . txiReferenceInputs + +{-| A function that modifies the @TxBodyContent@, after seeing the inputs of +the entire finished transaction (lazily). -instance Semigroup BTX where +Note that the result of @unTxBuilder inputs@ must not depend on the entirety of +@inputs@. For example, using this to construct a redeemer that contains the whole +@TransactionInputs@ map is going to loop forever. However, it is fine to look +at all the keys of the map, and at individual values of the map. +-} +newtype TxBuilder = TxBuilder{ unTxBuilder :: TransactionInputs -> C.TxBodyContent C.BuildTx C.BabbageEra -> C.TxBodyContent C.BuildTx C.BabbageEra } + +{-| Construct the final @TxBodyContent@ +-} +buildTx :: TxBuilder -> C.TxBodyContent C.BuildTx C.BabbageEra +buildTx txb = buildTxWith txb L.emptyTx + +{-| Construct the final @TxBodyContent@ from the provided @TxBodyContent@ +-} +buildTxWith :: TxBuilder -> C.TxBodyContent C.BuildTx C.BabbageEra -> C.TxBodyContent C.BuildTx C.BabbageEra +buildTxWith TxBuilder{unTxBuilder} initial = + let mp :: TransactionInputs + mp = mkTxInputs result + result = unTxBuilder mp initial + in result + +instance Semigroup TxBuilder where -- note that the order here is reversed, compared to @Data.Monoid.Endo@. -- This is so that @addBtx a >> addBtx b@ will result in a transaction -- where @a@ has been applied before @b@. - (BTX l) <> (BTX r) = BTX (r . l) + (TxBuilder l) <> (TxBuilder r) = TxBuilder $ \k -> (r k . l k) -instance Monoid BTX where - mempty = BTX id +instance Monoid TxBuilder where + mempty = TxBuilder $ const id +{-| An effect that collects @TxBuilder@ values for building +cardano transactions +-} class Monad m => MonadBuildTx m where - addBtx :: TxBuild -> m () + -- | Add a @TxBuilder@ + addTxBuilder :: TxBuilder -> m () instance MonadBuildTx m => MonadBuildTx (ExceptT e m) where - addBtx = lift . addBtx + addTxBuilder = lift . addTxBuilder instance MonadBuildTx m => MonadBuildTx (StrictState.StateT e m) where - addBtx = lift . addBtx + addTxBuilder = lift . addTxBuilder instance MonadBuildTx m => MonadBuildTx (LazyState.StateT e m) where - addBtx = lift . addBtx + addTxBuilder = lift . addTxBuilder instance (Monoid w, MonadBuildTx m) => MonadBuildTx (WriterT w m) where - addBtx = lift . addBtx + addTxBuilder = lift . addTxBuilder instance MonadBuildTx m => MonadBuildTx (MonadBlockchainCardanoNodeT e m) where - addBtx = lift . addBtx + addTxBuilder = lift . addTxBuilder instance MonadBuildTx m => MonadBuildTx (MonadLogIgnoreT m) where - addBtx = lift . addBtx + addTxBuilder = lift . addTxBuilder instance MonadBuildTx m => MonadBuildTx (MonadLogKatipT m) where - addBtx = lift . addBtx + addTxBuilder = lift . addTxBuilder + +addBtx :: MonadBuildTx m => (C.TxBodyContent C.BuildTx C.BabbageEra -> C.TxBodyContent C.BuildTx C.BabbageEra) -> m () +addBtx = addTxBuilder . TxBuilder . const {-| Monad transformer for the @MonadBuildTx@ effect -} -newtype BuildTxT m a = BuildTxT{unBuildTxT :: WriterT BTX m a } +newtype BuildTxT m a = BuildTxT{unBuildTxT :: WriterT TxBuilder m a } deriving newtype (Functor, Applicative, Monad) instance MonadTrans BuildTxT where lift = BuildTxT . lift instance Monad m => MonadBuildTx (BuildTxT m) where - addBtx = BuildTxT . tell . BTX + addTxBuilder = BuildTxT . tell instance MonadError e m => MonadError e (BuildTxT m) where throwError = lift . throwError @@ -155,31 +248,37 @@ instance MonadLog m => MonadLog (BuildTxT m) where {-| Run the @BuildTxT@ monad transformer -} -runBuildTxT :: Functor m => BuildTxT m a -> m (a, TxBuild) -runBuildTxT = fmap (fmap unBtx) . runWriterT . unBuildTxT +runBuildTxT :: BuildTxT m a -> m (a, TxBuilder) +runBuildTxT = runWriterT . unBuildTxT {-| Run the @BuildTxT@ monad transformer, returning the @TxBuild@ part only -} -execBuildTxT :: Monad m => BuildTxT m a -> m TxBuild -execBuildTxT = fmap unBtx . execWriterT . unBuildTxT +execBuildTxT :: Monad m => BuildTxT m a -> m TxBuilder +execBuildTxT = execWriterT . unBuildTxT {-| Run the @BuildTxT@ monad transformer, returnin only the result -} evalBuildTxT :: Monad m => BuildTxT m a -> m a evalBuildTxT = fmap fst . runWriterT . unBuildTxT -runBuildTx :: BuildTxT Identity a -> (a, TxBuild) +runBuildTx :: BuildTxT Identity a -> (a, TxBuilder) runBuildTx = runIdentity . runBuildTxT -execBuildTx :: BuildTxT Identity a -> TxBuild +execBuildTx :: BuildTxT Identity a -> TxBuilder execBuildTx = runIdentity . execBuildTxT {-| Run the @BuildTx@ action and produce a transaction body -} execBuildTx' :: BuildTxT Identity a -> C.TxBodyContent C.BuildTx C.BabbageEra -execBuildTx' = flip ($) L.emptyTx . runIdentity . execBuildTxT +execBuildTx' = buildTx . runIdentity . execBuildTxT -type TxBuild = C.TxBodyContent C.BuildTx C.BabbageEra -> C.TxBodyContent C.BuildTx C.BabbageEra +{-| Spend an UTxO using the given witness. To avoid an infinite loop when +constructing the witness, make sure that the witness does not depend on +itself. For example, @addInput txi (\mp -> Map.lookup txi mp)@ is going +to loop. +-} +addInput :: MonadBuildTx m => C.TxIn -> (TransactionInputs -> Witness WitCtxTxIn C.BabbageEra) -> m () +addInput txIn f = addTxBuilder (TxBuilder $ \lkp -> (over L.txIns ((txIn, C.BuildTxWith $ f lkp) :))) {-| Spend an output locked by a public key -} @@ -188,7 +287,7 @@ spendPublicKeyOutput txIn = do let wit = C.BuildTxWith (C.KeyWitness (C.KeyWitnessForSpending)) addBtx (over L.txIns ((txIn, wit) :)) -spendPlutusV1 :: forall datum redeemer m. (MonadBuildTx m, Plutus.ToData datum, Plutus.ToData redeemer) => C.TxIn -> PlutusScript PlutusScriptV1 -> datum -> redeemer -> m () +spendPlutusV1 :: forall datum redeemer m. (MonadBuildTx m, Plutus.ToData datum, Plutus.ToData redeemer) => C.TxIn -> PlutusScript PlutusScriptV1 -> datum -> (redeemer) -> m () spendPlutusV1 txIn s (toHashableScriptData -> dat) (toHashableScriptData -> red) = let wit = C.PlutusScriptWitness C.PlutusScriptV1InBabbage C.PlutusScriptV1 (C.PScript s) (C.ScriptDatumForTxIn dat) red (C.ExecutionUnits 0 0) wit' = C.BuildTxWith (C.ScriptWitness C.ScriptWitnessForSpending wit) @@ -208,16 +307,19 @@ spendPlutusV2InlineDatum txIn s (toHashableScriptData -> red) = wit' = C.BuildTxWith (C.ScriptWitness C.ScriptWitnessForSpending wit) in setScriptsValid >> addBtx (over L.txIns ((txIn, wit') :)) -spendPlutusV2RefBase :: forall redeemer m. (MonadBuildTx m, Plutus.ToData redeemer) => C.TxIn -> C.TxIn -> Maybe C.ScriptHash -> C.ScriptDatum C.WitCtxTxIn -> redeemer -> m () -spendPlutusV2RefBase txIn refTxIn sh dat (toHashableScriptData -> red) = - let wit = C.PlutusScriptWitness C.PlutusScriptV2InBabbage C.PlutusScriptV2 (C.PReferenceScript refTxIn sh) dat red (C.ExecutionUnits 0 0) - wit' = C.BuildTxWith (C.ScriptWitness C.ScriptWitnessForSpending wit) - in setScriptsValid >> addBtx (over L.txIns ((txIn, wit') :)) +{-| Spend an output locked by a Plutus V2 validator using the redeemer provided. The redeemer +can depend on the index of the @TxIn@ in the inputs of the final transaction. +-} +spendPlutusV2RefBase :: forall redeemer m. (MonadBuildTx m, Plutus.ToData redeemer) => C.TxIn -> C.TxIn -> Maybe C.ScriptHash -> C.ScriptDatum C.WitCtxTxIn -> (Int -> redeemer) -> m () +spendPlutusV2RefBase txIn refTxIn sh dat red = + let wit lkp = C.PlutusScriptWitness C.PlutusScriptV2InBabbage C.PlutusScriptV2 (C.PReferenceScript refTxIn sh) dat (toHashableScriptData $ red $ findIndexSpending txIn lkp) (C.ExecutionUnits 0 0) + wit' = C.BuildTxWith . C.ScriptWitness C.ScriptWitnessForSpending . wit + in setScriptsValid >> addTxBuilder (TxBuilder $ \lkp -> (over L.txIns ((txIn, wit' lkp) :))) -{-| same as spendPlutusV2RefBase but adds the reference script in the reference input list +{-| Spend an output locked by a Plutus V2 validator using the redeemer -} spendPlutusV2RefBaseWithInRef :: forall redeemer m. (MonadBuildTx m, Plutus.ToData redeemer) => C.TxIn -> C.TxIn -> Maybe C.ScriptHash -> C.ScriptDatum C.WitCtxTxIn -> redeemer -> m () -spendPlutusV2RefBaseWithInRef txIn refTxIn sh dat red = spendPlutusV2RefBase txIn refTxIn sh dat red >> addReference refTxIn +spendPlutusV2RefBaseWithInRef txIn refTxIn sh dat red = spendPlutusV2RefBase txIn refTxIn sh dat (const red) >> addReference refTxIn spendPlutusV2Ref :: forall datum redeemer m. (MonadBuildTx m, Plutus.ToData datum, Plutus.ToData redeemer) => C.TxIn -> C.TxIn -> Maybe C.ScriptHash -> datum -> redeemer -> m () spendPlutusV2Ref txIn refTxIn sh (toHashableScriptData -> dat) red = spendPlutusV2RefBaseWithInRef txIn refTxIn sh (C.ScriptDatumForTxIn dat) red @@ -231,13 +333,12 @@ spendPlutusV2RefWithInlineDatum txIn refTxIn sh red = spendPlutusV2RefBaseWithIn This is to cover the case whereby the reference script utxo is expected to be consumed in the same tx. -} spendPlutusV2RefWithoutInRef :: forall datum redeemer m. (MonadBuildTx m, Plutus.ToData datum, Plutus.ToData redeemer) => C.TxIn -> C.TxIn -> Maybe C.ScriptHash -> datum -> redeemer -> m () -spendPlutusV2RefWithoutInRef txIn refTxIn sh (toHashableScriptData -> dat) red = spendPlutusV2RefBase txIn refTxIn sh (C.ScriptDatumForTxIn dat) red +spendPlutusV2RefWithoutInRef txIn refTxIn sh (toHashableScriptData -> dat) red = spendPlutusV2RefBase txIn refTxIn sh (C.ScriptDatumForTxIn dat) (const red) {-| same as spendPlutusV2RefWithoutInRef but considers inline datum at the spent utxo -} spendPlutusV2RefWithoutInRefInlineDatum :: forall redeemer m. (MonadBuildTx m, Plutus.ToData redeemer) => C.TxIn -> C.TxIn -> Maybe C.ScriptHash -> redeemer -> m () -spendPlutusV2RefWithoutInRefInlineDatum txIn refTxIn sh red = spendPlutusV2RefBase txIn refTxIn sh C.InlineScriptDatum red - +spendPlutusV2RefWithoutInRefInlineDatum txIn refTxIn sh red = spendPlutusV2RefBase txIn refTxIn sh C.InlineScriptDatum (const red) mintPlutusV1 :: forall redeemer m. (Plutus.ToData redeemer, MonadBuildTx m) => PlutusScript PlutusScriptV1 -> redeemer -> C.AssetName -> C.Quantity -> m () mintPlutusV1 script (toHashableScriptData -> red) assetName quantity = @@ -354,6 +455,9 @@ setMinAdaDeposit params txOut = let minUtxo = minAdaDeposit params txOut in txOut & over (L._TxOut . _2 . L._TxOutValue . L._Value . at C.AdaAssetId) (maybe (Just minUtxo) (Just . max minUtxo)) +{-| Calculate the minimum amount of Ada that must be locked in the given UTxO to +satisfy the ledger's minimum Ada constraint. +-} minAdaDeposit :: C.LedgerProtocolParameters C.BabbageEra -> C.TxOut C.CtxTx C.BabbageEra -> C.Quantity minAdaDeposit (C.LedgerProtocolParameters params) txOut = let minAdaValue = C.Quantity 3_000_000 @@ -380,3 +484,8 @@ addRequiredSignature sig = -} prependTxOut :: MonadBuildTx m => C.TxOut C.CtxTx C.BabbageEra -> m () prependTxOut txOut = addBtx (over L.txOuts ((:) txOut)) + +{-| Add a transaction output to the end of the list of transaction outputs. +-} +addOutput :: MonadBuildTx m => C.TxOut C.CtxTx C.BabbageEra -> m () +addOutput txOut = addBtx (over (L.txOuts . L.reversed) ((:) txOut)) 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/lib/Convex/CoinSelection.hs b/src/coin-selection/lib/Convex/CoinSelection.hs index de034983..186299f1 100644 --- a/src/coin-selection/lib/Convex/CoinSelection.hs +++ b/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 -} diff --git a/src/coin-selection/lib/Convex/MockChain/CoinSelection.hs b/src/coin-selection/lib/Convex/MockChain/CoinSelection.hs index 899b2169..1ec3588f 100644 --- a/src/coin-selection/lib/Convex/MockChain/CoinSelection.hs +++ b/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@ diff --git a/src/coin-selection/test/Scripts.hs b/src/coin-selection/test/Scripts.hs index 4a113255..7dad8543 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.findIndexSpending 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 08892d89..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) @@ -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)