Invalid fields testing

Author: Soupstraw

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

@@ -10,6 +10,7 @@ module Test.Cardano.Ledger.Alonzo.Binary.Golden (
   spec,
   witsEmptyField,
   expectFailureOnTxWitsEmptyField,
+  txWitsDecodingFailsOnInvalidField,
   module Test.Cardano.Ledger.Allegra.Binary.Golden,
 ) where
 
@@ -30,11 +31,11 @@ import Test.Cardano.Ledger.Alonzo.Era (AlonzoEraTest)
 import Test.Cardano.Ledger.Binary.Plain.Golden (Enc (..))
 import Test.Cardano.Ledger.Common (
   Expectation,
-  NonNegative (..),
   Spec,
   describe,
   it,
   prop,
+  (==>),
  )
 import Test.Cardano.Ledger.Imp.Common (forEachEraVersion)
 
@@ -65,6 +66,16 @@ expectSuccessOnEmptyFieldRaw ::
 expectSuccessOnEmptyFieldRaw version k =
   expectDecoderSuccessAnnWith eqRaw version (witsEmptyField k) (mkBasicTxWits @era)
 
+txWitsDecodingFailsOnInvalidField :: forall era. AlonzoEraTest era => Version -> [Int] -> Spec
+txWitsDecodingFailsOnInvalidField version validFields =
+  prop "Invalid field" $ \n ->
+    n `notElem` validFields ==> expectFailureOnTxWitsEmptyField @era version n $
+      DecoderErrorDeserialiseFailure
+        (Binary.label $ Proxy @(Annotator (TxWits era)))
+        ( DeserialiseFailure 2 $
+            "An error occurred while decoding (Int,Void) not a valid key:.\nError: " <> show n
+        )
+
 spec ::
   forall era.
   (AlonzoEraTest era, ShelleyEraTxCert era) =>
@@ -84,13 +95,5 @@ spec = do
         -- from there onwards
         it "plutusV2Script" $ expectSuccessOnEmptyFieldRaw @era version 6
         it "plutusV3Script" $ expectSuccessOnEmptyFieldRaw @era version 7
-        prop "Invalid field" $ \(NonNegative n) ->
-          let invalidTag = n + 8
-           in expectFailureOnTxWitsEmptyField @era version invalidTag $
-                DecoderErrorDeserialiseFailure
-                  (Binary.label $ Proxy @(Annotator (TxWits era)))
-                  ( DeserialiseFailure 2 $
-                      "An error occurred while decoding (Int,Void) not a valid key:.\nError: " <> show invalidTag
-                  )
   describe "TxCerts" $ do
     forEachEraVersion @era $ allegraDecodeDuplicateDelegCertSucceeds @era

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

@@ -150,10 +150,7 @@ spec = do
             DecoderErrorDeserialiseFailure
               (Binary.label $ Proxy @(Annotator (TxWits era)))
               (DeserialiseFailure 4 "Empty list of scripts is not allowed")
-          it "8th field" . expectFailureOnTxWitsEmptyField @era version 8 $
-            DecoderErrorDeserialiseFailure
-              (Binary.label $ Proxy @(Annotator (TxWits era)))
-              (DeserialiseFailure 2 "An error occurred while decoding (Int,Void) not a valid key:.\nError: 8")
+          txWitsDecodingFailsOnInvalidField @era version [0 .. 7]
         describe "Tagged" $ do
           it "addrTxWits" . expectFailureOnTxWitsEmptyField @era version 0 $
             DecoderErrorDeserialiseFailure

eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Binary/Golden.hs

@@ -92,10 +92,7 @@ goldenEmptyFields version =
           "Annotator (MemoBytes (AlonzoTxWitsRaw DijkstraEra))"
           (DeserialiseFailure 4 "Empty list of scripts is not allowed")
       -- TODO replace this with `plutusV4Script` once that is added
-      it "8th field" . expectFailureOnTxWitsEmptyField @era version 8 $
-        DecoderErrorDeserialiseFailure
-          (Binary.label $ Proxy @(Annotator (TxWits era)))
-          (DeserialiseFailure 2 "An error occurred while decoding (Int,Void) not a valid key:.\nError: 8")
+      txWitsDecodingFailsOnInvalidField @era version [0 .. 7]
     describe "Tagged" $ do
       let
       it "addrTxWits" . expectFailureOnTxWitsEmptyField @era version 0 $

libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Binary/Golden.hs

@@ -0,0 +1,84 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Test.Cardano.Ledger.Core.Binary.Golden (
+  decodeEnc,
+  expectDecoderSuccessAnn,
+  expectDecoderSuccessAnnWith,
+  expectDecoderFailureAnn,
+  expectDecoderResultOn,
+) where
+
+import Cardano.Ledger.Binary (
+  Annotator,
+  DecCBOR (..),
+  DecoderError,
+  ToCBOR (..),
+  Version,
+  decodeFullAnnotator,
+  toLazyByteString,
+ )
+import qualified Cardano.Ledger.Binary as Binary
+import Data.Typeable (Proxy (..))
+import GHC.Stack (HasCallStack)
+import Test.Cardano.Ledger.Binary.Plain.Golden (Enc)
+import Test.Cardano.Ledger.Binary.RoundTrip (embedTripAnnExpectation)
+import Test.Cardano.Ledger.Common (
+  Expectation,
+  diffExprString,
+  expectationFailure,
+  shouldBe,
+  showExpr,
+ )
+import Test.Cardano.Ledger.TreeDiff (ToExpr, expectExprEqualWithMessage)
+
+decodeEnc :: forall a. DecCBOR (Annotator a) => Version -> Enc -> Either DecoderError a
+decodeEnc version enc = decodeFullAnnotator @a version (Binary.label $ Proxy @(Annotator a)) decCBOR bytes
+  where
+    bytes = toLazyByteString $ toCBOR enc
+
+expectDecoderSuccessAnnWith ::
+  forall a.
+  (ToExpr a, DecCBOR (Annotator a), HasCallStack) =>
+  (a -> a -> Bool) ->
+  Version ->
+  Enc ->
+  a ->
+  Expectation
+expectDecoderSuccessAnnWith equals version enc expected =
+  case decodeEnc @a version enc of
+    Left err -> expectationFailure $ "Unexpected decoder failure: " <> show err
+    Right x | x `equals` expected -> pure ()
+    Right result -> expectationFailure $ diffExprString expected result
+
+expectDecoderSuccessAnn ::
+  (ToExpr a, DecCBOR (Annotator a), Eq a, HasCallStack) => Version -> Enc -> a -> Expectation
+expectDecoderSuccessAnn = expectDecoderSuccessAnnWith (==)
+
+expectDecoderFailureAnn ::
+  forall a.
+  (ToExpr a, DecCBOR (Annotator a), HasCallStack) =>
+  Version ->
+  Enc ->
+  DecoderError ->
+  Expectation
+expectDecoderFailureAnn version enc expectedErr =
+  case decodeEnc @a version enc of
+    Left err -> expectedErr `shouldBe` err
+    Right x ->
+      expectationFailure $
+        "Expected a failure, but decoder succeeded:\n"
+          <> showExpr x
+
+expectDecoderResultOn ::
+  forall a b.
+  (ToExpr b, DecCBOR (Annotator a), Eq b, HasCallStack) =>
+  Version -> Enc -> a -> (a -> b) -> Expectation
+expectDecoderResultOn version enc expected f =
+  embedTripAnnExpectation
+    version
+    version
+    (\x _ -> expectExprEqualWithMessage "" (f x) (f expected))
+    enc