Merge pull request #128 from mlabs-haskell/issue-32-better-coin-selection

Issue 32 better coin selection

Author: IAmPara0x

.gitignore

@@ -64,6 +64,6 @@ geth-node/chaindata/history
 *.~undo-tree~
 
 # debug configs
-examples/debug/ci-test.http
-examples/debug/run-test-lc.sh
-examples/debug/run-test-tn.sh
+examples/debug/
+
+visualization/

bot-plutus-interface.cabal

@@ -82,6 +82,7 @@ library
     BotPlutusInterface.BodyBuilder
     BotPlutusInterface.CardanoCLI
     BotPlutusInterface.ChainIndex
+    BotPlutusInterface.CoinSelection
     BotPlutusInterface.Collateral
     BotPlutusInterface.Config
     BotPlutusInterface.Contract
@@ -176,6 +177,7 @@ test-suite bot-plutus-interface-test
   ghc-options:    -fplugin-opt PlutusTx.Plugin:defer-errors
   other-modules:
     Spec.BotPlutusInterface.Balance
+    Spec.BotPlutusInterface.CoinSelection
     Spec.BotPlutusInterface.Collateral
     Spec.BotPlutusInterface.Config
     Spec.BotPlutusInterface.Contract
@@ -184,6 +186,7 @@ test-suite bot-plutus-interface-test
     Spec.BotPlutusInterface.TxStatusChange
     Spec.BotPlutusInterface.UtxoParser
     Spec.MockContract
+    Spec.RandomLedger
 
   build-depends:
     , aeson                      ^>=1.5.0.0
@@ -236,6 +239,7 @@ test-suite bot-plutus-interface-test
     , text                       ^>=1.2.4.0
     , utf8-string
     , uuid
+    , vector
     , warp
 
   hs-source-dirs: test

cabal.project

@@ -7,3 +7,4 @@ packages: ./bot-plutus-interface.cabal
 
 tests: true
 benchmarks: true
+test-show-details: direct

src/BotPlutusInterface/Balance.hs

@@ -13,6 +13,7 @@ module BotPlutusInterface.Balance (
 
 import BotPlutusInterface.BodyBuilder qualified as BodyBuilder
 import BotPlutusInterface.CardanoCLI qualified as CardanoCLI
+import BotPlutusInterface.CoinSelection (selectTxIns)
 import BotPlutusInterface.Collateral (removeCollateralFromMap)
 import BotPlutusInterface.Effects (
   PABEffect,
@@ -30,7 +31,6 @@ import BotPlutusInterface.Types (
   PABConfig,
   collateralTxOutRef,
  )
-
 import Cardano.Api (ExecutionUnitPrices (ExecutionUnitPrices))
 import Cardano.Api.Shelley (ProtocolParameters (protocolParamPrices))
 import Control.Monad (foldM, void, zipWithM)
@@ -40,14 +40,12 @@ import Control.Monad.Trans.Either (EitherT, hoistEither, newEitherT, runEitherT)
 import Control.Monad.Trans.Except (throwE)
 import Data.Bifunctor (bimap)
 import Data.Coerce (coerce)
-import Data.Either.Combinators (rightToMaybe)
 import Data.Kind (Type)
 import Data.List ((\\))
 import Data.List qualified as List
 import Data.Map (Map)
 import Data.Map qualified as Map
 import Data.Maybe (fromMaybe, mapMaybe)
-import Data.Set (Set)
 import Data.Set qualified as Set
 import Data.Text (Text)
 import Data.Text qualified as Text
@@ -76,7 +74,6 @@ import Ledger.Tx qualified as Tx
 import Ledger.Value (Value)
 import Ledger.Value qualified as Value
 import Plutus.V1.Ledger.Api (
-  Credential (PubKeyCredential, ScriptCredential),
   CurrencySymbol (..),
   TokenName (..),
  )
@@ -168,6 +165,18 @@ balanceTxIO' balanceCfg pabConf ownPkh unbalancedTx =
       -- Get the updated change, add it to the tx
       let finalAdaChange = getAdaChange utxoIndex balancedTxWithChange
           fullyBalancedTx = addAdaChange balanceCfg changeAddr finalAdaChange balancedTxWithChange
+          txInfoLog =
+            printBpiLog @w (Debug [TxBalancingLog]) $
+              "UnbalancedTx TxInputs: "
+                <+> pretty (length $ txInputs preBalancedTx)
+                <+> "UnbalancedTx TxOutputs: "
+                <+> pretty (length $ txOutputs preBalancedTx)
+                <+> "TxInputs: "
+                <+> pretty (length $ txInputs fullyBalancedTx)
+                <+> "TxOutputs: "
+                <+> pretty (length $ txOutputs fullyBalancedTx)
+
+      lift txInfoLog
 
       -- finally, we must update the signatories
       hoistEither $ addSignatories ownPkh privKeys requiredSigs fullyBalancedTx
@@ -193,7 +202,7 @@ balanceTxIO' balanceCfg pabConf ownPkh unbalancedTx =
 
       -- Calculate fees by pre-balancing the tx, building it, and running the CLI on result
       txWithoutFees <-
-        hoistEither $ balanceTxStep balanceCfg minUtxos utxoIndex changeAddr $ tx `withFee` 0
+        newEitherT $ balanceTxStep @w balanceCfg minUtxos utxoIndex changeAddr $ tx `withFee` 0
 
       exBudget <- newEitherT $ BodyBuilder.buildAndEstimateBudget @w pabConf privKeys txWithoutFees
 
@@ -204,7 +213,7 @@ balanceTxIO' balanceCfg pabConf ownPkh unbalancedTx =
       lift $ printBpiLog @w (Debug [TxBalancingLog]) $ "Fees:" <+> pretty fees
 
       -- Rebalance the initial tx with the above fees
-      balancedTx <- hoistEither $ balanceTxStep balanceCfg minUtxos utxoIndex changeAddr $ tx `withFee` fees
+      balancedTx <- newEitherT $ balanceTxStep @w balanceCfg minUtxos utxoIndex changeAddr $ tx `withFee` fees
 
       if balancedTx == tx
         then pure (balancedTx, minUtxos)
@@ -272,16 +281,18 @@ calculateMinUtxos pabConf datums txOuts =
   zipWithM (fmap . (,)) txOuts <$> mapM (CardanoCLI.calculateMinUtxo @w pabConf datums) txOuts
 
 balanceTxStep ::
+  forall (w :: Type) (effs :: [Type -> Type]).
+  Member (PABEffect w) effs =>
   BalanceConfig ->
   [(TxOut, Integer)] ->
   Map TxOutRef TxOut ->
   Address ->
   Tx ->
-  Either Text Tx
+  Eff effs (Either Text Tx)
 balanceTxStep balanceCfg minUtxos utxos changeAddr tx =
-  Right (addLovelaces minUtxos tx)
-    >>= balanceTxIns utxos
-    >>= handleNonAdaChange balanceCfg changeAddr utxos
+  runEitherT $
+    (newEitherT . balanceTxIns @w utxos) (addLovelaces minUtxos tx)
+      >>= hoistEither . handleNonAdaChange balanceCfg changeAddr utxos
 
 -- | Get change value of a transaction, taking inputs, outputs, mint and fees into account
 getChange :: Map TxOutRef TxOut -> Tx -> Value
@@ -303,45 +314,6 @@ getAdaChange utxos = lovelaceValue . getChange utxos
 getNonAdaChange :: Map TxOutRef TxOut -> Tx -> Value
 getNonAdaChange utxos = Ledger.noAdaValue . getChange utxos
 
--- | Getting the necessary utxos to cover the fees for the transaction
-collectTxIns :: Set TxIn -> Map TxOutRef TxOut -> Value -> Either Text (Set TxIn)
-collectTxIns originalTxIns utxos value =
-  if isSufficient updatedInputs
-    then Right updatedInputs
-    else
-      Left $
-        Text.unlines
-          [ "Insufficient tx inputs, needed: "
-          , showText (Value.flattenValue value)
-          , "got:"
-          , showText (Value.flattenValue (txInsValue updatedInputs))
-          ]
-  where
-    updatedInputs =
-      foldl
-        ( \acc txIn ->
-            if isSufficient acc
-              then acc
-              else Set.insert txIn acc
-        )
-        originalTxIns
-        $ mapMaybe (rightToMaybe . txOutToTxIn) $ Map.toList utxos
-
-    isSufficient :: Set TxIn -> Bool
-    isSufficient txIns' =
-      not (Set.null txIns') && txInsValue txIns' `Value.geq` value
-
-    txInsValue :: Set TxIn -> Value
-    txInsValue txIns' =
-      mconcat $ map Tx.txOutValue $ mapMaybe ((`Map.lookup` utxos) . Tx.txInRef) $ Set.toList txIns'
-
--- Converting a chain index transaction output to a transaction input type
-txOutToTxIn :: (TxOutRef, TxOut) -> Either Text TxIn
-txOutToTxIn (txOutRef, txOut) =
-  case addressCredential (txOutAddress txOut) of
-    PubKeyCredential _ -> Right $ Tx.pubKeyTxIn txOutRef
-    ScriptCredential _ -> Left "Cannot covert a script output to TxIn"
-
 -- | Add min lovelaces to each tx output
 addLovelaces :: [(TxOut, Integer)] -> Tx -> Tx
 addLovelaces minLovelaces tx =
@@ -359,17 +331,23 @@ addLovelaces minLovelaces tx =
           $ txOutputs tx
    in tx {txOutputs = lovelacesAdded}
 
-balanceTxIns :: Map TxOutRef TxOut -> Tx -> Either Text Tx
+balanceTxIns ::
+  forall (w :: Type) (effs :: [Type -> Type]).
+  Member (PABEffect w) effs =>
+  Map TxOutRef TxOut ->
+  Tx ->
+  Eff effs (Either Text Tx)
 balanceTxIns utxos tx = do
-  let txOuts = Tx.txOutputs tx
-      nonMintedValue = mconcat (map Tx.txOutValue txOuts) `minus` txMint tx
-      minSpending =
-        mconcat
-          [ txFee tx
-          , nonMintedValue
-          ]
-  txIns <- collectTxIns (txInputs tx) utxos minSpending
-  pure $ tx {txInputs = txIns <> txInputs tx}
+  runEitherT $ do
+    let txOuts = Tx.txOutputs tx
+        nonMintedValue = mconcat (map Tx.txOutValue txOuts) `minus` txMint tx
+        minSpending =
+          mconcat
+            [ txFee tx
+            , nonMintedValue
+            ]
+    txIns <- newEitherT $ selectTxIns @w (txInputs tx) utxos minSpending
+    pure $ tx {txInputs = txIns <> txInputs tx}
 
 -- | Set collateral or fail in case it's required but not available
 addTxCollaterals :: CollateralUtxo -> Tx -> Tx
@@ -500,9 +478,6 @@ modifyFirst ::
 modifyFirst _ m [] = m Nothing `consJust` []
 modifyFirst p m (x : xs) = if p x then m (Just x) `consJust` xs else x : modifyFirst p m xs
 
-showText :: forall (a :: Type). Show a => a -> Text
-showText = Text.pack . show
-
 minus :: Value -> Value -> Value
 minus x y =
   let negativeValues = map (\(c, t, a) -> (c, t, - a)) $ Value.flattenValue y