SCP-5027 write web versions of marlowe input functions

input-output-hk · Mar 23, 2023 · 4756a5c · 4756a5c
1 parent a5d996d
commit 4756a5c
Show file tree

Hide file tree

Showing 4 changed files with 375 additions and 3 deletions.
diff --git a/marlowe-integration-tests/marlowe-integration-tests.cabal b/marlowe-integration-tests/marlowe-integration-tests.cabal
@@ -65,6 +65,7 @@ executable marlowe-integration-tests
     Language.Marlowe.Runtime.IntegrationSpec
     Language.Marlowe.Runtime.WebSpec
     Language.Marlowe.Runtime.Web.Common
+    Language.Marlowe.Runtime.Web.StandardContract
     Language.Marlowe.Runtime.Web.GetContracts
     Language.Marlowe.Runtime.Web.GetContract
     Language.Marlowe.Runtime.Web.GetTransactions

diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Common.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Common.hs
@@ -17,16 +17,27 @@ import Control.Monad.IO.Class (MonadIO(liftIO))
 import qualified Data.Set as Set
 import qualified Data.Text as T
 import qualified Language.Marlowe as V1
+import Language.Marlowe.Core.V1.Semantics.Types
+  (ChoiceId(ChoiceId), Input(NormalInput), InputContent(IChoice, IDeposit, INotify))
 import Language.Marlowe.Runtime.Integration.Common
 import Language.Marlowe.Runtime.Transaction.Api (WalletAddresses(..))
 import qualified Language.Marlowe.Runtime.Web as Web
 import Language.Marlowe.Runtime.Web.Client
-  (getContract, getTransaction, postContract, postTransaction, putContract, putTransaction)
+  ( getContract
+  , getTransaction
+  , postContract
+  , postTransaction
+  , postWithdrawal
+  , putContract
+  , putTransaction
+  , putWithdrawal
+  )
 import Language.Marlowe.Runtime.Web.Server.DTO (ToDTO(toDTO))
+import qualified Plutus.V2.Ledger.Api as PV2
 import Servant.Client (ClientM)
 
 createCloseContract :: Wallet -> ClientM Web.TxOutRef
-createCloseContract Wallet{..}= do
+createCloseContract Wallet{..} = do
   let WalletAddresses{..} = addresses
   let webChangeAddress = toDTO changeAddress
   let webExtraAddresses = Set.map toDTO extraAddresses
@@ -67,6 +78,7 @@ applyCloseTransaction  Wallet{..} contractId = do
       , invalidBefore = Nothing
       , invalidHereafter = Nothing
       , inputs = []
+      , tags = mempty
       }
 
   applyTx <- liftIO $ signShelleyTransaction' applyTxBody signingKeys
@@ -95,3 +107,169 @@ waitUntilConfirmed getStatus getResource = do
       liftIO $ threadDelay 1000
       waitUntilConfirmed getStatus getResource
 
+submitContract
+  :: Wallet
+  -> Web.TxOutRef
+  -> Web.TextEnvelope
+  -> ClientM Web.BlockHeader
+submitContract Wallet{..} contractId txBody = do
+  signedCreateTx <- liftIO $ signShelleyTransaction' txBody signingKeys
+  putContract contractId signedCreateTx
+  Web.ContractState{block} <- waitUntilConfirmed (\Web.ContractState{status} -> status) $ getContract contractId
+  liftIO $ expectJust "Expected a block header" block
+
+submitTransaction
+  :: Wallet
+  -> Web.TxOutRef
+  -> Web.TxId
+  -> Web.TextEnvelope
+  -> ClientM Web.BlockHeader
+submitTransaction Wallet{..} contractId transactionId txBody = do
+  signedTx <- liftIO $ signShelleyTransaction' txBody signingKeys
+  putTransaction contractId transactionId signedTx
+  Web.ContractState{block} <- waitUntilConfirmed (\Web.ContractState{status} -> status) $ getContract contractId
+  liftIO $ expectJust "Expected a block header" block
+
+submitWithdrawal
+  :: Wallet
+  -> Web.TxOutRef
+  -> Web.TxId
+  -> Web.TextEnvelope
+  -> ClientM Web.BlockHeader
+submitWithdrawal Wallet{..} contractId transactionId withdrawTxBody  = do
+  signedWithdrawalTx <- liftIO $ signShelleyTransaction' withdrawTxBody signingKeys
+  putWithdrawal transactionId signedWithdrawalTx
+  Web.Tx{block} <- waitUntilConfirmed (\Web.Tx{status} -> status) $ getTransaction contractId transactionId
+  liftIO $ expectJust "Expected a block header" block
+
+deposit
+  :: Wallet
+  -> Web.TxOutRef
+  -> V1.Party
+  -> V1.Party
+  -> V1.Token
+  -> Integer
+  -> ClientM Web.BlockHeader
+deposit Wallet{..} contractId intoAccount fromParty ofToken quantity = do
+  let WalletAddresses{..} = addresses
+  let webChangeAddress = toDTO changeAddress
+  let webExtraAddresses = Set.map toDTO extraAddresses
+  let webCollataralUtxos = Set.map toDTO collateralUtxos
+
+
+  Web.ApplyInputsTxBody{transactionId, txBody = applyTxBody} <- postTransaction
+    webChangeAddress
+    (Just webExtraAddresses)
+    (Just webCollataralUtxos)
+    contractId
+    Web.PostTransactionsRequest
+      { version = Web.V1
+      , metadata = mempty
+      , invalidBefore = Nothing
+      , invalidHereafter = Nothing
+      , inputs = [NormalInput $ IDeposit intoAccount fromParty ofToken quantity]
+      , tags = mempty
+      }
+
+  applyTx <- liftIO $ signShelleyTransaction' applyTxBody signingKeys
+
+  putTransaction contractId transactionId applyTx
+
+  Web.ContractState{block} <- waitUntilConfirmed (\Web.ContractState{status} -> status) $ getContract contractId
+  liftIO $ expectJust "Expected a block header" block
+
+choose
+  :: Wallet
+  -> Web.TxOutRef
+  -> PV2.BuiltinByteString
+  -> V1.Party
+  -> Integer
+  -> ClientM Web.BlockHeader
+choose Wallet{..} contractId choice party chosenNum = do
+  let WalletAddresses{..} = addresses
+  let webChangeAddress = toDTO changeAddress
+  let webExtraAddresses = Set.map toDTO extraAddresses
+  let webCollataralUtxos = Set.map toDTO collateralUtxos
+
+
+  Web.ApplyInputsTxBody{transactionId, txBody = applyTxBody} <- postTransaction
+    webChangeAddress
+    (Just webExtraAddresses)
+    (Just webCollataralUtxos)
+    contractId
+    Web.PostTransactionsRequest
+      { version = Web.V1
+      , metadata = mempty
+      , invalidBefore = Nothing
+      , invalidHereafter = Nothing
+      , inputs = [NormalInput $ IChoice (ChoiceId choice party) chosenNum]
+      , tags = mempty
+      }
+
+  applyTx <- liftIO $ signShelleyTransaction' applyTxBody signingKeys
+
+  putTransaction contractId transactionId applyTx
+
+  Web.ContractState{block} <- waitUntilConfirmed (\Web.ContractState{status} -> status) $ getContract contractId
+  liftIO $ expectJust "Expected a block header" block
+
+notify
+  :: Wallet
+  -> Web.TxOutRef
+  -> ClientM Web.BlockHeader
+notify Wallet{..} contractId = do
+  let WalletAddresses{..} = addresses
+  let webChangeAddress = toDTO changeAddress
+  let webExtraAddresses = Set.map toDTO extraAddresses
+  let webCollataralUtxos = Set.map toDTO collateralUtxos
+
+
+  Web.ApplyInputsTxBody{transactionId, txBody = applyTxBody} <- postTransaction
+    webChangeAddress
+    (Just webExtraAddresses)
+    (Just webCollataralUtxos)
+    contractId
+    Web.PostTransactionsRequest
+      { version = Web.V1
+      , metadata = mempty
+      , invalidBefore = Nothing
+      , invalidHereafter = Nothing
+      , inputs = [NormalInput INotify]
+      , tags = mempty
+      }
+
+  applyTx <- liftIO $ signShelleyTransaction' applyTxBody signingKeys
+
+  putTransaction contractId transactionId applyTx
+
+  Web.ContractState{block} <- waitUntilConfirmed (\Web.ContractState{status} -> status) $ getContract contractId
+  liftIO $ expectJust "Expected a block header" block
+
+withdraw
+  :: Wallet
+  -> Web.TxOutRef
+  -> T.Text
+  -> ClientM Web.BlockHeader
+withdraw Wallet{..} contractId role = do
+  let WalletAddresses{..} = addresses
+  let webChangeAddress = toDTO changeAddress
+  let webExtraAddresses = Set.map toDTO extraAddresses
+  let webCollataralUtxos = Set.map toDTO collateralUtxos
+
+  Web.WithdrawTxBody{withdrawalId, txBody = withdrawTxBody} <- postWithdrawal
+    webChangeAddress
+    (Just webExtraAddresses)
+    (Just webCollataralUtxos)
+    Web.PostWithdrawalsRequest
+      { role
+      , contractId
+      }
+
+  withdrawTx <- liftIO $ signShelleyTransaction' withdrawTxBody signingKeys
+
+  putWithdrawal withdrawalId withdrawTx
+
+  Web.ContractState{block} <- waitUntilConfirmed (\Web.ContractState{status} -> status) $ getContract contractId
+
+  liftIO $ expectJust "Expected a block header" block
+
diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/GetTransactions.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/GetTransactions.hs
@@ -164,7 +164,7 @@ multipleTransactionsValidSpec  = focus $ it "returns a list with multiple Tx hea
     _ <- applyCloseTransaction wallet1 expectedContractId1
     expectedContractId2 <- createCloseContract wallet2
     expectedTxId <- applyCloseTransaction wallet2 expectedContractId2
-    Page {..}<- getTransactions expectedContractId2 Nothing
+    Page {..} <- getTransactions expectedContractId2 Nothing
     liftIO $ fmap (\Web.TxHeader{..} -> transactionId) items `shouldBe` [expectedTxId]