From 57e6289d3174a8a909e11af8afc631d946a81db1 Mon Sep 17 00:00:00 2001 From: Giovanni Garufi Date: Thu, 18 Apr 2024 11:26:58 +0200 Subject: [PATCH] Change TxBuilder so it has access to the whole TxBodyContent instead of just the inputs. (#140) Add some utility functions to index into mints and withdrawls. --- src/base/lib/Convex/BuildTx.hs | 124 +++++++++++------- src/base/lib/Convex/Lenses.hs | 9 +- src/coin-selection/test/Scripts.hs | 45 +++++-- .../test/Scripts/MatchingIndex.hs | 13 +- src/coin-selection/test/Spec.hs | 10 +- 5 files changed, 136 insertions(+), 65 deletions(-) diff --git a/src/base/lib/Convex/BuildTx.hs b/src/base/lib/Convex/BuildTx.hs index 1e5ca37d..8fe080c8 100644 --- a/src/base/lib/Convex/BuildTx.hs +++ b/src/base/lib/Convex/BuildTx.hs @@ -11,11 +11,14 @@ module Convex.BuildTx( -- * Tx Builder TxBuilder(..), -- ** Looking at transaction inputs - TransactionInputs(..), lookupIndexSpending, lookupIndexReference, + lookupIndexMinted, + lookupIndexWithdrawl, findIndexSpending, findIndexReference, + findIndexMinted, + findIndexWithdrawl, buildTx, buildTxWith, -- * Effect @@ -30,7 +33,9 @@ module Convex.BuildTx( evalBuildTxT, -- * Building transactions - addInput, + addInputWithTxBody, + addMintWithTxBody, + addWithdrawalWithTxBody, addReference, addCollateral, addAuxScript, @@ -83,8 +88,8 @@ module Convex.BuildTx( import Cardano.Api.Shelley (Hash, NetworkId, PaymentKey, PlutusScript, PlutusScriptV1, PlutusScriptV2, ScriptData, - ScriptHash, TxBodyContent (..), - WitCtxTxIn, Witness) + ScriptHash, WitCtxTxIn, + Witness) import qualified Cardano.Api.Shelley as C import qualified Cardano.Ledger.Core as CLedger import Control.Lens (_1, _2, at, mapped, over, set, @@ -109,71 +114,78 @@ import Convex.MonadLog (MonadLog (..), MonadLogIgnoreT, import Convex.Scripts (toScriptData) 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 Data.Maybe (fromMaybe, fromJust) import qualified Data.Set as Set import qualified Plutus.V1.Ledger.Api as Plutus -{-| 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) - } +type TxBody = C.TxBodyContent C.BuildTx C.BabbageEra {-| 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 +lookupIndexSpending :: C.TxIn -> TxBody -> Maybe Int +lookupIndexSpending txi = Map.lookupIndex txi . Map.fromList . (fmap (view L._BuildTxWith) <$>) . view L.txIns + +{-| Look up the index of the @TxIn@ in the list of spending inputs. Throws an error if the @TxIn@ is not present. +-} +findIndexSpending :: C.TxIn -> TxBody -> Int +findIndexSpending txi = fromJust . lookupIndexSpending txi {-| 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 +lookupIndexReference :: C.TxIn -> TxBody -> Maybe Int +lookupIndexReference txi = Set.lookupIndex txi . Set.fromList . view (L.txInsReference . L._TxInsReference) -{-| Look up the index of the @TxIn@ in the list of spending inputs +{-| Look up the index of the @TxIn@ in the list of reference inputs. Throws an error if the @TxIn@ is not present. -} -findIndexSpending :: C.TxIn -> TransactionInputs -> Int -findIndexSpending txi = Map.findIndex txi . txiSpendingInputs +findIndexReference :: C.TxIn -> TxBody -> Int +findIndexReference txi = fromJust . lookupIndexReference txi -{-| Look up the index of the @TxIn@ in the list of reference inputs +{-| Look up the index of the @PolicyId@ in the transaction mint. +Note: cardano-api represents a value as a @Map AssetId Quantity@, this is different than the on-chain representation +which is @Map CurrencySymbol (Map TokenName Quantity). +Here, we want to get the index into the on-chain map, but instead index into the cardano-api @Map CurrencySymbol Witness@. +These two indexes should be the same by construction, but it is possible to violate this invariant when building a tx. +-} +lookupIndexMinted :: C.PolicyId -> TxBody -> Maybe Int +lookupIndexMinted policy = Map.lookupIndex policy . view (L.txMintValue . L._TxMintValue . _2) + +{-| Look up the index of the @PolicyId@ in the transaction mint. Throws an error if the @PolicyId@ is not present. -} -findIndexReference :: C.TxIn -> TransactionInputs -> Int -findIndexReference txi = Set.findIndex txi . txiReferenceInputs +findIndexMinted :: C.PolicyId -> TxBody -> Int +findIndexMinted policy = fromJust . lookupIndexMinted policy -{-| A function that modifies the @TxBodyContent@, after seeing the inputs of +{-| Look up the index of the @StakeAddress@ in the list of withdrawls. +-} +lookupIndexWithdrawl :: C.StakeAddress -> TxBody -> Maybe Int +lookupIndexWithdrawl stakeAddress = Set.lookupIndex stakeAddress . Set.fromList . fmap (view _1) . view (L.txWithdrawals . L._TxWithdrawals) + +{-| Look up the index of the @StakeAddress@ in the list of withdrawls. Throws an error if the @StakeAddress@ is not present. +-} +findIndexWithdrawl :: C.StakeAddress -> TxBody -> Int +findIndexWithdrawl stakeAddress = fromJust . lookupIndexWithdrawl stakeAddress + + +{-| +A function that modifies the final @TxBodyContent@, after seeing the @TxBodyContent@ of the entire finished transaction (lazily). -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. +Note that the result of @unTxBuilder txBody@ must not completely force the @txBody@, +or refer to itself circularly. For example, using this to construct a redeemer that contains the whole +@TransactionInputs@ map is going to loop forever. -} -newtype TxBuilder = TxBuilder{ unTxBuilder :: TransactionInputs -> C.TxBodyContent C.BuildTx C.BabbageEra -> C.TxBodyContent C.BuildTx C.BabbageEra } +newtype TxBuilder = TxBuilder{ unTxBuilder :: TxBody -> TxBody -> TxBody } {-| Construct the final @TxBodyContent@ -} -buildTx :: TxBuilder -> C.TxBodyContent C.BuildTx C.BabbageEra +buildTx :: TxBuilder -> TxBody 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 -> TxBody -> TxBody buildTxWith TxBuilder{unTxBuilder} initial = - let mp :: TransactionInputs - mp = mkTxInputs result - result = unTxBuilder mp initial + let result = unTxBuilder result initial in result instance Semigroup TxBuilder where @@ -213,7 +225,7 @@ instance MonadBuildTx m => MonadBuildTx (MonadLogIgnoreT m) where instance MonadBuildTx m => MonadBuildTx (MonadLogKatipT m) where addTxBuilder = lift . addTxBuilder -addBtx :: MonadBuildTx m => (C.TxBodyContent C.BuildTx C.BabbageEra -> C.TxBodyContent C.BuildTx C.BabbageEra) -> m () +addBtx :: MonadBuildTx m => (TxBody -> TxBody) -> m () addBtx = addTxBuilder . TxBuilder . const {-| Monad transformer for the @MonadBuildTx@ effect @@ -282,16 +294,26 @@ execBuildTx = runIdentity . execBuildTxT {-| Run the @BuildTx@ action and produce a transaction body -} -execBuildTx' :: BuildTxT Identity a -> C.TxBodyContent C.BuildTx C.BabbageEra +execBuildTx' :: BuildTxT Identity a -> TxBody execBuildTx' = buildTx . runIdentity . execBuildTxT -{-| Spend an UTxO using the given witness. To avoid an infinite loop when +{-| These functions allow to build the witness for an input/asset/withdrawl +by accessing the final @TxBodyContent@. 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. +itself. For example: @addInputWithTxBody txi (\body -> find (\in -> in == txi) (txInputs body))@ +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) :))) +addInputWithTxBody :: MonadBuildTx m => C.TxIn -> (TxBody -> Witness WitCtxTxIn C.BabbageEra) -> m () +addInputWithTxBody txIn f = addTxBuilder (TxBuilder $ \body -> (over L.txIns ((txIn, C.BuildTxWith $ f body) :))) + +addMintWithTxBody :: MonadBuildTx m => C.PolicyId -> C.AssetName -> C.Quantity -> (TxBody -> C.ScriptWitness C.WitCtxMint C.BabbageEra) -> m () +addMintWithTxBody policy assetName quantity f = + let v = assetValue (C.unPolicyId policy) assetName quantity + in addTxBuilder (TxBuilder $ \body -> (over (L.txMintValue . L._TxMintValue) (over _1 (<> v) . over _2 (Map.insert policy (f body))))) + +addWithdrawalWithTxBody :: MonadBuildTx m => C.StakeAddress -> C.Lovelace -> (TxBody -> C.Witness C.WitCtxStake C.BabbageEra) -> m () +addWithdrawalWithTxBody address amount f = + addTxBuilder (TxBuilder $ \body -> (over (L.txWithdrawals . L._TxWithdrawals) ((address, amount, C.BuildTxWith $ f body) :))) {-| Spend an output locked by a public key -} @@ -324,7 +346,7 @@ spendPlutusV2RefBase :: forall redeemer m. (MonadBuildTx m, Plutus.ToData redeem spendPlutusV2RefBase txIn refTxIn sh dat red = let wit lkp = C.PlutusScriptWitness C.PlutusScriptV2InBabbage C.PlutusScriptV2 (C.PReferenceScript refTxIn sh) dat (toScriptData $ 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) :)) + in setScriptsValid >> addTxBuilder (TxBuilder $ \body -> over L.txIns ((txIn, wit' body) :)) {-| Spend an output locked by a Plutus V2 validator using the redeemer -} diff --git a/src/base/lib/Convex/Lenses.hs b/src/base/lib/Convex/Lenses.hs index e0e05f58..9f925b76 100644 --- a/src/base/lib/Convex/Lenses.hs +++ b/src/base/lib/Convex/Lenses.hs @@ -31,6 +31,7 @@ module Convex.Lenses( _TxMintValue, _TxInsReference, _Value, + _AssetId, _TxOut, _TxOutValue, _ShelleyAddressInBabbageEra, @@ -302,13 +303,19 @@ _TxInsReference = iso from to where [] -> C.TxInsReferenceNone xs -> C.TxInsReference C.ReferenceTxInsScriptsInlineDatumsInBabbageEra xs - _Value :: Iso' Value (Map AssetId Quantity) _Value = iso from to where -- the 'Value' constructor is not exposed so we have to take the long way around from = Map.fromList . C.valueToList to = C.valueFromList . Map.toList +_AssetId :: Prism' C.AssetId (C.PolicyId, C.AssetName) +_AssetId = prism' from to where + from (p, a) = C.AssetId p a + to = \case + C.AssetId p a -> Just (p, a) + _1 -> Nothing + _TxOut :: Iso' (TxOut ctx era) (AddressInEra era, TxOutValue era, TxOutDatum ctx era, ReferenceScript era) _TxOut = iso from to where from (C.TxOut addr vl dt rs) = (addr, vl, dt, rs) diff --git a/src/coin-selection/test/Scripts.hs b/src/coin-selection/test/Scripts.hs index ea65d47d..5146e711 100644 --- a/src/coin-selection/test/Scripts.hs +++ b/src/coin-selection/test/Scripts.hs @@ -4,8 +4,10 @@ -- | Scripts used for testing module Scripts( v2SpendingScript, - matchingIndexScript, - spendMatchingIndex + matchingIndexValidatorScript, + matchingIndexMPScript, + spendMatchingIndex, + mintMatchingIndex ) where import Cardano.Api (TxIn) @@ -27,27 +29,48 @@ unappliedRewardFeeValidator = $$(PlutusTx.compile [|| \_ _ _ -> () ||]) v2SpendingScript :: C.PlutusScript C.PlutusScriptV2 v2SpendingScript = compiledCodeToScript unappliedRewardFeeValidator -matchingIndexCompiled :: CompiledCode (BuiltinData -> BuiltinData -> BuiltinData -> ()) -matchingIndexCompiled = $$(PlutusTx.compile [|| \d r c -> MatchingIndex.validator d r c ||]) +matchingIndexValidatorCompiled :: CompiledCode (BuiltinData -> BuiltinData -> BuiltinData -> ()) +matchingIndexValidatorCompiled = $$(PlutusTx.compile [|| \d r c -> MatchingIndex.validator d r c ||]) + +matchingIndexMPCompiled :: CompiledCode (BuiltinData -> BuiltinData -> ()) +matchingIndexMPCompiled = $$(PlutusTx.compile [|| \r c -> MatchingIndex.mintingPolicy 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 +matchingIndexValidatorScript :: C.PlutusScript C.PlutusScriptV2 +matchingIndexValidatorScript = compiledCodeToScript matchingIndexValidatorCompiled + +matchingIndexMPScript :: C.PlutusScript C.PlutusScriptV2 +matchingIndexMPScript = compiledCodeToScript matchingIndexMPCompiled -{-| Spend an output locked by 'matchingIndexScript', setting +{-| Spend an output locked by 'matchingIndexValidatorScript', setting the redeemer to the index of the input in the final transaction -} spendMatchingIndex :: MonadBuildTx m => TxIn -> m () spendMatchingIndex txi = - let witness lkp = + let witness txBody = C.ScriptWitness C.ScriptWitnessForSpending $ C.PlutusScriptWitness C.PlutusScriptV2InBabbage C.PlutusScriptV2 - (C.PScript matchingIndexScript) + (C.PScript matchingIndexValidatorScript) (C.ScriptDatumForTxIn $ toScriptData ()) - (toScriptData $ fromIntegral @Int @Integer $ BuildTx.findIndexSpending txi lkp) + (toScriptData $ fromIntegral @Int @Integer $ BuildTx.findIndexSpending txi txBody) (C.ExecutionUnits 0 0) - in BuildTx.setScriptsValid >> BuildTx.addInput txi witness + in BuildTx.setScriptsValid >> BuildTx.addInputWithTxBody txi witness + +{-| Mint a token from the 'matchingIndexMPScript', setting +the redeemer to the index of its currency symbol in the final transaction mint +-} +mintMatchingIndex :: MonadBuildTx m => C.PolicyId -> C.AssetName -> C.Quantity -> m () +mintMatchingIndex policy assetName quantity = + let witness txBody = + C.PlutusScriptWitness + C.PlutusScriptV2InBabbage + C.PlutusScriptV2 + (C.PScript matchingIndexMPScript) + (C.NoScriptDatumForMint) + (toScriptData $ fromIntegral @Int @Integer $ BuildTx.findIndexMinted policy txBody) + (C.ExecutionUnits 0 0) + in BuildTx.setScriptsValid >> BuildTx.addMintWithTxBody policy assetName quantity witness diff --git a/src/coin-selection/test/Scripts/MatchingIndex.hs b/src/coin-selection/test/Scripts/MatchingIndex.hs index 7031fcf9..c8cbfa01 100644 --- a/src/coin-selection/test/Scripts/MatchingIndex.hs +++ b/src/coin-selection/test/Scripts/MatchingIndex.hs @@ -8,12 +8,14 @@ {-# LANGUAGE ViewPatterns #-} -- A plutus validator that only succeeds if the redeemer is identical to the script's input index module Scripts.MatchingIndex( - validator + validator + , mintingPolicy ) where import Plutus.V2.Ledger.Contexts (ScriptContext (..), ScriptPurpose (..), TxInInfo (..), TxInfo (..)) +import Plutus.V1.Ledger.Value (flattenValue) import PlutusTx.IsData.Class (UnsafeFromData (unsafeFromBuiltinData)) import PlutusTx.Prelude (BuiltinData) import qualified PlutusTx.Prelude as P @@ -25,3 +27,12 @@ validator _datum (unsafeFromBuiltinData -> idx :: P.Integer) (unsafeFromBuiltinD ownIndex = P.findIndex isOwnIndex txInfoInputs in if ownIndex P.== (P.Just idx) then () else P.traceError "Different indices" validator _ _ _ = P.error () + +{-# INLINABLE mintingPolicy #-} +mintingPolicy :: BuiltinData -> BuiltinData -> () +mintingPolicy (unsafeFromBuiltinData -> idx :: P.Integer) (unsafeFromBuiltinData -> ScriptContext{scriptContextPurpose=Minting ownCs, scriptContextTxInfo=TxInfo{txInfoMint}}) = + let mintList = flattenValue txInfoMint + isOwnIndex (cs,_,_) = cs P.== ownCs + ownIndex = P.findIndex isOwnIndex mintList + in if ownIndex P.== (P.Just idx) then () else P.traceError "Different indices" +mintingPolicy _ _ = P.error () diff --git a/src/coin-selection/test/Spec.hs b/src/coin-selection/test/Spec.hs index 95ea02ab..d673b467 100644 --- a/src/coin-selection/test/Spec.hs +++ b/src/coin-selection/test/Spec.hs @@ -88,6 +88,7 @@ tests = testGroup "unit tests" , 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) + , testCase "mint a token with the matching index minting policy" (mockchainSucceeds $ failOnError matchingIndexMP) ] , testGroup "mockchain" [ testCase "resolveDatumHash" (mockchainSucceeds $ failOnError checkResolveDatumHash) @@ -332,7 +333,7 @@ largeTransactionTest = do matchingIndex :: (MonadMockchain m, MonadError BalanceTxError m) => m () matchingIndex = do - let txBody = execBuildTx' (payToPlutusV2 Defaults.networkId Scripts.matchingIndexScript () C.NoStakeAddress (C.lovelaceToValue 10_000_000)) + let txBody = execBuildTx' (payToPlutusV2 Defaults.networkId Scripts.matchingIndexValidatorScript () 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 @@ -340,3 +341,10 @@ matchingIndex = do -- Spend the outputs in a single transaction void (balanceAndSubmit mempty Wallet.w1 $ execBuildTx' $ traverse_ Scripts.spendMatchingIndex inputs) + +matchingIndexMP :: (MonadMockchain m, MonadError BalanceTxError m) => m () +matchingIndexMP = do + let sh = C.hashScript (C.PlutusScript C.PlutusScriptV2 Scripts.matchingIndexMPScript) + policyId = C.PolicyId sh + runTx assetName = Scripts.mintMatchingIndex policyId assetName 100 + void $ balanceAndSubmit mempty Wallet.w1 $ execBuildTx' $ traverse_ runTx ["assetName1", "assetName2", "assetName3"]