Merge pull request #718 from IntersectMBO/mgalazyn/fix/autobalancing-when-credential-deregistration

Fix transaction autobalancing when deregistering credential

Author: carbolymer

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

@@ -98,6 +98,7 @@ import           Data.Set (Set)
 import qualified Data.Set as Set
 import           Data.Text (Text)
 import           GHC.Exts (IsList (..))
+import           GHC.Stack
 import           Lens.Micro ((.~), (^.))
 
 -- | Type synonym for logs returned by the ledger's @evalTxExUnitsWithLogs@ function.
@@ -190,7 +191,8 @@ instance Error (TxFeeEstimationError era) where
 -- | Use when you do not have access to the UTxOs you intend to spend
 estimateBalancedTxBody
   :: forall era
-   . MaryEraOnwards era
+   . HasCallStack
+  => MaryEraOnwards era
   -> TxBodyContent BuildTx era
   -> L.PParams (ShelleyLedgerEra era)
   -> Set PoolId
@@ -273,9 +275,9 @@ estimateBalancedTxBody
             , negateValue (lovelaceToValue totalDeposits)
             ]
 
-    let change = toLedgerValue w $ calculateChangeValue sbe availableUTxOValue txbodycontent1
+    let partialChange = toLedgerValue w $ calculatePartialChangeValue sbe availableUTxOValue txbodycontent1
         maxLovelaceChange = L.Coin (2 ^ (64 :: Integer)) - 1
-        changeWithMaxLovelace = change & A.adaAssetL sbe .~ maxLovelaceChange
+        changeWithMaxLovelace = partialChange & A.adaAssetL sbe .~ maxLovelaceChange
         changeTxOut =
           forShelleyBasedEraInEon
             sbe
@@ -1002,6 +1004,7 @@ data FeeEstimationMode era
 makeTransactionBodyAutoBalance
   :: forall era
    . ()
+  => HasCallStack
   => ShelleyBasedEra era
   -> SystemStart
   -> LedgerEpochInfo
@@ -1016,7 +1019,7 @@ makeTransactionBodyAutoBalance
   -- ^ Map of all deposits for drep credentials that are being
   --   unregistered in this transaction
   -> UTxO era
-  -- ^ Just the transaction inputs, not the entire 'UTxO'.
+  -- ^ Just the transaction inputs (including reference and collateral ones), not the entire 'UTxO'.
   -> TxBodyContent BuildTx era
   -> AddressInEra era
   -- ^ Change address
@@ -1042,18 +1045,21 @@ makeTransactionBodyAutoBalance
       -- 3. update tx with fees
       -- 4. balance the transaction and update tx change output
 
-      let totalValueAtSpendableUTxO = fromLedgerValue sbe . calculateIncomingUTxOValue . Map.elems $ unUTxO utxo
-          change =
-            monoidForEraInEon (toCardanoEra sbe) $ \w ->
-              toLedgerValue w $ calculateChangeValue sbe totalValueAtSpendableUTxO txbodycontent
+      txbodyForChange <- first TxBodyError $ createTransactionBody sbe txbodycontent
+      let initialChangeTxOut =
+            evaluateTransactionBalance sbe pp poolids stakeDelegDeposits drepDelegDeposits utxo txbodyForChange
 
-      txbody0 <-
+      -- Tx body used only for evaluating execution units. Because txout exact
+      -- values do not matter much here, we are using an initial change value,
+      -- which is slightly overestimated, because it does not include fee or
+      -- scripts execution costs.
+      txbody <-
         first TxBodyError
           $ createTransactionBody
             sbe
           $ txbodycontent
             & modTxOuts
-              (<> [TxOut changeaddr (TxOutValueShelleyBased sbe change) TxOutDatumNone ReferenceScriptNone])
+              (<> [TxOut changeaddr initialChangeTxOut TxOutDatumNone ReferenceScriptNone])
       exUnitsMapWithLogs <-
         first TxBodyErrorValidityInterval $
           evaluateTransactionExecutionUnits
@@ -1062,7 +1068,7 @@ makeTransactionBodyAutoBalance
             history
             lpp
             utxo
-            txbody0
+            txbody
 
       let exUnitsMap = Map.map (fmap snd) exUnitsMapWithLogs
 
@@ -1077,24 +1083,14 @@ makeTransactionBodyAutoBalance
       txbodycontent1 <- substituteExecutionUnits exUnitsMap' txbodycontent
 
       -- Make a txbody that we will use for calculating the fees. For the purpose
-      -- of fees we just need to make a txbody of the right size in bytes. We do
-      -- not need the right values for the fee or change output. We use
-      -- "big enough" values for the change output and set so that the CBOR
-      -- encoding size of the tx will be big enough to cover the size of the final
-      -- 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 maxLovelaceChange = L.Coin (2 ^ (64 :: Integer)) - 1
+      -- of fees we just need to make a txbody of the right size in bytes. We
+      -- do not need the right values for the fee. We use "big enough" value
+      -- for the fee and set so that the CBOR encoding size of the tx will be
+      -- big enough to cover the size of the final 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).
       let maxLovelaceFee = L.Coin (2 ^ (32 :: Integer) - 1)
-      let changeWithMaxLovelace = change & A.adaAssetL sbe .~ maxLovelaceChange
-      let changeTxOut =
-            forShelleyBasedEraInEon
-              sbe
-              (lovelaceToTxOutValue sbe maxLovelaceChange)
-              (\w -> maryEraOnwardsConstraints w $ TxOutValueShelleyBased sbe changeWithMaxLovelace)
-
+      -- Make a txbody that we will use for calculating the fees.
       let (dummyCollRet, dummyTotColl) = maybeDummyTotalCollAndCollReturnOutput sbe txbodycontent changeaddr
       txbody1 <-
         first TxBodyError $ -- TODO: impossible to fail now
@@ -1104,7 +1100,7 @@ makeTransactionBodyAutoBalance
               { txFee = TxFeeExplicit sbe maxLovelaceFee
               , txOuts =
                   txOuts txbodycontent
-                    <> [TxOut changeaddr changeTxOut TxOutDatumNone ReferenceScriptNone]
+                    <> [TxOut changeaddr initialChangeTxOut TxOutDatumNone ReferenceScriptNone]
               , txReturnCollateral = dummyCollRet
               , txTotalCollateral = dummyTotColl
               }
@@ -1240,15 +1236,10 @@ isNotAda _ = True
 onlyAda :: Value -> Bool
 onlyAda = null . toList . filterValue isNotAda
 
-calculateIncomingUTxOValue
-  :: Monoid (Ledger.Value (ShelleyLedgerEra era))
-  => [TxOut ctx era]
-  -> Ledger.Value (ShelleyLedgerEra era)
-calculateIncomingUTxOValue providedUtxoOuts =
-  mconcat [v | (TxOut _ (TxOutValueShelleyBased _ v) _ _) <- providedUtxoOuts]
-
--- 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
--- TODO: Bug Jared to expose a function from the ledger that returns total and return collateral.
+-- 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
+-- TODO: Bug Jared to expose a function from the ledger that returns total and
+-- return collateral.
 calcReturnAndTotalCollateral
   :: ()
   => Ledger.AlonzoEraPParams (ShelleyLedgerEra era)
@@ -1311,17 +1302,19 @@ calcReturnAndTotalCollateral w fee pp' TxInsCollateral{} txReturnCollateral txTo
           , totalCollateral
           )
 
-calculateCreatedUTOValue
-  :: ShelleyBasedEra era -> TxBodyContent build era -> Value
-calculateCreatedUTOValue sbe txbodycontent =
-  mconcat [fromLedgerValue sbe v | (TxOut _ (TxOutValueShelleyBased _ v) _ _) <- txOuts txbodycontent]
-
-calculateChangeValue
-  :: ShelleyBasedEra era -> Value -> TxBodyContent build era -> Value
-calculateChangeValue sbe incoming txbodycontent =
-  let outgoing = calculateCreatedUTOValue sbe txbodycontent
+-- | Calculate the partial change - this does not include certificates' deposits
+calculatePartialChangeValue
+  :: ShelleyBasedEra era
+  -> Value
+  -> TxBodyContent build era
+  -> Value
+calculatePartialChangeValue sbe incoming txbodycontent = do
+  let outgoing = newUtxoValue
       mintedValue = txMintValueToValue $ txMintValue txbodycontent
-   in mconcat [incoming, mintedValue, negateValue outgoing]
+  mconcat [incoming, mintedValue, negateValue outgoing]
+ where
+  newUtxoValue =
+    mconcat [fromLedgerValue sbe v | (TxOut _ (TxOutValueShelleyBased _ v) _ _) <- txOuts txbodycontent]
 
 -- | This is used in the balance calculation in the event where
 -- the user does not supply the UTxO(s) they intend to spend
@@ -1585,7 +1578,8 @@ traverseScriptWitnesses =
   traverse (\(item, eRes) -> eRes >>= (\res -> Right (item, res)))
 
 calculateMinimumUTxO
-  :: ShelleyBasedEra era
+  :: HasCallStack
+  => ShelleyBasedEra era
   -> TxOut CtxTx era
   -> Ledger.PParams (ShelleyLedgerEra era)
   -> L.Coin

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

@@ -174,6 +174,7 @@ data LocalNodeConnectInfo
   , localNodeNetworkId :: NetworkId
   , localNodeSocketPath :: SocketPath
   }
+  deriving Show
 
 -- ----------------------------------------------------------------------------
 -- Actually connect to the node

cardano-api/internal/Cardano/Api/Tx/Body.hs

@@ -1916,6 +1916,7 @@ instance Error TxBodyError where
 
 createTransactionBody
   :: ()
+  => HasCallStack
   => ShelleyBasedEra era
   -> TxBodyContent BuildTx era
   -> Either TxBodyError (TxBody era)
@@ -2661,7 +2662,8 @@ convTotalCollateral txTotalCollateral =
 
 convTxOuts
   :: forall ctx era ledgerera
-   . ShelleyLedgerEra era ~ ledgerera
+   . HasCallStack
+  => ShelleyLedgerEra era ~ ledgerera
   => ShelleyBasedEra era
   -> [TxOut ctx era]
   -> Seq.StrictSeq (Ledger.TxOut ledgerera)
@@ -2844,6 +2846,7 @@ guardShelleyTxInsOverflow txIns = do
 -- all eras
 mkCommonTxBody
   :: ()
+  => HasCallStack
   => ShelleyBasedEra era
   -> TxIns BuildTx era
   -> [TxOut ctx era]

cardano-api/internal/Cardano/Api/Tx/Compatible.hs

@@ -37,6 +37,7 @@ import           Data.Maybe.Strict
 import           Data.Monoid
 import qualified Data.Sequence.Strict as Seq
 import           GHC.Exts (IsList (..))
+import           GHC.Stack
 import           Lens.Micro hiding (ix)
 
 data AnyProtocolUpdate era where
@@ -206,7 +207,8 @@ createCompatibleSignedTx sbe ins outs witnesses txFee' anyProtocolUpdate anyVote
         .~ shelleyBootstrapWitnesses
 
 createCommonTxBody
-  :: ShelleyBasedEra era
+  :: HasCallStack
+  => ShelleyBasedEra era
   -> [TxIn]
   -> [TxOut ctx era]
   -> Lovelace