Merge pull request #5135 from IntersectMBO/aniketd/alonzo-pred-failure-serialization

Fix AlonzoPlutusPurpose CBOR instances

Author: aniketd

eras/alonzo/impl/CHANGELOG.md

@@ -2,6 +2,8 @@
 
 ## 1.14.0.0
 
+* Fix `AlonzoPlutusPurpose` CBOR(Group) instances. #5135
+  * Reset shuffled serialization indexes for `AlonzoPlutusPurpose AsItem`.
 * Deprecated `toAlonzoTransitionConfigPairs`
 * Fixed `FromJSON` instance for `TransitionConfig AlonzoEra`
 * Added `COMPLETE` pragma for `TxCert AlonzoEra`

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Scripts.hs

@@ -66,6 +66,7 @@ import Cardano.Ledger.Alonzo.TxCert ()
 import Cardano.Ledger.BaseTypes (ProtVer (..), kindObject)
 import Cardano.Ledger.Binary (
   Annotator,
+  CBORGroup (..),
   DecCBOR (decCBOR),
   DecCBORGroup (..),
   Decoder,
@@ -83,7 +84,6 @@ import Cardano.Ledger.Binary.Coders (
   decode,
   encode,
   (!>),
-  (<!),
   (<*!),
  )
 import Cardano.Ledger.Binary.Plain (serializeAsHexText)
@@ -323,36 +323,62 @@ instance
     AlonzoCertifying x -> rnf x
     AlonzoRewarding x -> rnf x
 
-instance Era era => EncCBORGroup (AlonzoPlutusPurpose AsIx era) where
+instance
+  ( forall a b. (EncCBOR a, EncCBOR b) => EncCBOR (f a b)
+  , Era era
+  , Typeable f
+  , EncCBOR (TxCert era)
+  ) =>
+  EncCBORGroup (AlonzoPlutusPurpose f era)
+  where
   listLen _ = 2
   listLenBound _ = 2
   encCBORGroup = \case
-    AlonzoSpending (AsIx redeemerIx) -> encodeWord8 0 <> encCBOR redeemerIx
-    AlonzoMinting (AsIx redeemerIx) -> encodeWord8 1 <> encCBOR redeemerIx
-    AlonzoCertifying (AsIx redeemerIx) -> encodeWord8 2 <> encCBOR redeemerIx
-    AlonzoRewarding (AsIx redeemerIx) -> encodeWord8 3 <> encCBOR redeemerIx
+    AlonzoSpending p -> encodeWord8 0 <> encCBOR p
+    AlonzoMinting p -> encodeWord8 1 <> encCBOR p
+    AlonzoCertifying p -> encodeWord8 2 <> encCBOR p
+    AlonzoRewarding p -> encodeWord8 3 <> encCBOR p
   encodedGroupSizeExpr size_ _proxy =
     encodedSizeExpr size_ (Proxy :: Proxy Word8)
       + encodedSizeExpr size_ (Proxy :: Proxy Word16)
 
-instance Era era => DecCBORGroup (AlonzoPlutusPurpose AsIx era) where
+instance
+  ( forall a b. (DecCBOR a, DecCBOR b) => DecCBOR (f a b)
+  , Era era
+  , Typeable f
+  , DecCBOR (TxCert era)
+  ) =>
+  DecCBORGroup (AlonzoPlutusPurpose f era)
+  where
   decCBORGroup =
     decodeWord8 >>= \case
-      0 -> AlonzoSpending . AsIx <$> decCBOR
-      1 -> AlonzoMinting . AsIx <$> decCBOR
-      2 -> AlonzoCertifying . AsIx <$> decCBOR
-      3 -> AlonzoRewarding . AsIx <$> decCBOR
+      0 -> AlonzoSpending <$> decCBOR
+      1 -> AlonzoMinting <$> decCBOR
+      2 -> AlonzoCertifying <$> decCBOR
+      3 -> AlonzoRewarding <$> decCBOR
       n -> fail $ "Unexpected tag for AlonzoPlutusPurpose: " <> show n
 
--- | Incorrect CBOR implementation. Missing length encoding. Must keep it for backwards
--- compatibility
-instance Era era => EncCBOR (AlonzoPlutusPurpose AsIx era) where
-  encCBOR = encCBORGroup
-
--- | Incorrect CBOR implementation. Missing length encoding. Must keep it for backwards
--- compatibility
-instance Era era => DecCBOR (AlonzoPlutusPurpose AsIx era) where
-  decCBOR = decCBORGroup
+deriving via
+  (CBORGroup (AlonzoPlutusPurpose f era))
+  instance
+    ( forall a b. (EncCBOR a, EncCBOR b) => EncCBOR (f a b)
+    , Era era
+    , Typeable f
+    , EncCBOR (TxCert era)
+    ) =>
+    EncCBOR (AlonzoPlutusPurpose f era)
+
+deriving via
+  (CBORGroup (AlonzoPlutusPurpose f era))
+  instance
+    ( forall a b. (EncCBOR a, EncCBOR b) => EncCBOR (f a b)
+    , forall a b. (DecCBOR a, DecCBOR b) => DecCBOR (f a b)
+    , Era era
+    , Typeable f
+    , EncCBOR (TxCert era)
+    , DecCBOR (TxCert era)
+    ) =>
+    DecCBOR (AlonzoPlutusPurpose f era)
 
 instance
   ( forall a b. (ToJSON a, ToJSON b) => ToJSON (f a b)
@@ -369,29 +395,6 @@ instance
     where
       kindObjectWithValue name n = kindObject name ["value" .= n]
 
--- | /Note/ - serialization of `AlonzoPlutusPurpose` `AsItem`
---
--- * Tags do not match the `AlonzoPlutusPurpose` `AsIx`. Unfortunate inconsistency
---
--- * It is only used for predicate failures. Thus we can change it after Conway to be
---   consistent with `AlonzoPlutusPurpose` `AsIx`
-instance (Era era, EncCBOR (TxCert era)) => EncCBOR (AlonzoPlutusPurpose AsItem era) where
-  encCBOR = \case
-    AlonzoSpending (AsItem x) -> encode (Sum (AlonzoSpending @_ @era . AsItem) 1 !> To x)
-    AlonzoMinting (AsItem x) -> encode (Sum (AlonzoMinting @_ @era . AsItem) 0 !> To x)
-    AlonzoCertifying (AsItem x) -> encode (Sum (AlonzoCertifying . AsItem) 3 !> To x)
-    AlonzoRewarding (AsItem x) -> encode (Sum (AlonzoRewarding @_ @era . AsItem) 2 !> To x)
-
--- | See note on the `EncCBOR` instace.
-instance (Era era, DecCBOR (TxCert era)) => DecCBOR (AlonzoPlutusPurpose AsItem era) where
-  decCBOR = decode (Summands "AlonzoPlutusPurpose" dec)
-    where
-      dec 1 = SumD (AlonzoSpending . AsItem) <! From
-      dec 0 = SumD (AlonzoMinting . AsItem) <! From
-      dec 3 = SumD (AlonzoCertifying . AsItem) <! From
-      dec 2 = SumD (AlonzoRewarding . AsItem) <! From
-      dec n = Invalid n
-
 pattern SpendingPurpose ::
   AlonzoEraScript era => f Word32 TxIn -> PlutusPurpose f era
 pattern SpendingPurpose c <- (toSpendingPurpose -> Just c)

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

@@ -349,18 +349,7 @@ instance
   ) =>
   Arbitrary (AlonzoUtxowPredFailure era)
   where
-  -- Switch to this implementation once #4110 is taken care of
-  -- arbitrary = genericArbitraryU
-  arbitrary =
-    oneof
-      [ ShelleyInAlonzoUtxowPredFailure <$> arbitrary
-      , -- MissingRedeemers <$> arbitrary -- see #4110
-        MissingRequiredDatums <$> arbitrary <*> arbitrary
-      , NotAllowedSupplementalDatums <$> arbitrary <*> arbitrary
-      , PPViewHashesDontMatch <$> arbitrary
-      , UnspendableUTxONoDatumHash <$> arbitrary
-      -- , ExtraRedeemers <$> arbitrary -- see #4110
-      ]
+  arbitrary = genericArbitraryU
 
 deriving instance Arbitrary ix => Arbitrary (AsIx ix it)
 

eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxowSpec/Invalid.hs

@@ -19,7 +19,7 @@ import Cardano.Ledger.Alonzo.Rules (
  )
 import Cardano.Ledger.Alonzo.Scripts (eraLanguages)
 import Cardano.Ledger.Alonzo.TxWits (TxDats (..), unRedeemersL)
-import Cardano.Ledger.BaseTypes (Mismatch (..), StrictMaybe (..), natVersion)
+import Cardano.Ledger.BaseTypes (Mismatch (..), StrictMaybe (..))
 import Cardano.Ledger.Coin (Coin (..))
 import Cardano.Ledger.Credential (Credential (..), StakeReference (..))
 import Cardano.Ledger.Keys (asWitness, witVKeyHash)
@@ -67,11 +67,6 @@ spec = describe "Invalid transactions" $ do
 
   let resetAddrWits tx = updateAddrTxWits $ tx & witsTxL . addrTxWitsL .~ []
       fixupResetAddrWits = fixupPPHash >=> resetAddrWits
-      -- PlutusPurpose serialization wasn't fixed until Conway
-      withPlutusPurposeRoundTripFailures =
-        if eraProtVerLow @era < natVersion @9
-          then withCborRoundTripFailures
-          else id
 
   forM_ (eraLanguages @era) $ \lang ->
     withSLanguage lang $ \slang ->
@@ -205,16 +200,15 @@ spec = describe "Invalid transactions" $ do
               removeSpenders = Map.filterWithKey (const . not . isSpender)
               dropSpendingRedeemers = pure . (witsTxL . rdmrsTxWitsL . unRedeemersL %~ removeSpenders)
           withPostFixup (dropSpendingRedeemers >=> fixupPPHash >=> resetAddrWits) $
-            withPlutusPurposeRoundTripFailures $
-              submitFailingTx
-                tx
-                [ injectFailure $
-                    ExtraRedeemers [mkMintingPurpose $ AsIx 0]
-                , injectFailure $
-                    MissingRedeemers [(mkSpendingPurpose $ AsItem txIn, scriptHash)]
-                , injectFailure $
-                    CollectErrors [NoRedeemer $ mkSpendingPurpose $ AsItem txIn]
-                ]
+            submitFailingTx
+              tx
+              [ injectFailure $
+                  ExtraRedeemers [mkMintingPurpose $ AsIx 0]
+              , injectFailure $
+                  MissingRedeemers [(mkSpendingPurpose $ AsItem txIn, scriptHash)]
+              , injectFailure $
+                  CollectErrors [NoRedeemer $ mkSpendingPurpose $ AsItem txIn]
+              ]
 
         it "Missing witness for collateral input" $ do
           let scriptHash = alwaysSucceedsWithDatumHash
@@ -249,10 +243,9 @@ spec = describe "Invalid transactions" $ do
                 let fixedRedeemers = txFixed ^. witsTxL . rdmrsTxWitsL . unRedeemersL
                     extraRedeemers = Map.keys $ Map.filter (== redeemer) fixedRedeemers
                 withNoFixup $
-                  withPlutusPurposeRoundTripFailures $
-                    submitFailingTx
-                      txFixed
-                      [injectFailure $ ExtraRedeemers extraRedeemers]
+                  submitFailingTx
+                    txFixed
+                    [injectFailure $ ExtraRedeemers extraRedeemers]
 
             it "Minting" $
               testPurpose (mkMintingPurpose $ AsIx 2)
@@ -277,7 +270,6 @@ spec = describe "Invalid transactions" $ do
                     mkBasicTx mkBasicTxBody
                       & bodyTxL . certsTxBodyL <>~ certs
                       & witsTxL . rdmrsTxWitsL . unRedeemersL <>~ redeemers
-              withPlutusPurposeRoundTripFailures $
-                submitFailingTx
-                  tx
-                  [injectFailure $ ExtraRedeemers [mkCertifyingPurpose (AsIx 2)]]
+              submitFailingTx
+                tx
+                [injectFailure $ ExtraRedeemers [mkCertifyingPurpose (AsIx 2)]]

eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Arbitrary.hs

@@ -90,17 +90,7 @@ instance
   ) =>
   Arbitrary (BabbageContextError era)
   where
-  -- Switch to this implementation once #4110 is taken care of
-  -- arbitrary = genericArbitraryU
-  arbitrary =
-    oneof
-      [ AlonzoContextError <$> arbitrary
-      , ByronTxOutInContext <$> arbitrary
-      , -- , RedeemerPointerPointsToNothing <$> arbitrary -- see #4110
-        InlineDatumsNotSupported <$> arbitrary
-      , ReferenceScriptsNotSupported <$> arbitrary
-      , ReferenceInputsNotSupported <$> arbitrary
-      ]
+  arbitrary = genericArbitraryU
 
 instance
   ( EraTxOut era

eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Imp/UtxowSpec.hs

@@ -81,17 +81,12 @@ spec = describe "UTXOW" $ do
             mkBasicTx mkBasicTxBody
               & bodyTxL . inputsTxBodyL .~ [txIn]
               & witsTxL . rdmrsTxWitsL . unRedeemersL %~ Map.insert prp (dt, ExUnits 0 0)
-      let submit =
-            submitFailingTx
-              tx
-              [ injectFailure $ ExtraRedeemers [prp]
-              , injectFailure $
-                  CollectErrors [BadTranslation (inject $ RedeemerPointerPointsToNothing prp)]
-              ]
-      if eraProtVerLow @era < natVersion @9
-        then -- PlutusPurpose serialization was fixed in Conway
-          withCborRoundTripFailures submit
-        else submit
+      submitFailingTx
+        tx
+        [ injectFailure $ ExtraRedeemers [prp]
+        , injectFailure $
+            CollectErrors [BadTranslation (inject $ RedeemerPointerPointsToNothing prp)]
+        ]
 
   it "P1 reference scripts must be witnessed" $ do
     (_, addr) <- freshKeyAddr