Merge pull request #722 from input-output-hk/plt-6904-ada-role-token

PLT-6904 Marlowe Runtime fails to create transaction involving ada as the role token

marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Basic.hs

@@ -1,147 +1,200 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE RankNTypes #-}
 
 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 (..),
   MarloweVersionTag (..),
   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 (
   ContractCreated (..),
   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]

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.

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 =