Merge pull request #631 from IntersectMBO/mgalazyn/fix/collateral-aut…

…obalance Fix collateral balancing when building transaction
IntersectMBO · Sep 16, 2024 · 680ed80 · 680ed80
2 parents eb2108c + 2bf5f99
commit 680ed80
Show file tree

Hide file tree

Showing 21 changed files with 648 additions and 462 deletions.
diff --git a/cardano-api/cardano-api.cabal b/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,
@@ -340,7 +341,11 @@ test-suite cardano-api-test
     time,
 
   other-modules:
+    Test.Cardano.Api.Address
+    Test.Cardano.Api.Bech32
+    Test.Cardano.Api.CBOR
     Test.Cardano.Api.Crypto
+    Test.Cardano.Api.Envelope
     Test.Cardano.Api.EpochLeadership
     Test.Cardano.Api.Eras
     Test.Cardano.Api.Genesis
@@ -349,17 +354,13 @@ test-suite cardano-api-test
     Test.Cardano.Api.KeysByron
     Test.Cardano.Api.Ledger
     Test.Cardano.Api.Metadata
+    Test.Cardano.Api.Ord
+    Test.Cardano.Api.Orphans
     Test.Cardano.Api.ProtocolParameters
-    Test.Cardano.Api.Typed.Address
-    Test.Cardano.Api.Typed.Bech32
-    Test.Cardano.Api.Typed.CBOR
-    Test.Cardano.Api.Typed.Envelope
-    Test.Cardano.Api.Typed.JSON
-    Test.Cardano.Api.Typed.Ord
-    Test.Cardano.Api.Typed.Orphans
-    Test.Cardano.Api.Typed.RawBytes
-    Test.Cardano.Api.Typed.TxBody
-    Test.Cardano.Api.Typed.Value
+    Test.Cardano.Api.RawBytes
+    Test.Cardano.Api.Transaction.Autobalance
+    Test.Cardano.Api.TxBody
+    Test.Cardano.Api.Value
 
   ghc-options:
     -threaded
@@ -412,6 +413,6 @@ test-suite cardano-api-golden
     Test.Golden.Cardano.Api.Genesis
     Test.Golden.Cardano.Api.Ledger
     Test.Golden.Cardano.Api.ProtocolParameters
-    Test.Golden.Cardano.Api.Typed.Script
+    Test.Golden.Cardano.Api.Script
     Test.Golden.Cardano.Api.Value
     Test.Golden.ErrorsSpec
diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/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
 

diff --git a/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs
@@ -12,11 +12,13 @@ module Cardano.Api.Eon.ConwayEraOnwards
   ( ConwayEraOnwards (..)
   , conwayEraOnwardsConstraints
   , conwayEraOnwardsToShelleyBasedEra
+  , conwayEraOnwardsToBabbageEraOnwards
   , ConwayEraOnwardsConstraints
   , IsConwayBasedEra (..)
   )
 where
 
+import           Cardano.Api.Eon.BabbageEraOnwards
 import           Cardano.Api.Eon.ShelleyBasedEra
 import           Cardano.Api.Eras.Core
 import           Cardano.Api.Modes
@@ -114,6 +116,10 @@ conwayEraOnwardsToShelleyBasedEra :: ConwayEraOnwards era -> ShelleyBasedEra era
 conwayEraOnwardsToShelleyBasedEra = \case
   ConwayEraOnwardsConway -> ShelleyBasedEraConway
 
+conwayEraOnwardsToBabbageEraOnwards :: ConwayEraOnwards era -> BabbageEraOnwards era
+conwayEraOnwardsToBabbageEraOnwards = \case
+  ConwayEraOnwardsConway -> BabbageEraOnwardsConway
+
 class IsConwayBasedEra era where
   conwayBasedEra :: ConwayEraOnwards era
 

diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs
@@ -30,6 +30,7 @@ module Cardano.Api.Fees
   , estimateBalancedTxBody
   , estimateOrCalculateBalancedTxBody
   , makeTransactionBodyAutoBalance
+  , calcReturnAndTotalCollateral
   , AutoBalanceError (..)
   , BalancedTxBody (..)
   , FeeEstimationMode (..)
@@ -81,6 +82,7 @@ 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.Plutus.Language as Plutus
+import qualified Cardano.Ledger.Val as L
 import qualified Ouroboros.Consensus.HardFork.History as Consensus
 import qualified PlutusLedgerApi.V1 as Plutus
 
@@ -325,7 +327,7 @@ estimateBalancedTxBody
                   (txReturnCollateral txbodycontent)
                   (txTotalCollateral txbodycontent)
                   changeaddr
-                  totalPotentialCollateral
+                  (A.mkAdaValue sbe totalPotentialCollateral)
             )
             sbe
 
@@ -1070,10 +1072,8 @@ makeTransactionBodyAutoBalance
             availableEra
           $ obtainCommonConstraints availableEra
           $ txbodycontent
-            { txOuts =
-                txOuts txbodycontent
-                  <> [TxOut changeaddr (TxOutValueShelleyBased sbe change) TxOutDatumNone ReferenceScriptNone]
-            }
+            & modTxOuts
+              (<> [TxOut changeaddr (TxOutValueShelleyBased sbe change) TxOutDatumNone ReferenceScriptNone])
       exUnitsMapWithLogs <-
         first TxBodyErrorValidityInterval
           $ evaluateTransactionExecutionUnitsShelley
@@ -1143,21 +1143,23 @@ makeTransactionBodyAutoBalance
           (retColl, reqCol) =
             caseShelleyToAlonzoOrBabbageEraOnwards
               (const (TxReturnCollateralNone, TxTotalCollateralNone))
-              ( \w ->
-                  let collIns = case txInsCollateral txbodycontent of
-                        TxInsCollateral _ collIns' -> collIns'
-                        TxInsCollateralNone -> mempty
-                      collateralOuts = catMaybes [Map.lookup txin (unUTxO utxo) | txin <- collIns]
-                      totalPotentialCollateral = mconcat $ map (\(TxOut _ txOutVal _ _) -> txOutValueToLovelace txOutVal) collateralOuts
-                   in calcReturnAndTotalCollateral
-                        w
-                        fee
-                        pp
-                        (txInsCollateral txbodycontent)
-                        (txReturnCollateral txbodycontent)
-                        (txTotalCollateral txbodycontent)
-                        changeaddr
-                        totalPotentialCollateral
+              ( \w -> do
+                  let totalPotentialCollateral =
+                        mconcat
+                          [ txOutValue
+                          | TxInsCollateral _ collInputs <- pure $ txInsCollateral txbodycontent
+                          , collTxIn <- collInputs
+                          , Just (TxOut _ (TxOutValueShelleyBased _ txOutValue) _ _) <- pure $ Map.lookup collTxIn (unUTxO utxo)
+                          ]
+                  calcReturnAndTotalCollateral
+                    w
+                    fee
+                    pp
+                    (txInsCollateral txbodycontent)
+                    (txReturnCollateral txbodycontent)
+                    (txTotalCollateral txbodycontent)
+                    changeaddr
+                    totalPotentialCollateral
               )
               sbe
 
@@ -1295,49 +1297,52 @@ calcReturnAndTotalCollateral
   -- ^ From the initial TxBodyContent
   -> AddressInEra era
   -- ^ Change address
-  -> Coin
-  -- ^ Total available collateral in lovelace
+  -> L.Value (ShelleyLedgerEra era)
+  -- ^ Total available collateral (can include non-ada)
   -> (TxReturnCollateral CtxTx era, TxTotalCollateral era)
 calcReturnAndTotalCollateral _ _ _ TxInsCollateralNone _ _ _ _ = (TxReturnCollateralNone, TxTotalCollateralNone)
-calcReturnAndTotalCollateral retColSup fee pp' TxInsCollateral{} txReturnCollateral txTotalCollateral cAddr totalAvailableAda =
-  do
-    let colPerc = pp' ^. Ledger.ppCollateralPercentageL
-        -- We must first figure out how much lovelace we have committed
-        -- as collateral and we must determine if we have enough lovelace at our
-        -- collateral tx inputs to cover the tx
-        totalCollateralLovelace = totalAvailableAda
-        requiredCollateral@(L.Coin reqAmt) = fromIntegral colPerc * fee
-        totalCollateral =
-          TxTotalCollateral retColSup . L.rationalToCoinViaCeiling $
-            reqAmt % 100
-        -- Why * 100? requiredCollateral is the product of the collateral percentage and the tx fee
-        -- We choose to multiply 100 rather than divide by 100 to make the calculation
-        -- easier to manage. At the end of the calculation we then use % 100 to perform our division
-        -- and round the returnCollateral down which has the effect of potentially slightly
-        -- overestimating the required collateral.
-        L.Coin amt = totalCollateralLovelace * 100 - requiredCollateral
-        returnCollateral = L.rationalToCoinViaFloor $ amt % 100
-    case (txReturnCollateral, txTotalCollateral) of
-      (rc@TxReturnCollateral{}, tc@TxTotalCollateral{}) ->
-        (rc, tc)
-      (rc@TxReturnCollateral{}, TxTotalCollateralNone) ->
-        (rc, TxTotalCollateralNone)
-      (TxReturnCollateralNone, tc@TxTotalCollateral{}) ->
-        (TxReturnCollateralNone, tc)
-      (TxReturnCollateralNone, TxTotalCollateralNone) ->
-        if totalCollateralLovelace * 100 >= requiredCollateral
-          then
-            ( TxReturnCollateral
-                retColSup
-                ( TxOut
-                    cAddr
-                    (lovelaceToTxOutValue (babbageEraOnwardsToShelleyBasedEra retColSup) returnCollateral)
-                    TxOutDatumNone
-                    ReferenceScriptNone
-                )
-            , totalCollateral
-            )
-          else (TxReturnCollateralNone, TxTotalCollateralNone)
+calcReturnAndTotalCollateral w fee pp' TxInsCollateral{} txReturnCollateral txTotalCollateral cAddr totalAvailableCollateral = babbageEraOnwardsConstraints w $ do
+  let sbe = babbageEraOnwardsToShelleyBasedEra w
+      colPerc = pp' ^. Ledger.ppCollateralPercentageL
+      -- We must first figure out how much lovelace we have committed
+      -- as collateral and we must determine if we have enough lovelace at our
+      -- collateral tx inputs to cover the tx
+      totalCollateralLovelace = totalAvailableCollateral ^. A.adaAssetL sbe
+      requiredCollateral@(L.Coin reqAmt) = fromIntegral colPerc * fee
+      totalCollateral =
+        TxTotalCollateral w . L.rationalToCoinViaCeiling $
+          reqAmt % 100
+      -- Why * 100? requiredCollateral is the product of the collateral percentage and the tx fee
+      -- We choose to multiply 100 rather than divide by 100 to make the calculation
+      -- easier to manage. At the end of the calculation we then use % 100 to perform our division
+      -- and round the returnCollateral down which has the effect of potentially slightly
+      -- overestimating the required collateral.
+      L.Coin returnCollateralAmount = totalCollateralLovelace * 100 - requiredCollateral
+      returnAdaCollateral = A.mkAdaValue sbe $ L.rationalToCoinViaFloor $ returnCollateralAmount % 100
+      -- non-ada collateral is not used, so just return it as is in the return collateral output
+      nonAdaCollateral = L.modifyCoin (const mempty) totalAvailableCollateral
+      returnCollateral = returnAdaCollateral <> nonAdaCollateral
+  case (txReturnCollateral, txTotalCollateral) of
+    (rc@TxReturnCollateral{}, tc@TxTotalCollateral{}) ->
+      (rc, tc)
+    (rc@TxReturnCollateral{}, TxTotalCollateralNone) ->
+      (rc, TxTotalCollateralNone)
+    (TxReturnCollateralNone, tc@TxTotalCollateral{}) ->
+      (TxReturnCollateralNone, tc)
+    (TxReturnCollateralNone, TxTotalCollateralNone)
+      | returnCollateralAmount < 0 ->
+          (TxReturnCollateralNone, TxTotalCollateralNone)
+      | otherwise ->
+          ( TxReturnCollateral
+              w
+              ( TxOut
+                  cAddr
+                  (TxOutValueShelleyBased sbe returnCollateral)
+                  TxOutDatumNone
+                  ReferenceScriptNone
+              )
+          , totalCollateral
+          )
 
 calculateCreatedUTOValue
   :: ShelleyBasedEra era -> TxBodyContent build era -> Value

diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs
@@ -104,6 +104,7 @@ module Cardano.Api
   , ConwayEraOnwards (..)
   , conwayEraOnwardsConstraints
   , conwayEraOnwardsToShelleyBasedEra
+  , conwayEraOnwardsToBabbageEraOnwards
   , IsConwayBasedEra (..)
 
     -- * Era case handling

diff --git a/...n/Test/Golden/Cardano/Api/Typed/Script.hs → ...-golden/Test/Golden/Cardano/Api/Script.hs b/...n/Test/Golden/Cardano/Api/Typed/Script.hs → ...-golden/Test/Golden/Cardano/Api/Script.hs
@@ -1,6 +1,6 @@
 {-# LANGUAGE TypeApplications #-}
 
-module Test.Golden.Cardano.Api.Typed.Script
+module Test.Golden.Cardano.Api.Script
   ( test_golden_SimpleScriptV1_All
   , test_golden_SimpleScriptV1_Any
   , test_golden_SimpleScriptV1_MofN

diff --git a/...pi-test/Test/Cardano/Api/Typed/Address.hs → ...dano-api-test/Test/Cardano/Api/Address.hs b/...pi-test/Test/Cardano/Api/Typed/Address.hs → ...dano-api-test/Test/Cardano/Api/Address.hs
@@ -1,6 +1,6 @@
 {-# LANGUAGE FlexibleContexts #-}
 
-module Test.Cardano.Api.Typed.Address
+module Test.Cardano.Api.Address
   ( tests
   )
 where
@@ -11,7 +11,7 @@ import qualified Data.Aeson as Aeson
 
 import           Test.Gen.Cardano.Api.Typed (genAddressByron, genAddressShelley)
 
-import           Test.Cardano.Api.Typed.Orphans ()
+import           Test.Cardano.Api.Orphans ()
 
 import           Hedgehog (Property)
 import qualified Hedgehog as H

diff --git a/...api-test/Test/Cardano/Api/Typed/Bech32.hs → ...rdano-api-test/Test/Cardano/Api/Bech32.hs b/...api-test/Test/Cardano/Api/Typed/Bech32.hs → ...rdano-api-test/Test/Cardano/Api/Bech32.hs
@@ -1,4 +1,4 @@
-module Test.Cardano.Api.Typed.Bech32
+module Test.Cardano.Api.Bech32
   ( tests
   )
 where

diff --git a/...o-api-test/Test/Cardano/Api/Typed/CBOR.hs → ...cardano-api-test/Test/Cardano/Api/CBOR.hs b/...o-api-test/Test/Cardano/Api/Typed/CBOR.hs → ...cardano-api-test/Test/Cardano/Api/CBOR.hs
@@ -4,7 +4,7 @@
 -- TODO remove when serialiseTxLedgerCddl is removed
 {-# OPTIONS_GHC -Wno-deprecations #-}
 
-module Test.Cardano.Api.Typed.CBOR
+module Test.Cardano.Api.CBOR
   ( tests
   )
 where
@@ -16,7 +16,7 @@ import           Data.Proxy (Proxy (..))
 
 import           Test.Gen.Cardano.Api.Typed
 
-import           Test.Cardano.Api.Typed.Orphans ()
+import           Test.Cardano.Api.Orphans ()
 
 import           Hedgehog (Property, forAll, property, tripping)
 import qualified Hedgehog as H

diff --git a/...i-test/Test/Cardano/Api/Typed/Envelope.hs → ...ano-api-test/Test/Cardano/Api/Envelope.hs b/...i-test/Test/Cardano/Api/Typed/Envelope.hs → ...ano-api-test/Test/Cardano/Api/Envelope.hs
@@ -1,7 +1,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE FlexibleContexts #-}
 
-module Test.Cardano.Api.Typed.Envelope
+module Test.Cardano.Api.Envelope
   ( tests
   )
 where
@@ -10,7 +10,7 @@ import           Cardano.Api
 
 import           Test.Gen.Cardano.Api.Typed
 
-import           Test.Cardano.Api.Typed.Orphans ()
+import           Test.Cardano.Api.Orphans ()
 
 import           Hedgehog (Property)
 import qualified Hedgehog as H

diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Json.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Json.hs
@@ -6,6 +6,7 @@ module Test.Cardano.Api.Json
   )
 where
 
+import           Cardano.Api
 import           Cardano.Api.Orphans ()
 import           Cardano.Api.Shelley
 
@@ -14,8 +15,11 @@ import           Data.Aeson (eitherDecode, encode)
 import           Test.Gen.Cardano.Api (genAlonzoGenesis)
 import           Test.Gen.Cardano.Api.Typed
 
+import           Test.Cardano.Api.Orphans ()
+
 import           Hedgehog (Property, forAll, tripping)
 import qualified Hedgehog as H
+import qualified Hedgehog.Gen as Gen
 import           Test.Tasty (TestTree, testGroup)
 import           Test.Tasty.Hedgehog (testProperty)
 
@@ -56,6 +60,17 @@ prop_json_roundtrip_scriptdata_detailed_json = H.property $ do
   sData <- forAll genHashableScriptData
   tripping sData scriptDataToJsonDetailedSchema scriptDataFromJsonDetailedSchema
 
+prop_roundtrip_praos_nonce_JSON :: Property
+prop_roundtrip_praos_nonce_JSON = H.property $ do
+  pNonce <- forAll $ Gen.just genMaybePraosNonce
+  tripping pNonce encode eitherDecode
+
+prop_roundtrip_protocol_parameters_JSON :: Property
+prop_roundtrip_protocol_parameters_JSON = H.property $ do
+  AnyCardanoEra era <- forAll $ Gen.element [minBound .. maxBound]
+  pp <- forAll (genProtocolParameters era)
+  tripping pp encode eitherDecode
+
 tests :: TestTree
 tests =
   testGroup
@@ -67,4 +82,6 @@ tests =
     , testProperty "json roundtrip txout tx context" prop_json_roundtrip_txout_tx_context
     , testProperty "json roundtrip txout utxo context" prop_json_roundtrip_txout_utxo_context
     , testProperty "json roundtrip scriptdata detailed json" prop_json_roundtrip_scriptdata_detailed_json
+    , testProperty "json roundtrip praos nonce" prop_roundtrip_praos_nonce_JSON
+    , testProperty "json roundtrip protocol parameters" prop_roundtrip_protocol_parameters_JSON
     ]
diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/KeysByron.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/KeysByron.hs
@@ -7,7 +7,7 @@ where
 
 import           Cardano.Api (AsType (AsByronKey, AsSigningKey), Key (deterministicSigningKey))
 
-import           Test.Cardano.Api.Typed.Orphans ()
+import           Test.Cardano.Api.Orphans ()
 import qualified Test.Gen.Cardano.Crypto.Seed as Gen
 
 import           Hedgehog (Property)