Merge pull request #3332 from input-output-hk/lehins/embed-trip-failure

Improve roundtrip CBOR serialization failure testing functions:

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

@@ -102,7 +102,7 @@ test-suite tests
         base16-bytestring,
         bytestring,
         cardano-data:{cardano-data, testlib},
-        cardano-ledger-binary:testlib,
+        cardano-ledger-binary:testlib >=1.1,
         cardano-ledger-core:{cardano-ledger-core, testlib},
         cardano-ledger-mary,
         testlib

eras/mary/impl/test/Test/Cardano/Ledger/Mary/ValueSpec.hs

@@ -22,9 +22,9 @@ import GHC.Exts
 import Test.Cardano.Data
 import Test.Cardano.Ledger.Binary.RoundTrip (
   roundTripCborExpectation,
+  roundTripCborFailureExpectation,
   roundTripCborRangeExpectation,
-  roundTripFailureCborExpectation,
-  roundTripFailureCborRangeExpectation,
+  roundTripCborRangeFailureExpectation,
  )
 import Test.Cardano.Ledger.Common
 import Test.Cardano.Ledger.Mary.Arbitrary (genEmptyMultiAsset, genMaryValue, genMultiAsset)
@@ -40,29 +40,29 @@ spec = do
       prop "Negative Coin succeeds for pre-Conway" $
         \(Negative i) -> roundTripCborRangeExpectation minBound (natVersion @8) (Coin i)
       prop "Negative Coin fails to deserialise for Conway" $
-        \(Negative i) -> roundTripFailureCborRangeExpectation (natVersion @9) (natVersion @9) (Coin i)
+        \(Negative i) -> roundTripCborRangeFailureExpectation (natVersion @9) (natVersion @9) (Coin i)
     context "MultiAsset" $ do
       prop "Non-zero-valued MultiAsset succeeds for all eras" $
         roundTripCborExpectation @(MultiAsset StandardCrypto)
-      prop "zero-valued MultiAsset fails for pre-Conway, due to pruning, and for Conway, due to decoder implementation" $
+      prop "Zero-valued MultiAsset fails for Conway" $
         forAll (genMultiAsset @StandardCrypto (pure 0)) $
-          roundTripFailureCborExpectation
+          roundTripCborRangeFailureExpectation (natVersion @9) maxBound
       prop "Empty MultiAsset fails for Conway" $
         forAll (genEmptyMultiAsset @StandardCrypto) $
-          roundTripFailureCborRangeExpectation (natVersion @9) (natVersion @9)
+          roundTripCborRangeFailureExpectation (natVersion @9) maxBound
     context "MaryValue" $ do
       prop "Positive MaryValue succeeds for all eras" $
-        forAll (genMaryValue (genMultiAsset @StandardCrypto (toInteger . getPositive @Int <$> arbitrary))) $
+        forAll (genMaryValue (genMultiAsset @StandardCrypto (toInteger <$> chooseInt (1, maxBound)))) $
           roundTripCborExpectation
       prop "Negative MaryValue fails for all eras" $
-        forAll (genMaryValue (genMultiAsset @StandardCrypto (toInteger . getNegative @Int <$> arbitrary))) $
-          roundTripFailureCborExpectation
-      prop "Zero MaryValue fails for pre-Conway, due to pruning, and for Conway, due to decoder implementation" $
+        forAll (genMaryValue (genMultiAsset @StandardCrypto (toInteger <$> chooseInt (minBound, -1)))) $
+          roundTripCborFailureExpectation
+      prop "Zero MaryValue fails for Conway" $
         forAll (genMaryValue (genMultiAsset @StandardCrypto (pure 0))) $
-          roundTripFailureCborExpectation
+          roundTripCborRangeFailureExpectation (natVersion @9) maxBound
       prop "Empty MaryValue fails for Conway" $
         forAll (genMaryValue (genEmptyMultiAsset @StandardCrypto)) $
-          roundTripFailureCborRangeExpectation (natVersion @9) (natVersion @9)
+          roundTripCborRangeFailureExpectation (natVersion @9) maxBound
 
 instance IsString AssetName where
   fromString = AssetName . either error SBS.toShort . BS16.decode . BS8.pack

eras/shelley-ma/test-suite/cardano-ledger-shelley-ma-test.cabal

@@ -94,7 +94,7 @@ test-suite cardano-ledger-shelley-ma-test
         base,
         bytestring,
         cardano-data,
-        cardano-ledger-binary:{cardano-ledger-binary, testlib},
+        cardano-ledger-binary:{cardano-ledger-binary, testlib} >=1.1,
         cardano-ledger-core:{cardano-ledger-core, testlib},
         cardano-ledger-shelley-ma-test >=1.1,
         cardano-ledger-allegra >=1.1,

eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/ShelleyMA/Serialisation/Golden/Encoding.hs

@@ -49,7 +49,7 @@ import qualified Data.Map.Strict as Map
 import qualified Data.Sequence.Strict as StrictSeq
 import qualified Data.Set as Set
 import Lens.Micro
-import Test.Cardano.Ledger.Binary.RoundTrip (roundTripFailureCborRangeExpectation)
+import Test.Cardano.Ledger.Binary.RoundTrip (roundTripCborRangeFailureExpectation)
 import Test.Cardano.Ledger.Shelley.Generator.EraGen (genesisId)
 import Test.Cardano.Ledger.Shelley.Serialisation.GoldenUtils (
   ToTokens (..),
@@ -442,7 +442,7 @@ goldenEncodingTestsMary =
 
 assetName32Bytes :: Assertion
 assetName32Bytes =
-  roundTripFailureCborRangeExpectation (eraProtVerHigh @Mary) maxBound $
+  roundTripCborRangeFailureExpectation (eraProtVerHigh @Mary) maxBound $
     AssetName "123456789-123456789-123456789-123"
 
 -- | Golden Tests for Allegra and Mary

libs/cardano-ledger-binary/CHANGELOG.md

@@ -1,6 +1,6 @@
 # Version history for `cardano-ledger-binary`
 
-## 1.0.1.0
+## 1.1.0.0
 
 * Add `ToJSON`/`FromJSON` instances for `Version`
 * Add `decodeFullFromHexText` and `serializeAsHexText`
@@ -14,6 +14,14 @@
 ### `testlib`
 
 * Add `Arbitrary` instance for `Term`
+* Renamed:
+  * `roundTripAnnFailureRangeExpectation` -> `roundTripAnnRangeFailureExpectation`
+  * `roundTripFailureCborRangeExpectation` -> `roundTripCborRangeFailureExpectation`
+  * `roundTripAnnFailureRangeExpectation` -> `roundTripAnnRangeFailureExpectation`
+* Added:
+  * `embedTripFailureExpectation`
+  * `embedTripRangeFailureExpectation`
+  * `roundTripRangeFailureExpectation`
 
 ## 1.0.0.0
 

libs/cardano-ledger-binary/cardano-ledger-binary.cabal

@@ -1,6 +1,6 @@
 cabal-version: 3.0
 name:          cardano-ledger-binary
-version:       1.0.1.0
+version:       1.1.0.0
 license:       Apache-2.0
 maintainer:    operations@iohk.io
 author:        IOHK

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

@@ -1,7 +1,6 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
@@ -11,35 +10,53 @@
 
 -- | Defines reusable abstractions for testing RoundTrip properties of CBOR instances
 module Test.Cardano.Ledger.Binary.RoundTrip (
+  -- * Spec
   roundTripSpec,
   roundTripRangeSpec,
-  roundTripFailureExpectation,
+
+  -- * Expectations
+
+  -- ** Trip
   roundTripExpectation,
+  roundTripRangeExpectation,
+  roundTripFailureExpectation,
+  roundTripRangeFailureExpectation,
+
+  -- ** Enc/DecCBOR
   roundTripCborExpectation,
+  roundTripCborRangeExpectation,
+  roundTripCborFailureExpectation,
+  roundTripCborRangeFailureExpectation,
   roundTripAnnExpectation,
   roundTripAnnRangeExpectation,
   roundTripAnnFailureExpectation,
-  roundTripAnnFailureRangeExpectation,
+  roundTripAnnRangeFailureExpectation,
+
+  -- ** Embed
   embedTripSpec,
   embedTripExpectation,
   embedTripAnnExpectation,
+  embedTripFailureExpectation,
+  embedTripRangeFailureExpectation,
   roundTripTwiddledProperty,
   roundTripAnnTwiddledProperty,
+
+  -- * Tripping failure
   RoundTripFailure (..),
+
+  -- * Tripping definitions
   Trip (..),
   mkTrip,
   cborTrip,
+
+  -- * Tripping functions
   roundTrip,
   roundTripTwiddled,
   roundTripAnn,
   roundTripAnnTwiddled,
   embedTrip,
   embedTripAnn,
   embedTripLabel,
-  roundTripRangeExpectation,
-  roundTripCborRangeExpectation,
-  roundTripFailureCborRangeExpectation,
-  roundTripFailureCborExpectation,
 )
 where
 
@@ -104,14 +121,14 @@ roundTripExpectation ::
   Expectation
 roundTripExpectation trip = roundTripRangeExpectation trip minBound maxBound
 
-roundTripFailureCborExpectation ::
+roundTripCborFailureExpectation ::
   forall t.
   (EncCBOR t, DecCBOR t, HasCallStack) =>
   t ->
   Expectation
-roundTripFailureCborExpectation = roundTripFailureExpectation (cborTrip @t @t)
+roundTripCborFailureExpectation = roundTripFailureExpectation (cborTrip @t @t)
 
-roundTripFailureCborRangeExpectation ::
+roundTripCborRangeFailureExpectation ::
   forall t.
   (EncCBOR t, DecCBOR t, HasCallStack) =>
   -- | From Version
@@ -120,30 +137,56 @@ roundTripFailureCborRangeExpectation ::
   Version ->
   t ->
   Expectation
-roundTripFailureCborRangeExpectation = roundTripFailureRangeExpectation (cborTrip @t)
+roundTripCborRangeFailureExpectation = roundTripRangeFailureExpectation (cborTrip @t)
 
 roundTripFailureExpectation ::
-  (EncCBOR t, HasCallStack) =>
+  (Typeable t, HasCallStack) =>
   Trip t t ->
   t ->
   Expectation
-roundTripFailureExpectation trip = roundTripFailureRangeExpectation trip minBound maxBound
+roundTripFailureExpectation trip = roundTripRangeFailureExpectation trip minBound maxBound
 
-roundTripFailureRangeExpectation ::
+roundTripRangeFailureExpectation ::
   forall t.
-  (EncCBOR t, HasCallStack) =>
+  (Typeable t, HasCallStack) =>
   Trip t t ->
   -- | From Version
   Version ->
   -- | To Version
   Version ->
   t ->
   Expectation
-roundTripFailureRangeExpectation trip fromVersion toVersion t =
+roundTripRangeFailureExpectation = embedTripRangeFailureExpectation
+
+embedTripFailureExpectation ::
+  (Typeable b, HasCallStack) =>
+  Trip a b ->
+  a ->
+  Expectation
+embedTripFailureExpectation trip = embedTripRangeFailureExpectation trip minBound maxBound
+
+embedTripRangeFailureExpectation ::
+  forall a b.
+  (Typeable b, HasCallStack) =>
+  Trip a b ->
+  -- | From Version
+  Version ->
+  -- | To Version
+  Version ->
+  a ->
+  Expectation
+embedTripRangeFailureExpectation trip fromVersion toVersion t =
   forM_ [fromVersion .. toVersion] $ \version ->
-    case roundTrip version trip t of
-      Left _ -> pure ()
-      Right _ -> expectationFailure $ "Should not have deserialized: " <> showExpr (CBORBytes (serialize' version t))
+    case embedTripLabelExtra (typeLabel @b) version version trip t of
+      (Left _, _, _) -> pure ()
+      (Right _, _, bs) ->
+        expectationFailure $
+          mconcat
+            [ "Should not have deserialized: <version: "
+            , show version
+            , "> "
+            , showExpr (CBORBytes (BSL.toStrict bs))
+            ]
 
 -- | Verify that round triping through the binary form holds for a range of versions.
 --
@@ -207,15 +250,15 @@ roundTripAnnFailureExpectation ::
   (ToCBOR t, DecCBOR (Annotator t), HasCallStack) =>
   t ->
   Expectation
-roundTripAnnFailureExpectation = roundTripAnnFailureRangeExpectation (natVersion @2) maxBound
+roundTripAnnFailureExpectation = roundTripAnnRangeFailureExpectation (natVersion @2) maxBound
 
-roundTripAnnFailureRangeExpectation ::
+roundTripAnnRangeFailureExpectation ::
   (ToCBOR t, DecCBOR (Annotator t), HasCallStack) =>
   Version ->
   Version ->
   t ->
   Expectation
-roundTripAnnFailureRangeExpectation fromVersion toVersion t =
+roundTripAnnRangeFailureExpectation fromVersion toVersion t =
   forM_ [fromVersion .. toVersion] $ \version ->
     case roundTripAnn version t of
       Left _ -> pure ()
@@ -350,9 +393,14 @@ cborTrip = Trip encCBOR decCBOR (dropCBOR (Proxy @b))
 mkTrip :: forall a b. (a -> Encoding) -> (forall s. Decoder s b) -> Trip a b
 mkTrip encoder decoder = Trip encoder decoder (() <$ decoder)
 
+-- | Check that serialization forllowed by deserialization of the value produces the same
+-- value back. We also check that re-serialization is idempotent. In other words, we
+-- ensure that deserialization does not modify the decoded value in a way that its binary
+-- representation has changed. Dropper is checked as well.
 roundTrip :: forall t. Typeable t => Version -> Trip t t -> t -> Either RoundTripFailure t
 roundTrip version trip val = do
-  (val', encoding, encodedBytes) <- embedTripLabelExtra (typeLabel @t) version version trip val
+  let (res, encoding, encodedBytes) = embedTripLabelExtra (typeLabel @t) version version trip val
+  val' <- res
   let reserialized = serialize version (tripEncoder trip val')
   if reserialized /= encodedBytes
     then
@@ -405,7 +453,8 @@ embedTripLabel ::
   a ->
   Either RoundTripFailure b
 embedTripLabel lbl encVersion decVersion trip s =
-  (\(val, _, _) -> val) <$> embedTripLabelExtra lbl encVersion decVersion trip s
+  case embedTripLabelExtra lbl encVersion decVersion trip s of
+    (res, _, _) -> res
 
 embedTripLabelExtra ::
   forall a b.
@@ -416,22 +465,23 @@ embedTripLabelExtra ::
   Version ->
   Trip a b ->
   a ->
-  Either RoundTripFailure (b, Plain.Encoding, BSL.ByteString)
+  (Either RoundTripFailure b, Plain.Encoding, BSL.ByteString)
 embedTripLabelExtra lbl encVersion decVersion (Trip encoder decoder dropper) s =
-  case decodeFullDecoder decVersion lbl decoder encodedBytes of
-    Right val
-      | Nothing <- mDropperError -> Right (val, encoding, encodedBytes)
-      | Just err <- mDropperError ->
-          Left $
-            RoundTripFailure encVersion decVersion encoding encodedBytes Nothing (Just err) Nothing
-    Left err ->
-      let mErr = do
-            dropperError <- mDropperError
-            guard (dropperError /= err)
-            pure dropperError
-       in Left $
-            RoundTripFailure encVersion decVersion encoding encodedBytes Nothing mErr (Just err)
+  (result, encoding, encodedBytes)
   where
+    mkFailure = RoundTripFailure encVersion decVersion encoding encodedBytes Nothing
+    result =
+      case decodeFullDecoder decVersion lbl decoder encodedBytes of
+        Right val
+          | Nothing <- mDropperError -> Right val
+          | Just err <- mDropperError -> Left $ mkFailure (Just err) Nothing
+        Left err ->
+          -- In case of failure we only record dropper error if it differs from the
+          -- decoder failure:
+          let mErr = do
+                dropperError <- mDropperError
+                dropperError <$ guard (dropperError /= err)
+           in Left $ mkFailure mErr (Just err)
     encoding = toPlainEncoding encVersion (encoder s)
     encodedBytes = Plain.serialize encoding
     mDropperError =