Implement property test for calcReturnAndTotalCollateral

cardano-api/cardano-api.cabal

@@ -318,16 +318,17 @@ test-suite cardano-api-test
     cardano-ledger-binary,
     cardano-ledger-core:{cardano-ledger-core, testlib} >=1.14,
     cardano-ledger-mary,
-    cardano-ledger-shelley,
     cardano-protocol-tpraos,
     cardano-slotting,
     cborg,
     containers,
+    data-default,
     directory,
     hedgehog >=1.1,
     hedgehog-extras,
     hedgehog-quickcheck,
     interpolatedstring-perl6,
+    microlens,
     mtl,
     ouroboros-consensus,
     ouroboros-consensus-cardano,

cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs

@@ -409,8 +409,8 @@ genValueForTxOut sbe = do
   caseShelleyToAllegraOrMaryEraOnwards
     (const (pure ada))
     ( \w -> do
-        v <- genValue w genAssetId genPositiveQuantity
-        pure $ ada <> v
+        v <- Gen.list (Range.constant 0 5) $ genValue w genAssetId genPositiveQuantity
+        pure $ ada <> mconcat v
     )
     sbe
 

cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs

@@ -35,7 +35,6 @@ import qualified Cardano.Ledger.Core as L
 import qualified Cardano.Ledger.Mary.Value as L
 import qualified Cardano.Ledger.SafeHash as L
 import qualified Cardano.Ledger.UTxO as L
-import qualified Cardano.Ledger.Val as L
 import qualified Ouroboros.Consensus.Protocol.Abstract as Consensus
 import qualified Ouroboros.Consensus.Protocol.Praos.Common as Consensus
 import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus

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

@@ -30,6 +30,7 @@ module Cardano.Api.Fees
   , estimateBalancedTxBody
   , estimateOrCalculateBalancedTxBody
   , makeTransactionBodyAutoBalance
+  , calcReturnAndTotalCollateral
   , AutoBalanceError (..)
   , BalancedTxBody (..)
   , FeeEstimationMode (..)
@@ -80,7 +81,6 @@ import qualified Cardano.Ledger.Core as L
 import           Cardano.Ledger.Credential as Ledger (Credential)
 import qualified Cardano.Ledger.Crypto as Ledger
 import qualified Cardano.Ledger.Keys as Ledger
-import qualified Cardano.Ledger.Mary as L
 import qualified Cardano.Ledger.Plutus.Language as Plutus
 import qualified Cardano.Ledger.Val as L
 import qualified Ouroboros.Consensus.HardFork.History as Consensus

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

@@ -1,4 +1,5 @@
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE RankNTypes #-}
@@ -14,29 +15,40 @@ module Test.Cardano.Api.Transaction.Autobalance
 where
 
 import           Cardano.Api
+import           Cardano.Api.Fees
 import qualified Cardano.Api.Ledger as L
+import qualified Cardano.Api.Ledger.Lens as L
 import           Cardano.Api.Script
 import           Cardano.Api.Shelley (Address (..), LedgerProtocolParameters (..))
 
+import qualified Cardano.Ledger.Alonzo.Core as L
+import qualified Cardano.Ledger.Coin as L
 import qualified Cardano.Ledger.Mary.Value as L
-import qualified Cardano.Ledger.Shelley.Scripts as L
+import           Cardano.Ledger.Val ((<->))
+import qualified Cardano.Ledger.Val as L
 import qualified Cardano.Slotting.EpochInfo as CS
 import qualified Cardano.Slotting.Slot as CS
 import qualified Cardano.Slotting.Time as CS
 
 import qualified Data.ByteString as B
+import           Data.Default (def)
 import           Data.Function
 import qualified Data.Map.Strict as M
 import           Data.Maybe
+import           Data.Ratio ((%))
 import qualified Data.Time.Format as DT
 import           GHC.Exts (IsList (..))
 import           GHC.Stack
+import           Lens.Micro ((^.))
+
+import           Test.Gen.Cardano.Api.Typed
 
 import           Test.Cardano.Api.Orphans ()
 
-import           Hedgehog (MonadTest, Property, (===))
+import           Hedgehog (MonadTest, Property, forAll, (===))
 import qualified Hedgehog as H
 import qualified Hedgehog.Extras as H
+import qualified Hedgehog.Gen as Gen
 import           Test.Tasty (TestTree, testGroup)
 import           Test.Tasty.Hedgehog (testProperty)
 
@@ -188,6 +200,78 @@ prop_make_transaction_body_autobalance_multi_asset_collateral = H.propertyOnce $
   H.note_ "Check that all assets from UTXO, from the collateral txin, are in the return collateral."
   [(AssetId policyId' "eeee", 1)] === assets
 
+-- | Implements collateral validation from Babbage spec, from
+-- https://github.com/IntersectMBO/cardano-ledger/releases, babbage-ledger.pdf, Figure 2.
+--
+-- Seems that under 400 runs the test is not able to detect the violation of properties.
+prop_calcReturnAndTotalCollateral :: Property
+prop_calcReturnAndTotalCollateral = H.withTests 400 . H.property $ do
+  let beo = BabbageEraOnwardsConway
+      sbe = babbageEraOnwardsToShelleyBasedEra beo
+      era = toCardanoEra beo
+  feeCoin@(L.Coin fee) <- forAll genLovelace
+  totalCollateral <- forAll $ genValueForTxOut sbe
+  let totalCollateralAda = totalCollateral ^. L.adaAssetL sbe
+  pparams <-
+    H.readJsonFileOk "test/cardano-api-test/files/input/protocol-parameters/conway.json"
+  requiredCollateralPct <- H.noteShow . fromIntegral $ pparams ^. L.ppCollateralPercentageL
+  requiredCollateralAda <-
+    H.noteShow . L.rationalToCoinViaCeiling $ (fee * requiredCollateralPct) % 100
+  txInsColl <- forAll $ genTxInsCollateral era
+  txRetColl <-
+    forAll $ Gen.frequency [(4, pure TxReturnCollateralNone), (1, genTxReturnCollateral sbe)]
+  txTotColl <- forAll $ Gen.frequency [(4, pure TxTotalCollateralNone), (1, genTxTotalCollateral era)]
+  let address = AddressInEra (ShelleyAddressInEra sbe) (ShelleyAddress L.Testnet def L.StakeRefNull)
+
+  let (resRetColl, resTotColl) =
+        calcReturnAndTotalCollateral
+          beo
+          feeCoin
+          pparams
+          txInsColl
+          txRetColl
+          txTotColl
+          address
+          totalCollateral
+
+  H.annotateShow resRetColl
+  H.annotateShow resTotColl
+
+  let resRetCollValue =
+        mconcat
+          [ txOutValue
+          | TxReturnCollateral _ (TxOut _ (TxOutValueShelleyBased _ txOutValue) _ _) <- pure resRetColl
+          ]
+      collBalance = totalCollateral <-> resRetCollValue
+
+  resTotCollValue <-
+    H.noteShow $ mconcat [L.mkAdaValue sbe lovelace | TxTotalCollateral _ lovelace <- pure resTotColl]
+
+  if
+    | txInsColl == TxInsCollateralNone -> do
+        -- no inputs - no outputs
+        TxReturnCollateralNone === resRetColl
+        TxTotalCollateralNone === resTotColl
+    | txRetColl /= TxReturnCollateralNone || txTotColl /= TxTotalCollateralNone -> do
+        -- got collateral values as function arguments - not calculating anything
+        txRetColl === resRetColl
+        txTotColl === resTotColl
+    | totalCollateralAda < requiredCollateralAda -> do
+        -- provided collateral not enough, not calculating anything
+        TxReturnCollateralNone === resRetColl
+        TxTotalCollateralNone === resTotColl
+    | otherwise -> do
+        -- no explicit collateral or return collateral was provided, we do the calculation
+        H.annotateShow collBalance
+        H.note_ "Check if collateral balance is positive"
+        H.assertWith collBalance $ L.pointwise (<=) mempty
+        H.note_ "Check if collateral balance contains only ada"
+        H.assertWith collBalance L.isAdaOnly
+        H.note_ "Check if collateral balance is at least minimum required"
+        H.assertWith collBalance $ L.pointwise (<=) (L.inject requiredCollateralAda)
+        H.note_ "Check that collateral balance is equal to collateral in tx body"
+        collBalance === resTotCollValue
+
 -- * Utilities
 
 loadPlutusWitness
@@ -301,4 +385,5 @@ tests =
     , testProperty
         "makeTransactionBodyAutoBalance autobalances multi-asset collateral"
         prop_make_transaction_body_autobalance_multi_asset_collateral
+    , testProperty "calcReturnAndTotalCollateral constraints hold" prop_calcReturnAndTotalCollateral
     ]