Change the balance in InsufficientCollateral to DeltaCoin (#4247)

* Added test for a deserialization bug

* Fixed the predicate failure deserialization bug

eras/alonzo/impl/CHANGELOG.md

@@ -1,7 +1,8 @@
 # Version history for `cardano-ledger-alonzo`
 
-## 1.7.1.0
+## 1.8.0.0
 
+* Change the type of the balance field in `InsufficientCollateral` to `DeltaCoin`
 * Add `ToJSON` instances for `FailureDescription` and `TagMismatchDescription`
 * Undeprecate `redeemerPointer`.
 

eras/alonzo/impl/cardano-ledger-alonzo.cabal

@@ -1,6 +1,6 @@
 cabal-version:      3.0
 name:               cardano-ledger-alonzo
-version:            1.7.1.0
+version:            1.8.0.0
 license:            Apache-2.0
 maintainer:         operations@iohk.io
 author:             IOHK

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxo.hs

@@ -74,7 +74,7 @@ import Cardano.Ledger.Binary.Coders (
   (!>),
   (<!),
  )
-import Cardano.Ledger.Coin (Coin (unCoin), rationalToCoinViaCeiling)
+import Cardano.Ledger.Coin (Coin (unCoin), DeltaCoin, rationalToCoinViaCeiling, toDeltaCoin)
 import Cardano.Ledger.Core
 import Cardano.Ledger.Credential (Credential (..))
 import Cardano.Ledger.Rules.ValidationMode (
@@ -164,7 +164,7 @@ data AlonzoUtxoPredFailure era
       ![(Integer, Integer, TxOut era)]
   | InsufficientCollateral
       -- | balance computed
-      !Coin
+      !DeltaCoin
       -- | the required collateral for the given fee
       !Coin
   | -- | The UTxO entries which have the wrong kind of script
@@ -325,7 +325,7 @@ validateCollateral pp txb utxoCollateral =
       failureIf (null utxoCollateral) NoCollateralInputs
     ]
   where
-    bal = coinBalance (UTxO utxoCollateral)
+    bal = toDeltaCoin $ coinBalance (UTxO utxoCollateral)
 
 -- > (∀(a,_,_) ∈ range (collateral txb ◁ utxo), a ∈ Addrvkey)
 validateScriptsNotPaidUTxO ::
@@ -343,10 +343,10 @@ validateInsufficientCollateral ::
   ) =>
   PParams era ->
   TxBody era ->
-  Coin ->
+  DeltaCoin ->
   Test (AlonzoUtxoPredFailure era)
 validateInsufficientCollateral pp txBody bal =
-  failureUnless (Val.scale (100 :: Int) bal >= Val.scale collPerc txfee) $
+  failureUnless (Val.scale (100 :: Int) bal >= Val.scale collPerc (toDeltaCoin txfee)) $
     InsufficientCollateral bal $
       rationalToCoinViaCeiling $
         (fromIntegral collPerc * unCoin txfee) % 100

eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/ImpTest.hs

@@ -27,6 +27,7 @@ module Test.Cardano.Ledger.Alonzo.ImpTest (
   fixupOutputDatums,
   fixupPPHash,
   fixupRedeemers,
+  fixupScriptWits,
 ) where
 
 import Cardano.Crypto.DSIGN (DSIGNAlgorithm (..), Ed25519DSIGN)
@@ -126,13 +127,13 @@ makeCollateralInput = do
   -- TODO: make more accurate
   let collateral = Coin 10_000_000
   (_, addr) <- freshKeyAddr
-  sendCoinTo addr collateral
+  withFixup fixupTx $ sendCoinTo addr collateral
 
 addCollateralInput ::
   (AlonzoEraImp era, ScriptsNeeded era ~ AlonzoScriptsNeeded era) =>
   Tx era ->
   ImpTestM era (Tx era)
-addCollateralInput tx = do
+addCollateralInput tx = impAnn "addCollateralInput" $ do
   ctx <- impGetPlutusContexts tx
   if null ctx
     then pure tx
@@ -170,7 +171,7 @@ fixupRedeemerIndices ::
   AlonzoEraImp era =>
   Tx era ->
   ImpTestM era (Tx era)
-fixupRedeemerIndices tx = do
+fixupRedeemerIndices tx = impAnn "fixupRedeemerIndices" $ do
   (rootTxIn, _) <- lookupImpRootTxOut
   let
     txInputs = tx ^. bodyTxL . inputsTxBodyL
@@ -190,7 +191,7 @@ fixupRedeemers ::
   ) =>
   Tx era ->
   ImpTestM era (Tx era)
-fixupRedeemers tx = do
+fixupRedeemers tx = impAnn "fixupRedeemers" $ do
   contexts <- impGetPlutusContexts tx
   exUnits <- getsNES $ nesEsL . curPParamsEpochStateL . ppMaxTxExUnitsL
   let
@@ -209,7 +210,7 @@ fixupScriptWits ::
   ) =>
   Tx era ->
   ImpTestM era (Tx era)
-fixupScriptWits tx = do
+fixupScriptWits tx = impAnn "fixupScriptWits" $ do
   contexts <- impGetPlutusContexts tx
   utxo <- getUTxO
   let ScriptsProvided provided = getScriptsProvided utxo tx
@@ -238,7 +239,7 @@ fixupDatums ::
   ) =>
   Tx era ->
   ImpTestM era (Tx era)
-fixupDatums tx = do
+fixupDatums tx = impAnn "fixupDatums" $ do
   contexts <- impGetPlutusContexts tx
   let purposes = (^. _1) <$> contexts
   datums <- traverse collectDatums purposes
@@ -272,7 +273,7 @@ fixupPPHash ::
   AlonzoEraImp era =>
   Tx era ->
   ImpTestM era (Tx era)
-fixupPPHash tx = do
+fixupPPHash tx = impAnn "fixupPPHash" $ do
   pp <- getsNES $ nesEsL . curPParamsEpochStateL
   utxo <- getUTxO
   let
@@ -297,7 +298,7 @@ fixupOutputDatums ::
   AlonzoEraImp era =>
   Tx era ->
   ImpTestM era (Tx era)
-fixupOutputDatums tx = do
+fixupOutputDatums tx = impAnn "fixupOutputDatums" $ do
   let
     isDatum (Datum _) = True
     isDatum _ = False

eras/babbage/impl/CHANGELOG.md

@@ -1,8 +1,10 @@
 # Version history for `cardano-ledger-babbage`
 
-## 1.7.0.1
+## 1.8.0.0
 
-*
+* Change the return type of `collAdaBalance` to `DeltaCoin`
+* Change the type of the provided collateral field in `IncorrectTotalCollateralField` to `DeltaCoin`
+* Change the type of `validateCollateralEqBalance`
 
 ## 1.7.0.0
 

eras/babbage/impl/cardano-ledger-babbage.cabal

@@ -1,6 +1,6 @@
 cabal-version:      3.0
 name:               cardano-ledger-babbage
-version:            1.7.0.1
+version:            1.8.0.0
 license:            Apache-2.0
 maintainer:         operations@iohk.io
 author:             IOHK
@@ -73,7 +73,7 @@ library
         cardano-crypto-class,
         cardano-data >=1.2,
         cardano-ledger-allegra ^>=1.4,
-        cardano-ledger-alonzo ^>=1.7,
+        cardano-ledger-alonzo ^>=1.8,
         cardano-ledger-binary ^>=1.3,
         cardano-ledger-core ^>=1.11,
         cardano-ledger-mary ^>=1.5,

eras/babbage/impl/src/Cardano/Ledger/Babbage/Collateral.hs

@@ -15,7 +15,7 @@ where
 import Cardano.Ledger.Babbage.PParams ()
 import Cardano.Ledger.Babbage.TxBody (BabbageEraTxBody (..))
 import Cardano.Ledger.BaseTypes (TxIx (..), txIxFromIntegral)
-import Cardano.Ledger.Coin (Coin)
+import Cardano.Ledger.Coin (DeltaCoin, toDeltaCoin)
 import Cardano.Ledger.Core
 import Cardano.Ledger.TxIn (TxIn (..))
 import Cardano.Ledger.UTxO (UTxO (..), coinBalance)
@@ -32,8 +32,8 @@ collAdaBalance ::
   BabbageEraTxBody era =>
   TxBody era ->
   Map.Map (TxIn (EraCrypto era)) (TxOut era) ->
-  Coin
-collAdaBalance txBody utxoCollateral =
+  DeltaCoin
+collAdaBalance txBody utxoCollateral = toDeltaCoin $
   case txBody ^. collateralReturnTxBodyL of
     SNothing -> colbal
     SJust txOut -> colbal <-> (txOut ^. coinTxOutL @era)

eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxo.hs

@@ -61,7 +61,7 @@ import Cardano.Ledger.BaseTypes (
  )
 import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..), Sized (..))
 import Cardano.Ledger.Binary.Coders
-import Cardano.Ledger.Coin (Coin (..))
+import Cardano.Ledger.Coin (Coin (..), DeltaCoin, toDeltaCoin)
 import Cardano.Ledger.Rules.ValidationMode (
   Test,
   runTest,
@@ -111,7 +111,7 @@ data BabbageUtxoPredFailure era
   | -- | The collateral is not equivalent to the total collateral asserted by the transaction
     IncorrectTotalCollateralField
       -- | collateral provided
-      !Coin
+      !DeltaCoin
       -- | collateral amount declared in transaction body
       !Coin
   | -- | list of supplied transaction outputs that are too small,
@@ -310,11 +310,11 @@ validateCollateralContainsNonADA txBody utxoCollateral =
 
 -- > (txcoll tx ≠ ◇) => balance == txcoll tx
 validateCollateralEqBalance ::
-  Coin -> StrictMaybe Coin -> Validation (NonEmpty (BabbageUtxoPredFailure era)) ()
+  DeltaCoin -> StrictMaybe Coin -> Validation (NonEmpty (BabbageUtxoPredFailure era)) ()
 validateCollateralEqBalance bal txcoll =
   case txcoll of
     SNothing -> pure ()
-    SJust tc -> failureUnless (bal == tc) (IncorrectTotalCollateralField bal tc)
+    SJust tc -> failureUnless (bal == toDeltaCoin tc) (IncorrectTotalCollateralField bal tc)
 
 -- > getValue txout ≥ inject ( serSize txout ∗ coinsPerUTxOByte pp )
 validateOutputTooSmallUTxO ::

eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxos.hs

@@ -54,6 +54,7 @@ import Cardano.Ledger.BaseTypes (
  )
 import Cardano.Ledger.Binary (EncCBOR (..))
 import Cardano.Ledger.CertState (certDState, dsGenDelegs)
+import Cardano.Ledger.Coin (Coin (..), DeltaCoin (..))
 import Cardano.Ledger.Plutus.Evaluate (
   ScriptFailure (..),
   ScriptResult (..),
@@ -288,11 +289,11 @@ babbageEvalScriptsTxInvalid = do
   {- utxoDel  = txBody ^. collateralInputsTxBodyL ◁ utxo -}
   let !(utxoKeep, utxoDel) = extractKeys (unUTxO utxo) (txBody ^. collateralInputsTxBodyL)
       UTxO collouts = collOuts txBody
-      collateralFees = collAdaBalance txBody utxoDel -- NEW to Babbage
+      DeltaCoin collateralFees = collAdaBalance txBody utxoDel -- NEW to Babbage
   pure $!
     us {- (collInputs txb ⋪ utxo) ∪ collouts tx -}
       { utxosUtxo = UTxO (Map.union utxoKeep collouts) -- NEW to Babbage
       {- fees + collateralFees -}
-      , utxosFees = fees <> collateralFees -- NEW to Babbage
+      , utxosFees = fees <> Coin collateralFees -- NEW to Babbage
       , utxosStakeDistr = updateStakeDistribution pp (utxosStakeDistr us) (UTxO utxoDel) (UTxO collouts)
       }

eras/babbage/test-suite/cardano-ledger-babbage-test.cabal

@@ -36,7 +36,7 @@ library
         cardano-ledger-binary:{cardano-ledger-binary, testlib} >=1.0,
         cardano-ledger-alonzo:{cardano-ledger-alonzo, testlib} >=1.5.1,
         cardano-ledger-alonzo-test >=1.1,
-        cardano-ledger-babbage:{cardano-ledger-babbage, testlib} >=1.5 && <1.8,
+        cardano-ledger-babbage:{cardano-ledger-babbage, testlib} >=1.5 && <1.9,
         cardano-ledger-core:{cardano-ledger-core, testlib} >=1.11,
         cardano-ledger-shelley-ma-test >=1.1,
         cardano-ledger-mary >=1.4,

eras/conway/impl/cardano-ledger-conway.cabal

@@ -88,8 +88,8 @@ library
         cardano-data >=1.2.1,
         cardano-ledger-binary >=1.3.2,
         cardano-ledger-allegra ^>=1.4,
-        cardano-ledger-alonzo ^>=1.7,
-        cardano-ledger-babbage ^>=1.7,
+        cardano-ledger-alonzo ^>=1.8,
+        cardano-ledger-babbage ^>=1.8,
         cardano-ledger-core ^>=1.11,
         cardano-ledger-mary ^>=1.5,
         cardano-ledger-shelley ^>=1.10,

eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Binary/Regression.hs

@@ -1,15 +1,49 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 
 module Test.Cardano.Ledger.Conway.Binary.Regression where
 
-import Cardano.Ledger.Binary (decCBOR, decodeFullAnnotatorFromHexText)
-import Cardano.Ledger.Conway.Core (EraTx (..), eraProtVerLow)
-import Test.Cardano.Ledger.Common (NFData, Spec, describe, expectRightDeep_, it)
+import Cardano.Ledger.Alonzo.Rules (AlonzoUtxoPredFailure (..))
+import Cardano.Ledger.Babbage.Rules (BabbageUtxoPredFailure (..), BabbageUtxowPredFailure (..))
+import Cardano.Ledger.BaseTypes (Inject (..), StrictMaybe (..), TxIx (..))
+import Cardano.Ledger.Binary (
+  EncCBOR (..),
+  decCBOR,
+  decodeFull,
+  decodeFullAnnotatorFromHexText,
+  mkVersion,
+  serialize,
+ )
+import Cardano.Ledger.Coin (Coin (..))
+import Cardano.Ledger.Conway (Conway)
+import Cardano.Ledger.Conway.Core (
+  BabbageEraTxBody (..),
+  EraTx (..),
+  EraTxBody (..),
+  EraTxOut (..),
+  EraTxWits (..),
+  coinTxOutL,
+  eraProtVerLow,
+  txIdTx,
+ )
+import Cardano.Ledger.Conway.Rules (ConwayLedgerPredFailure (..))
+import Cardano.Ledger.Plutus.Language (SLanguage (..), hashPlutusScript)
+import Cardano.Ledger.TxIn (TxIn (..))
+import Control.Monad ((<=<))
+import qualified Data.Sequence.Strict as SSeq
+import qualified Data.Set as Set
+import Lens.Micro ((%~), (&), (.~))
+import Test.Cardano.Ledger.Conway.ImpTest
+import Test.Cardano.Ledger.Core.KeyPair (mkScriptAddr)
+import Test.Cardano.Ledger.Imp.Common
+import Test.Cardano.Ledger.Plutus.Examples (guessTheNumber3)
 
 spec ::
   forall era.
@@ -19,7 +53,7 @@ spec ::
   Spec
 spec = describe "Regression" $ do
   it "DeserialiseFailure on resubmitting Conway Tx with invalid plutus script #4198" $ do
-    expectRightDeep_ $
+    io . expectRightDeep_ $
       decodeFullAnnotatorFromHexText @(Tx era) (eraProtVerLow @era) "Unwitnessed Tx" decCBOR $
         mconcat
           [ "84a700d9010282825820745f04573e7429be1404f9b936d208b81159f3fc4b300"
@@ -55,3 +89,59 @@ spec = describe "Regression" $ do
           , "d0403d9010281581e581c01000033223232222350040071235002353003001498"
           , "49848004800504d9010281d8799f182aff0581840000d8799f182aff820000f4f6"
           ]
+  describe "ImpTest" $
+    withImpState @Conway $
+      it "InsufficientCollateral is not encoded with negative coin #4198" $ do
+        let lockedVal = inject $ Coin 100
+        (_, collateralAddress) <- freshKeyAddr
+        (_, skp) <- freshKeyPair
+        let
+          plutusVersion = SPlutusV2
+          scriptHash = hashPlutusScript $ guessTheNumber3 plutusVersion
+          lockScriptAddress = mkScriptAddr scriptHash skp
+        (_, collateralReturnAddr) <- freshKeyAddr
+        lockedTx <-
+          submitTxAnn @Conway "Script locked tx" $
+            mkBasicTx mkBasicTxBody
+              & bodyTxL . outputsTxBodyL
+                .~ SSeq.fromList
+                  [ mkBasicTxOut lockScriptAddress lockedVal
+                  , mkBasicTxOut collateralAddress (inject $ Coin 1)
+                  ]
+              & bodyTxL . collateralReturnTxBodyL
+                .~ SJust (mkBasicTxOut collateralReturnAddr . inject $ Coin 1)
+        let
+          modifyRootCoin = coinTxOutL .~ Coin 989482376
+          modifyRootTxOut (x SSeq.:<| SSeq.Empty) =
+            modifyRootCoin x SSeq.:<| SSeq.Empty
+          modifyRootTxOut (x SSeq.:<| xs) = x SSeq.:<| modifyRootTxOut xs
+          modifyRootTxOut (xs SSeq.:|> x) = xs SSeq.:|> modifyRootCoin x
+          modifyRootTxOut SSeq.Empty = SSeq.Empty
+          breakCollaterals tx =
+            pure $
+              tx
+                & bodyTxL . collateralReturnTxBodyL
+                  .~ SJust (mkBasicTxOut collateralReturnAddr . inject $ Coin 1_000_000_000)
+                & bodyTxL . feeTxBodyL .~ Coin 178349
+                & bodyTxL . outputsTxBodyL %~ modifyRootTxOut
+                & witsTxL . addrTxWitsL .~ mempty
+        res <-
+          impAnn "Consume the script locked output" $
+            withPostFixup (updateAddrTxWits <=< breakCollaterals) $ do
+              trySubmitTx @Conway $
+                mkBasicTx mkBasicTxBody
+                  & bodyTxL . inputsTxBodyL .~ Set.singleton (TxIn (txIdTx lockedTx) $ TxIx 0)
+        pFailure <- impAnn "Expecting failure" $ expectLeftDeepExpr res
+        let
+          hasInsufficientCollateral
+            (ConwayUtxowFailure (UtxoFailure (AlonzoInBabbageUtxoPredFailure (InsufficientCollateral _ _)))) = True
+          hasInsufficientCollateral _ = False
+        impAnn "Fails with InsufficientCollateral" $
+          pFailure `shouldSatisfyExpr` any hasInsufficientCollateral
+        let encoding = encCBOR pFailure
+        version <- mkVersion (11 :: Int)
+        let
+          bs = serialize version encoding
+          decoded = decodeFull version bs
+        impAnn "Expecting deserialization of predicate failure to succeed" $
+          decoded `shouldBe` Right pFailure

eras/conway/test-suite/cardano-ledger-conway-test.cabal

@@ -33,7 +33,7 @@ library
         cardano-data,
         cardano-ledger-alonzo:{cardano-ledger-alonzo, testlib} >=1.6,
         cardano-ledger-alonzo-test,
-        cardano-ledger-babbage >=1.3 && <1.8,
+        cardano-ledger-babbage >=1.3 && <1.9,
         cardano-ledger-babbage-test >=1.1.1,
         cardano-ledger-binary >=1.0,
         cardano-ledger-conway:{cardano-ledger-conway, testlib} ^>=1.13,