Revert "Test that Consensus emits valid CBOR" (#362)

This reverts commit f8426b2 from #323. These tests turned out to be flaky, see eg [here](https://github.com/input-output-hk/ouroboros-consensus/actions/runs/6252676869/job/16976447179?pr=354#step:15:1589).
IntersectMBO · Sep 25, 2023 · 2a30527 · 2a30527
2 parents f743b8f + d0cfb91
commit 2a30527
Show file tree

Hide file tree

Showing 9 changed files with 25 additions and 142 deletions.
diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml
@@ -25,7 +25,7 @@ jobs:
          os: [ubuntu-latest]
     env:
       # Modify this value to "invalidate" the Cabal cache.
-      CABAL_CACHE_VERSION: "2023-09-04"
+      CABAL_CACHE_VERSION: "2023-09-25"
 
     steps:
     - uses: actions/checkout@v4

diff --git a/cabal.project b/cabal.project
@@ -31,11 +31,3 @@ tests: true
 benchmarks: true
 
 import: ./asserts.cabal
-
--- This can be removed once this fix is released https://github.com/well-typed/cborg/pull/325
-source-repository-package
-  type: git
-  location: https://github.com/well-typed/cborg.git
-  tag: c8013b3474d876f4da56c869d57e3f3ac7f42dc6
-  --sha256: 1rahq47qm977fawkq3d3718bz7fvd7hvy0s9qnbhlzafkqhqnqzj
-  subdir: cborg
diff --git a/ouroboros-consensus-cardano/test/byron-test/Test/Consensus/Byron/Serialisation.hs b/ouroboros-consensus-cardano/test/byron-test/Test/Consensus/Byron/Serialisation.hs
@@ -38,7 +38,9 @@ import           Test.Util.Serialisation.Roundtrip
 tests :: TestTree
 tests = testGroup "Byron"
     [ roundtrip_all testCodecCfg dictNestedHdr
+
     , testProperty "BinaryBlockInfo sanity check" prop_byronBinaryBlockInfo
+
     , testGroup "Integrity"
         [ testProperty "detect corruption in RegularBlock" prop_detectCorruption_RegularBlock
         ]

diff --git a/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/Serialisation.hs b/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/Serialisation.hs
@@ -1,5 +1,4 @@
 {-# LANGUAGE EmptyCase           #-}
-{-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE GADTs               #-}
 {-# LANGUAGE LambdaCase          #-}
 {-# LANGUAGE NamedFieldPuns      #-}
@@ -20,18 +19,16 @@ import           Ouroboros.Consensus.Shelley.Node ()
 import           Ouroboros.Consensus.Storage.Serialisation
 import           Ouroboros.Consensus.Util (Dict (..))
 import           Ouroboros.Network.Block (Serialised (..))
-import qualified Test.Consensus.Cardano.Examples as Cardano.Examples
 import           Test.Consensus.Cardano.Generators (epochSlots)
 import           Test.Consensus.Cardano.MockCrypto (MockCryptoCompatByron)
 import           Test.Tasty
-import           Test.Tasty.QuickCheck (Property, testProperty, (===))
+import           Test.Tasty.QuickCheck
 import           Test.Util.Orphans.Arbitrary ()
 import           Test.Util.Serialisation.Roundtrip
 
 tests :: TestTree
 tests = testGroup "Cardano"
-    [ testGroup "Examples roundtrip" $ examplesRoundtrip Cardano.Examples.codecConfig Cardano.Examples.examples
-    , roundtrip_all testCodecCfg dictNestedHdr
+    [ roundtrip_all testCodecCfg dictNestedHdr
     , testProperty "BinaryBlockInfo sanity check" prop_CardanoBinaryBlockInfo
     ]
 

diff --git a/ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/Serialisation.hs b/ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/Serialisation.hs
@@ -30,10 +30,13 @@ import           Test.Util.Serialisation.Roundtrip
 tests :: TestTree
 tests = testGroup "Shelley"
     [ roundtrip_all testCodecCfg dictNestedHdr
+
       -- Test for real crypto too
     , testProperty "hashSize real crypto"       $ prop_hashSize pReal
     , testProperty "ConvertRawHash real crypto" $ roundtrip_ConvertRawHash pReal
+
     , testProperty "BinaryBlockInfo sanity check" prop_shelleyBinaryBlockInfo
+
     , testGroup "Integrity"
         [ testProperty "generate non-corrupt blocks"  prop_blockIntegrity
         , testProperty "generate non-corrupt headers" prop_headerIntegrity

diff --git a/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/BFT.hs b/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/BFT.hs
@@ -28,6 +28,7 @@ import           Test.ThreadNet.Util.SimpleBlock
 import           Test.Util.HardFork.Future (singleEraFuture)
 import           Test.Util.Orphans.Arbitrary ()
 import           Test.Util.Serialisation.Roundtrip
+import           Test.Util.Serialisation.SomeResult ()
 
 data TestSetup = TestSetup
   { setupK            :: SecurityParam

diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal
@@ -351,7 +351,6 @@ library unstable-consensus-testlib
     , ouroboros-consensus
     , ouroboros-network-api
     , ouroboros-network-mock
-    , pretty-simple
     , QuickCheck
     , quickcheck-state-machine
     , quiet
@@ -361,11 +360,9 @@ library unstable-consensus-testlib
     , sop-extras
     , strict-sop-core
     , tasty
-    , tasty-expected-failure
     , tasty-golden
     , tasty-quickcheck
     , template-haskell
-    , text
     , time
     , tree-diff
     , utf8-string

diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/Golden.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/Golden.hs
@@ -1,10 +1,14 @@
 {-# LANGUAGE DefaultSignatures   #-}
+{-# LANGUAGE DeriveAnyClass      #-}
+{-# LANGUAGE DeriveGeneric       #-}
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE FlexibleInstances   #-}
+{-# LANGUAGE LambdaCase          #-}
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE RankNTypes          #-}
 {-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving  #-}
 {-# LANGUAGE TypeApplications    #-}
 
 {-# OPTIONS_GHC -Wno-orphans #-}

diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/Roundtrip.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/Roundtrip.hs
@@ -28,39 +28,27 @@ module Test.Util.Serialisation.Roundtrip (
   , roundtrip_SerialiseNodeToNode
   , roundtrip_all
   , roundtrip_envelopes
-    -- * Roundtrip tests for 'Example's
-  , examplesRoundtrip
   ) where
 
 import           Codec.CBOR.Decoding (Decoder)
 import           Codec.CBOR.Encoding (Encoding)
-import           Codec.CBOR.FlatTerm (toFlatTerm, validFlatTerm)
-import           Codec.CBOR.Read (DeserialiseFailure, deserialiseFromBytes)
+import           Codec.CBOR.Read (deserialiseFromBytes)
 import           Codec.CBOR.Write (toLazyByteString)
-import           Codec.Serialise (decode, encode)
-import           Control.Arrow (left)
-import           Control.Monad (unless)
 import qualified Data.ByteString.Base16.Lazy as Base16
 import qualified Data.ByteString.Lazy as Lazy
 import qualified Data.ByteString.Lazy.Char8 as Char8
 import qualified Data.ByteString.Short as Short
 import           Data.Function (on)
-import           Data.Maybe (fromMaybe)
-import qualified Data.Text.Lazy as T
 import           Data.Typeable
 import           GHC.Generics (Generic)
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.HeaderValidation (AnnTip)
 import           Ouroboros.Consensus.Ledger.Abstract (LedgerState)
-import           Ouroboros.Consensus.Ledger.Extended (ExtLedgerState,
-                     decodeExtLedgerState, encodeExtLedgerState)
 import           Ouroboros.Consensus.Ledger.Query (BlockQuery, Query (..),
                      QueryVersion)
 import qualified Ouroboros.Consensus.Ledger.Query as Query
 import           Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr, GenTx,
                      GenTxId)
-import           Ouroboros.Consensus.Ledger.SupportsProtocol
-                     (LedgerSupportsProtocol)
 import           Ouroboros.Consensus.Node.NetworkProtocolVersion
 import           Ouroboros.Consensus.Node.Run (SerialiseNodeToClientConstraints,
                      SerialiseNodeToNodeConstraints (..))
@@ -73,12 +61,9 @@ import           Ouroboros.Network.Block (Serialised (..), fromSerialised,
                      mkSerialised)
 import           Quiet (Quiet (..))
 import           Test.Tasty
-import           Test.Tasty.ExpectedFailure (expectFailBecause)
 import           Test.Tasty.QuickCheck
 import           Test.Util.Orphans.Arbitrary ()
-import           Test.Util.Serialisation.Examples (Examples (..), Labelled)
 import           Test.Util.Serialisation.SomeResult (SomeResult (..))
-import           Text.Pretty.Simple (pShow)
 
 {------------------------------------------------------------------------------
   Basic test helpers
@@ -93,75 +78,31 @@ roundtrip enc dec = roundtrip' enc (const <$> dec)
 
 -- | Roundtrip property for values annotated with their serialized form
 --
--- In addition, we check that the encoded CBOR is valid using 'validFlatTerm'.
---
--- We check the roundtrip property both by decoding from a 'FlatTerm' directly, and from a bytestring.
---
--- Decoding from a 'FlatTerm' has the advantage that it allows to
--- catch bugs more
--- [easily](https://hackage.haskell.org/package/cborg-0.2.9.0/docs/Codec-CBOR-FlatTerm.html):
---
---     The FlatTerm form is very simple and internally mirrors the
---     original Encoding type very carefully. The intention here
---     is that once you have Encoding and Decoding values for your
---     types, you can round-trip values through FlatTerm to catch
---     bugs more easily and with a smaller amount of code to look
---     through.
---
--- We also check 'ByteString' decoding for extra assurance.
---
 -- NOTE: Suppose @a@ consists of a pair of the unannotated value @a'@ and some
 -- 'Lazy.ByteString'. The roundtrip property will fail if that
 -- 'Lazy.ByteString' encoding is not equal to @enc a'@. One way in which this
 -- might happen is if the annotation is not canonical CBOR, but @enc@ does
 -- produce canonical CBOR.
-roundtrip' :: forall a.
-              (Eq a, Show a)
+roundtrip' :: (Eq a, Show a)
            => (a -> Encoding)  -- ^ @enc@
            -> (forall s. Decoder s (Lazy.ByteString -> a))
            -> a
            -> Property
-roundtrip' enc dec a = checkRoundtripResult $ do
-    let enc_a = enc a
-        bs    = toLazyByteString enc_a
-        flatTerm_a = toFlatTerm enc_a
-
-    validFlatTerm flatTerm_a                     ?! "Encoded flat term is not valid: " <> show enc_a
-    -- TODO: the decode test via FlatTerm will currently fail because https://github.com/input-output-hk/cardano-ledger/issues/3741
-    --
-    -- a' <- fromFlatTerm dec flatTerm_a
-    -- a == a' bs                                   ?! pShowNeq a (a' bs)
-    (bsRem, a'' ) <- deserialiseFromBytes dec bs `onError` showByteString bs
-    Lazy.null bsRem                              ?! "Left-over bytes: " <> toBase16 bsRem
-    a == a'' bs                                  ?! pShowNeq a (a'' bs)
+roundtrip' enc dec a = case deserialiseFromBytes dec bs of
+    Right (bs', a')
+      | Lazy.null bs'
+      -> a === a' bs
+      | otherwise
+      -> counterexample ("left-over bytes: " <> toBase16 bs') False
+    Left e
+      -> counterexample (show e) $
+         counterexample (toBase16 bs) False
   where
-    (?!) :: Bool -> String -> Either String ()
-    cond ?! msg = unless cond $ Left msg
-    infix 1 ?!
-
-    pShowNeq x y = T.unpack (pShow x) <> "\n \t/= \n"  <> T.unpack (pShow y)
-
-    onError ::
-          Either DeserialiseFailure (Char8.ByteString, Char8.ByteString -> a)
-      -> (DeserialiseFailure -> String)
-      -> Either String (Char8.ByteString, Char8.ByteString -> a)
-    onError result showDeserialiseFailure =
-      left showDeserialiseFailure result
-
-    showByteString ::
-         Char8.ByteString
-      -> DeserialiseFailure
-      -> String
-    showByteString bs deserialiseFailure =
-      show deserialiseFailure <> "\n" <> "When deserialising " <> toBase16 bs
+    bs = toLazyByteString (enc a)
 
     toBase16 :: Lazy.ByteString -> String
     toBase16 = Char8.unpack . Base16.encode
 
-    checkRoundtripResult :: Either String () -> Property
-    checkRoundtripResult (Left str) = counterexample str False
-    checkRoundtripResult (Right ()) = property ()
-
 {------------------------------------------------------------------------------
   Test skeleton
 ------------------------------------------------------------------------------}
@@ -651,57 +592,3 @@ decodeThroughSerialised
 decodeThroughSerialised dec decSerialised = do
     serialised <- decSerialised
     fromSerialised dec serialised
-
-{------------------------------------------------------------------------------
-  Roundtrip tests for examples
-------------------------------------------------------------------------------}
-
-examplesRoundtrip ::
-     forall blk . (SerialiseDiskConstraints blk, Eq blk, Show blk, LedgerSupportsProtocol blk)
-  => CodecConfig blk
-  -> Examples blk
-  -> [TestTree]
-examplesRoundtrip codecConfig examples =
-    [ testRoundtripFor "Block"                 (encodeDisk codecConfig) (decodeDisk codecConfig)           exampleBlock
-    , testRoundtripFor "Header hash"           encode                   (const <$> decode)                 exampleHeaderHash
-    , testRoundtripFor "Ledger state"          (encodeDisk codecConfig) (const <$> decodeDisk codecConfig) exampleLedgerState
-    , testRoundtripFor "Annotated tip"         (encodeDisk codecConfig) (const <$> decodeDisk codecConfig) exampleAnnTip
-    , testRoundtripFor "Chain dependent state" (encodeDisk codecConfig) (const <$> decodeDisk codecConfig) exampleChainDepState
-    , testRoundtripFor "Extended ledger state" encodeExt                (const <$> decodeExt)              exampleExtLedgerState
-    ]
-  where
-    testRoundtripFor ::
-         forall a . (Eq a, Show a)
-      => String
-      -> (a -> Encoding)
-      -> (forall s . Decoder s (Char8.ByteString -> a))
-      -> (Examples blk -> Labelled a)
-      -> TestTree
-    testRoundtripFor testLabel enc dec field =
-        testGroup testLabel
-          [ mkTest exampleName example
-          | (exampleName, example) <- field examples
-          ]
-      where
-        mkTest exampleName example =
-          let
-            runTest = testProperty (fromMaybe "" exampleName) $ once $ roundtrip' enc dec example
-            _3740   = "https://github.com/input-output-hk/cardano-ledger/issues/3740"
-          in
-          case (testLabel, exampleName) of
-            ("Ledger state"         , Just "Conway") -> expectFailBecause _3740 $ runTest
-            ("Extended ledger state", Just "Conway") -> expectFailBecause _3740 $ runTest
-            _                                        ->                           runTest
-
-    encodeExt =
-      encodeExtLedgerState
-        (encodeDisk codecConfig)
-        (encodeDisk codecConfig)
-        (encodeDisk codecConfig)
-
-    decodeExt :: forall s. Decoder s (ExtLedgerState blk)
-    decodeExt =
-      decodeExtLedgerState
-        (decodeDisk codecConfig)
-        (decodeDisk codecConfig)
-        (decodeDisk codecConfig)