Stake pool for integration test

src/base/lib/Convex/NodeQueries.hs

@@ -8,7 +8,9 @@ module Convex.NodeQueries(
   querySystemStart,
   queryLocalState,
   queryTip,
-  queryProtocolParameters
+  queryProtocolParameters,
+  queryStakeAddresses,
+  queryStakePools
 ) where
 
 import           Cardano.Api                                        (CardanoMode,
@@ -22,9 +24,13 @@ import           Cardano.Api                                        (CardanoMode
                                                                      NetworkId (Mainnet, Testnet),
                                                                      NetworkMagic (..),
                                                                      SystemStart,
+                                                                     Lovelace,
                                                                      envSecurityParam)
 import qualified Cardano.Api                                        as CAPI
-import           Cardano.Api.Shelley                                (ProtocolParameters)
+import           Cardano.Api.Shelley                                (ProtocolParameters,
+                                                                     PoolId,
+                                                                     StakeAddress,
+                                                                     StakeCredential)
 import qualified Cardano.Chain.Genesis
 import           Cardano.Crypto                                     (RequiresNetworkMagic (..),
                                                                      getProtocolMagic)
@@ -33,6 +39,8 @@ import           Control.Monad.Except                               (MonadError,
 import           Control.Monad.IO.Class                             (MonadIO (..))
 import           Control.Monad.Trans.Except                         (runExceptT)
 import           Data.SOP.Strict                                    (NP ((:*)))
+import           Data.Set                                           (Set)
+import           Data.Map                                           (Map)
 import qualified Ouroboros.Consensus.Cardano.CanHardFork            as Consensus
 import qualified Ouroboros.Consensus.HardFork.Combinator            as Consensus
 import qualified Ouroboros.Consensus.HardFork.Combinator.AcrossEras as HFC
@@ -87,6 +95,26 @@ queryEraHistory = queryLocalState (CAPI.QueryEraHistory CAPI.CardanoModeIsMultiE
 queryTip :: LocalNodeConnectInfo CardanoMode -> IO ChainPoint
 queryTip = queryLocalState (CAPI.QueryChainPoint CAPI.CardanoMode)
 
+queryStakePools :: LocalNodeConnectInfo CardanoMode -> IO (Set PoolId)
+queryStakePools connectInfo = do
+  result <- queryLocalState
+              (CAPI.QueryInEra CAPI.BabbageEraInCardanoMode (CAPI.QueryInShelleyBasedEra CAPI.ShelleyBasedEraBabbage CAPI.QueryStakePools))
+              connectInfo
+  case result of
+    Left err -> do
+      fail ("queryStakePools: failed with: " <> show err)
+    Right k -> pure k
+
+queryStakeAddresses :: LocalNodeConnectInfo CardanoMode -> Set StakeCredential -> NetworkId -> IO (Map StakeAddress Lovelace, Map StakeAddress PoolId)
+queryStakeAddresses info creds nid = do
+  result <- queryLocalState
+              (CAPI.QueryInEra CAPI.BabbageEraInCardanoMode (CAPI.QueryInShelleyBasedEra CAPI.ShelleyBasedEraBabbage (CAPI.QueryStakeAddresses creds nid)))
+              info
+  case result of
+    Left err -> do
+      fail ("queryStakeAddresses: failed with: " <> show err)
+    Right k -> pure k
+
 queryLocalState :: CAPI.QueryInMode CardanoMode b -> LocalNodeConnectInfo CardanoMode -> IO b
 queryLocalState query connectInfo = do
   CAPI.queryNodeLocalState connectInfo Nothing query >>= \case

src/coin-selection/lib/Convex/CoinSelection.hs

@@ -493,9 +493,12 @@ balanceTx ::
   -- | The unbalanced transaction body
   TxBodyContent BuildTx ERA ->
 
+  -- | Additional required signature count
+  TransactionSignatureCount ->
+
   -- | The balanced transaction body and the balance changes (per address)
   m (C.BalancedTxBody ERA, BalanceChanges)
-balanceTx dbg returnUTxO0 walletUtxo txb = do
+balanceTx dbg returnUTxO0 walletUtxo txb count' = do
   (params, ledgerPPs) <- queryProtocolParameters
   pools <- queryStakePools
   availableUTxOs <- checkCompatibilityLevel dbg txb walletUtxo
@@ -512,7 +515,7 @@ balanceTx dbg returnUTxO0 walletUtxo txb = do
     bodyWithInputs <- addOwnInput txb0 walletUtxo
     bodyWithCollat <- setCollateral bodyWithInputs walletUtxo
     balancePositive (natTracer lift dbg) pools ledgerPPs combinedTxIns returnUTxO0 walletUtxo bodyWithCollat
-  count <- requiredSignatureCount finalBody
+  count <- (+count') <$> requiredSignatureCount finalBody
   csi <- prepCSInputs count returnUTxO1 combinedTxIns finalBody
   start <- querySystemStart
   hist <- queryEraHistory
@@ -531,18 +534,18 @@ checkCompatibilityLevel tr txB (UtxoSet w) = do
 
 {-| Balance the transaction using the wallet's funds, then sign it.
 -}
-balanceForWallet :: (MonadBlockchain m, MonadError BalanceTxError m) => Tracer m TxBalancingMessage -> Wallet -> UtxoSet C.CtxUTxO a -> TxBodyContent BuildTx ERA -> m (C.Tx ERA, BalanceChanges)
-balanceForWallet dbg wallet walletUtxo txb = do
+balanceForWallet :: (MonadBlockchain m, MonadError BalanceTxError m) => Tracer m TxBalancingMessage -> Wallet -> UtxoSet C.CtxUTxO a -> TxBodyContent BuildTx ERA -> TransactionSignatureCount -> m (C.Tx ERA, BalanceChanges)
+balanceForWallet dbg wallet walletUtxo txb count = do
   n <- networkId
   let walletAddress = Wallet.addressInEra n wallet
       txOut = L.emptyTxOut walletAddress
-  balanceForWalletReturn dbg wallet walletUtxo txOut txb
+  balanceForWalletReturn dbg wallet walletUtxo txOut txb count
 
 {-| Balance the transaction using the wallet's funds and the provided return output, then sign it.
 -}
-balanceForWalletReturn :: (MonadBlockchain m, MonadError BalanceTxError m) => Tracer m TxBalancingMessage -> Wallet -> UtxoSet C.CtxUTxO a -> C.TxOut C.CtxTx C.BabbageEra -> TxBodyContent BuildTx ERA -> m (C.Tx ERA, BalanceChanges)
-balanceForWalletReturn dbg wallet walletUtxo returnOutput txb = do
-  first (signForWallet wallet) <$> balanceTx dbg returnOutput walletUtxo txb
+balanceForWalletReturn :: (MonadBlockchain m, MonadError BalanceTxError m) => Tracer m TxBalancingMessage -> Wallet -> UtxoSet C.CtxUTxO a -> C.TxOut C.CtxTx C.BabbageEra -> TxBodyContent BuildTx ERA -> TransactionSignatureCount -> m (C.Tx ERA, BalanceChanges)
+balanceForWalletReturn dbg wallet walletUtxo returnOutput txb count = do
+  first (signForWallet wallet) <$> balanceTx dbg returnOutput walletUtxo txb count
 
 {-| Sign a transaction with the wallet's key
 -}

src/coin-selection/lib/Convex/CoinSelection/Class.hs

@@ -28,7 +28,8 @@ import           Control.Tracer                   (Tracer, natTracer)
 import           Convex.Class                     (MonadBlockchain (..),
                                                    MonadMockchain (..))
 import           Convex.CoinSelection             (BalanceTxError,
-                                                   TxBalancingMessage)
+                                                   TxBalancingMessage,
+                                                   TransactionSignatureCount)
 import qualified Convex.CoinSelection
 import           Convex.Lenses                    (emptyTxOut)
 import           Convex.MonadLog                  (MonadLog, MonadLogIgnoreT)
@@ -61,6 +62,9 @@ class Monad m => MonadBalance m where
     -- | The unbalanced transaction body
     TxBodyContent BuildTx BabbageEra ->
 
+    -- | Additional transaction signature count
+    TransactionSignatureCount ->
+
     -- | The balanced transaction body and the balance changes (per address)
     m (Either BalanceTxError (C.BalancedTxBody BabbageEra, BalanceChanges))
 
@@ -73,22 +77,22 @@ instance MonadTrans BalancingT where
 deriving newtype instance MonadError e m => MonadError e (BalancingT m)
 
 instance MonadBalance m => MonadBalance (ExceptT e m) where
-  balanceTx addr utxos = lift . balanceTx addr utxos
+  balanceTx addr utxos count = lift . balanceTx addr utxos count
 
 instance MonadBalance m => MonadBalance (ReaderT e m) where
-  balanceTx addr utxos = lift . balanceTx addr utxos
+  balanceTx addr utxos count = lift . balanceTx addr utxos count
 
 instance MonadBalance m => MonadBalance (StrictState.StateT s m) where
-  balanceTx addr utxos = lift . balanceTx addr utxos
+  balanceTx addr utxos count = lift . balanceTx addr utxos count
 
 instance MonadBalance m => MonadBalance (LazyState.StateT s m) where
-  balanceTx addr utxos = lift . balanceTx addr utxos
+  balanceTx addr utxos count = lift . balanceTx addr utxos count
 
 instance MonadBalance m => MonadBalance (MonadLogIgnoreT m) where
-  balanceTx addr utxos = lift . balanceTx addr utxos
+  balanceTx addr utxos count = lift . balanceTx addr utxos count
 
 instance (MonadBlockchain m) => MonadBalance (BalancingT m) where
-  balanceTx addr utxos txb = runExceptT (Convex.CoinSelection.balanceTx mempty (emptyTxOut addr) utxos txb)
+  balanceTx addr utxos txb count = runExceptT (Convex.CoinSelection.balanceTx mempty (emptyTxOut addr) utxos txb count)
 
 instance MonadMockchain m => MonadMockchain (BalancingT m) where
   modifySlot = lift . modifySlot
@@ -106,9 +110,9 @@ instance MonadTrans TracingBalancingT where
 deriving newtype instance MonadError e m => MonadError e (TracingBalancingT m)
 
 instance (MonadBlockchain m) => MonadBalance (TracingBalancingT m) where
-  balanceTx addr utxos txb = TracingBalancingT $ do
+  balanceTx addr utxos txb count = TracingBalancingT $ do
     tr <- ask
-    runExceptT (Convex.CoinSelection.balanceTx (natTracer (lift . lift) tr) (emptyTxOut addr) utxos txb)
+    runExceptT (Convex.CoinSelection.balanceTx (natTracer (lift . lift) tr) (emptyTxOut addr) utxos txb count)
 
 instance MonadMockchain m => MonadMockchain (TracingBalancingT m) where
   modifySlot = lift . modifySlot

src/coin-selection/lib/Convex/MockChain/CoinSelection.hs

@@ -20,7 +20,8 @@ import           Convex.BuildTx            (buildTx, execBuildTx, execBuildTx',
                                             payToAddress, setMinAdaDepositAll)
 import           Convex.Class              (MonadBlockchain (..),
                                             MonadMockchain)
-import           Convex.CoinSelection      (BalanceTxError, TxBalancingMessage)
+import           Convex.CoinSelection      (BalanceTxError, TxBalancingMessage,
+                                            TransactionSignatureCount)
 import qualified Convex.CoinSelection      as CoinSelection
 import           Convex.Lenses             (emptyTxOut)
 import qualified Convex.MockChain          as MockChain
@@ -32,20 +33,20 @@ import           Convex.Wallet.Operator    (Operator (..), verificationKey)
 {-| Balance and submit a transaction using the wallet's UTXOs
 on the mockchain, using the default network ID
 -}
-balanceAndSubmit :: (MonadMockchain m, MonadError BalanceTxError m) => Tracer m TxBalancingMessage -> Wallet -> TxBodyContent BuildTx BabbageEra -> m (C.Tx CoinSelection.ERA)
-balanceAndSubmit dbg wallet tx = do
+balanceAndSubmit :: (MonadMockchain m, MonadError BalanceTxError m) => Tracer m TxBalancingMessage -> Wallet -> TxBodyContent BuildTx BabbageEra -> TransactionSignatureCount -> m (C.Tx CoinSelection.ERA)
+balanceAndSubmit dbg wallet tx count = do
   n <- networkId
   let walletAddress = Wallet.addressInEra n wallet
       txOut = emptyTxOut walletAddress
-  balanceAndSubmitReturn dbg wallet txOut tx
+  balanceAndSubmitReturn dbg wallet txOut tx count
 
 {-| Balance and submit a transaction using the given return output and the wallet's UTXOs
 on the mockchain, using the default network ID
 -}
-balanceAndSubmitReturn :: (MonadMockchain m, MonadError BalanceTxError m) => Tracer m TxBalancingMessage -> Wallet -> C.TxOut C.CtxTx C.BabbageEra -> TxBodyContent BuildTx BabbageEra -> m (C.Tx CoinSelection.ERA)
-balanceAndSubmitReturn dbg wallet returnOutput tx = do
+balanceAndSubmitReturn :: (MonadMockchain m, MonadError BalanceTxError m) => Tracer m TxBalancingMessage -> Wallet -> C.TxOut C.CtxTx C.BabbageEra -> TxBodyContent BuildTx BabbageEra -> TransactionSignatureCount -> m (C.Tx CoinSelection.ERA)
+balanceAndSubmitReturn dbg wallet returnOutput tx count = do
   u <- MockChain.walletUtxo wallet
-  (tx', _) <- CoinSelection.balanceForWalletReturn dbg wallet u returnOutput tx
+  (tx', _) <- CoinSelection.balanceForWalletReturn dbg wallet u returnOutput tx count
   _ <- sendTx tx'
   pure tx'
 
@@ -54,7 +55,7 @@ balanceAndSubmitReturn dbg wallet returnOutput tx = do
 paymentTo :: (MonadMockchain m, MonadError BalanceTxError m) => Wallet -> Wallet -> m (C.Tx CoinSelection.ERA)
 paymentTo wFrom wTo = do
   let tx = buildTx $ execBuildTx (payToAddress (Wallet.addressInEra Defaults.networkId wTo) (C.lovelaceToValue 10_000_000))
-  balanceAndSubmit mempty wFrom tx
+  balanceAndSubmit mempty wFrom tx 0
 
 {-| Pay 100 Ada from one of the seed addresses to an @Operator@
 -}
@@ -71,4 +72,4 @@ payToOperator' dbg value wFrom Operator{oPaymentKey} = do
         (C.PaymentCredentialByKey $ C.verificationKeyHash $ verificationKey oPaymentKey)
         C.NoStakeAddress
       tx = execBuildTx' $ payToAddress addr value >> setMinAdaDepositAll (snd p)
-  balanceAndSubmit dbg wFrom tx
+  balanceAndSubmit dbg wFrom tx 0

src/coin-selection/lib/Convex/Query.hs

@@ -47,7 +47,8 @@ import           Control.Tracer                     (Tracer, natTracer)
 import           Convex.Class                       (MonadBlockchain (..),
                                                      MonadBlockchainCardanoNodeT)
 import           Convex.CoinSelection               (BalanceTxError,
-                                                     TxBalancingMessage)
+                                                     TxBalancingMessage,
+                                                     TransactionSignatureCount)
 import qualified Convex.CoinSelection
 import           Convex.MockChain                   (MockchainT, utxoSet)
 import           Convex.MonadLog                    (MonadLog, MonadLogIgnoreT)
@@ -103,10 +104,10 @@ deriving newtype instance MonadUtxoQuery m => MonadUtxoQuery (MonadBlockchainWai
 {-| Balance the transaction body using the UTxOs locked by the payment credentials,
 returning any unused funds to the given return output
 |-}
-balanceTx :: (MonadBlockchain m, MonadUtxoQuery m) => Tracer m TxBalancingMessage -> [PaymentCredential] -> TxOut CtxTx BabbageEra -> TxBodyContent BuildTx BabbageEra -> m (Either BalanceTxError (BalancedTxBody BabbageEra, BalanceChanges))
-balanceTx dbg inputCredentials changeOutput txBody = do
+balanceTx :: (MonadBlockchain m, MonadUtxoQuery m) => Tracer m TxBalancingMessage -> [PaymentCredential] -> TxOut CtxTx BabbageEra -> TxBodyContent BuildTx BabbageEra -> TransactionSignatureCount -> m (Either BalanceTxError (BalancedTxBody BabbageEra, BalanceChanges))
+balanceTx dbg inputCredentials changeOutput txBody count = do
   o <- fromApiUtxo <$> utxosByPaymentCredentials (Set.fromList inputCredentials)
-  runExceptT (Convex.CoinSelection.balanceTx (natTracer lift dbg) changeOutput o txBody)
+  runExceptT (Convex.CoinSelection.balanceTx (natTracer lift dbg) changeOutput o txBody count)
 
 newtype WalletAPIQueryT m a = WalletAPIQueryT{ runWalletAPIQueryT_ :: ReaderT ClientEnv m a }
   deriving newtype (Functor, Applicative, Monad, MonadIO, MonadBlockchain, MonadLog)
@@ -139,7 +140,7 @@ balancePaymentCredentials ::
   -> m (C.Tx C.BabbageEra)
 balancePaymentCredentials dbg primaryCred otherCreds returnOutput txBody = do
   output <- maybe (returnOutputFor primaryCred) pure returnOutput
-  (C.BalancedTxBody txbody _changeOutput _fee, _) <- liftEither BalanceError (balanceTx dbg (primaryCred:otherCreds) output txBody)
+  (C.BalancedTxBody txbody _changeOutput _fee, _) <- liftEither BalanceError (balanceTx dbg (primaryCred:otherCreds) output txBody 0)
   pure (C.makeSignedTransaction [] txbody)
 
 {-| Balance a transaction body using the funds locked by the payment credential

src/devnet/convex-devnet.cabal

@@ -109,3 +109,5 @@ test-suite convex-devnet-test
     , mtl
     , text
     , aeson
+    , filepath
+    , containers