added Role Web API/Server/Client + integration tests

marlowe-client/src/Control/Monad/Trans/Marlowe/Class.hs

@@ -2,13 +2,37 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE RankNTypes #-}
 
-module Control.Monad.Trans.Marlowe.Class where
+module Control.Monad.Trans.Marlowe.Class (
+  MonadMarlowe (..),
+  runClientStreaming,
+  runMarloweSyncClient,
+  runMarloweHeaderSyncClient,
+  runMarloweBulkSyncClient,
+  runMarloweQueryClient,
+  runContractQueryClient,
+  runMarloweLoadClient,
+  runMarloweTransferClient,
+  runMarloweTxClient,
+  loadContract,
+  createContract,
+  applyInputs,
+  applyInputs',
+  withdraw,
+  buildBurnRoleTokensTx,
+  submitAndWait,
+  submitAndDetach,
+  submit,
+  attachSubmit,
+) where
 
 import Cardano.Api (BabbageEraOnwards, Tx)
 import Control.Concurrent (threadDelay)
 import Control.Monad (join)
 import Control.Monad.Identity (IdentityT (..))
-import Control.Monad.Trans.Marlowe
+import Control.Monad.Trans.Marlowe (
+  MarloweT (MarloweT),
+  runMarloweT,
+ )
 import Control.Monad.Trans.Reader (ReaderT (..))
 import Control.Monad.Trans.Resource.Internal (ResourceT (..))
 import Data.Coerce (coerce)
@@ -48,8 +72,8 @@ import Language.Marlowe.Runtime.Core.Api (
 import Language.Marlowe.Runtime.Transaction.Api (
   Account,
   ApplyInputsError,
-  BurnError,
-  BurnTx,
+  BurnRoleTokensError,
+  BurnRoleTokensTx,
   ContractCreated,
   CreateError,
   InputsApplied,
@@ -310,16 +334,18 @@ withdraw
 withdraw version wallet payouts =
   runMarloweTxClient $ liftCommand $ Withdraw version wallet payouts
 
--- | Withdraw funds that have been paid out to a role in a contract.
-burn
+-- | Burn role tokens.
+buildBurnRoleTokensTx
   :: (MonadMarlowe m)
-  => WalletAddresses
+  => MarloweVersion v
+  -- ^ The Marlowe version to use
+  -> WalletAddresses
   -- ^ The wallet addresses to use when constructing the transaction.
   -> RoleTokenFilter
   -- ^ A filter that identifies which role tokens to burn.
-  -> m (Either BurnError BurnTx)
-burn wallet tFilter =
-  runMarloweTxClient $ liftCommand $ Burn wallet tFilter
+  -> m (Either BurnRoleTokensError (BurnRoleTokensTx v))
+buildBurnRoleTokensTx version wallet tFilter =
+  runMarloweTxClient $ liftCommand $ BurnRoleTokens version wallet tFilter
 
 -- | Submit a signed transaction via the Marlowe Runtime. Waits for completion
 -- with exponential back-off in the polling.

marlowe-client/src/Language/Marlowe/Runtime/Client.hs

@@ -9,7 +9,7 @@ module Language.Marlowe.Runtime.Client (
   connectToMarloweRuntimeTraced,
 ) where
 
-import Control.Monad.Event.Class
+import Control.Monad.Event.Class (MonadEvent)
 import Control.Monad.Trans.Marlowe
 import Control.Monad.Trans.Marlowe.Class
 import Language.Marlowe.Protocol.Client (marloweRuntimeClientPeer)

marlowe-client/src/Language/Marlowe/Runtime/Client/Transfer.hs

@@ -8,9 +8,36 @@ module Language.Marlowe.Runtime.Client.Transfer (
 ) where
 
 import Data.Map (Map)
-import Language.Marlowe.Object.Types
-import Language.Marlowe.Protocol.Transfer.Client
-import Language.Marlowe.Protocol.Transfer.Types
+import Language.Marlowe.Object.Types (
+  Label,
+  ObjectBundle (ObjectBundle),
+ )
+import Language.Marlowe.Protocol.Transfer.Client (
+  ClientStCanDownload (SendMsgDownload),
+  ClientStCanUpload (SendMsgImported, SendMsgUpload),
+  ClientStDownload (
+    ClientStDownload,
+    recvMsgDownloaded,
+    recvMsgExported
+  ),
+  ClientStExport (
+    ClientStExport,
+    recvMsgContractNotFound,
+    recvMsgStartExport
+  ),
+  ClientStIdle (
+    SendMsgDone,
+    SendMsgRequestExport,
+    SendMsgStartImport
+  ),
+  ClientStUpload (
+    ClientStUpload,
+    recvMsgUploadFailed,
+    recvMsgUploaded
+  ),
+  MarloweTransferClient (MarloweTransferClient),
+ )
+import Language.Marlowe.Protocol.Transfer.Types (ImportError)
 import Language.Marlowe.Runtime.ChainSync.Api (DatumHash)
 import Numeric.Natural (Natural)
 import Pipes (Pipe, Producer, await, yield)

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

@@ -4,7 +4,59 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE RecursiveDo #-}
 
-module Language.Marlowe.Runtime.Integration.Common where
+module Language.Marlowe.Runtime.Integration.Common (
+  allocateWallet,
+  contractCreatedToContractHeader,
+  marloweSyncRequestNextExpectWait,
+  contractCreatedToCreateStep,
+  expectLeft,
+  expectJust,
+  expectRight,
+  getGenesisWallet,
+  getStakeCredential,
+  getTip,
+  getUTxO,
+  inputsAppliedToTransaction,
+  retryDelayMicroSeconds,
+  runIntegrationTest,
+  submitBuilder,
+  submit',
+  testnet,
+  timeout,
+  Wallet (..),
+  withCurrentEra,
+  withdraw,
+  notify,
+  buildBurnRoleTokensTx,
+  choose,
+  deposit,
+  submit,
+  bulkSyncRequestNextNExpectRollForward,
+  bulkSyncRequestNextExpectRollForward,
+  bulkSyncPollExpectWait,
+  bulkSyncRequestNextExpectWait,
+  headerSyncRequestNextExpectWait,
+  headerSyncPollExpectNewHeaders,
+  headerSyncRequestNextExpectNewHeaders,
+  headerSyncPollExpectWait,
+  headerSyncExpectWait,
+  Integration,
+  bulkSyncPollExpectRollForward,
+  marloweSyncExpectContractFound,
+  marloweSyncExpectRollForward,
+  headerSyncIntersectExpectNotFound,
+  headerSyncIntersectExpectFound,
+  marloweSyncIntersectExpectNotFound,
+  marloweSyncIntersectExpectFound,
+  marloweSyncPollExpectRollForward,
+  marloweSyncPollExpectWait,
+  marloweSyncRequestNextExpectRollForward,
+  prepareCliArgs,
+  execMarlowe,
+  execMarlowe_,
+  execMarlowe',
+  runWebClient,
+) where
 
 import Cardano.Api (
   AddressAny (AddressShelley),
@@ -40,6 +92,13 @@ import qualified Control.Monad.Reader as Reader
 import Control.Monad.Reader.Class (asks)
 import Control.Monad.State (StateT, runStateT, state)
 import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.Marlowe (MarloweT, runMarloweT)
+import Control.Monad.Trans.Marlowe.Class (
+  applyInputs,
+  runMarloweHeaderSyncClient,
+  runMarloweSyncClient,
+  runMarloweTxClient,
+ )
 import Data.Aeson (FromJSON (..), Value (..), decodeFileStrict, eitherDecodeStrict)
 import Data.Aeson.Types (parseFail)
 import Data.ByteString (ByteString)
@@ -83,14 +142,6 @@ import Language.Marlowe.Runtime.ChainSync.Api (
   fromBech32,
  )
 import qualified Language.Marlowe.Runtime.ChainSync.Api as Chain
-import Language.Marlowe.Runtime.Client (
-  MarloweT,
-  applyInputs,
-  runMarloweHeaderSyncClient,
-  runMarloweSyncClient,
-  runMarloweT,
-  runMarloweTxClient,
- )
 import qualified Language.Marlowe.Runtime.Client as Client
 import Language.Marlowe.Runtime.Core.Api (
   ContractId (..),
@@ -104,7 +155,7 @@ import Language.Marlowe.Runtime.Core.Api (
 import Language.Marlowe.Runtime.Discovery.Api (ContractHeader (..))
 import Language.Marlowe.Runtime.History.Api (ContractStep, CreateStep (..), MarloweBlock)
 import Language.Marlowe.Runtime.Transaction.Api (
-  BurnTx,
+  BurnRoleTokensTx,
   ContractCreated (..),
   ContractCreatedInEra (..),
   InputsApplied (..),
@@ -424,13 +475,13 @@ withdraw Wallet{..} payouts = do
   result <- Client.withdraw MarloweV1 addresses payouts
   expectRight "Failed to create withdraw transaction" result
 
-burn
+buildBurnRoleTokensTx
   :: Wallet
   -> RoleTokenFilter
-  -> Integration BurnTx
-burn Wallet{..} tokenFilter = do
-  result <- Client.burn addresses tokenFilter
-  expectRight "Failed to create burn transaction" result
+  -> Integration (BurnRoleTokensTx 'V1)
+buildBurnRoleTokensTx Wallet{..} tokenFilter = do
+  result <- Client.buildBurnRoleTokensTx MarloweV1 addresses tokenFilter
+  expectRight "Failed to create burn Role Tokens transaction" result
 
 timeout :: NominalDiffTime
 timeout = secondsToNominalDiffTime 2

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

@@ -42,7 +42,7 @@ import Language.Marlowe.Runtime.Integration.StandardContract (
     initialDepositBlock,
     initialFundsDeposited
   ),
-  StandardContractInit (..),
+  StandardContractLifecycleInit (..),
   StandardContractNotified (
     StandardContractNotified,
     makeReturnDeposit,
@@ -112,8 +112,8 @@ spec = it "Intersections" $ withLocalMarloweRuntime $ runIntegrationTest do
   marloweSyncIntersectExpectNotFound (ContractId $ TxOutRef txIdA1 1) [pA1, pA2, pA3, pA4, pA5]
 
 completeContract
-  :: StandardContractInit v -> Integration (BlockHeader, TxId, BlockHeader, BlockHeader, BlockHeader, BlockHeader)
-completeContract StandardContractInit{..} = do
+  :: StandardContractLifecycleInit v -> Integration (BlockHeader, TxId, BlockHeader, BlockHeader, BlockHeader, BlockHeader)
+completeContract StandardContractLifecycleInit{..} = do
   StandardContractFundsDeposited{..} <- makeInitialDeposit
   StandardContractChoiceMade{..} <- chooseGimmeTheMoney
   StandardContractNotified{..} <- sendNotify

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

@@ -330,8 +330,8 @@ payoutContract = \case
   Payout2 -> Contract2
   Payout3 -> Contract3
 
-standardContractRoleCurrency :: StandardContractInit 'V1 -> PolicyId
-standardContractRoleCurrency StandardContractInit{..} = case contractCreated of
+standardContractRoleCurrency :: StandardContractLifecycleInit 'V1 -> PolicyId
+standardContractRoleCurrency StandardContractLifecycleInit{..} = case contractCreated of
   ContractCreated _ ContractCreatedInEra{..} -> rolesCurrency
 
 data PartyAddress = Wallet1 | Wallet2
@@ -498,7 +498,7 @@ evalTestRoleCurrencyFilter MarloweQueryTestData{..} = go
         , (Known Contract4, standardContractRoleCurrency' contract4 True)
         ]
 
-standardContractRoleCurrency' :: StandardContractInit 'V1 -> Bool -> RoleCurrency
+standardContractRoleCurrency' :: StandardContractLifecycleInit 'V1 -> Bool -> RoleCurrency
 standardContractRoleCurrency' contract active =
   RoleCurrency
     { rolePolicyId = standardContractRoleCurrency contract
@@ -560,24 +560,24 @@ data MarloweQueryTestData = MarloweQueryTestData
   { runtime :: MarloweRuntime
   , wallet1 :: Wallet
   , wallet2 :: Wallet
-  , contract1 :: StandardContractInit 'V1
+  , contract1 :: StandardContractLifecycleInit 'V1
   , contract1Step1 :: StandardContractFundsDeposited 'V1
   , contract1Step2 :: StandardContractChoiceMade 'V1
   , contract1Step3 :: StandardContractNotified 'V1
   , contract1Step4 :: StandardContractClosed 'V1
   , contract1Step5 :: (WithdrawTx 'V1, BlockHeader)
-  , contract2 :: StandardContractInit 'V1
+  , contract2 :: StandardContractLifecycleInit 'V1
   , contract2Step1 :: StandardContractFundsDeposited 'V1
   , contract2Step2 :: StandardContractChoiceMade 'V1
   , contract2Step3 :: StandardContractNotified 'V1
   , contract2Step4 :: StandardContractClosed 'V1
   , contract2Step5 :: (WithdrawTx 'V1, BlockHeader)
-  , contract3 :: StandardContractInit 'V1
+  , contract3 :: StandardContractLifecycleInit 'V1
   , contract3Step1 :: StandardContractFundsDeposited 'V1
   , contract3Step2 :: StandardContractChoiceMade 'V1
   , contract3Step3 :: StandardContractNotified 'V1
   , contract3Step4 :: StandardContractClosed 'V1
-  , contract4 :: StandardContractInit 'V1
+  , contract4 :: StandardContractLifecycleInit 'V1
   }
 
 data TxNo
@@ -856,7 +856,7 @@ txNoToTxId testData = inputsAppliedTxId . txNoToInputsApplied testData
 inputsAppliedTxId :: InputsApplied v -> TxId
 inputsAppliedTxId (InputsApplied _ InputsAppliedInEra{..}) = fromCardanoTxId $ getTxId txBody
 
-contractNoToStandardContract :: MarloweQueryTestData -> RefSym GetHeaders -> StandardContractInit 'V1
+contractNoToStandardContract :: MarloweQueryTestData -> RefSym GetHeaders -> StandardContractLifecycleInit 'V1
 contractNoToStandardContract MarloweQueryTestData{..} = \case
   Contract1 -> contract1
   Contract2 -> contract2