PLT-6847 withdraw by payout

marlowe-apps/src/Language/Marlowe/Runtime/App.hs

@@ -39,7 +39,7 @@ handle config request =
             ListHeaders{..} -> Right . Headers <$> allHeaders reqFilter
             Get{..} -> fmap (uncurry Info) <$> getContract reqContractId
             Create{..} ->
-              second (uncurry mkBody)
+              second (uncurry $ mkBody . Just)
                 <$> buildCreation
                   MarloweV1
                   reqContract
@@ -50,7 +50,7 @@ handle config request =
                   reqChange
                   reqCollateral
             Apply{..} ->
-              second (uncurry mkBody)
+              second (uncurry $ mkBody . Just)
                 <$> buildApplication
                   MarloweV1
                   reqContractId
@@ -61,7 +61,7 @@ handle config request =
                   reqAddresses
                   reqChange
                   reqCollateral
-            Withdraw{..} -> second (uncurry mkBody) <$> buildWithdrawal MarloweV1 reqContractId reqRole reqAddresses reqChange reqCollateral
+            Withdraw{..} -> second (mkBody Nothing) <$> buildWithdrawal MarloweV1 reqPayouts reqAddresses reqChange reqCollateral
             Sign{reqTxEra = ReferenceTxInsScriptsInlineDatumsInBabbageEra, ..} ->
               pure . Right . uncurry (Tx ReferenceTxInsScriptsInlineDatumsInBabbageEra) $
                 sign reqTxBody reqPaymentKeys reqPaymentExtendedKeys

marlowe-apps/src/Language/Marlowe/Runtime/App/Build.hs

@@ -22,16 +22,13 @@ import Language.Marlowe.Runtime.App.Types (Client, TxBodyInEraWithReferenceScrip
 import Language.Marlowe.Runtime.ChainSync.Api (Address, Lovelace (..), TokenName, TxOutRef)
 import Language.Marlowe.Runtime.Core.Api (ContractId, IsMarloweVersion (..), MarloweTransactionMetadata, MarloweVersion)
 import Language.Marlowe.Runtime.Transaction.Api (
-  ApplyInputsError,
   ContractCreated (..),
   ContractCreatedInEra (..),
-  CreateError,
   InputsApplied (..),
   InputsAppliedInEra (..),
   MarloweTxCommand (ApplyInputs, Create, Withdraw),
   RoleTokensConfig (..),
   WalletAddresses (WalletAddresses),
-  WithdrawError,
   WithdrawTx (..),
   WithdrawTxInEra (..),
   mkMint,
@@ -40,12 +37,12 @@ import Network.Protocol.Job.Client (liftCommand)
 
 import qualified Data.List.NonEmpty as NE (fromList)
 import qualified Data.Map.Strict as M (Map, null, toList)
+import Data.Set (Set)
 import qualified Data.Set as S (fromList)
 import Language.Marlowe.Runtime.Client (runMarloweTxClient)
 
 buildCreation
-  :: (Show (CreateError v))
-  => MarloweVersion v
+  :: MarloweVersion v
   -> Contract v
   -> M.Map TokenName Address
   -> Lovelace
@@ -63,8 +60,7 @@ buildCreation version' contract roles minUtxo metadata' =
         \w -> Create Nothing version' w roles' metadata' minUtxo $ Left contract
 
 buildApplication
-  :: (Show (ApplyInputsError v))
-  => MarloweVersion v
+  :: MarloweVersion v
   -> ContractId
   -> Inputs v
   -> Maybe POSIXTime
@@ -82,17 +78,15 @@ buildApplication version' contractId' inputs lower upper metadata' =
     $ \w -> ApplyInputs version' w contractId' metadata' (utcTime <$> lower) (utcTime <$> upper) inputs
 
 buildWithdrawal
-  :: (Show (WithdrawError v))
-  => MarloweVersion v
-  -> ContractId
-  -> TokenName
+  :: MarloweVersion v
+  -> Set TxOutRef
   -> [Address]
   -> Address
   -> [TxOutRef]
-  -> Client (Either String (ContractId, TxBodyInEraWithReferenceScripts))
-buildWithdrawal version contractId' role =
-  build show (\(WithdrawTx era WithdrawTxInEra{txBody}) -> (contractId', TxBodyInEraWithReferenceScripts era txBody)) $
-    \w -> Withdraw version w contractId' role
+  -> Client (Either String TxBodyInEraWithReferenceScripts)
+buildWithdrawal version payouts =
+  build show (\(WithdrawTx era WithdrawTxInEra{txBody}) -> TxBodyInEraWithReferenceScripts era txBody) $
+    \w -> Withdraw version w payouts
 
 build
   :: (err -> String)

marlowe-apps/src/Language/Marlowe/Runtime/App/Transact.hs

@@ -18,6 +18,8 @@ module Language.Marlowe.Runtime.App.Transact (
   runWithEvents,
   transact,
   transactWithEvents,
+  transact',
+  transactWithEvents',
 ) where
 
 import Control.Concurrent (threadDelay)
@@ -66,9 +68,9 @@ runWithEvents
   -> App ContractId
 runWithEvents backend config address key contract inputs minUtxo =
   do
-    let transact' = transactWithEvents backend config key
-    contractId <- transact' $ Create contract mempty minUtxo mempty mempty address mempty
-    mapM_ (\input -> transact' $ Apply contractId input Nothing Nothing mempty mempty address mempty) inputs
+    let transact'' = transactWithEvents' backend config key
+    contractId <- transact'' $ Create contract mempty minUtxo mempty mempty address mempty
+    mapM_ (\input -> transact'' $ Apply contractId input Nothing Nothing mempty mempty address mempty) inputs
     pure contractId
 
 create
@@ -89,7 +91,7 @@ createWithEvents
   -> Lovelace
   -> App ContractId
 createWithEvents backend config address key contract minUtxo =
-  transactWithEvents backend config key $
+  transactWithEvents' backend config key $
     Create contract mempty minUtxo mempty mempty address mempty
 
 apply
@@ -110,22 +112,39 @@ applyWithEvents
   -> [Input]
   -> App ContractId
 applyWithEvents backend config address key contractId input =
-  transactWithEvents backend config key $
+  transactWithEvents' backend config key $
     Apply contractId input Nothing Nothing mempty mempty address mempty
 
-transact
+transact'
   :: Config
   -> C.SigningKey C.PaymentExtendedKey
   -> MarloweRequest 'V1
   -> App ContractId
+transact' = transactWithEvents' unitEventBackend
+
+transact
+  :: Config
+  -> C.SigningKey C.PaymentExtendedKey
+  -> MarloweRequest 'V1
+  -> App (Maybe ContractId)
 transact = transactWithEvents unitEventBackend
 
-transactWithEvents
+transactWithEvents'
   :: EventBackend App r DynamicEventSelector
   -> Config
   -> C.SigningKey C.PaymentExtendedKey
   -> MarloweRequest 'V1
   -> App ContractId
+transactWithEvents' backend config key request = do
+  mContractId <- transactWithEvents backend config key request
+  maybe (fail "Contract ID expected") pure mContractId
+
+transactWithEvents
+  :: EventBackend App r DynamicEventSelector
+  -> Config
+  -> C.SigningKey C.PaymentExtendedKey
+  -> MarloweRequest 'V1
+  -> App (Maybe ContractId)
 transactWithEvents backend config@Config{buildSeconds, confirmSeconds, retryLimit, retrySeconds} key request =
   let show' = LBS8.unpack . A.encode
       unexpected response = throwError $ "Unexpected response: " <> show' response

marlowe-apps/src/Language/Marlowe/Runtime/App/Types.hs

@@ -54,6 +54,7 @@ import Language.Marlowe.Runtime.ChainSync.Api (
   TxOutRef,
   fromBech32,
   fromJSONEncodedTransactionMetadata,
+  parseTxOutRef,
   toBech32,
  )
 import Language.Marlowe.Runtime.Core.Api (
@@ -105,6 +106,8 @@ import qualified Data.Aeson.Types as A (
  )
 import Data.Foldable (fold)
 import qualified Data.Map.Strict as M (Map, map, mapKeys)
+import Data.Set (Set)
+import qualified Data.Set as Set
 import qualified Data.Text as T (Text)
 import Data.Time.Units (Second)
 import Language.Marlowe.Protocol.Client (hoistMarloweRuntimeClient)
@@ -225,8 +228,7 @@ data MarloweRequest v
       , reqCollateral :: [TxOutRef]
       }
   | Withdraw
-      { reqContractId :: ContractId
-      , reqRole :: TokenName
+      { reqPayouts :: Set TxOutRef
       , reqAddresses :: [Address]
       , reqChange :: Address
       , reqCollateral :: [TxOutRef]
@@ -283,8 +285,8 @@ instance A.FromJSON (MarloweRequest 'V1) where
               reqCollateral <- fmap fromString <$> o A..: "collateral"
               pure Apply{..}
             "withdraw" -> do
-              reqContractId <- fromString <$> o A..: "contractId"
-              reqRole <- fromString <$> o A..: "role"
+              reqPayouts <-
+                Set.fromList <$> (traverse (maybe (fail "invalid tx out ref syntax") pure . parseTxOutRef) =<< o A..: "payouts")
               reqAddresses <- mapM addressFromJSON =<< o A..: "addresses"
               reqChange <- addressFromJSON =<< o A..: "change"
               reqCollateral <- fmap fromString <$> o A..: "collateral"
@@ -358,7 +360,7 @@ instance A.ToJSON (MarloweRequest 'V1) where
   toJSON Withdraw{..} =
     A.object
       [ "request" A..= ("withdraw" :: String)
-      , "role" A..= reqRole
+      , "payouts" A..= reqPayouts
       , "addresses" A..= fmap addressToJSON reqAddresses
       , "change" A..= addressToJSON reqChange
       , "collateral" A..= reqCollateral
@@ -408,7 +410,7 @@ data MarloweResponse v
   | forall era.
     Body
       { resTxEra :: C.ReferenceTxInsScriptsInlineDatumsSupportedInEra era
-      , resContractId :: ContractId
+      , resContractId :: Maybe ContractId
       , resTxId :: TxId
       , resTxBody :: C.TxBody era
       }
@@ -448,15 +450,17 @@ instance A.ToJSON (MarloweResponse 'V1) where
       , "steps" A..= fmap contractStepToJSON resSteps
       ]
   toJSON Body{..} =
-    A.object
+    A.object $
       [ "response" A..= ("body" :: String)
-      , "contractId" A..= renderContractId resContractId
       , "txId" A..= C.getTxId resTxBody
       , case resTxEra of
           C.ReferenceTxInsScriptsInlineDatumsInBabbageEra -> "era" A..= C.BabbageEra
       , case resTxEra of
           C.ReferenceTxInsScriptsInlineDatumsInBabbageEra -> "body" A..= textEnvelopeToJSON resTxBody
       ]
+        <> case resContractId of
+          Nothing -> []
+          Just contractId -> ["contractId" A..= contractId]
   toJSON Tx{..} =
     A.object
       [ "response" A..= ("tx" :: String)
@@ -540,7 +544,7 @@ textEnvelopeToJSON x =
   let envelope = C.serialiseToTextEnvelope Nothing x
    in A.toJSON envelope
 
-mkBody :: ContractId -> TxBodyInEraWithReferenceScripts -> MarloweResponse v
+mkBody :: Maybe ContractId -> TxBodyInEraWithReferenceScripts -> MarloweResponse v
 mkBody resContractId (TxBodyInEraWithReferenceScripts resTxEra resTxBody) =
   let resTxId = fromCardanoTxId $ C.getTxId resTxBody
    in Body{..}

marlowe-chain-sync/libchainsync/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL.hs

@@ -897,48 +897,51 @@ getUTxOs =
             txOutRefs' = (V.fromList *** V.fromList) . unzip . fmap txOutRefTuple . Set.toList $ txOutRefs
         HT.statement txOutRefs' $
           [foldStatement|
-        SELECT txOut.txId :: bytea
-             , txOut.txIx :: smallint
-             , txOut.address :: bytea
-             , txOut.lovelace :: bigint
-             , txOut.datumHash :: bytea?
-             , txOut.datumBytes :: bytea?
-             , asset.policyId :: bytea?
-             , asset.name :: bytea?
-             , assetOut.quantity :: bigint?
-          FROM chain.txOut         AS txOut
-          LEFT JOIN chain.txIn     AS txIn     ON txIn.txOutId = txOut.txId AND txIn.txOutIx = txOut.txIx
-          LEFT JOIN chain.assetOut AS assetOut ON assetOut.txOutId = txOut.txId AND assetOut.txOutIx = txOut.txIx
-          LEFT JOIN chain.asset    AS asset    ON asset.id = assetOut.assetId
-         WHERE (txOut.txId, txOut.txTx) = ANY(unnest ($1 :: bytea[], $2 :: smallint[]))
-           AND txIn.txInId IS NULL
-         ORDER BY txIx
-      |]
+            WITH txOuts (txId, txIx) AS
+              ( SELECT * FROM UNNEST($1 :: bytea[], $2 :: smallint[])
+              )
+            SELECT txOut.txId :: bytea
+                , txOut.txIx :: smallint
+                , txOut.address :: bytea
+                , txOut.lovelace :: bigint
+                , txOut.datumHash :: bytea?
+                , txOut.datumBytes :: bytea?
+                , asset.policyId :: bytea?
+                , asset.name :: bytea?
+                , assetOut.quantity :: bigint?
+              FROM chain.txOut         AS txOut
+              NATURAL JOIN txOuts
+              LEFT JOIN chain.txIn     AS txIn     ON txIn.txOutId = txOut.txId AND txIn.txOutIx = txOut.txIx
+              LEFT JOIN chain.assetOut AS assetOut ON assetOut.txOutId = txOut.txId AND assetOut.txOutIx = txOut.txIx
+              LEFT JOIN chain.asset    AS asset    ON asset.id = assetOut.assetId
+            WHERE txIn.txInId IS NULL
+            ORDER BY txIx
+          |]
             (Fold foldRow mempty id)
       GetUTxOsAtAddresses addresses -> do
         let addresses' = V.fromList $ fmap unAddress . Set.toList $ addresses
         HT.statement addresses' $
           [foldStatement|
-        WITH addresses (address) AS
-          ( SELECT * FROM UNNEST($1 :: bytea[])
-          )
-        SELECT txOut.txId :: bytea
-             , txOut.txIx :: smallint
-             , txOut.address :: bytea
-             , txOut.lovelace :: bigint
-             , txOut.datumHash :: bytea?
-             , txOut.datumBytes :: bytea?
-             , asset.policyId :: bytea?
-             , asset.name :: bytea?
-             , assetOut.quantity :: bigint?
-          FROM chain.txOut         AS txOut
-          JOIN addresses           AS addr     ON addr.address = txOut.address AND CAST(MD5(addr.address) AS uuid) = CAST(MD5(txOut.address) AS uuid)
-          LEFT JOIN chain.txIn     AS txIn     ON txIn.txOutId = txOut.txId AND txIn.txOutIx = txOut.txIx
-          LEFT JOIN chain.assetOut AS assetOut ON assetOut.txOutId = txOut.txId AND assetOut.txOutIx = txOut.txIx
-          LEFT JOIN chain.asset    AS asset    ON asset.id = assetOut.assetId
-         WHERE txIn.txInId IS NULL
-         ORDER BY txIx
-      |]
+            WITH addresses (address) AS
+              ( SELECT * FROM UNNEST($1 :: bytea[])
+              )
+            SELECT txOut.txId :: bytea
+                , txOut.txIx :: smallint
+                , txOut.address :: bytea
+                , txOut.lovelace :: bigint
+                , txOut.datumHash :: bytea?
+                , txOut.datumBytes :: bytea?
+                , asset.policyId :: bytea?
+                , asset.name :: bytea?
+                , assetOut.quantity :: bigint?
+              FROM chain.txOut         AS txOut
+              JOIN addresses           AS addr     ON addr.address = txOut.address AND CAST(MD5(addr.address) AS uuid) = CAST(MD5(txOut.address) AS uuid)
+              LEFT JOIN chain.txIn     AS txIn     ON txIn.txOutId = txOut.txId AND txIn.txOutIx = txOut.txIx
+              LEFT JOIN chain.assetOut AS assetOut ON assetOut.txOutId = txOut.txId AND assetOut.txOutIx = txOut.txIx
+              LEFT JOIN chain.asset    AS asset    ON asset.id = assetOut.assetId
+            WHERE txIn.txInId IS NULL
+            ORDER BY txIx
+          |]
             (Fold foldRow mempty id)
   where
     foldRow acc (txId, txIx, address, lovelace, datumHash, datumBytes, policyId, tokenName, quantity) =

marlowe-cli/cli-test/Language/Marlowe/CLI/Test/Runtime/Interpret.hs

@@ -38,6 +38,7 @@ import Data.Coerce (coerce)
 import Data.Foldable (for_)
 import Data.Map.Strict qualified as Map
 import Data.Maybe (fromMaybe, isJust, isNothing)
+import Data.Set qualified as Set
 import Data.Text qualified as Text
 import Data.Time.Units (Microsecond, Second, TimeUnit (fromMicroseconds, toMicroseconds))
 import Data.Traversable (for)
@@ -97,8 +98,11 @@ import Language.Marlowe.Cardano.Thread qualified as Marlowe.Cardano.Thread
 import Language.Marlowe.Core.V1.Merkle (MerkleizedContract (MerkleizedContract), deepMerkleize, merkleizeInputs)
 import Language.Marlowe.Core.V1.Semantics qualified as M
 import Language.Marlowe.Protocol.Client qualified as Marlowe.Protocol
+import Language.Marlowe.Protocol.Query.Client (getPayouts)
+import Language.Marlowe.Protocol.Query.Types (Order (..), Page (..), PayoutFilter (..), PayoutHeader (..), Range (..))
 import Language.Marlowe.Runtime.Cardano.Api qualified as MRCA
 import Language.Marlowe.Runtime.Cardano.Api qualified as RCA
+import Language.Marlowe.Runtime.ChainSync.Api (AssetId (..))
 import Language.Marlowe.Runtime.ChainSync.Api qualified as ChainSync
 import Language.Marlowe.Runtime.Core.Api (
   ContractId,
@@ -323,7 +327,17 @@ withdraw ro contractId tokenName walletNickname Wallet{_waAddress, _waSigningKey
             , extraAddresses = mempty
             , collateralUtxos = mempty
             }
-    Marlowe.Class.withdraw MarloweV1 walletAddresses contractId tokenName'
+    let isWithdrawn = Just False
+    let contractIds = Set.singleton contractId
+    let roleTokens = mempty
+    let rangeStart = Nothing
+    let rangeOffset = 0
+    let rangeLimit = 100
+    let rangeDirection = Descending
+    Just Page{..} <- Marlowe.Class.runMarloweQueryClient $ getPayouts PayoutFilter{..} $ Range{..}
+    let matchesRole PayoutHeader{role = AssetId{tokenName = roleName}} = tokenName' == roleName
+    let payouts = Set.fromList $ payoutId <$> filter matchesRole items
+    Marlowe.Class.withdraw MarloweV1 walletAddresses payouts
   case result of
     Right (WithdrawTx ReferenceTxInsScriptsInlineDatumsInBabbageEra WithdrawTxInEra{..}) -> do
       let witness = somePaymentsigningKeyToTxWitness _waSigningKey

marlowe-cli/marlowe-cli.cabal

@@ -194,7 +194,7 @@ library cli-test
     , marlowe-client
     , marlowe-contracts
     , marlowe-protocols
-    , marlowe-runtime:{marlowe-runtime, history-api, proxy-api, tx-api}
+    , marlowe-runtime:{marlowe-runtime, history-api, proxy-api, sync-api, tx-api}
     , monad-loops
     , mtl
     , network