Fixed unannotated TxDats decoder

Author: Soupstraw

eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Binary/Annotator.hs

@@ -29,6 +29,7 @@ import Cardano.Ledger.Binary.Coders
 import Cardano.Ledger.Core
 import Cardano.Ledger.Plutus
 import Cardano.Ledger.Shelley.BlockBody (auxDataSeqDecoder)
+import Data.Coerce (coerce)
 import qualified Data.List.NonEmpty as NE
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
@@ -274,14 +275,42 @@ instance (AlonzoEraScript era, DecCBOR (NativeScript era)) => DecCBOR (AlonzoScr
       decodePlutus slang =
         SumD PlutusScript <! D (decodePlutusScript slang)
 
+-- | Decodes a set of `a`'s and maps a function over it to get key-value pairs.
+-- If the key-value pairs create a non-empty Map without duplicates, then that map is returned,
+-- otherwise fail
+noDuplicateNonEmptySetAsMapDecoder ::
+  (Ord k, DecCBOR a) =>
+  (a -> (k, v)) ->
+  Decoder s (Map k v)
+noDuplicateNonEmptySetAsMapDecoder toKV = do
+  allowTag setTag
+  vals <- decodeList decCBOR
+  go (Map.empty, 0) vals
+  where
+    go (m, n) []
+      | Map.null m = fail "Empty script Set is not allowed"
+      | length m /= n = fail "Duplicate elements in the scripts Set were encountered"
+      | otherwise = pure m
+    go (!m, !n) (x : xs) = do
+      let (k, v) = toKV x
+      go (Map.insert k v m, n + 1) xs
+
 instance Era era => DecCBOR (TxDatsRaw era) where
   decCBOR =
     ifDecoderVersionAtLeast
       (natVersion @9)
-      ( allowTag setTag
-          >> TxDatsRaw . Map.fromElems hashData . NE.toList <$> decodeNonEmptyList decCBOR
+      ( ifDecoderVersionAtLeast
+          (natVersion @12)
+          noDuplicatesDatsDecoder
+          ( allowTag setTag
+              >> TxDatsRaw . Map.fromElems hashData . NE.toList <$> decodeNonEmptyList decCBOR
+          )
       )
       (TxDatsRaw . Map.fromElems hashData <$> decodeList decCBOR)
+    where
+      noDuplicatesDatsDecoder :: Decoder s (TxDatsRaw era)
+      noDuplicatesDatsDecoder =
+        coerce . noDuplicateNonEmptySetAsMapDecoder $ \dat -> (hashData dat, dat)
   {-# INLINE decCBOR #-}
 
 deriving newtype instance Era era => DecCBOR (TxDats era)

libs/cardano-ledger-binary/testlib/Test/Cardano/Ledger/Binary.hs

@@ -12,6 +12,9 @@ module Test.Cardano.Ledger.Binary (
 ) where
 
 import Cardano.Ledger.Binary
+import Codec.CBOR.Pretty (prettyHexEnc)
+import Codec.CBOR.Read (deserialiseFromBytes)
+import qualified Codec.CBOR.Term as C
 import Control.Monad (forM_)
 import qualified Data.ByteString.Lazy as BSL
 import Data.Proxy
@@ -21,6 +24,7 @@ import Test.Cardano.Ledger.Binary.RoundTrip (embedTripAnnExpectation)
 import Test.Hspec
 import Test.Hspec.QuickCheck (prop)
 import Test.QuickCheck hiding (label)
+import Text.Show.Pretty (ppShow)
 
 -- | Generates arbitrary values, encodes them, and verifies that
 -- decoding with `DecCBOR (Annotator)` produces the same result as decoding with `DecCBOR`.
@@ -76,4 +80,15 @@ decoderEquivalenceExpectation version bs = do
     (Left _, Left _) -> pure ()
     _ ->
       expectationFailure $
-        "Decoding result: " ++ show dec ++ " did not match the one via Annotator: " ++ show decAnn
+        unlines
+          [ "Decoding result:"
+          , ppShow dec
+          , "did not match the one via Annotator:"
+          , ppShow decAnn
+          , "CBOR:"
+          , hexDebug
+          ]
+      where
+        hexDebug = case deserialiseFromBytes C.decodeTerm bs of
+          Right (_, res) -> prettyHexEnc $ C.encodeTerm res
+          Left err -> "Failed to decode CBOR: " <> show err