Fix autobalancing when there's no change. Add property test.

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

@@ -384,7 +384,6 @@ import Cardano.Ledger.Plutus.Language qualified as Plutus
 import Cardano.Ledger.Val qualified as L
 import Ouroboros.Consensus.HardFork.History qualified as Consensus
 
-import Control.Monad
 import Data.Bifunctor (bimap, first, second)
 import Data.Bitraversable (bitraverse)
 import Data.ByteString.Short (ShortByteString)
@@ -651,8 +650,9 @@ estimateBalancedTxBody
         balanceTxOut = TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone
 
     -- Step 6. Check all txouts have the min required UTxO value
-    forM_ (txOuts txbodycontent1) $
-      \txout -> first TxFeeEstimationBalanceError $ checkMinUTxOValue sbe pparams txout
+    first (TxFeeEstimationBalanceError . uncurry TxBodyErrorMinUTxONotMet)
+      . mapM_ (checkMinUTxOValue sbe pparams)
+      $ txOuts txbodycontent1
 
     -- check if the balance is positive or negative
     -- in one case we can produce change, in the other the inputs are insufficient
@@ -1375,7 +1375,9 @@ makeTransactionBodyAutoBalance
               TxOutDatumNone
               ReferenceScriptNone
 
-      _ <- balanceCheck sbe pp initialChangeTxOut
+      -- Initial change is only used for execution units evaluation, so we don't require minimum UTXO requirement
+      -- to be satisfied at this point
+      _ <- checkNonNegative sbe pp initialChangeTxOut
 
       -- Tx body used only for evaluating execution units. Because txout exact
       -- values do not matter much here, we are using an initial change value,
@@ -1477,7 +1479,9 @@ makeTransactionBodyAutoBalance
               }
       let balance = evaluateTransactionBalance sbe pp poolids stakeDelegDeposits drepDelegDeposits utxo txbody2
           balanceTxOut = TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone
-      forM_ (txOuts txbodycontent1) $ \txout -> checkMinUTxOValue sbe pp txout
+      first (uncurry TxBodyErrorMinUTxONotMet)
+        . mapM_ (checkMinUTxOValue sbe pp)
+        $ txOuts txbodycontent1
 
       -- check if change meets txout criteria, and include if non-zero
       finalTxOuts <- checkAndIncludeChange sbe pp balanceTxOut (txOuts txbodycontent1)
@@ -1523,52 +1527,52 @@ checkAndIncludeChange
   -> TxOut CtxTx era
   -> [TxOut CtxTx era]
   -> Either (TxBodyErrorAutoBalance era) [TxOut CtxTx era]
-checkAndIncludeChange sbe pp change rest = do
-  isChangeEmpty <- balanceCheck sbe pp change
+checkAndIncludeChange sbe pp change@(TxOut _ changeValue _ _) rest = do
+  isChangeEmpty <- checkNonNegative sbe pp change
   if isChangeEmpty == Empty
     then pure rest
     else do
+      let coin = txOutValueToLovelace changeValue
+      first ((coin &) . uncurry TxBodyErrorAdaBalanceTooSmall) $
+        checkMinUTxOValue sbe pp change
       -- We append change at the end so a client can predict the indexes of the outputs.
-      -- Note that if this function will append change with 0 ADA, and non-ada assets in it.
       pure $ rest <> [change]
 
 checkMinUTxOValue
   :: ShelleyBasedEra era
   -> Ledger.PParams (ShelleyLedgerEra era)
   -> TxOut CtxTx era
-  -> Either (TxBodyErrorAutoBalance era) ()
+  -> Either (TxOutInAnyEra, Coin) ()
+  -- ^ @Left (offending txout, minimum required utxo)@ or @Right ()@ when txout is ok
 checkMinUTxOValue sbe bpp txout@(TxOut _ v _ _) = do
   let minUTxO = calculateMinimumUTxO sbe bpp txout
   if txOutValueToLovelace v >= minUTxO
     then Right ()
-    else Left $ TxBodyErrorMinUTxONotMet (txOutInAnyEra (toCardanoEra sbe) txout) minUTxO
+    else Left (txOutInAnyEra (toCardanoEra sbe) txout, minUTxO)
 
 data IsEmpty = Empty | NonEmpty
   deriving (Eq, Show)
 
-balanceCheck
+checkNonNegative
   :: ShelleyBasedEra era
   -> Ledger.PParams (ShelleyLedgerEra era)
   -> TxOut CtxTx era
   -> Either (TxBodyErrorAutoBalance era) IsEmpty
-balanceCheck sbe bpparams txout@(TxOut _ balance _ _) = do
+  -- ^ result of check if txout is empty
+checkNonNegative sbe bpparams txout@(TxOut _ balance _ _) = do
   let outValue@(L.MaryValue coin multiAsset) = toMaryValue $ txOutValueToValue balance
       isPositiveValue = L.pointwise (>) outValue mempty
   if
     | L.isZero outValue -> pure Empty -- empty TxOut - ok, it's removed at the end
-    | L.isZero coin -> -- no ADA, just non-ADA assets
+    | L.isZero coin ->
+        -- no ADA, just non-ADA assets: positive lovelace is required in such case
         Left $
           TxBodyErrorAdaBalanceTooSmall
             (TxOutInAnyEra (toCardanoEra sbe) txout)
             (calculateMinimumUTxO sbe bpparams txout)
             coin
     | not isPositiveValue -> Left $ TxBodyErrorBalanceNegative coin multiAsset
-    | otherwise ->
-        case checkMinUTxOValue sbe bpparams txout of
-          Left (TxBodyErrorMinUTxONotMet txOutAny minUTxO) ->
-            Left $ TxBodyErrorAdaBalanceTooSmall txOutAny minUTxO coin
-          Left err -> Left err
-          Right _ -> Right NonEmpty
+    | otherwise -> pure NonEmpty
 
 -- Calculation taken from validateInsufficientCollateral:
 -- https://github.com/input-output-hk/cardano-ledger/blob/389b266d6226dedf3d2aec7af640b3ca4984c5ea/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxo.hs#L335

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

@@ -9,6 +9,7 @@ module Test.Cardano.Api.Orphans () where
 
 import Cardano.Api.Shelley
 
+import Cardano.Ledger.Alonzo.Core qualified as L
 import Cardano.Ledger.Mary.Value qualified as L
 
 import Data.String (IsString (..))
@@ -36,3 +37,5 @@ deriving instance Eq (SigningKey KesKey)
 deriving instance Eq (SigningKey VrfKey)
 
 deriving instance IsString L.AssetName
+
+deriving instance IsString (L.KeyHash r)

cardano-api/test/cardano-api-test/Test/Cardano/Api/Transaction/Autobalance.hs

@@ -35,7 +35,9 @@ import Cardano.Slotting.EpochInfo qualified as CS
 import Cardano.Slotting.Slot qualified as CS
 import Cardano.Slotting.Time qualified as CS
 
+import Control.Monad
 import Data.Aeson (eitherDecodeStrict)
+import Data.Bifunctor (first)
 import Data.ByteString qualified as B
 import Data.Default (def)
 import Data.Function
@@ -55,9 +57,185 @@ import Hedgehog (MonadTest, Property, forAll, (===))
 import Hedgehog qualified as H
 import Hedgehog.Extras qualified as H
 import Hedgehog.Gen qualified as Gen
+import Hedgehog.Range qualified as Range
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.Hedgehog (testProperty)
 
+prop_make_transaction_body_autobalance_invariants :: Property
+prop_make_transaction_body_autobalance_invariants = H.property $ do
+  let ceo = ConwayEraOnwardsConway
+      sbe = convert ceo
+
+  systemStart <- parseSystemStart "2021-09-01T00:00:00Z"
+  let epochInfo = LedgerEpochInfo $ CS.fixedEpochInfo (CS.EpochSize 100) (CS.mkSlotLength 1000)
+
+  pparams <-
+    LedgerProtocolParameters
+      <$> H.readJsonFileOk "test/cardano-api-test/files/input/protocol-parameters/conway.json"
+
+  -- assume a value larger the one from protocol params to account for min utxo scaling with minted assets
+  let minUtxo = 2_000_000
+
+  -- generate utxos with random values
+  utxos <- fmap (UTxO . fromList) . forAll $ do
+    Gen.list (Range.constant 1 10) $ do
+      txIn <- genTxIn
+      addr <- genAddressInEra sbe
+      utxoValue <- L.Coin <$> Gen.integral (Range.linear minUtxo 20_000_000)
+      let mintValue = mempty -- TODO generate and check in invariants
+          txOut =
+            TxOut
+              addr
+              (TxOutValueShelleyBased sbe $ L.MaryValue utxoValue mintValue)
+              TxOutDatumNone
+              ReferenceScriptNone
+      pure (txIn, txOut)
+
+  let utxoSum =
+        mconcat
+          [ maryValue
+          | (_, TxOut _ (TxOutValueShelleyBased _ maryValue) _ _) <- toList utxos
+          ]
+  H.noteShowPretty_ utxoSum
+
+  -- split inputs into min utxo txouts
+  let nTxOuts = L.unCoin (L.coin utxoSum) `div` minUtxo - 1 -- leave one out for change
+  H.noteShow_ nTxOuts
+  txOut <- forAll $ forM ([1 .. nTxOuts] :: [Integer]) $ \_ -> do
+    addr <- genAddressInEra sbe
+    let mintValue = mempty -- TODO generate and check in invariants
+    pure $
+      TxOut
+        addr
+        (TxOutValueShelleyBased sbe $ L.MaryValue (L.Coin minUtxo) mintValue)
+        TxOutDatumNone
+        ReferenceScriptNone
+
+  changeAddress <- forAll $ genAddressInEra sbe
+
+  -- use all UTXOs as inputs
+  let txInputs = map (,BuildTxWith (KeyWitness KeyWitnessForSpending)) . toList . M.keys . unUTxO $ utxos
+
+  let content =
+        defaultTxBodyContent sbe
+          & setTxIns txInputs
+          & setTxOuts txOut
+          & setTxProtocolParams (pure $ pure pparams)
+
+  (BalancedTxBody balancedContent _ change fee) <-
+    H.leftFail . first prettyError $
+      makeTransactionBodyAutoBalance
+        sbe
+        systemStart
+        epochInfo
+        pparams
+        mempty
+        mempty
+        mempty
+        utxos
+        content
+        changeAddress
+        Nothing
+
+  H.note_ "Check that fee is greater than 0"
+  H.assertWith (L.unCoin fee) $ (<) 0
+
+  H.noteShow_ fee
+  H.noteShowPretty_ change
+  H.noteShowPretty_ $ txOuts balancedContent
+
+  let txOutSum =
+        mconcat
+          [ maryValue
+          | TxOut _ (TxOutValueShelleyBased _ maryValue) _ _ <- txOuts balancedContent
+          ]
+
+  H.note_ "Check that all inputs are spent"
+  utxoSum === (txOutSum <> inject fee)
+
+prop_make_transaction_body_autobalance_no_change :: Property
+prop_make_transaction_body_autobalance_no_change = H.propertyOnce $ do
+  let ceo = ConwayEraOnwardsConway
+      sbe = convert ceo
+
+  systemStart <- parseSystemStart "2021-09-01T00:00:00Z"
+  let epochInfo = LedgerEpochInfo $ CS.fixedEpochInfo (CS.EpochSize 100) (CS.mkSlotLength 1000)
+
+  pparams <-
+    LedgerProtocolParameters
+      <$> H.readJsonFileOk "test/cardano-api-test/files/input/protocol-parameters/conway.json"
+
+  let expectedFee = 170_077
+      utxoValue = 5_000_000
+
+  let address =
+        AddressInEra
+          (ShelleyAddressInEra sbe)
+          ( ShelleyAddress
+              L.Testnet
+              (L.KeyHashObj "ebe9de78a37f84cc819c0669791aa0474d4f0a764e54b9f90cfe2137")
+              L.StakeRefNull
+          )
+  let utxos =
+        UTxO
+          [
+            ( TxIn
+                "01f4b788593d4f70de2a45c2e1e87088bfbdfa29577ae1b62aba60e095e3ab53"
+                (TxIx 0)
+            , TxOut
+                address
+                ( TxOutValueShelleyBased
+                    sbe
+                    (L.MaryValue utxoValue mempty)
+                )
+                TxOutDatumNone
+                ReferenceScriptNone
+            )
+          ]
+
+      txInputs = map (,BuildTxWith (KeyWitness KeyWitnessForSpending)) . toList . M.keys . unUTxO $ utxos
+
+      -- tx out fully spending the txin minus the fee
+      txOut =
+        [ TxOut
+            address
+            ( TxOutValueShelleyBased
+                sbe
+                (L.MaryValue (utxoValue - expectedFee) mempty)
+            )
+            TxOutDatumNone
+            ReferenceScriptNone
+        ]
+
+  let content =
+        defaultTxBodyContent sbe
+          & setTxIns txInputs
+          & setTxOuts txOut
+          & setTxProtocolParams (pure $ pure pparams)
+
+  (BalancedTxBody balancedContent _ (TxOut _ (TxOutValueShelleyBased _ change) _ _) fee) <-
+    H.leftFail . first prettyError $
+      makeTransactionBodyAutoBalance
+        sbe
+        systemStart
+        epochInfo
+        pparams
+        mempty
+        mempty
+        mempty
+        utxos
+        content
+        address
+        Nothing
+
+  H.noteShowPretty_ change
+  H.noteShowPretty_ $ txOuts balancedContent
+
+  expectedFee === fee
+
+  -- check that the txins were fully spent before autobalancing
+  H.assertWith change L.isZero
+
 -- | Test that the fee is the same when spending minted asset manually or when autobalancing it
 prop_make_transaction_body_autobalance_return_correct_fee_for_multi_asset :: Property
 prop_make_transaction_body_autobalance_return_correct_fee_for_multi_asset = H.propertyOnce $ do
@@ -396,8 +574,7 @@ prop_ensure_gov_actions_are_preserved_by_autobalance = H.propertyOnce $ do
           , L.pProcReturnAddr =
               L.RewardAccount
                 { L.raNetwork = L.Testnet
-                , L.raCredential =
-                    L.KeyHashObj (L.KeyHash{L.unKeyHash = "0b1b872f7953bccfc4245f3282b3363f3d19e9e001a5c41e307363d7"})
+                , L.raCredential = L.KeyHashObj "0b1b872f7953bccfc4245f3282b3363f3d19e9e001a5c41e307363d7"
                 }
           , L.pProcGovAction = L.InfoAction
           , L.pProcAnchor = anchor
@@ -452,9 +629,7 @@ mkSimpleUTxOs sbe =
               (ShelleyAddressInEra sbe)
               ( ShelleyAddress
                   L.Testnet
-                  ( L.KeyHashObj $
-                      L.KeyHash "ebe9de78a37f84cc819c0669791aa0474d4f0a764e54b9f90cfe2137"
-                  )
+                  (L.KeyHashObj "ebe9de78a37f84cc819c0669791aa0474d4f0a764e54b9f90cfe2137")
                   L.StakeRefNull
               )
           )
@@ -518,9 +693,7 @@ mkUtxos beo mScriptHash = babbageEraOnwardsConstraints beo $ do
               (ShelleyAddressInEra sbe)
               ( ShelleyAddress
                   L.Testnet
-                  ( L.KeyHashObj $
-                      L.KeyHash "ebe9de78a37f84cc819c0669791aa0474d4f0a764e54b9f90cfe2137"
-                  )
+                  (L.KeyHashObj "ebe9de78a37f84cc819c0669791aa0474d4f0a764e54b9f90cfe2137")
                   L.StakeRefNull
               )
           )
@@ -530,7 +703,7 @@ mkUtxos beo mScriptHash = babbageEraOnwardsConstraints beo $ do
                   (L.Coin 4_000_000)
                   ( L.MultiAsset $
                       fromList
-                        [(L.PolicyID scriptHash, [(L.AssetName "eeee", 1)]) | scriptHash <- maybeToList mScriptHash]
+                        [(L.PolicyID scriptHash, [("eeee", 1)]) | scriptHash <- maybeToList mScriptHash]
                   )
               )
           )
@@ -569,7 +742,7 @@ mkTxOutput beo address coin mScriptHash = babbageEraOnwardsConstraints beo $ do
               coin
               ( L.MultiAsset $
                   fromList
-                    [(L.PolicyID scriptHash, [(L.AssetName "eeee", 2)]) | scriptHash <- maybeToList mScriptHash]
+                    [(L.PolicyID scriptHash, [("eeee", 2)]) | scriptHash <- maybeToList mScriptHash]
               )
           )
       )
@@ -597,6 +770,12 @@ tests =
   testGroup
     "Test.Cardano.Api.Typed.TxBody"
     [ testProperty
+        "makeTransactionBodyAutoBalance invariants"
+        prop_make_transaction_body_autobalance_invariants
+    , testProperty
+        "makeTransactionBodyAutoBalance no change"
+        prop_make_transaction_body_autobalance_no_change
+    , testProperty
         "makeTransactionBodyAutoBalance test correct fees when mutli-asset tx"
         prop_make_transaction_body_autobalance_return_correct_fee_for_multi_asset
     , testProperty