Merge pull request #622 from IntersectMBO/mgalazyn/fix/invalid-fee-wh…

…en-autobalancing-minting

Fix incorrect fees estimation when balancing transaction minting assets

cardano-api/cardano-api.cabal

@@ -318,6 +318,8 @@ test-suite cardano-api-test
     cardano-ledger-api ^>=1.9,
     cardano-ledger-binary,
     cardano-ledger-core:{cardano-ledger-core, testlib} >=1.8,
+    cardano-ledger-mary,
+    cardano-ledger-shelley,
     cardano-protocol-tpraos,
     cardano-slotting,
     cborg,

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

@@ -246,7 +246,7 @@ genPlutusScript _ =
 genScriptDataSchema :: Gen ScriptDataJsonSchema
 genScriptDataSchema = Gen.element [ScriptDataJsonNoSchema, ScriptDataJsonDetailedSchema]
 
-genHashableScriptData :: Gen HashableScriptData
+genHashableScriptData :: HasCallStack => Gen HashableScriptData
 genHashableScriptData = do
   sd <- genScriptData
   case deserialiseFromCBOR AsHashableScriptData $ serialiseToCBOR sd of

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

@@ -39,8 +39,8 @@ import           Cardano.Ledger.Hashes
 import qualified Cardano.Ledger.Keys as L
 import qualified Cardano.Ledger.SafeHash as L
 
-import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
+import           GHC.Exts (IsList (..))
 import           Lens.Micro
 
 -- | A transaction that can contain everything
@@ -115,7 +115,7 @@ makeUnsignedTx era bc = obtainCommonConstraints era $ do
       scriptWitnesses =
         L.mkBasicTxWits
           & L.scriptTxWitsL
-            .~ Map.fromList
+            .~ fromList
               [ (L.hashScript sw, sw)
               | sw <- scripts
               ]

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

@@ -1062,6 +1062,12 @@ makeTransactionBodyAutoBalance
             -- 2. figure out the overall min fees
             -- 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
+
             UnsignedTx unsignedTx0 <-
               first TxBodyError
                 $ makeUnsignedTx
@@ -1070,9 +1076,7 @@ makeTransactionBodyAutoBalance
                 $ txbodycontent
                   { txOuts =
                       txOuts txbodycontent
-                        ++ [TxOut changeaddr (lovelaceToTxOutValue sbe 0) TxOutDatumNone ReferenceScriptNone]
-                        -- TODO: think about the size of the change output
-                        -- 1,2,4 or 8 bytes?
+                        <> [TxOut changeaddr (TxOutValueShelleyBased sbe change) TxOutDatumNone ReferenceScriptNone]
                   }
             exUnitsMapWithLogs <-
               first TxBodyErrorValidityInterval
@@ -1109,12 +1113,6 @@ makeTransactionBodyAutoBalance
             let maxLovelaceChange = L.Coin (2 ^ (64 :: Integer)) - 1
             let maxLovelaceFee = L.Coin (2 ^ (32 :: Integer) - 1)
 
-            let totalValueAtSpendableUTxO = fromLedgerValue sbe $ calculateIncomingUTxOValue $ Map.elems $ unUTxO utxo
-            let change =
-                  forShelleyBasedEraInEon
-                    sbe
-                    mempty
-                    (\w -> toLedgerValue w $ calculateChangeValue sbe totalValueAtSpendableUTxO txbodycontent1)
             let changeWithMaxLovelace = change & A.adaAssetL sbe .~ maxLovelaceChange
             let changeTxOut =
                   forShelleyBasedEraInEon
@@ -1131,8 +1129,8 @@ makeTransactionBodyAutoBalance
                 $ txbodycontent1
                   { txFee = TxFeeExplicit sbe maxLovelaceFee
                   , txOuts =
-                      TxOut changeaddr changeTxOut TxOutDatumNone ReferenceScriptNone
-                        : txOuts txbodycontent
+                      txOuts txbodycontent
+                        <> [TxOut changeaddr changeTxOut TxOutDatumNone ReferenceScriptNone]
                   , txReturnCollateral = dummyCollRet
                   , txTotalCollateral = dummyTotColl
                   }
@@ -1278,7 +1276,7 @@ isNotAda AdaAssetId = False
 isNotAda _ = True
 
 onlyAda :: Value -> Bool
-onlyAda = null . valueToList . filterValue isNotAda
+onlyAda = null . toList . filterValue isNotAda
 
 calculateIncomingUTxOValue
   :: Monoid (Ledger.Value (ShelleyLedgerEra era))

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

@@ -288,6 +288,7 @@ import qualified Data.Text as Text
 import           Data.Type.Equality (TestEquality (..), (:~:) (Refl))
 import           Data.Word (Word16, Word32, Word64)
 import           GHC.Exts (IsList (..))
+import           GHC.Stack
 import           Lens.Micro hiding (ix)
 import           Lens.Micro.Extras (view)
 import qualified Text.Parsec as Parsec
@@ -709,7 +710,8 @@ toByronTxOut = \case
 
 toShelleyTxOut
   :: forall era ledgerera
-   . ShelleyLedgerEra era ~ ledgerera
+   . HasCallStack
+  => ShelleyLedgerEra era ~ ledgerera
   => ShelleyBasedEra era
   -> TxOut CtxUTxO era
   -> Ledger.TxOut ledgerera
@@ -959,12 +961,12 @@ instance IsShelleyBasedEra era => FromJSON (TxOutValue era) where
     decodeAssetId (polid, Aeson.Object assetNameHm) = do
       let polId = fromString . Text.unpack $ Aeson.toText polid
       aNameQuantity <- decodeAssets assetNameHm
-      pure . valueFromList $
+      pure . fromList $
         map (first $ AssetId polId) aNameQuantity
     decodeAssetId ("lovelace", Aeson.Number sci) =
       case toBoundedInteger sci of
         Just (ll :: Word64) ->
-          pure $ valueFromList [(AdaAssetId, Quantity $ toInteger ll)]
+          pure $ fromList [(AdaAssetId, Quantity $ toInteger ll)]
         Nothing ->
           fail $ "Expected a Bounded number but got: " <> show sci
     decodeAssetId wrong = fail $ "Expected a policy id and a JSON object but got: " <> show wrong
@@ -1829,7 +1831,7 @@ outputDoesNotExceedMax
   -> TxOut CtxTx era
   -> Either TxBodyError ()
 outputDoesNotExceedMax era v txout =
-  case [q | (_, q) <- valueToList v, q > maxTxOut] of
+  case [q | (_, q) <- toList v, q > maxTxOut] of
     [] -> Right ()
     q : _ -> Left (TxBodyOutputOverflow q (txOutInAnyEra era txout))
 
@@ -1840,7 +1842,7 @@ positiveOutput
   -> TxOut CtxTx era
   -> Either TxBodyError ()
 positiveOutput era v txout =
-  case [q | (_, q) <- valueToList v, q < 0] of
+  case [q | (_, q) <- toList v, q < 0] of
     [] -> Right ()
     q : _ -> Left (TxBodyOutputNegative q (txOutInAnyEra era txout))
 
@@ -3057,7 +3059,8 @@ makeShelleyTransactionBody
 -- embedded datums (taking only their hash).
 toShelleyTxOutAny
   :: forall ctx era ledgerera
-   . ShelleyLedgerEra era ~ ledgerera
+   . HasCallStack
+  => ShelleyLedgerEra era ~ ledgerera
   => ShelleyBasedEra era
   -> TxOut ctx era
   -> Ledger.TxOut ledgerera

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

@@ -189,14 +189,22 @@ newtype Value = Value (Map AssetId Quantity)
 instance Show Value where
   showsPrec d v =
     showParen (d > 10) $
-      showString "valueFromList " . shows (valueToList v)
+      showString "valueFromList " . shows (toList v)
 
 instance Semigroup Value where
   Value a <> Value b = Value (mergeAssetMaps a b)
 
 instance Monoid Value where
   mempty = Value Map.empty
 
+instance IsList Value where
+  type Item Value = (AssetId, Quantity)
+  fromList =
+    Value
+      . Map.filter (/= 0)
+      . Map.fromListWith (<>)
+  toList (Value m) = toList m
+
 {-# NOINLINE mergeAssetMaps #-} -- as per advice in Data.Map.Merge docs
 mergeAssetMaps
   :: Map AssetId Quantity
@@ -223,14 +231,13 @@ instance FromJSON Value where
 selectAsset :: Value -> (AssetId -> Quantity)
 selectAsset (Value m) a = Map.findWithDefault mempty a m
 
+{-# DEPRECATED valueFromList "Use 'fromList' instead." #-}
 valueFromList :: [(AssetId, Quantity)] -> Value
-valueFromList =
-  Value
-    . Map.filter (/= 0)
-    . Map.fromListWith (<>)
+valueFromList = fromList
 
+{-# DEPRECATED valueToList "Use 'toList' instead." #-}
 valueToList :: Value -> [(AssetId, Quantity)]
-valueToList (Value m) = toList m
+valueToList = toList
 
 -- | This lets you write @a - b@ as @a <> negateValue b@.
 negateValue :: Value -> Value

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

@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedLists #-}
+
 module Cardano.Api.ValueParser
   ( parseValue
   , assetName
@@ -34,9 +36,8 @@ evalValueExpr vExpr =
   case vExpr of
     ValueExprAdd x y -> evalValueExpr x <> evalValueExpr y
     ValueExprNegate x -> negateValue (evalValueExpr x)
-    ValueExprLovelace quant -> valueFromList [(AdaAssetId, quant)]
-    ValueExprMultiAsset polId aName quant ->
-      valueFromList [(AssetId polId aName, quant)]
+    ValueExprLovelace quant -> [(AdaAssetId, quant)]
+    ValueExprMultiAsset polId aName quant -> [(AssetId polId aName, quant)]
 
 ------------------------------------------------------------------------------
 -- Expression parser

cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/Value.hs

@@ -11,6 +11,7 @@ import           Data.Aeson (eitherDecode, encode)
 import           Data.List (groupBy, sort)
 import qualified Data.Map.Strict as Map
 import qualified Data.Text as Text
+import           GHC.Exts (IsList (..))
 import qualified Text.Parsec as Parsec (parse)
 
 import           Test.Gen.Cardano.Api.Typed (genAssetName, genValueDefault, genValueNestedRep)
@@ -47,7 +48,7 @@ hprop_goldenValue_1_lovelace :: Property
 hprop_goldenValue_1_lovelace =
   H.propertyOnce $ do
     valueList <- pure [(Api.AdaAssetId, 1)]
-    value <- pure $ Text.unpack $ Api.renderValuePretty $ Api.valueFromList valueList
+    value <- pure $ Text.unpack $ Api.renderValuePretty $ fromList valueList
 
     H.diffVsGoldenFile value "test/cardano-api-golden/files/golden/Cardano/Api/Value/value-ada-1.json"
 
@@ -57,7 +58,7 @@ hprop_goldenValue1 =
     policyId <- pure $ Api.PolicyId "a0000000000000000000000000000000000000000000000000000000"
     assetName <- pure $ Api.AssetName "asset1"
     valueList <- pure [(Api.AssetId policyId assetName, 1)]
-    value <- pure $ Text.unpack $ Api.renderValuePretty $ Api.valueFromList valueList
+    value <- pure $ Text.unpack $ Api.renderValuePretty $ fromList valueList
 
     H.diffVsGoldenFile
       value

cardano-api/test/cardano-api-golden/Test/Golden/ErrorsSpec.hs

@@ -382,7 +382,7 @@ test_TxBodyErrorAutoBalance =
     , ("TxBodyErrorMinUTxONotMet", TxBodyErrorMinUTxONotMet txOutInAnyEra1 1)
     ,
       ( "TxBodyErrorNonAdaAssetsUnbalanced"
-      , TxBodyErrorNonAdaAssetsUnbalanced (valueFromList [(AdaAssetId, Quantity 1)])
+      , TxBodyErrorNonAdaAssetsUnbalanced (fromList [(AdaAssetId, Quantity 1)])
       )
     ,
       ( "TxBodyErrorScriptWitnessIndexMissingFromExecUnitsMap"