SCP-5027 finished writing marlowe input application functions for web…

… api
input-output-hk · Mar 21, 2023 · 92e8351 · 92e8351
1 parent 5fa94ce
commit 92e8351
Show file tree

Hide file tree

Showing 3 changed files with 197 additions and 274 deletions.
diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Common.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Common.hs
@@ -25,6 +25,7 @@ import qualified Language.Marlowe.Runtime.Web as Web
 import Language.Marlowe.Runtime.Web.Client
   ( getContract
   , getTransaction
+  , getWithdrawal
   , postContract
   , postTransaction
   , postWithdrawal
@@ -88,58 +89,34 @@ applyCloseTransaction  Wallet{..} contractId = do
   _ <- waitUntilConfirmed (\Web.Tx{status} -> status) $ getTransaction contractId transactionId
   pure transactionId
 
-
-signShelleyTransaction' :: Web.TextEnvelope -> [ShelleyWitnessSigningKey] -> IO Web.TextEnvelope
-signShelleyTransaction' Web.TextEnvelope{..} wits = do
-  let te = TextEnvelope { teType = TextEnvelopeType (T.unpack teType), teDescription = TextEnvelopeDescr (T.unpack teDescription), teRawCBOR = Web.unBase16 teCborHex }
-  txBody <- case deserialiseFromTextEnvelope (AsTxBody AsBabbage) te of
-    Left err -> fail $ show err
-    Right a -> pure a
-  pure case serialiseToTextEnvelope Nothing $ signShelleyTransaction txBody wits of
-    TextEnvelope (TextEnvelopeType ty) _ bytes -> Web.TextEnvelope (T.pack ty) "" $ Web.Base16 bytes
-
-waitUntilConfirmed :: MonadIO m => (a -> Web.TxStatus) -> m a -> m a
-waitUntilConfirmed getStatus getResource = do
-  resource <- getResource
-  case getStatus resource of
-    Web.Confirmed -> pure resource
-    _ -> do
-      liftIO $ threadDelay 1000
-      waitUntilConfirmed getStatus getResource
-
 submitContract
   :: Wallet
-  -> Web.TxOutRef
-  -> Web.TextEnvelope
+  -> Web.CreateTxBody
   -> ClientM Web.BlockHeader
-submitContract Wallet{..} contractId txBody = do
+submitContract Wallet{..} Web.CreateTxBody{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
+  -> Web.ApplyInputsTxBody
   -> ClientM Web.BlockHeader
-submitTransaction Wallet{..} contractId transactionId txBody = do
+submitTransaction Wallet{..} Web.ApplyInputsTxBody{contractId, transactionId, txBody} = do
   signedTx <- liftIO $ signShelleyTransaction' txBody signingKeys
   putTransaction contractId transactionId signedTx
-  Web.ContractState{block} <- waitUntilConfirmed (\Web.ContractState{status} -> status) $ getContract contractId
+  Web.Tx{block} <- waitUntilConfirmed (\Web.Tx{status} -> status) $ getTransaction contractId transactionId
   liftIO $ expectJust "Expected a block header" block
 
 submitWithdrawal
   :: Wallet
-  -> Web.TxOutRef
-  -> Web.TxId
-  -> Web.TextEnvelope
+  -> Web.WithdrawTxBody
   -> ClientM Web.BlockHeader
-submitWithdrawal Wallet{..} contractId transactionId withdrawTxBody  = do
+submitWithdrawal Wallet{..} Web.WithdrawTxBody{withdrawalId, txBody = withdrawTxBody}  = do
   signedWithdrawalTx <- liftIO $ signShelleyTransaction' withdrawTxBody signingKeys
-  putWithdrawal transactionId signedWithdrawalTx
-  Web.Tx{block} <- waitUntilConfirmed (\Web.Tx{status} -> status) $ getTransaction contractId transactionId
+  putWithdrawal withdrawalId signedWithdrawalTx
+  Web.Withdrawal{block} <- waitUntilConfirmed (\Web.Withdrawal{status} -> status) $ getWithdrawal withdrawalId
   liftIO $ expectJust "Expected a block header" block
 
 deposit
@@ -149,82 +126,57 @@ deposit
   -> 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
+  -> ClientM Web.ApplyInputsTxBody
+deposit wallet contractId intoAccount fromParty ofToken quantity =
+  applyInputs wallet contractId [NormalInput $ IDeposit intoAccount fromParty ofToken quantity]
 
 choose
   :: Wallet
   -> Web.TxOutRef
   -> PV2.BuiltinByteString
   -> V1.Party
   -> Integer
-  -> ClientM Web.BlockHeader
-choose Wallet{..} contractId choice party chosenNum = do
+  -> ClientM Web.ApplyInputsTxBody
+choose wallet contractId choice party chosenNum =
+  applyInputs wallet contractId [NormalInput $ IChoice (ChoiceId choice party) chosenNum]
+
+notify
+  :: Wallet
+  -> Web.TxOutRef
+  -> ClientM Web.ApplyInputsTxBody
+notify wallet contractId = applyInputs wallet contractId [NormalInput INotify]
+
+withdraw
+  :: Wallet
+  -> Web.TxOutRef
+  -> T.Text
+  -> ClientM Web.WithdrawTxBody
+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.ApplyInputsTxBody{transactionId, txBody = applyTxBody} <- postTransaction
+  postWithdrawal
     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
+    Web.PostWithdrawalsRequest
+      { role
+      , contractId
       }
-
-  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
+applyInputs
   :: Wallet
   -> Web.TxOutRef
-  -> ClientM Web.BlockHeader
-notify Wallet{..} contractId = do
+  -> [V1.Input]
+  -> ClientM Web.ApplyInputsTxBody
+applyInputs Wallet{..} contractId inputs = 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
+  postTransaction
     webChangeAddress
     (Just webExtraAddresses)
     (Just webCollataralUtxos)
@@ -234,42 +186,25 @@ notify Wallet{..} contractId = do
       , metadata = mempty
       , invalidBefore = Nothing
       , invalidHereafter = Nothing
-      , inputs = [NormalInput INotify]
+      , inputs
       , 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
+signShelleyTransaction' :: Web.TextEnvelope -> [ShelleyWitnessSigningKey] -> IO Web.TextEnvelope
+signShelleyTransaction' Web.TextEnvelope{..} wits = do
+  let te = TextEnvelope { teType = TextEnvelopeType (T.unpack teType), teDescription = TextEnvelopeDescr (T.unpack teDescription), teRawCBOR = Web.unBase16 teCborHex }
+  txBody <- case deserialiseFromTextEnvelope (AsTxBody AsBabbage) te of
+    Left err -> fail $ show err
+    Right a -> pure a
+  pure case serialiseToTextEnvelope Nothing $ signShelleyTransaction txBody wits of
+    TextEnvelope (TextEnvelopeType ty) _ bytes -> Web.TextEnvelope (T.pack ty) "" $ Web.Base16 bytes
 
-  liftIO $ expectJust "Expected a block header" block
+waitUntilConfirmed :: MonadIO m => (a -> Web.TxStatus) -> m a -> m a
+waitUntilConfirmed getStatus getResource = do
+  resource <- getResource
+  case getStatus resource of
+    Web.Confirmed -> pure resource
+    _ -> do
+      liftIO $ threadDelay 1000
+      waitUntilConfirmed getStatus getResource