From 0b9d680d18dca24c1658aa76f8ab490e2e6f70f3 Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Wed, 27 Sep 2023 16:34:21 -0400 Subject: [PATCH 1/3] Fix building transactions with ADA role tokens --- .../Runtime/Transaction/ConstraintsSpec.hs | 31 ++++++++++++------- .../Runtime/Transaction/Constraints.hs | 11 +++++-- 2 files changed, 28 insertions(+), 14 deletions(-) diff --git a/marlowe-runtime/test/Language/Marlowe/Runtime/Transaction/ConstraintsSpec.hs b/marlowe-runtime/test/Language/Marlowe/Runtime/Transaction/ConstraintsSpec.hs index e549c86f14..562d766584 100644 --- a/marlowe-runtime/test/Language/Marlowe/Runtime/Transaction/ConstraintsSpec.hs +++ b/marlowe-runtime/test/Language/Marlowe/Runtime/Transaction/ConstraintsSpec.hs @@ -16,14 +16,14 @@ import Cardano.Api.Shelley ( ) import Control.Applicative (Alternative) import Control.Arrow (Arrow ((&&&), (***))) -import Control.Error (note) +import Control.Error (catMaybes, note) import Control.Monad (guard) import Data.Bifunctor (Bifunctor (..)) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.Either (fromLeft, isRight) import Data.Foldable (fold) -import Data.Functor ((<&>)) +import Data.Functor (($>), (<&>)) import Data.List (find, isPrefixOf) import Data.Map (Map) import qualified Data.Map as Map @@ -1167,6 +1167,7 @@ mustSpendRoleTokenViolations MarloweV1 utxos TxConstraints{..} TxBodyContent{..} passThroughUtxo = case roleTokenConstraints of SpendRoleTokens roleTokens -> do roleToken <- Set.toList roleTokens + guard $ roleToken /= Chain.AssetId "" "" (("roleToken: " <> show roleToken <> ": ") <>) <$> do let isMatch (_, Chain.TransactionOutput{assets = Chain.Assets{tokens = Chain.Tokens tokens}}) = Map.member roleToken tokens @@ -1410,11 +1411,11 @@ genV1MarloweConstraints = sized \n -> frequency [ (n, resize (n `div` 2) $ (<>) <$> genV1MarloweConstraints <*> genV1MarloweConstraints) , (1, pure mempty) - , (1, mustMintRoleToken <$> arbitrary <*> genMintScriptWitness <*> genRoleToken <*> arbitrary) - , (1, mustSpendRoleToken <$> genRoleToken) + , (1, mustMintRoleToken <$> arbitrary <*> genMintScriptWitness <*> genRoleToken False <*> arbitrary) + , (1, mustSpendRoleToken <$> genRoleToken True) , (1, mustPayToAddress <$> arbitrary <*> arbitrary) , (1, mustSendMarloweOutput <$> arbitrary <*> genDatum) - , (1, mustPayToRole <$> arbitrary <*> genRoleToken) + , (1, mustPayToRole <$> arbitrary <*> genRoleToken True) , (1, uncurry mustConsumeMarloweOutput <$> genValidityInterval <*> genInputs) , (1, requiresSignature <$> arbitrary) , (1, requiresMetadata <$> arbitrary) @@ -1425,7 +1426,7 @@ genV1PayoutConstraints = sized \n -> frequency [ (n, resize (n `div` 2) $ (<>) <$> genV1PayoutConstraints <*> genV1PayoutConstraints) , (1, pure mempty) - , (1, mustSpendRoleToken <$> genRoleToken) + , (1, mustSpendRoleToken <$> genRoleToken True) , (1, mustPayToAddress <$> arbitrary <*> arbitrary) , (1, mustConsumePayout <$> arbitrary) , (1, requiresSignature <$> arbitrary) @@ -1465,11 +1466,16 @@ genMintScriptWitness = <*> (ExecutionUnits <$> (fromIntegral @Word32 <$> arbitrary) <*> (fromIntegral @Word32 <$> arbitrary)) ] -genRoleToken :: Gen Chain.AssetId -genRoleToken = - Chain.AssetId - <$> (hedgehog $ fromCardanoPolicyId . PolicyId <$> genScriptHash) - <*> genRole +genRoleToken :: Bool -> Gen Chain.AssetId +genRoleToken includeAda = + oneof $ + catMaybes + [ pure $ + Chain.AssetId + <$> (hedgehog $ fromCardanoPolicyId . PolicyId <$> genScriptHash) + <*> genRole + , guard includeAda $> pure (Chain.AssetId "" "") + ] -- NOTE just a random list of names that won't conflict with anything generated -- by Gen.Cardano.Api.Typed @@ -1549,7 +1555,8 @@ genPayoutOutputs scriptAddresses TxConstraints{..} = (<>) <$> required <*> arbit where required = Map.fromList <$> for (Set.toList payoutInputConstraints) \payout -> - (payout,) <$> genTransactionOutput (elements scriptAddresses) (Just . toChainPayoutDatum MarloweV1 <$> genRoleToken) + (payout,) + <$> genTransactionOutput (elements scriptAddresses) (Just . toChainPayoutDatum MarloweV1 <$> genRoleToken True) genReferenceScriptUtxo :: Chain.Address -> Gen ReferenceScriptUtxo genReferenceScriptUtxo address = diff --git a/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/Constraints.hs b/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/Constraints.hs index 390955f9c8..69111064ec 100644 --- a/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/Constraints.hs +++ b/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/Constraints.hs @@ -992,7 +992,8 @@ solveInitialTxBodyContent era protocol marloweVersion scriptCtx WalletContext{.. SpendRoleTokens roleTokens -> do let availTuples = map toUTxOTuple . toUTxOsList $ availableUtxos txIns <- - nub <$> forM (Set.toList roleTokens) \token -> do + -- Filter out Ada because we don't need to specifically select an input for an Ada role token. + nub <$> forM (filter (not . isAda) $ Set.toList roleTokens) \token -> do -- Find an element from availTuples where 'token' is in the assets. let containsToken :: Chain.TransactionOutput -> Bool containsToken = Map.member token . Chain.unTokens . Chain.tokens . Chain.assets @@ -1152,7 +1153,9 @@ solveInitialTxBodyContent era protocol marloweVersion scriptCtx WalletContext{.. Nothing SpendRoleTokens roleTokens -> do let availTuples = map toUTxOTuple . toUTxOsList $ availableUtxos - nub <$> forM (Set.toList roleTokens) \token -> do + -- Ignore ada role tokens because we don't specifically select an input for it, and balancing will refund all + -- spent Ada. + nub <$> forM (filter (not . isAda) $ Set.toList roleTokens) \token -> do -- Find an element from availTuples where 'token' is in the assets. let containsToken :: Chain.TransactionOutput -> Bool containsToken = Map.member token . Chain.unTokens . Chain.tokens . Chain.assets @@ -1230,3 +1233,7 @@ solveInitialTxBodyContent era protocol marloweVersion scriptCtx WalletContext{.. C.BuildTxWith $ Map.fromSet (const witness) policyIds _ -> pure C.TxMintNone + +isAda :: Chain.AssetId -> Bool +isAda (Chain.AssetId "" "") = True +isAda _ = False From c90296f3746ccdfda5903cec31aa1544d6efd01f Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Wed, 27 Sep 2023 17:16:34 -0400 Subject: [PATCH 2/3] Add ada role token integration test --- .../Marlowe/Runtime/Integration/Basic.hs | 263 +++++++++++------- 1 file changed, 158 insertions(+), 105 deletions(-) diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Basic.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Basic.hs index 14c424a1de..e48f71a6f0 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Basic.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Basic.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE RankNTypes #-} module Language.Marlowe.Runtime.Integration.Basic where @@ -8,11 +9,22 @@ module Language.Marlowe.Runtime.Integration.Basic where import Cardano.Api (getTxId) import Control.Monad.IO.Class (MonadIO (liftIO)) import qualified Data.Map as Map +import Data.Time (addUTCTime, getCurrentTime, secondsToNominalDiffTime) +import Language.Marlowe.Core.V1.Semantics.Types ( + Action (..), + Bound (..), + Case (..), + ChoiceId (..), + Contract (..), + Input (..), + InputContent (..), + Party (..), + ) import qualified Language.Marlowe.Protocol.HeaderSync.Client as HeaderSync import qualified Language.Marlowe.Protocol.Sync.Client as MarloweSync import Language.Marlowe.Runtime.Cardano.Api (fromCardanoTxId) import Language.Marlowe.Runtime.ChainSync.Api (AssetId (..), TxOutRef (..)) -import Language.Marlowe.Runtime.Client (runMarloweHeaderSyncClient, runMarloweSyncClient) +import Language.Marlowe.Runtime.Client (createContract, runMarloweHeaderSyncClient, runMarloweSyncClient) import Language.Marlowe.Runtime.Core.Api ( ContractId (..), MarloweVersion (..), @@ -20,8 +32,10 @@ import Language.Marlowe.Runtime.Core.Api ( Transaction (..), TransactionOutput (..), TransactionScriptOutput (..), + emptyMarloweTransactionMetadata, ) import Language.Marlowe.Runtime.History.Api (ContractStep (..), RedeemStep (..)) +import Language.Marlowe.Runtime.Integration.ApplyInputs (utcTimeToPOSIXTime) import Language.Marlowe.Runtime.Integration.Common import Language.Marlowe.Runtime.Integration.StandardContract import Language.Marlowe.Runtime.Transaction.Api ( @@ -29,119 +43,158 @@ import Language.Marlowe.Runtime.Transaction.Api ( ContractCreatedInEra (..), InputsApplied (..), InputsAppliedInEra (..), + RoleTokensConfig (..), WithdrawTx (..), WithdrawTxInEra (..), ) -import Test.Hspec (Spec, it, shouldBe) +import Test.Hspec (Spec, describe, it, shouldBe) import Test.Integration.Marlowe.Local (withLocalMarloweRuntime) spec :: Spec -spec = it "Basic e2e scenario" $ withLocalMarloweRuntime $ runIntegrationTest do - partyAWallet <- getGenesisWallet 0 - partyBWallet <- getGenesisWallet 1 - let -- 1. Start MarloweHeaderSyncClient (request next) - startDiscoveryClient :: Integration TxOutRef - startDiscoveryClient = runMarloweHeaderSyncClient $ - HeaderSync.MarloweHeaderSyncClient $ - pure - -- 2. Expect wait - $ - headerSyncRequestNextExpectWait do - -- 3. Create standard contract - contract@StandardContractInit{..} <- createStandardContract partyAWallet partyBWallet - -- 4. Poll - -- 5. Expect new headers - headerSyncPollExpectNewHeaders createdBlock [contractCreatedToContractHeader createdBlock contractCreated] $ - continueWithNewHeaders contract +spec = describe "Basic scenarios" do + it "Basic e2e scenario" $ withLocalMarloweRuntime $ runIntegrationTest do + partyAWallet <- getGenesisWallet 0 + partyBWallet <- getGenesisWallet 1 + let -- 1. Start MarloweHeaderSyncClient (request next) + startDiscoveryClient :: Integration TxOutRef + startDiscoveryClient = runMarloweHeaderSyncClient $ + HeaderSync.MarloweHeaderSyncClient $ + pure + -- 2. Expect wait + $ + headerSyncRequestNextExpectWait do + -- 3. Create standard contract + contract@StandardContractInit{..} <- createStandardContract partyAWallet partyBWallet + -- 4. Poll + -- 5. Expect new headers + headerSyncPollExpectNewHeaders createdBlock [contractCreatedToContractHeader createdBlock contractCreated] $ + continueWithNewHeaders contract - -- 6. RequestNext (header sync) - -- 7. Expect Wait - continueWithNewHeaders contract = pure $ HeaderSync.SendMsgRequestNext $ headerSyncExpectWait do - -- 8. Deposit funds - fundsDeposited <- makeInitialDeposit contract - txOutRef <- runMarloweSyncClient $ marloweSyncClient contract fundsDeposited - -- 33. Poll - -- 34. Expect wait - -- 35. Cancel - -- 36. Done - pure $ HeaderSync.SendMsgPoll $ headerSyncExpectWait $ pure $ HeaderSync.SendMsgCancel $ HeaderSync.SendMsgDone txOutRef + -- 6. RequestNext (header sync) + -- 7. Expect Wait + continueWithNewHeaders contract = pure $ HeaderSync.SendMsgRequestNext $ headerSyncExpectWait do + -- 8. Deposit funds + fundsDeposited <- makeInitialDeposit contract + txOutRef <- runMarloweSyncClient $ marloweSyncClient contract fundsDeposited + -- 33. Poll + -- 34. Expect wait + -- 35. Cancel + -- 36. Done + pure $ HeaderSync.SendMsgPoll $ headerSyncExpectWait $ pure $ HeaderSync.SendMsgCancel $ HeaderSync.SendMsgDone txOutRef - -- 9. Start MarloweSyncClient (follow contract) - marloweSyncClient - :: StandardContractInit 'V1 - -> StandardContractFundsDeposited 'V1 - -> MarloweSync.MarloweSyncClient Integration TxOutRef - marloweSyncClient StandardContractInit{..} StandardContractFundsDeposited{..} = MarloweSync.MarloweSyncClient do - let ContractCreated _ ContractCreatedInEra{contractId, rolesCurrency} = contractCreated - pure $ - MarloweSync.SendMsgFollowContract contractId - -- 10. Expect contract found - $ - marloweSyncExpectContractFound \actualBlock MarloweV1 createStep -> do - liftIO $ actualBlock `shouldBe` createdBlock - liftIO $ createStep `shouldBe` contractCreatedToCreateStep contractCreated - -- 11. Request next - -- 12. Expect roll forward with deposit - marloweSyncRequestNextExpectRollForward - initialDepositBlock - [ApplyTransaction $ inputsAppliedToTransaction initialDepositBlock initialFundsDeposited] - do - -- 13. Request next - -- 14. Expect wait, poll, expect wait - pure $ marloweSyncRequestNextExpectWait $ pure $ marloweSyncPollExpectWait do - -- 15. Make choice as party B - StandardContractChoiceMade{..} <- chooseGimmeTheMoney - -- 16. Poll - -- 17. Expect roll forward with choice - marloweSyncPollExpectRollForward - choiceBlock - [ApplyTransaction $ inputsAppliedToTransaction choiceBlock gimmeTheMoneyChosen] - do - -- 18. Request next - -- 19. Expect wait - pure $ marloweSyncRequestNextExpectWait do - -- 20. Notify - StandardContractNotified{..} <- sendNotify + -- 9. Start MarloweSyncClient (follow contract) + marloweSyncClient + :: StandardContractInit 'V1 + -> StandardContractFundsDeposited 'V1 + -> MarloweSync.MarloweSyncClient Integration TxOutRef + marloweSyncClient StandardContractInit{..} StandardContractFundsDeposited{..} = MarloweSync.MarloweSyncClient do + let ContractCreated _ ContractCreatedInEra{contractId, rolesCurrency} = contractCreated + pure $ + MarloweSync.SendMsgFollowContract contractId + -- 10. Expect contract found + $ + marloweSyncExpectContractFound \actualBlock MarloweV1 createStep -> do + liftIO $ actualBlock `shouldBe` createdBlock + liftIO $ createStep `shouldBe` contractCreatedToCreateStep contractCreated + -- 11. Request next + -- 12. Expect roll forward with deposit + marloweSyncRequestNextExpectRollForward + initialDepositBlock + [ApplyTransaction $ inputsAppliedToTransaction initialDepositBlock initialFundsDeposited] + do + -- 13. Request next + -- 14. Expect wait, poll, expect wait + pure $ marloweSyncRequestNextExpectWait $ pure $ marloweSyncPollExpectWait do + -- 15. Make choice as party B + StandardContractChoiceMade{..} <- chooseGimmeTheMoney + -- 16. Poll + -- 17. Expect roll forward with choice + marloweSyncPollExpectRollForward + choiceBlock + [ApplyTransaction $ inputsAppliedToTransaction choiceBlock gimmeTheMoneyChosen] + do + -- 18. Request next + -- 19. Expect wait + pure $ marloweSyncRequestNextExpectWait do + -- 20. Notify + StandardContractNotified{..} <- sendNotify - -- 21. Deposit as party B - StandardContractClosed{..} <- makeReturnDeposit + -- 21. Deposit as party B + StandardContractClosed{..} <- makeReturnDeposit - -- 22. Withdraw as party A - (WithdrawTx _ WithdrawTxInEra{txBody = withdrawTxBody}, withdrawBlock) <- withdrawPartyAFunds + -- 22. Withdraw as party A + (WithdrawTx _ WithdrawTxInEra{txBody = withdrawTxBody}, withdrawBlock) <- withdrawPartyAFunds - -- 23. Poll - -- 24. Expect roll forward with notify - marloweSyncPollExpectRollForward notifiedBlock [ApplyTransaction $ inputsAppliedToTransaction notifiedBlock notified] do - let depositTransaction@Transaction{output = TransactionOutput{payouts}} = inputsAppliedToTransaction returnDepositBlock returnDeposited - -- 25. Request next - -- 26. Expect roll forward with deposit - marloweSyncRequestNextExpectRollForward returnDepositBlock [ApplyTransaction depositTransaction] do - -- 27. Request next - -- 28. Expect roll forward with withdraw - payoutTxOutRef <- expectJust "Failed to extract payout from deposit" case Map.toList payouts of - [(txOutRef, _)] -> Just txOutRef - _ -> Nothing - let withdrawTxId' = fromCardanoTxId $ getTxId withdrawTxBody - marloweSyncRequestNextExpectRollForward - withdrawBlock - [RedeemPayout $ RedeemStep payoutTxOutRef withdrawTxId' $ AssetId rolesCurrency "Party A"] - do - -- 29. Request next (marlowe sync) - -- 30. Expect wait - -- 31. Cancel - -- 32. Done - let InputsApplied _ InputsAppliedInEra{output} = notified - TransactionScriptOutput{utxo = notifyTxOutRef} <- expectJust "Failed to obtain deposit output" $ scriptOutput output - pure $ marloweSyncRequestNextExpectWait $ pure $ MarloweSync.SendMsgCancel $ MarloweSync.SendMsgDone notifyTxOutRef + -- 23. Poll + -- 24. Expect roll forward with notify + marloweSyncPollExpectRollForward notifiedBlock [ApplyTransaction $ inputsAppliedToTransaction notifiedBlock notified] do + let depositTransaction@Transaction{output = TransactionOutput{payouts}} = inputsAppliedToTransaction returnDepositBlock returnDeposited + -- 25. Request next + -- 26. Expect roll forward with deposit + marloweSyncRequestNextExpectRollForward returnDepositBlock [ApplyTransaction depositTransaction] do + -- 27. Request next + -- 28. Expect roll forward with withdraw + payoutTxOutRef <- expectJust "Failed to extract payout from deposit" case Map.toList payouts of + [(txOutRef, _)] -> Just txOutRef + _ -> Nothing + let withdrawTxId' = fromCardanoTxId $ getTxId withdrawTxBody + marloweSyncRequestNextExpectRollForward + withdrawBlock + [RedeemPayout $ RedeemStep payoutTxOutRef withdrawTxId' $ AssetId rolesCurrency "Party A"] + do + -- 29. Request next (marlowe sync) + -- 30. Expect wait + -- 31. Cancel + -- 32. Done + let InputsApplied _ InputsAppliedInEra{output} = notified + TransactionScriptOutput{utxo = notifyTxOutRef} <- expectJust "Failed to obtain deposit output" $ scriptOutput output + pure $ marloweSyncRequestNextExpectWait $ pure $ MarloweSync.SendMsgCancel $ MarloweSync.SendMsgDone notifyTxOutRef + + txOutRef <- startDiscoveryClient + -- 37. Start MarloweSyncClient (follow a tx in the contract) + -- 38. Expect contract not found + runMarloweSyncClient $ + MarloweSync.MarloweSyncClient $ + pure $ + MarloweSync.SendMsgFollowContract (ContractId txOutRef) $ + MarloweSync.ClientStFollow + { recvMsgContractFound = \_ _ _ -> fail "Expected contract not found, got contract found" + , recvMsgContractNotFound = pure () + } - txOutRef <- startDiscoveryClient - -- 37. Start MarloweSyncClient (follow a tx in the contract) - -- 38. Expect contract not found - runMarloweSyncClient $ - MarloweSync.MarloweSyncClient $ - pure $ - MarloweSync.SendMsgFollowContract (ContractId txOutRef) $ - MarloweSync.ClientStFollow - { recvMsgContractFound = \_ _ _ -> fail "Expected contract not found, got contract found" - , recvMsgContractNotFound = pure () - } + -- This is an adaptation of https://nbviewer.org/gist/bwbush/4e8a7196902bfdb0f7f6f7f4a6e3e643 + it "PLT-6904 ADA role tokens" $ withLocalMarloweRuntime $ runIntegrationTest do + wallet <- getGenesisWallet 0 + now <- liftIO getCurrentTime + let deadline = addUTCTime (secondsToNominalDiffTime $ 30 * 60) now + contract = + When + [ Case (Choice (ChoiceId "Option A" $ Role "") [Bound 1 1]) Close + ] + (utcTimeToPOSIXTime deadline) + Close + ContractCreated era0 created <- + expectRight "Failed to create contract" + =<< createContract + Nothing + MarloweV1 + (wallet.addresses) + (RoleTokensUsePolicy "") + emptyMarloweTransactionMetadata + 2_000_000 + (Left contract) + _ <- submit wallet era0 created.txBody + InputsApplied era1 applied <- + choose wallet created.contractId "Option A" (Role "") 1 + _ <- submit wallet era1 applied.txBody + liftIO do + applied.input + `shouldBe` TransactionScriptOutput + { address = created.marloweScriptAddress + , assets = created.assets + , utxo = unContractId created.contractId + , datum = created.datum + } + applied.output.payouts `shouldBe` mempty + applied.output.scriptOutput `shouldBe` Nothing + applied.inputs `shouldBe` [NormalInput $ IChoice (ChoiceId "Option A" $ Role "") 1] From 5eb2ab12e02e9da50b76d546a7119ca2e14e2f6a Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Thu, 28 Sep 2023 12:12:31 -0400 Subject: [PATCH 3/3] Update changelog --- .../20230928_121137_jhbertra_plt_6904_ada_role_token.md | 3 +++ 1 file changed, 3 insertions(+) create mode 100644 marlowe-runtime/changelog.d/20230928_121137_jhbertra_plt_6904_ada_role_token.md diff --git a/marlowe-runtime/changelog.d/20230928_121137_jhbertra_plt_6904_ada_role_token.md b/marlowe-runtime/changelog.d/20230928_121137_jhbertra_plt_6904_ada_role_token.md new file mode 100644 index 0000000000..0316570018 --- /dev/null +++ b/marlowe-runtime/changelog.d/20230928_121137_jhbertra_plt_6904_ada_role_token.md @@ -0,0 +1,3 @@ +### Fixed + +- Building a transaction for a contract that uses ADA role tokens fails.