Auto-balance multiasset transactions

Previously we gave up when the non-Ada part of a transaction wasn't
balanced. We now balance the transaction and correctly update the fee
accordingly (since the fee will be higher). We also return an error in
the case where the is non-Ada change, but not at least minUTxO
change (e.g. in the case where the Ada is already balanced).

Resolves: #3068

Author: Robert 'Probie' Offner

cardano-api/ChangeLog.md

@@ -8,6 +8,8 @@
 
 - Expose convenience functions `executeQueryCardanoMode`, `determineEra`, `constructBalancedTx` and `queryStateForBalancedTx` ([PR 4446](https://github.com/input-output-hk/cardano-node/pull/4446))
 
+- Auto-balance multi asset transactions ([PR 4450](https://github.com/input-output-hk/cardano-node/pull/4450))
+
 ### Bugs
 
 - Allow reading text envelopes from pipes ([PR 4384](https://github.com/input-output-hk/cardano-node/pull/4384))

cardano-api/cardano-api.cabal

@@ -227,6 +227,7 @@ test-suite cardano-api-test
                       , time
 
   other-modules:        Test.Cardano.Api.Crypto
+                        Test.Cardano.Api.Fees
                         Test.Cardano.Api.Genesis
                         Test.Cardano.Api.Json
                         Test.Cardano.Api.KeysByron

cardano-api/src/Cardano/Api/Fees.hs

@@ -763,11 +763,6 @@ data TxBodyErrorAutoBalance =
        -- | One or more of the scripts were expected to fail validation, but none did.
      | TxBodyScriptBadScriptValidity
 
-       -- | The balance of the non-ada assets is not zero. The 'Value' here is
-       -- that residual non-zero balance. The 'makeTransactionBodyAutoBalance'
-       -- function only automatically balances ada, not other assets.
-     | TxBodyErrorAssetBalanceWrong Value
-
        -- | There is not enough ada to cover both the outputs and the fees.
        -- The transaction should be changed to provide more input ada, or
        -- otherwise adjusted to need less (e.g. outputs, script etc).
@@ -826,13 +821,6 @@ instance Error TxBodyErrorAutoBalance where
   displayError TxBodyScriptBadScriptValidity =
       "One or more of the scripts were expected to fail validation, but none did."
 
-  displayError (TxBodyErrorAssetBalanceWrong _value) =
-      "The transaction does not correctly balance in its non-ada assets. "
-   ++ "The balance between inputs and outputs should sum to zero. "
-   ++ "The actual balance is: "
-   ++ "TODO: move the Value renderer and parser from the CLI into the API and use them here"
-   -- TODO: do this ^^
-
   displayError (TxBodyErrorAdaBalanceNegative lovelace) =
       "The transaction does not balance in its use of ada. The net balance "
    ++ "of the transaction is negative: " ++ show lovelace ++ " lovelace. "
@@ -971,13 +959,23 @@ makeTransactionBodyAutoBalance eraInMode systemstart history pparams
     -- output and fee. Yes this means this current code will only work for
     -- final fee of less than around 4000 ada (2^32-1 lovelace) and change output
     -- of less than around 18 trillion ada  (2^64-1 lovelace).
+    -- However, since at this point we know how much non-Ada change to give
+    -- we can use the true values for that.
+
+    let outgoingNonAda = mconcat [filterValue isNotAda v | (TxOut _ (TxOutValue _ v) _ _) <- txOuts txbodycontent]
+    let incomingNonAda = mconcat [filterValue isNotAda v | (TxOut _ (TxOutValue _ v) _ _) <- Map.elems $ unUTxO utxo]
+    let nonAdaChange = incomingNonAda <> negateValue outgoingNonAda
+
+    let changeTxOut = case multiAssetSupportedInEra cardanoEra of
+          Left _ -> lovelaceToTxOutValue $ Lovelace (2^(64 :: Integer)) - 1
+          Right multiAsset -> TxOutValue multiAsset (lovelaceToValue (Lovelace (2^(64 :: Integer)) - 1) <> nonAdaChange)
 
     let (dummyCollRet, dummyTotColl) = maybeDummyTotalCollAndCollReturnOutput txbodycontent changeaddr
     txbody1 <- first TxBodyError $ -- TODO: impossible to fail now
                createAndValidateTransactionBody txbodycontent1 {
                  txFee  = TxFeeExplicit explicitTxFees $ Lovelace (2^(32 :: Integer) - 1),
                  txOuts = TxOut changeaddr
-                                (lovelaceToTxOutValue $ Lovelace (2^(64 :: Integer)) - 1)
+                                changeTxOut
                                 TxOutDatumNone ReferenceScriptNone
                         : txOuts txbodycontent,
                  txReturnCollateral = dummyCollRet,
@@ -1009,13 +1007,7 @@ makeTransactionBodyAutoBalance eraInMode systemstart history pparams
 
     -- check if the balance is positive or negative
     -- in one case we can produce change, in the other the inputs are insufficient
-    case balance of
-      TxOutAdaOnly _ _ -> balanceCheck balance
-      TxOutValue _ v   ->
-        case valueToLovelace v of
-          Nothing -> Left $ TxBodyErrorNonAdaAssetsUnbalanced v
-          Just _ -> balanceCheck balance
-
+    balanceCheck balance
 
     --TODO: we could add the extra fee for the CBOR encoding of the change,
     -- now that we know the magnitude of the change: i.e. 1-8 bytes extra.
@@ -1135,7 +1127,7 @@ makeTransactionBodyAutoBalance eraInMode systemstart history pparams
 
    balanceCheck :: TxOutValue era -> Either TxBodyErrorAutoBalance ()
    balanceCheck balance
-    | txOutValueToLovelace balance == 0 = return ()
+    | txOutValueToLovelace balance == 0 && onlyAda (txOutValueToValue balance) = return ()
     | txOutValueToLovelace balance < 0 =
         Left . TxBodyErrorAdaBalanceNegative $ txOutValueToLovelace balance
     | otherwise =
@@ -1145,6 +1137,13 @@ makeTransactionBodyAutoBalance eraInMode systemstart history pparams
           Left err -> Left err
           Right _ -> Right ()
 
+   isNotAda :: AssetId -> Bool
+   isNotAda AdaAssetId = False
+   isNotAda _ = True
+
+   onlyAda :: Value -> Bool
+   onlyAda = null . valueToList . filterValue isNotAda
+
    checkMinUTxOValue
      :: TxOut CtxTx era
      -> ProtocolParameters

cardano-api/test/Test/Cardano/Api/Fees.hs

@@ -0,0 +1,63 @@
+module Test.Cardano.Api.Fees (tests) where
+
+import           Data.Either (isLeft)
+import           Data.Maybe (fromJust)
+import           Data.Time.Format.ISO8601 (iso8601ParseM)
+import           Gen.Cardano.Api.Typed (genValueDefault)
+import           Hedgehog (Property, assert, forAll, property)
+import           Hedgehog.Gen (list)
+import           Hedgehog.Range (linear)
+import           Prelude
+import           Test.Tasty (TestTree, testGroup)
+import           Test.Tasty.Hedgehog (testPropertyNamed)
+
+import           Cardano.Api
+import           Cardano.Api.Shelley (shelleyGenesisDefaults)
+import           Ouroboros.Consensus.HardFork.History (mkInterpreter, summarize)
+import           Ouroboros.Consensus.Shelley.Node (ShelleyGenesis (..))
+
+runAutoBalance :: [Value] -> [Value] -> Either TxBodyErrorAutoBalance (BalancedTxBody AlonzoEra)
+runAutoBalance _inValues _outValues = makeTransactionBodyAutoBalance
+  AlonzoEraInCardanoMode
+  (SystemStart $ fromJust $ iso8601ParseM "1970-01-01Z00:00:00")
+  (EraHistory CardanoMode (mkInterpreter (summarize _ _ _)))
+  pparams
+  _
+  _
+  TxBodyContent
+    { txIns = _
+    , txInsCollateral = _
+    , txInsReference = _
+    , txOuts = _
+    , txTotalCollateral = _
+    , txReturnCollateral = _
+    , txFee = _
+    , txValidityRange = _
+    , txMetadata = _
+    , txAuxScripts = _
+    , txExtraKeyWits = _
+    , txProtocolParams = BuildTxWith (Just pparams)
+    , txWithdrawals = _
+    , txCertificates = _
+    , txUpdateProposal = TxUpdateProposalNone
+    , txMintValue = _
+    , txScriptValidity = _
+    }
+  (AddressInEra
+    (ShelleyAddressInEra ShelleyBasedEraAlonzo)
+    (makeShelleyAddress (Testnet (NetworkMagic 42))
+      (PaymentCredentialByKey _)
+     NoStakeAddress))
+  Nothing
+  where
+    pparams = _ (sgProtocolParams shelleyGenesisDefaults)
+
+prop_noFeeFailure :: Property
+prop_noFeeFailure = property $ do
+  v <- forAll $ list (linear 0 10) genValueDefault
+  assert $ isLeft $ runAutoBalance v v
+
+tests :: TestTree
+tests =
+  testGroup "Cardano.Api.Fees"
+    [ testPropertyNamed "fail on no fee" "fail on no fee" prop_noFeeFailure]

cardano-api/test/cardano-api-test.hs

@@ -5,6 +5,7 @@ import           Cardano.Prelude
 import           Test.Tasty (TestTree, defaultMain, testGroup)
 
 import qualified Test.Cardano.Api.Crypto
+import qualified Test.Cardano.Api.Fees
 import qualified Test.Cardano.Api.Json
 import qualified Test.Cardano.Api.KeysByron
 import qualified Test.Cardano.Api.Ledger
@@ -30,6 +31,7 @@ tests :: TestTree
 tests =
   testGroup "Cardano.Api"
     [ Test.Cardano.Api.Crypto.tests
+    , Test.Cardano.Api.Fees.tests
     , Test.Cardano.Api.Json.tests
     , Test.Cardano.Api.KeysByron.tests
     , Test.Cardano.Api.Ledger.tests