Make withBalancedTx and withBalancedTxs balancer-agnostic

Author: errfrom

examples/AdditionalUtxos.purs

@@ -45,6 +45,7 @@ import Contract.Transaction
   , buildTx
   , createAdditionalUtxos
   , defaultBalancer
+  , emptyBalancerCtx
   , signTransaction
   , submit
   , submitTxFromBlueprint
@@ -54,7 +55,7 @@ import Contract.Utxos (UtxoMap)
 import Contract.Value (Value)
 import Contract.Value (lovelaceValueOf) as Value
 import Ctl.Examples.PlutusV2.Scripts.AlwaysSucceeds (alwaysSucceedsScriptV2)
-import Data.Map (difference, empty, filter) as Map
+import Data.Map (difference, filter) as Map
 import JS.BigInt (fromInt) as BigInt
 import Test.QuickCheck (arbitrary)
 import Test.QuickCheck.Gen (randomSampleOne)
@@ -75,7 +76,7 @@ contract testAdditionalUtxoOverlap = withoutSync do
   validator <- alwaysSucceedsScriptV2
   let vhash = PlutusScript.hash validator
   { unbalancedTx, datum } <- payToValidator vhash
-  withBalancedTx unbalancedTx Map.empty mempty \balancedTx -> do
+  withBalancedTx defaultBalancer unbalancedTx emptyBalancerCtx \balancedTx -> do
     balancedSignedTx <- signTransaction balancedTx
     txHash <- submit balancedSignedTx
     when testAdditionalUtxoOverlap $ awaitTxConfirmed txHash

examples/KeyWallet/SignMultiple.purs

@@ -9,6 +9,7 @@ import Contract.ScriptLookups as Lookups
 import Contract.Transaction
   ( TransactionHash
   , awaitTxConfirmed
+  , defaultBalancer
   , signTransaction
   , submit
   , withBalancedTxs
@@ -46,14 +47,18 @@ main = runKeyWalletContract_ \pkh lovelace unlock -> do
   unbalancedTx1 /\ usedUtxos1 <- mkUnbalancedTx lookups constraints
 
   txIds <-
-    withBalancedTxs
+    withBalancedTxs defaultBalancer
       [ { transaction: unbalancedTx0
-        , usedUtxos: usedUtxos0
-        , balancerConstraints: mempty
+        , balancerCtx:
+            { balancerConstraints: mempty
+            , extraUtxos: usedUtxos0
+            }
         }
       , { transaction: unbalancedTx1
-        , usedUtxos: usedUtxos1
-        , balancerConstraints: mempty
+        , balancerCtx:
+            { balancerConstraints: mempty
+            , extraUtxos: usedUtxos1
+            }
         }
       ] $ \balancedTxs -> do
       locked <- getLockedInputs

examples/SignMultiple.purs

@@ -39,6 +39,8 @@ import Contract.Transaction
   , awaitTxConfirmed
   , awaitTxConfirmedWithTimeout
   , buildTx
+  , defaultBalancer
+  , emptyBalancerCtx
   , signTransaction
   , submit
   , submitTxFromBuildPlan
@@ -98,14 +100,12 @@ contract = do
   unbalancedTx1 <- buildTx plan
 
   txIds <-
-    withBalancedTxs
+    withBalancedTxs defaultBalancer
       [ { transaction: unbalancedTx0
-        , usedUtxos: Map.empty
-        , balancerConstraints: mempty
+        , balancerCtx: emptyBalancerCtx
         }
       , { transaction: unbalancedTx1
-        , usedUtxos: Map.empty
-        , balancerConstraints: mempty
+        , balancerCtx: emptyBalancerCtx
         }
       ] $ \balancedTxs -> do
       locked <- getLockedInputs

examples/TxChaining.purs

@@ -36,9 +36,10 @@ import Contract.Log (logInfo')
 import Contract.Monad (Contract, launchAff_, liftedM, runContract)
 import Contract.Transaction
   ( awaitTxConfirmed
-  , balanceTx
   , buildTx
   , createAdditionalUtxos
+  , defaultBalancer
+  , emptyBalancerCtx
   , signTransaction
   , submit
   , withBalancedTx
@@ -76,24 +77,27 @@ contract = do
 
   unbalancedTx0 <- buildTx plan
 
-  withBalancedTx unbalancedTx0 Map.empty mempty \balancedTx0 -> do
-    logInfo' $ "balanced"
-    balancedSignedTx0 <- signTransaction balancedTx0
+  withBalancedTx defaultBalancer unbalancedTx0 emptyBalancerCtx \balancedTx0 ->
+    do
+      logInfo' $ "balanced"
+      balancedSignedTx0 <- signTransaction balancedTx0
 
-    additionalUtxos <- createAdditionalUtxos balancedSignedTx0
-    logInfo' $ "Additional utxos: " <> show additionalUtxos
-    when (Map.isEmpty additionalUtxos) do
-      liftEffect $ throw "empty utxos"
-    let
-      balanceTxConstraints :: BalancerConstraints
-      balanceTxConstraints =
-        mustUseAdditionalUtxos additionalUtxos
-    unbalancedTx1 <- buildTx plan
-    balancedTx1 <- balanceTx unbalancedTx1 additionalUtxos balanceTxConstraints
-    balancedSignedTx1 <- signTransaction balancedTx1
+      additionalUtxos <- createAdditionalUtxos balancedSignedTx0
+      logInfo' $ "Additional utxos: " <> show additionalUtxos
+      when (Map.isEmpty additionalUtxos) do
+        liftEffect $ throw "empty utxos"
+      let
+        balancerConstraints :: BalancerConstraints
+        balancerConstraints = mustUseAdditionalUtxos additionalUtxos
+      unbalancedTx1 <- buildTx plan
+      balancedTx1 <- liftEither =<< defaultBalancer unbalancedTx1
+        { balancerConstraints
+        , extraUtxos: additionalUtxos
+        }
+      balancedSignedTx1 <- signTransaction balancedTx1
 
-    txId0 <- submit balancedSignedTx0
-    txId1 <- submit balancedSignedTx1
+      txId0 <- submit balancedSignedTx0
+      txId1 <- submit balancedSignedTx1
 
-    awaitTxConfirmed txId0
-    awaitTxConfirmed txId1
+      awaitTxConfirmed txId0
+      awaitTxConfirmed txId1

src/Contract/Transaction.purs

@@ -1,27 +1,27 @@
 -- | A module that defines the different transaction data types, balancing
 -- | functionality, transaction fees, signing and submission.
 module Contract.Transaction
-  ( TxBlueprint
+  ( module BalanceTxError
+  , module X
+  , TxBlueprint
   , TxReceipt
   , balanceMultipleTxs
   , balanceTx
   , balanceTxE
   , balanceTxs
+  , buildTx
   , createAdditionalUtxos
   , getTxAuxiliaryData
-  , module BalanceTxError
-  , module X
+  , hashTransaction
+  , lookupTxHash
+  , mkPoolPubKeyHash
   , submit
   , submitE
+  , submitTxFromBlueprint
+  , submitTxFromBuildPlan
   , submitTxFromConstraints
   , withBalancedTx
   , withBalancedTxs
-  , lookupTxHash
-  , mkPoolPubKeyHash
-  , hashTransaction
-  , buildTx
-  , submitTxFromBlueprint
-  , submitTxFromBuildPlan
   ) where
 
 import Prelude
@@ -106,6 +106,7 @@ import Ctl.Internal.BalanceTx
   , CtlBalancerContext
   , defaultBalancer
   , defaultBalancerErr
+  , emptyBalancerCtx
   ) as X
 import Ctl.Internal.BalanceTx (defaultBalancerErr)
 import Ctl.Internal.Contract.AwaitTxConfirmed
@@ -137,8 +138,8 @@ import Data.Maybe (Maybe(Nothing))
 import Data.Newtype (unwrap)
 import Data.String.Utils (startsWith)
 import Data.Traversable (class Traversable, for_, traverse, traverse_)
-import Data.Tuple (fst, uncurry)
-import Data.Tuple.Nested (type (/\), (/\))
+import Data.Tuple (fst)
+import Data.Tuple.Nested ((/\))
 import Data.UInt (UInt)
 import Effect.Aff (bracket, error)
 import Effect.Aff.Class (liftAff)
@@ -232,49 +233,45 @@ withSingleTransaction prepare extract utx action =
     (action <<< NonEmptyArray.head)
 
 -- | Execute an action on an array of balanced
--- | transactions (`balanceTxs` will be called). Within
+-- | transactions (`balanceMultipleTxs` will be called). Within
 -- | this function, all transaction inputs used by these
 -- | transactions will be locked, so that they are not used
 -- | in any other context.
 -- | After the function completes, the locks will be removed.
 -- | Errors will be thrown.
 withBalancedTxs
-  :: forall (a :: Type)
-   . Array
+  :: forall (ctx :: Type) (a :: Type)
+   . TxBalancer Contract Error ctx
+  -> Array
        { transaction :: Transaction
-       , usedUtxos :: UtxoMap
-       , balancerConstraints :: BalancerConstraints
+       , balancerCtx :: ctx
        }
   -> (Array Transaction -> Contract a)
   -> Contract a
-withBalancedTxs = withTransactions balanceTxs identity
+withBalancedTxs balancer = withTransactions (balanceMultipleTxs balancer)
+  identity
 
--- | Execute an action on a balanced transaction (`balanceTx` will
+-- | Execute an action on a balanced transaction (the provided balancer will
 -- | be called). Within this function, all transaction inputs
 -- | used by this transaction will be locked, so that they are not
 -- | used in any other context.
 -- | After the function completes, the locks will be removed.
 -- | Errors will be thrown.
 withBalancedTx
-  :: forall (a :: Type)
-   . Transaction
-  -> UtxoMap
-  -> BalancerConstraints
+  :: forall (ctx :: Type) (a :: Type)
+   . TxBalancer Contract Error ctx
+  -> Transaction
+  -> ctx
   -> (Transaction -> Contract a)
   -> Contract a
-withBalancedTx tx usedUtxos balancerConstraints =
-  withSingleTransaction
-    ( \transaction -> balanceAndLock
-        { transaction, usedUtxos, balancerConstraints }
-    )
-    identity
-    tx
+withBalancedTx balancer transaction ctx =
+  withSingleTransaction (liftEither <=< flip balancer ctx) identity transaction
 
 -- | A variant of `balanceTx` that returns a balancer error value.
 balanceTxE
   :: Warn
        ( Text
-           "Deprecated, use a standalone transaction balancer instead (see `defaultBalancer`)"
+           "Deprecated, use a standalone transaction balancer instead (see `defaultBalancerErr`)"
        )
   => Transaction
   -> UtxoMap
@@ -329,16 +326,19 @@ balanceTxs unbalancedTxs =
 balanceMultipleTxs
   :: forall (ctx :: Type)
    . TxBalancer Contract Error ctx
-  -> Array (Transaction /\ ctx)
+  -> Array
+       { transaction :: Transaction
+       , balancerCtx :: ctx
+       }
   -> Contract (Array Transaction)
 balanceMultipleTxs balancer unbalancedTxs =
-  unlockAllUtxosOnError $ traverse (uncurry (balanceAndLockUtxos balancer))
+  unlockAllUtxosOnError $ traverse (balanceAndLockUtxos balancer)
     unbalancedTxs
   where
   unlockAllUtxosOnError :: forall (a :: Type). Contract a -> Contract a
   unlockAllUtxosOnError f =
     catchError f $ \err -> do
-      traverse_ (withUsedTxOuts <<< unlockTransactionInputs <<< fst)
+      traverse_ (withUsedTxOuts <<< unlockTransactionInputs <<< _.transaction)
         unbalancedTxs
       throwError err
 
@@ -357,11 +357,12 @@ balanceAndLock { transaction, usedUtxos, balancerConstraints } = do
 balanceAndLockUtxos
   :: forall (ctx :: Type)
    . TxBalancer Contract Error ctx
-  -> Transaction
-  -> ctx
+  -> { transaction :: Transaction
+     , balancerCtx :: ctx
+     }
   -> Contract Transaction
-balanceAndLockUtxos balancer transaction ctx = do
-  balancedTx <- liftEither =<< balancer transaction ctx
+balanceAndLockUtxos balancer { transaction, balancerCtx } = do
+  balancedTx <- liftEither =<< balancer transaction balancerCtx
   void $ withUsedTxOuts $ lockTransactionInputs balancedTx
   pure balancedTx
 

src/Internal/BalanceTx/BalanceTx.purs

@@ -3,6 +3,7 @@ module Ctl.Internal.BalanceTx
   , CtlBalancerContext
   , defaultBalancer
   , defaultBalancerErr
+  , emptyBalancerCtx
   ) where
 
 import Prelude
@@ -33,6 +34,7 @@ import Ctl.Internal.Contract.Wallet
   ) as Wallet
 import Ctl.Internal.Types.TxBalancer (TxBalancer)
 import Data.Bifunctor (lmap)
+import Data.Map (empty) as Map
 import Data.Maybe (isNothing)
 import Data.Newtype (unwrap)
 import Effect.Aff.Class (liftAff)
@@ -43,6 +45,12 @@ type CtlBalancerContext =
   , extraUtxos :: UtxoMap
   }
 
+emptyBalancerCtx :: CtlBalancerContext
+emptyBalancerCtx =
+  { balancerConstraints: mempty
+  , extraUtxos: Map.empty
+  }
+
 type CtlBalancer (err :: Type) = TxBalancer Contract err CtlBalancerContext
 
 defaultBalancer :: CtlBalancer Error

test/Testnet/Contract.purs

@@ -50,10 +50,7 @@ import Contract.BalanceTxConstraints
   , mustUseCollateralUtxos
   )
 import Contract.Chain (currentTime, waitUntilSlot)
-import Contract.Config
-  ( KnownWallet(Eternl, Gero, Lode, NuFi)
-  , walletName
-  )
+import Contract.Config (KnownWallet(Eternl, Gero, Lode, NuFi), walletName)
 import Contract.Hashing (datumHash, nativeScriptHash)
 import Contract.Keys (privateKeyFromBytes)
 import Contract.Log (logInfo')
@@ -104,6 +101,8 @@ import Contract.Transaction
   , balanceTxE
   , buildTx
   , createAdditionalUtxos
+  , defaultBalancer
+  , emptyBalancerCtx
   , getTxAuxiliaryData
   , lookupTxHash
   , signTransaction
@@ -1672,7 +1671,8 @@ suite = do
 
             unbalancedTx0 /\ usedUtxos0 <- mkUnbalancedTx lookups0 constraints0
 
-            withBalancedTx unbalancedTx0 usedUtxos0 mempty \balancedTx0 -> do
+            let ctx = emptyBalancerCtx { extraUtxos = usedUtxos0 }
+            withBalancedTx defaultBalancer unbalancedTx0 ctx \balancedTx0 -> do
               balancedSignedTx0 <- signTransaction balancedTx0
 
               additionalUtxos <- createAdditionalUtxos balancedSignedTx0
@@ -1787,7 +1787,8 @@ suite = do
 
             unbalancedTx0 /\ usedUtxos <- mkUnbalancedTx lookups0 constraints0
 
-            withBalancedTx unbalancedTx0 usedUtxos mempty \balancedTx0 -> do
+            let ctx = emptyBalancerCtx { extraUtxos = usedUtxos }
+            withBalancedTx defaultBalancer unbalancedTx0 ctx \balancedTx0 -> do
               balancedSignedTx0 <- signTransaction balancedTx0
 
               additionalUtxos <- createAdditionalUtxos balancedSignedTx0
@@ -2131,14 +2132,18 @@ signMultipleContract = do
   ubTx1 /\ usedUtxos1 <- mkUnbalancedTx lookups constraints
   ubTx2 /\ usedUtxos2 <- mkUnbalancedTx lookups constraints
 
-  withBalancedTxs
+  withBalancedTxs defaultBalancer
     [ { transaction: ubTx1
-      , usedUtxos: usedUtxos1
-      , balancerConstraints: mempty
+      , balancerCtx:
+          { balancerConstraints: mempty
+          , extraUtxos: usedUtxos1
+          }
       }
     , { transaction: ubTx2
-      , usedUtxos: usedUtxos2
-      , balancerConstraints: mempty
+      , balancerCtx:
+          { balancerConstraints: mempty
+          , extraUtxos: usedUtxos2
+          }
       }
     ] $ \txs -> do
     locked <- getLockedInputs