add case to handle min utxo in balance algorithm

Author: IAmPara0x

src/BotPlutusInterface/Balance.hs

@@ -13,7 +13,7 @@ module BotPlutusInterface.Balance (
 
 import BotPlutusInterface.BodyBuilder qualified as BodyBuilder
 import BotPlutusInterface.CardanoCLI qualified as CardanoCLI
-import BotPlutusInterface.CardanoNode.Effects (NodeQuery (UtxosAt))
+import BotPlutusInterface.CardanoNode.Effects (NodeQuery (MinUtxo, UtxosAt))
 import BotPlutusInterface.CoinSelection (selectTxIns)
 import BotPlutusInterface.Collateral (removeCollateralFromMap)
 import BotPlutusInterface.Effects (
@@ -160,10 +160,11 @@ balanceTxIO' balanceCfg pabConf ownPkh unbalancedTx =
 
       -- Balance the tx
       balancedTx <- balanceTxLoop utxoIndex privKeys preBalancedTx
+      changeTxOutWithMinAmt <- newEitherT $ addOutput @w changeAddr balancedTx
 
       -- Get current Ada change
       let adaChange = getAdaChange utxoIndex balancedTx
-          bTx = balanceTxLoop utxoIndex privKeys (addOutput changeAddr balancedTx)
+          bTx = balanceTxLoop utxoIndex privKeys changeTxOutWithMinAmt
 
       -- Checks if there's ada change left, if there is then we check
       -- if `bcSeparateChange` is true, if this is the case then we create a new UTxO at
@@ -289,7 +290,7 @@ balanceTxStep ::
 balanceTxStep balanceCfg utxos changeAddr tx =
   runEitherT $
     (newEitherT . balanceTxIns @w utxos) tx
-      >>= hoistEither . handleNonAdaChange balanceCfg changeAddr utxos
+      >>= newEitherT . handleNonAdaChange @w balanceCfg changeAddr utxos
 
 -- | Get change value of a transaction, taking inputs, outputs, mint and fees into account
 getChange :: Map TxOutRef TxOut -> Tx -> Value
@@ -347,9 +348,19 @@ txUsesScripts Tx {txInputs, txMintScripts} =
       txInputs
 
 -- | Ensures all non ada change goes back to user
-handleNonAdaChange :: BalanceConfig -> Address -> Map TxOutRef TxOut -> Tx -> Either Text Tx
-handleNonAdaChange balanceCfg changeAddr utxos tx =
-  let nonAdaChange = getNonAdaChange utxos tx
+handleNonAdaChange ::
+  forall (w :: Type) (effs :: [Type -> Type]).
+  Member (PABEffect w) effs =>
+  BalanceConfig ->
+  Address ->
+  Map TxOutRef TxOut ->
+  Tx ->
+  Eff effs (Either Text Tx)
+handleNonAdaChange balanceCfg changeAddr utxos tx = runEitherT $ do
+  let nonAdaChange :: Value
+      nonAdaChange = getNonAdaChange utxos tx
+
+      predicate :: TxOut -> Bool
       predicate =
         if bcSeparateChange balanceCfg
           then
@@ -358,20 +369,30 @@ handleNonAdaChange balanceCfg changeAddr utxos tx =
                   && not (justLovelace $ Tx.txOutValue txout)
             )
           else (\txout -> Tx.txOutAddress txout == changeAddr)
+
+      newOutput :: TxOut
       newOutput =
         TxOut
           { txOutAddress = changeAddr
           , txOutValue = nonAdaChange
           , txOutDatumHash = Nothing
           }
+
+  newOutputWithMinAmt <-
+    firstEitherT (Text.pack . show) $
+      newEitherT $
+        queryNode @w (MinUtxo newOutput)
+
+  let outputs :: [TxOut]
       outputs =
         modifyFirst
           predicate
-          (Just . maybe newOutput (addValueToTxOut nonAdaChange))
+          (Just . maybe newOutputWithMinAmt (addValueToTxOut nonAdaChange))
           (txOutputs tx)
-   in if isValueNat nonAdaChange
-        then Right $ if Value.isZero nonAdaChange then tx else tx {txOutputs = outputs}
-        else Left "Not enough inputs to balance tokens."
+
+  if isValueNat nonAdaChange
+    then return $ if Value.isZero nonAdaChange then tx else tx {txOutputs = outputs}
+    else throwE "Not enough inputs to balance tokens."
 
 {- | `addAdaChange` checks if `bcSeparateChange` is true,
       if it is then we add the ada change to seperate `TxOut` at changeAddr that contains only ada,
@@ -401,16 +422,29 @@ addAdaChange balanceCfg changeAddr change tx
 addValueToTxOut :: Value -> TxOut -> TxOut
 addValueToTxOut val txOut = txOut {txOutValue = txOutValue txOut <> val}
 
--- | Adds a 1 lovelace output to a transaction
-addOutput :: Address -> Tx -> Tx
-addOutput changeAddr tx = tx {txOutputs = txOutputs tx ++ [changeTxOut]}
-  where
-    changeTxOut =
-      TxOut
-        { txOutAddress = changeAddr
-        , txOutValue = Ada.lovelaceValueOf 1
-        , txOutDatumHash = Nothing
-        }
+-- | creates a Tx output with min lovelace.
+addOutput ::
+  forall (w :: Type) (effs :: [Type -> Type]).
+  Member (PABEffect w) effs =>
+  Address ->
+  Tx ->
+  Eff effs (Either Text Tx)
+addOutput changeAddr tx =
+  runEitherT $ do
+    let changeTxOut :: TxOut
+        changeTxOut =
+          TxOut
+            { txOutAddress = changeAddr
+            , txOutValue = Ada.lovelaceValueOf 1
+            , txOutDatumHash = Nothing
+            }
+
+    changeTxOutWithMinAmt <-
+      firstEitherT (Text.pack . show) $
+        newEitherT $
+          queryNode @w (MinUtxo changeTxOut)
+
+    return $ tx {txOutputs = txOutputs tx ++ [changeTxOutWithMinAmt]}
 
 {- | Add the required signatories to the transaction. Be aware the the signature itself is invalid,
  and will be ignored. Only the pub key hashes are used, mapped to signing key files on disk.

src/BotPlutusInterface/CardanoNode/Effects.hs

@@ -10,6 +10,8 @@
 -}
 module BotPlutusInterface.CardanoNode.Effects (
   utxosAt,
+  pparams,
+  minUtxo,
   handleNodeQuery,
   runNodeQuery,
   NodeQuery (..),
@@ -21,32 +23,44 @@ import BotPlutusInterface.CardanoNode.Query (
   QueryConstraint,
   connectionInfo,
   queryBabbageEra,
+  queryInCardanoMode,
   toQueryError,
  )
 
 import BotPlutusInterface.CardanoAPI (
   addressInEraToAny,
   fromCardanoTxOut,
  )
+
 import BotPlutusInterface.Types (PABConfig)
 import Cardano.Api (LocalNodeConnectInfo (..))
 import Cardano.Api qualified as CApi
+import Cardano.Api.Shelley qualified as CApi.S
+import Cardano.Ledger.Shelley.API.Wallet (
+  CLI (evaluateMinLovelaceOutput),
+ )
 import Control.Lens (folded, to, (^..))
 import Control.Monad.Freer (Eff, Members, interpret, runM, send, type (~>))
 import Control.Monad.Freer.Reader (Reader, ask, runReader)
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Either (firstEitherT, hoistEither, newEitherT, runEitherT)
+import Control.Monad.Trans.Except (throwE)
 import Data.Map (Map)
 import Data.Map qualified as Map
 import Data.Set qualified as Set
+import Ledger qualified
+import Ledger.Ada qualified as Ada
 import Ledger.Address (Address)
 import Ledger.Tx (ChainIndexTxOut (..))
 import Ledger.Tx.CardanoAPI qualified as TxApi
+import Ledger.Validation (Coin (Coin))
 import Plutus.V2.Ledger.Tx qualified as V2
 import Prelude
 
 data NodeQuery a where
   UtxosAt :: Address -> NodeQuery (Either NodeQueryError (Map V2.TxOutRef ChainIndexTxOut))
+  PParams :: NodeQuery (Either NodeQueryError CApi.S.ProtocolParameters)
+  MinUtxo :: Ledger.TxOut -> NodeQuery (Either NodeQueryError Ledger.TxOut)
 
 utxosAt ::
   forall effs.
@@ -55,13 +69,28 @@ utxosAt ::
   Eff effs (Either NodeQueryError (Map V2.TxOutRef ChainIndexTxOut))
 utxosAt = send . UtxosAt
 
+pparams ::
+  forall effs.
+  Members '[NodeQuery] effs =>
+  Eff effs (Either NodeQueryError CApi.S.ProtocolParameters)
+pparams = send PParams
+
+minUtxo ::
+  forall effs.
+  Members '[NodeQuery] effs =>
+  Ledger.TxOut ->
+  Eff effs (Either NodeQueryError Ledger.TxOut)
+minUtxo = send . MinUtxo
+
 handleNodeQuery ::
   forall effs.
   QueryConstraint effs =>
   Eff (NodeQuery ': effs) ~> Eff effs
 handleNodeQuery =
   interpret $ \case
     UtxosAt addr -> handleUtxosAt addr
+    PParams -> queryPParams
+    MinUtxo txout -> handleMinUtxo txout
 
 handleUtxosAt ::
   forall effs.
@@ -92,9 +121,56 @@ handleUtxosAt addr = runEitherT $ do
 
   return $ Map.fromList $ zip txOutRefs chainIndexTxOuts
 
+handleMinUtxo ::
+  forall effs.
+  QueryConstraint effs =>
+  Ledger.TxOut ->
+  Eff effs (Either NodeQueryError Ledger.TxOut)
+handleMinUtxo txout = runEitherT $ do
+  conn <- lift $ ask @NodeConn
+
+  params <- newEitherT queryPParams
+
+  let pparamsInEra = CApi.toLedgerPParams CApi.ShelleyBasedEraBabbage params
+      netId = localNodeNetworkId conn
+
+  ctxout <-
+    firstEitherT toQueryError $
+      hoistEither $
+        TxApi.toCardanoTxOut netId TxApi.toCardanoTxOutDatumHash txout
+
+  let (Coin minTxOut) =
+        evaluateMinLovelaceOutput pparamsInEra $
+          CApi.S.toShelleyTxOut CApi.ShelleyBasedEraBabbage ctxout
+
+      missingLovelace = Ada.lovelaceOf minTxOut - Ada.fromValue (Ledger.txOutValue txout)
+
+  if missingLovelace > 0
+    then
+      newEitherT $
+        handleMinUtxo (txout {Ledger.txOutValue = Ledger.txOutValue txout <> Ada.toValue missingLovelace})
+    else return txout
+
 runNodeQuery :: PABConfig -> Eff '[NodeQuery, Reader NodeConn, IO] ~> IO
 runNodeQuery conf effs = do
   conn <- connectionInfo conf
   runM $
     runReader conn $
       handleNodeQuery effs
+
+-- Helpers
+
+queryPParams ::
+  forall effs.
+  QueryConstraint effs =>
+  Eff effs (Either NodeQueryError CApi.S.ProtocolParameters)
+queryPParams = runEitherT $ do
+  let query =
+        CApi.QueryInEra CApi.BabbageEraInCardanoMode $
+          CApi.QueryInShelleyBasedEra CApi.ShelleyBasedEraBabbage CApi.QueryProtocolParameters
+
+  result <- newEitherT $ queryInCardanoMode query
+
+  case result of
+    Right params -> return params
+    Left err -> throwE $ toQueryError err

test/Spec/MockContract.hs

@@ -53,7 +53,8 @@ module Spec.MockContract (
 ) where
 
 import BotPlutusInterface.CardanoCLI (unsafeSerialiseAddress)
-import BotPlutusInterface.CardanoNode.Effects (NodeQuery (UtxosAt))
+import BotPlutusInterface.CardanoNode.Effects (NodeQuery (MinUtxo, PParams, UtxosAt))
+import BotPlutusInterface.CardanoNode.Query (toQueryError)
 import BotPlutusInterface.Collateral (removeCollateralFromPage)
 import BotPlutusInterface.Contract (handleContract)
 import BotPlutusInterface.Effects (PABEffect (..), ShellArgs (..))
@@ -112,6 +113,7 @@ import Data.ByteString.Lazy qualified as LBS
 import Data.ByteString.Short qualified as SBS
 import Data.Default (Default (def))
 import Data.Either.Combinators (fromRight, mapLeft)
+import Data.Either.Extra (maybeToEither)
 import Data.Hex (hex, unhex)
 import Data.Kind (Type)
 import Data.List (isPrefixOf, sortOn)
@@ -375,7 +377,14 @@ runPABEffectPure initState req =
     go (SetInMemCollateral collateral) = modify @(MockContractState w) $ set collateralUtxo (Just collateral)
     go (QueryNode (UtxosAt _addr)) = do
       state <- get @(MockContractState w)
-      return $ return $ Map.fromList (state ^. utxos)
+      return $ Right $ Map.fromList (state ^. utxos)
+    go (QueryNode (MinUtxo utxo)) = return $ Right utxo
+    go (QueryNode PParams) =
+      maybeToEither (toQueryError @String "Not able to get ProtocolParameters.")
+        . pcProtocolParams
+        . cePABConfig
+        . _contractEnv
+        <$> get @(MockContractState w)
     incSlot :: forall (v :: Type). MockContract w v -> MockContract w v
     incSlot mc =
       mc <* modify @(MockContractState w) (tip %~ incTip)