Fully internalise balancing, fix tests

Author: samuelWilliams99

README.md

@@ -125,13 +125,13 @@ The fake PAB consists of the following modules:
 - **BotPlutusInterface** main entry point
 - **BotPlutusInterface.Server** Servant server, handling http endpoint calls and websockets
 - **BotPlutusInterface.Contract** handling contract effects by creating the necessary files and calling cardano-cli commands (a few effects are mocked)
-- **BotPlutusInterface.PreBalance** doing some preparations so the cli can process the rest (non-ada asset balancing, addig tx inputs, adding minimum lovelaces, add signatories)
+- **BotPlutusInterface.Balance** doing some preparations so the cli can process the rest (non-ada asset balancing, addig tx inputs, adding minimum lovelaces, add signatories)
 - **BotPlutusInterface.CardanoCLI** wrappers for cardano-cli commands
 - For development purposes, I created an ssh wrapper, so I can call relay these commands through an ssh connection. This is not nice, unsafe, and pretty slow, avoid using it if you can.
 - **BotPlutusInterface.UtxoParser** parse the output of the `cardano-cli query utxo` command
 - **BotPlutusInterface.Files** functions for handling script, datum and redeemer files
 - **BotPlutusInterface.Types** configuration for the fake pab
-- **BotPlutusInterface.PreBalance** prepare a transaction before sending to the cli for balancing. This includes:
+- **BotPlutusInterface.Balance** prepare a transaction before sending to the cli for balancing. This includes:
   - adding tx inputs to cover fees and outputs
   - adding collaterals,
   - modifying tx outs to contain the minimum amount of lovelaces

bot-plutus-interface.cabal

@@ -81,7 +81,7 @@ library
     BotPlutusInterface.Contract
     BotPlutusInterface.Effects
     BotPlutusInterface.Files
-    BotPlutusInterface.PreBalance
+    BotPlutusInterface.Balance
     BotPlutusInterface.Types
     BotPlutusInterface.UtxoParser
 
@@ -143,7 +143,7 @@ test-suite bot-plutus-interface-test
   ghc-options:    -fplugin-opt PlutusTx.Plugin:defer-errors
   other-modules:
     Spec.BotPlutusInterface.Contract
-    Spec.BotPlutusInterface.PreBalance
+    Spec.BotPlutusInterface.Balance
     Spec.BotPlutusInterface.UtxoParser
     Spec.MockContract
 

src/BotPlutusInterface/PreBalance.hs renamed to src/BotPlutusInterface/Balance.hs

@@ -1,21 +1,20 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 
-module BotPlutusInterface.PreBalance (
-  preBalanceTx,
-  preBalanceTxIO,
+module BotPlutusInterface.Balance (
+  balanceTxStep,
+  balanceTxIO,
 ) where
 
 import BotPlutusInterface.CardanoCLI qualified as CardanoCLI
 import BotPlutusInterface.Effects (PABEffect, createDirectoryIfMissing, printLog)
 import BotPlutusInterface.Files (DummyPrivKey, unDummyPrivateKey)
 import BotPlutusInterface.Files qualified as Files
 import BotPlutusInterface.Types (LogLevel (Debug), PABConfig)
-import Cardano.Api.Shelley (Lovelace (Lovelace), ProtocolParameters (protocolParamUTxOCostPerWord))
 import Control.Monad (foldM, void, zipWithM)
 import Control.Monad.Freer (Eff, Member)
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Either (EitherT, hoistEither, newEitherT, runEitherT)
-import Data.Either.Combinators (maybeToRight, rightToMaybe)
+import Data.Either.Combinators (rightToMaybe)
 import Data.Kind (Type)
 import Data.List (partition, (\\))
 import Data.Map (Map)
@@ -47,27 +46,26 @@ import Ledger.Tx (
   TxOutRef (..),
  )
 import Ledger.Tx qualified as Tx
-import Ledger.Value (Value (Value), getValue)
+import Ledger.Value (Value)
 import Ledger.Value qualified as Value
 import Plutus.V1.Ledger.Api (
   Credential (PubKeyCredential, ScriptCredential),
   CurrencySymbol (..),
   TokenName (..),
  )
-import PlutusTx.AssocMap qualified as AssocMap
 import Prelude
 
 {- | Collect necessary tx inputs and collaterals, add minimum lovelace values and balance non ada
  assets
 -}
-preBalanceTxIO ::
+balanceTxIO ::
   forall (w :: Type) (effs :: [Type -> Type]).
   Member (PABEffect w) effs =>
   PABConfig ->
   PubKeyHash ->
   UnbalancedTx ->
   Eff effs (Either Text Tx)
-preBalanceTxIO pabConf ownPkh unbalancedTx =
+balanceTxIO pabConf ownPkh unbalancedTx =
   runEitherT $
     do
       utxos <- newEitherT $ CardanoCLI.utxosAt @w pabConf $ Ledger.pubKeyHashAddress (Ledger.PaymentPubKeyHash ownPkh) Nothing
@@ -83,16 +81,23 @@ preBalanceTxIO pabConf ownPkh unbalancedTx =
 
       lift $ printLog @w Debug $ show utxoIndex
 
-      loop utxoIndex privKeys requiredSigs [] tx
+      -- Adds required collaterals, only needs to happen once
+      -- Also adds signatures for fee calculation
+      preBalancedTx <- hoistEither $ addTxCollaterals utxoIndex tx >>= addSignatories ownPkh privKeys requiredSigs
+
+      -- Balance the tx
+      balancedTx <- loop utxoIndex privKeys [] preBalancedTx
+
+      -- finally, we must update the signatories
+      hoistEither $ addSignatories ownPkh privKeys requiredSigs balancedTx
   where
     loop ::
       Map TxOutRef TxOut ->
       Map PubKeyHash DummyPrivKey ->
-      [PubKeyHash] ->
       [(TxOut, Integer)] ->
       Tx ->
       EitherT Text (Eff effs) Tx
-    loop utxoIndex privKeys requiredSigs prevMinUtxos tx = do
+    loop utxoIndex privKeys prevMinUtxos tx = do
       void $ lift $ Files.writeAll @w pabConf tx
       nextMinUtxos <-
         newEitherT $
@@ -102,20 +107,24 @@ preBalanceTxIO pabConf ownPkh unbalancedTx =
 
       lift $ printLog @w Debug $ "Min utxos: " ++ show minUtxos
 
+      -- Calculate fees by pre-balancing the tx, building it, and running the CLI on result
       txWithoutFees <-
-        hoistEither $ preBalanceTx pabConf.pcProtocolParams minUtxos 0 utxoIndex ownPkh privKeys requiredSigs tx
+        hoistEither $ balanceTxStep minUtxos 0 utxoIndex ownPkh tx
 
       lift $ createDirectoryIfMissing @w False (Text.unpack pabConf.pcTxFileDir)
-      newEitherT $ CardanoCLI.buildTx @w pabConf privKeys ownPkh (CardanoCLI.BuildRaw 0) txWithoutFees
+      newEitherT $ CardanoCLI.buildTx @w pabConf privKeys txWithoutFees
       fees <- newEitherT $ CardanoCLI.calculateMinFee @w pabConf txWithoutFees
 
       lift $ printLog @w Debug $ "Fees: " ++ show fees
 
-      balancedTx <- hoistEither $ preBalanceTx pabConf.pcProtocolParams minUtxos fees utxoIndex ownPkh privKeys requiredSigs tx
+      -- Rebalance the initial tx with the above fees
+      balancedTx <- hoistEither $ balanceTxStep minUtxos fees utxoIndex ownPkh tx
+
+      let balanceTxWithFees = balancedTx {txFee = Ada.lovelaceValueOf fees}
 
-      if balancedTx == tx
-        then pure balancedTx
-        else loop utxoIndex privKeys requiredSigs minUtxos balancedTx
+      if balanceTxWithFees == tx
+        then pure balanceTxWithFees
+        else loop utxoIndex privKeys minUtxos balanceTxWithFees
 
 calculateMinUtxos ::
   forall (w :: Type) (effs :: [Type -> Type]).
@@ -127,24 +136,17 @@ calculateMinUtxos ::
 calculateMinUtxos pabConf datums txOuts =
   zipWithM (fmap . (,)) txOuts <$> mapM (CardanoCLI.calculateMinUtxo @w pabConf datums) txOuts
 
-preBalanceTx ::
-  ProtocolParameters ->
+balanceTxStep ::
   [(TxOut, Integer)] ->
   Integer ->
   Map TxOutRef TxOut ->
   PubKeyHash ->
-  Map PubKeyHash DummyPrivKey ->
-  [PubKeyHash] ->
   Tx ->
   Either Text Tx
-preBalanceTx pparams minUtxos fees utxos ownPkh privKeys requiredSigs tx =
-  addTxCollaterals utxos tx
-    >>= balanceTxIns pparams utxos fees
-    >>= balanceNonAdaOuts ownPkh utxos
-    >>= Right . addLovelaces minUtxos
-    >>= balanceTxIns pparams utxos fees -- Adding more inputs if required
-    >>= balanceNonAdaOuts ownPkh utxos
-    >>= addSignatories ownPkh privKeys requiredSigs
+balanceTxStep minUtxos fees utxos ownPkh tx =
+  Right (addLovelaces minUtxos tx)
+    >>= balanceTxIns utxos fees
+    >>= handleChange ownPkh utxos fees
 
 -- | Getting the necessary utxos to cover the fees for the transaction
 collectTxIns :: Set TxIn -> Map TxOutRef TxOut -> Value -> Either Text (Set TxIn)
@@ -202,18 +204,13 @@ addLovelaces minLovelaces tx =
           $ txOutputs tx
    in tx {txOutputs = lovelacesAdded}
 
-balanceTxIns :: ProtocolParameters -> Map TxOutRef TxOut -> Integer -> Tx -> Either Text Tx
-balanceTxIns pparams utxos fees tx = do
-  Lovelace utxoCost <-
-    maybeToRight "UTxOCostPerWord parameter not found" $ protocolParamUTxOCostPerWord pparams
+balanceTxIns :: Map TxOutRef TxOut -> Integer -> Tx -> Either Text Tx
+balanceTxIns utxos fees tx = do
   let txOuts = Tx.txOutputs tx
       nonMintedValue = mconcat (map Tx.txOutValue txOuts) `minus` txMint tx
-      -- An ada-only UTxO entry is 29 words. More details about min utxo calculation can be found here:
-      -- https://github.com/cardano-foundation/CIPs/tree/master/CIP-0028#rationale-for-parameter-choices
-      changeMinUtxo = 29 * utxoCost
       minSpending =
         mconcat
-          [ Ada.lovelaceValueOf (fees + changeMinUtxo)
+          [ Ada.lovelaceValueOf fees
           , nonMintedValue
           ]
   txIns <- collectTxIns (txInputs tx) utxos minSpending
@@ -235,28 +232,28 @@ addTxCollaterals utxos tx = do
       _ -> Left "There are no utxos to be used as collateral"
     filterAdaOnly = Map.filter (isAdaOnly . txOutValue)
 
--- | We need to balance non ada values, as the cardano-cli is unable to balance them (as of 2021/09/24)
-balanceNonAdaOuts :: PubKeyHash -> Map TxOutRef TxOut -> Tx -> Either Text Tx
-balanceNonAdaOuts ownPkh utxos tx =
+-- | Ensures all change goes back to user
+handleChange :: PubKeyHash -> Map TxOutRef TxOut -> Integer -> Tx -> Either Text Tx
+handleChange ownPkh utxos fees tx =
   let changeAddr = Ledger.pubKeyHashAddress (Ledger.PaymentPubKeyHash ownPkh) Nothing
       txInRefs = map Tx.txInRef $ Set.toList $ txInputs tx
       inputValue = mconcat $ map Tx.txOutValue $ mapMaybe (`Map.lookup` utxos) txInRefs
       outputValue = mconcat $ map Tx.txOutValue $ txOutputs tx
       nonMintedOutputValue = outputValue `minus` txMint tx
-      nonAdaChange = filterNonAda inputValue `minus` filterNonAda nonMintedOutputValue
+      change = (inputValue `minus` nonMintedOutputValue) `minus` Ada.lovelaceValueOf fees
       outputs =
         case partition ((==) changeAddr . Tx.txOutAddress) $ txOutputs tx of
           ([], txOuts) ->
             TxOut
               { txOutAddress = changeAddr
-              , txOutValue = nonAdaChange
+              , txOutValue = change
               , txOutDatumHash = Nothing
               } :
             txOuts
           (txOut@TxOut {txOutValue = v} : txOuts, txOuts') ->
-            txOut {txOutValue = v <> nonAdaChange} : (txOuts <> txOuts')
-   in if isValueNat nonAdaChange
-        then Right $ if Value.isZero nonAdaChange then tx else tx {txOutputs = outputs}
+            txOut {txOutValue = v <> change} : (txOuts <> txOuts')
+   in if isValueNat change
+        then Right $ if Value.isZero change then tx else tx {txOutputs = outputs}
         else Left "Not enough inputs to balance tokens."
 
 {- | Add the required signatorioes to the transaction. Be aware the the signature itself is invalid,
@@ -289,14 +286,6 @@ validateRange _ = True
 showText :: forall (a :: Type). Show a => a -> Text
 showText = Text.pack . show
 
--- | Filter by key for Associated maps (why doesn't this exist?)
-filterKey :: (k -> Bool) -> AssocMap.Map k v -> AssocMap.Map k v
-filterKey f = AssocMap.mapMaybeWithKey $ \k v -> if f k then Just v else Nothing
-
--- | Filter a value to contain only non ada assets
-filterNonAda :: Value -> Value
-filterNonAda = Value . filterKey (/= Ada.adaSymbol) . getValue
-
 minus :: Value -> Value -> Value
 minus x y =
   let negativeValues = map (\(c, t, a) -> (c, t, - a)) $ Value.flattenValue y

src/BotPlutusInterface/CardanoCLI.hs

@@ -2,7 +2,6 @@
 {-# LANGUAGE NamedFieldPuns #-}
 
 module BotPlutusInterface.CardanoCLI (
-  BuildMode (..),
   submitTx,
   calculateMinUtxo,
   calculateMinFee,
@@ -80,6 +79,7 @@ import Ledger.TxId (TxId (..))
 import Ledger.Value (Value)
 import Ledger.Value qualified as Value
 import Plutus.Contract.CardanoAPI (toCardanoAddress)
+import Plutus.V1.Ledger.Ada (fromValue, getLovelace)
 import Plutus.V1.Ledger.Api (
   BuiltinData,
   CurrencySymbol (..),
@@ -190,27 +190,17 @@ calculateMinFee pabConf tx =
         , cmdOutParser = mapLeft Text.pack . parseOnly UtxoParser.feeParser . Text.pack
         }
 
-data BuildMode = BuildRaw Integer | BuildAuto
-  deriving stock (Show)
-
-isRawBuildMode :: BuildMode -> Bool
-isRawBuildMode (BuildRaw _) = True
-isRawBuildMode _ = False
-
 -- | Build a tx body and write it to disk
 buildTx ::
   forall (w :: Type) (effs :: [Type -> Type]).
   Member (PABEffect w) effs =>
   PABConfig ->
   Map PubKeyHash DummyPrivKey ->
-  PubKeyHash ->
-  BuildMode ->
   Tx ->
   Eff effs (Either Text ())
-buildTx pabConf privKeys ownPkh buildMode tx =
+buildTx pabConf privKeys tx =
   callCommand @w $ ShellArgs "cardano-cli" opts (const ())
   where
-    ownAddr = Ledger.pubKeyHashAddress (Ledger.PaymentPubKeyHash ownPkh) Nothing
     requiredSigners =
       concatMap
         ( \pubKey ->
@@ -226,20 +216,14 @@ buildTx pabConf privKeys ownPkh buildMode tx =
         (Map.keys (Ledger.txSignatures tx))
     opts =
       mconcat
-        [ ["transaction", if isRawBuildMode buildMode then "build-raw" else "build", "--alonzo-era"]
-        , txInOpts pabConf buildMode (txInputs tx)
+        [ ["transaction", "build-raw", "--alonzo-era"]
+        , txInOpts pabConf (txInputs tx)
         , txInCollateralOpts (txCollateral tx)
         , txOutOpts pabConf (txData tx) (txOutputs tx)
-        , mintOpts pabConf buildMode (txMintScripts tx) (txRedeemers tx) (txMint tx)
+        , mintOpts pabConf (txMintScripts tx) (txRedeemers tx) (txMint tx)
         , validRangeOpts (txValidRange tx)
         , requiredSigners
-        , case buildMode of
-            BuildRaw fee -> ["--fee", showText fee]
-            BuildAuto ->
-              mconcat
-                [ ["--change-address", unsafeSerialiseAddress pabConf.pcNetwork ownAddr]
-                , networkOpt pabConf
-                ]
+        , ["--fee", showText . getLovelace . fromValue $ txFee tx]
         , mconcat
             [ ["--protocol-params-file", pabConf.pcProtocolParamsFile]
             , ["--out-file", txFilePath pabConf "raw" tx]
@@ -289,8 +273,8 @@ submitTx pabConf tx =
       )
       (const ())
 
-txInOpts :: PABConfig -> BuildMode -> Set TxIn -> [Text]
-txInOpts pabConf buildMode =
+txInOpts :: PABConfig -> Set TxIn -> [Text]
+txInOpts pabConf =
   concatMap
     ( \(TxIn txOutRef txInType) ->
         mconcat
@@ -315,9 +299,10 @@ txInOpts pabConf buildMode =
                         [ "--tx-in-redeemer-file"
                         , redeemerJsonFilePath pabConf (Ledger.redeemerHash redeemer)
                         ]
-                      , if isRawBuildMode buildMode
-                          then ["--tx-in-execution-units", exBudgetToCliArg exBudget]
-                          else []
+                      ,
+                        [ "--tx-in-execution-units"
+                        , exBudgetToCliArg exBudget
+                        ]
                       ]
               Just ConsumePublicKeyAddress -> []
               Just ConsumeSimpleScriptAddress -> []
@@ -331,8 +316,8 @@ txInCollateralOpts =
   concatMap (\(TxIn txOutRef _) -> ["--tx-in-collateral", txOutRefToCliArg txOutRef]) . Set.toList
 
 -- Minting options
-mintOpts :: PABConfig -> BuildMode -> Set Scripts.MintingPolicy -> Redeemers -> Value -> [Text]
-mintOpts pabConf buildMode mintingPolicies redeemers mintValue =
+mintOpts :: PABConfig -> Set Scripts.MintingPolicy -> Redeemers -> Value -> [Text]
+mintOpts pabConf mintingPolicies redeemers mintValue =
   mconcat
     [ mconcat $
         concatMap
@@ -348,9 +333,7 @@ mintOpts pabConf buildMode mintingPolicies redeemers mintValue =
                   toOpts r =
                     [ ["--mint-script-file", policyScriptFilePath pabConf curSymbol]
                     , ["--mint-redeemer-file", redeemerJsonFilePath pabConf (Ledger.redeemerHash r)]
-                    , if isRawBuildMode buildMode
-                        then ["--mint-execution-units", exBudgetToCliArg (exBudget r)]
-                        else []
+                    , ["--mint-execution-units", exBudgetToCliArg (exBudget r)]
                     ]
                in mconcat $ maybeToList $ fmap toOpts redeemer
           )