diff --git a/cabal.project b/cabal.project index 8e7e107719..9b4e2e44ab 100644 --- a/cabal.project +++ b/cabal.project @@ -31,3 +31,11 @@ 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/src/unstable-byron-testlib/Test/Consensus/Byron/Examples.hs b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Test/Consensus/Byron/Examples.hs index 3260b941a6..2447bdfb10 100644 --- a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Test/Consensus/Byron/Examples.hs +++ b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Test/Consensus/Byron/Examples.hs @@ -48,9 +48,10 @@ import qualified Test.Cardano.Chain.Genesis.Dummy as CC import qualified Test.Cardano.Chain.Update.Example as CC import qualified Test.Cardano.Chain.UTxO.Example as CC import Test.ThreadNet.Infra.Byron.ProtocolInfo (mkLeaderCredentials) -import qualified Test.Util.Serialisation.Golden as Golden -import Test.Util.Serialisation.Golden (Labelled, labelled, unlabelled) -import Test.Util.Serialisation.Roundtrip (SomeResult (..)) +import qualified Test.Util.Serialisation.Examples as Examples +import Test.Util.Serialisation.Examples (Examples (Examples), + Labelled, labelled, unlabelled) +import Test.Util.Serialisation.SomeResult (SomeResult (..)) {------------------------------------------------------------------------------- Setup @@ -89,8 +90,8 @@ leaderCredentials = Examples -------------------------------------------------------------------------------} -examples :: Golden.Examples ByronBlock -examples = Golden.Examples { +examples :: Examples ByronBlock +examples = Examples { exampleBlock = regularAndEBB exampleBlock exampleEBB , exampleSerialisedBlock = regularAndEBB exampleSerialisedBlock exampleSerialisedEBB , exampleHeader = regularAndEBB exampleHeader exampleEBBHeader diff --git a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Test/Consensus/Byron/Generators.hs b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Test/Consensus/Byron/Generators.hs index b1d0f32ff1..ac2d1a687d 100644 --- a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Test/Consensus/Byron/Generators.hs +++ b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Test/Consensus/Byron/Generators.hs @@ -56,7 +56,8 @@ import Test.QuickCheck hiding (Result) import Test.QuickCheck.Hedgehog (hedgehog) import Test.Util.Orphans.Arbitrary () import Test.Util.Serialisation.Roundtrip (Coherent (..), - SomeResult (..), WithVersion (..)) + WithVersion (..)) +import Test.Util.Serialisation.SomeResult (SomeResult (..)) {------------------------------------------------------------------------------- Generators diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/Examples.hs b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/Examples.hs index 4e03104eee..4f1806c15a 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/Examples.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/Examples.hs @@ -49,9 +49,9 @@ import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Network.Block (Serialised (..)) import qualified Test.Consensus.Byron.Examples as Byron import qualified Test.Consensus.Shelley.Examples as Shelley -import qualified Test.Util.Serialisation.Golden as Golden -import Test.Util.Serialisation.Golden (Examples, Labelled, labelled) -import Test.Util.Serialisation.Roundtrip (SomeResult (..)) +import Test.Util.Serialisation.Examples (Examples (..), Labelled, + labelled, prefixExamples) +import Test.Util.Serialisation.SomeResult (SomeResult (..)) type Crypto = StandardCrypto @@ -91,7 +91,7 @@ combineEras = mconcat . hcollapse . hap eraInjections -> Examples blk -> Examples (CardanoBlock Crypto) injExamples eraName idx = - Golden.prefixExamples eraName + prefixExamples eraName . inject exampleStartBounds idx {------------------------------------------------------------------------------- @@ -108,7 +108,7 @@ instance Inject SomeResult where SomeResult (QueryIfCurrent (injectQuery idx q)) (Right r) instance Inject Examples where - inject startBounds (idx :: Index xs x) Golden.Examples {..} = Golden.Examples { + inject startBounds (idx :: Index xs x) Examples {..} = Examples { exampleBlock = inj (Proxy @I) exampleBlock , exampleSerialisedBlock = inj (Proxy @Serialised) exampleSerialisedBlock , exampleHeader = inj (Proxy @Header) exampleHeader @@ -240,7 +240,7 @@ summary = (State.TransitionKnown shelleyTransitionEpoch) (hardForkLedgerStatePerEra (ledgerStateByron byronLedger)) where - (_, byronLedger) = head $ Golden.exampleLedgerState Byron.examples + (_, byronLedger) = head $ exampleLedgerState Byron.examples eraInfoByron :: SingleEraInfo ByronBlock eraInfoByron = singleEraInfo (Proxy @ByronBlock) @@ -277,16 +277,16 @@ ledgerStateByron stByron = -- | Multi-era examples, e.g., applying a transaction to the wrong era. multiEraExamples :: Examples (CardanoBlock Crypto) multiEraExamples = mempty { - Golden.exampleApplyTxErr = labelled [ + exampleApplyTxErr = labelled [ ("WrongEraByron", exampleApplyTxErrWrongEraByron) , ("WrongEraShelley", exampleApplyTxErrWrongEraShelley) ] - , Golden.exampleQuery = labelled [ + , exampleQuery = labelled [ ("AnytimeByron", exampleQueryAnytimeByron) , ("AnytimeShelley", exampleQueryAnytimeShelley) , ("HardFork", exampleQueryHardFork) ] - , Golden.exampleResult = labelled [ + , exampleResult = labelled [ ("EraMismatchByron", exampleResultEraMismatchByron) , ("EraMismatchShelley", exampleResultEraMismatchShelley) , ("AnytimeByron", exampleResultAnytimeByron) diff --git a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs index 7c48796591..e3f9adc50c 100644 --- a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs +++ b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs @@ -59,9 +59,9 @@ import Test.Cardano.Ledger.Shelley.Examples.Consensus (ShelleyLedgerExamples (..), ShelleyResultExamples (..), ledgerExamplesShelley, testShelleyGenesis) import Test.Util.Orphans.Arbitrary () -import qualified Test.Util.Serialisation.Golden as Golden -import Test.Util.Serialisation.Golden (labelled, unlabelled) -import Test.Util.Serialisation.Roundtrip (SomeResult (..)) +import Test.Util.Serialisation.Examples (Examples (..), labelled, + unlabelled) +import Test.Util.Serialisation.SomeResult (SomeResult (..)) {------------------------------------------------------------------------------- @@ -74,11 +74,11 @@ codecConfig = ShelleyCodecConfig fromShelleyLedgerExamples :: ShelleyCompatible (TPraos (EraCrypto era)) era => ShelleyLedgerExamples era - -> Golden.Examples (ShelleyBlock (TPraos (EraCrypto era)) era) + -> Examples (ShelleyBlock (TPraos (EraCrypto era)) era) fromShelleyLedgerExamples ShelleyLedgerExamples { sleResultExamples = ShelleyResultExamples{..} , ..} = - Golden.Examples { + Examples { exampleBlock = unlabelled blk , exampleSerialisedBlock = unlabelled serialisedBlock , exampleHeader = unlabelled $ getHeader blk @@ -148,11 +148,11 @@ fromShelleyLedgerExamplesPraos :: TranslateProto (TPraos (EraCrypto era)) (Praos (EraCrypto era)) ) => ShelleyLedgerExamples era - -> Golden.Examples (ShelleyBlock (Praos (EraCrypto era)) era) + -> Examples (ShelleyBlock (Praos (EraCrypto era)) era) fromShelleyLedgerExamplesPraos ShelleyLedgerExamples { sleResultExamples = ShelleyResultExamples{..} , ..} = - Golden.Examples { + Examples { exampleBlock = unlabelled blk , exampleSerialisedBlock = unlabelled serialisedBlock , exampleHeader = unlabelled $ getHeader blk @@ -237,20 +237,20 @@ fromShelleyLedgerExamplesPraos ShelleyLedgerExamples { -examplesShelley :: Golden.Examples StandardShelleyBlock +examplesShelley :: Examples StandardShelleyBlock examplesShelley = fromShelleyLedgerExamples ledgerExamplesShelley -examplesAllegra :: Golden.Examples StandardAllegraBlock +examplesAllegra :: Examples StandardAllegraBlock examplesAllegra = fromShelleyLedgerExamples ledgerExamplesAllegra -examplesMary :: Golden.Examples StandardMaryBlock +examplesMary :: Examples StandardMaryBlock examplesMary = fromShelleyLedgerExamples ledgerExamplesMary -examplesAlonzo :: Golden.Examples StandardAlonzoBlock +examplesAlonzo :: Examples StandardAlonzoBlock examplesAlonzo = fromShelleyLedgerExamples ledgerExamplesAlonzo -examplesBabbage :: Golden.Examples StandardBabbageBlock +examplesBabbage :: Examples StandardBabbageBlock examplesBabbage = fromShelleyLedgerExamplesPraos ledgerExamplesBabbage -examplesConway :: Golden.Examples StandardConwayBlock +examplesConway :: Examples StandardConwayBlock examplesConway = fromShelleyLedgerExamplesPraos ledgerExamplesConway diff --git a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Generators.hs b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Generators.hs index 8d3c5d74b2..789d8ba822 100644 --- a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Generators.hs +++ b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Generators.hs @@ -50,7 +50,8 @@ import Test.Consensus.Shelley.MockCrypto (CanMock) import Test.QuickCheck hiding (Result) import Test.Util.Orphans.Arbitrary () import Test.Util.Serialisation.Roundtrip (Coherent (..), - SomeResult (..), WithVersion (..)) + WithVersion (..)) +import Test.Util.Serialisation.SomeResult (SomeResult (..)) {------------------------------------------------------------------------------- Generators 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 index 3e11194508..592fb3da7b 100644 --- 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,9 +38,7 @@ 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/ByronCompatibility.hs b/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/ByronCompatibility.hs index 3bdfc75266..4bfd5c937f 100644 --- a/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/ByronCompatibility.hs +++ b/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/ByronCompatibility.hs @@ -48,6 +48,7 @@ import Test.Tasty import Test.Tasty.QuickCheck import Test.Util.Orphans.Arbitrary () import Test.Util.Serialisation.Roundtrip +import Test.Util.Serialisation.SomeResult (SomeResult (..)) tests :: TestTree tests = adjustOption reduceTests $ 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 index 66b60ec6cb..139daeb85f 100644 --- 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,4 +1,5 @@ {-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} @@ -19,16 +20,18 @@ 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 +import Test.Tasty.QuickCheck (Property, testProperty, (===)) import Test.Util.Orphans.Arbitrary () import Test.Util.Serialisation.Roundtrip tests :: TestTree tests = testGroup "Cardano" - [ roundtrip_all testCodecCfg dictNestedHdr + [ testGroup "Examples roundtrip" $ examplesRoundtrip Cardano.Examples.codecConfig Cardano.Examples.examples + , 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 index ecb7e79bd7..c258446e2d 100644 --- 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,13 +30,10 @@ 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/src/unstable-mock-testlib/Test/Consensus/Ledger/Mock/Generators.hs b/ouroboros-consensus-diffusion/src/unstable-mock-testlib/Test/Consensus/Ledger/Mock/Generators.hs index 8040b1cd22..d73a4f53d0 100644 --- a/ouroboros-consensus-diffusion/src/unstable-mock-testlib/Test/Consensus/Ledger/Mock/Generators.hs +++ b/ouroboros-consensus-diffusion/src/unstable-mock-testlib/Test/Consensus/Ledger/Mock/Generators.hs @@ -31,6 +31,7 @@ import Ouroboros.Consensus.Protocol.BFT import Test.QuickCheck import Test.Util.Orphans.Arbitrary () import Test.Util.Serialisation.Roundtrip +import Test.Util.Serialisation.SomeResult (SomeResult (..)) {------------------------------------------------------------------------------- General instances diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index 722717d278..5d7e4026d2 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -309,8 +309,10 @@ library unstable-consensus-testlib Test.Util.Range Test.Util.RefEnv Test.Util.Schedule + Test.Util.Serialisation.Examples Test.Util.Serialisation.Golden Test.Util.Serialisation.Roundtrip + Test.Util.Serialisation.SomeResult Test.Util.Shrink Test.Util.Slots Test.Util.SOP @@ -349,6 +351,7 @@ library unstable-consensus-testlib , ouroboros-consensus , ouroboros-network-api , ouroboros-network-mock + , pretty-simple , QuickCheck , quickcheck-state-machine , quiet @@ -358,9 +361,11 @@ 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/Examples.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/Examples.hs new file mode 100644 index 0000000000..85384dc26f --- /dev/null +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/Examples.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Util.Serialisation.Examples ( + -- * Examples + Examples (..) + -- ** Operations on examples + , combineExamples + , mapExamples + , prefixExamples + -- * Labelling + , Labelled + , labelled + , unlabelled + ) where + +import Data.Bifunctor (first) +import Ouroboros.Consensus.Block (BlockProtocol, Header, HeaderHash, + SlotNo, SomeSecond) +import Ouroboros.Consensus.HeaderValidation (AnnTip) +import Ouroboros.Consensus.Ledger.Abstract (LedgerState) +import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState) +import Ouroboros.Consensus.Ledger.Query (BlockQuery) +import Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr, GenTx, + GenTxId) +import Ouroboros.Consensus.Protocol.Abstract (ChainDepState) +import Ouroboros.Consensus.Storage.Serialisation (SerialisedHeader) +import Ouroboros.Network.Block (Serialised) +import Test.Util.Serialisation.SomeResult (SomeResult (..)) + +{------------------------------------------------------------------------------- + Examples +-------------------------------------------------------------------------------} + +data Examples blk = Examples { + exampleBlock :: Labelled blk + , exampleSerialisedBlock :: Labelled (Serialised blk) + , exampleHeader :: Labelled (Header blk) + , exampleSerialisedHeader :: Labelled (SerialisedHeader blk) + , exampleHeaderHash :: Labelled (HeaderHash blk) + , exampleGenTx :: Labelled (GenTx blk) + , exampleGenTxId :: Labelled (GenTxId blk) + , exampleApplyTxErr :: Labelled (ApplyTxErr blk) + , exampleQuery :: Labelled (SomeSecond BlockQuery blk) + , exampleResult :: Labelled (SomeResult blk) + , exampleAnnTip :: Labelled (AnnTip blk) + , exampleLedgerState :: Labelled (LedgerState blk) + , exampleChainDepState :: Labelled (ChainDepState (BlockProtocol blk)) + , exampleExtLedgerState :: Labelled (ExtLedgerState blk) + , exampleSlotNo :: Labelled SlotNo + } + +emptyExamples :: Examples blk +emptyExamples = Examples { + exampleBlock = mempty + , exampleSerialisedBlock = mempty + , exampleHeader = mempty + , exampleSerialisedHeader = mempty + , exampleHeaderHash = mempty + , exampleGenTx = mempty + , exampleGenTxId = mempty + , exampleApplyTxErr = mempty + , exampleQuery = mempty + , exampleResult = mempty + , exampleAnnTip = mempty + , exampleLedgerState = mempty + , exampleChainDepState = mempty + , exampleExtLedgerState = mempty + , exampleSlotNo = mempty + } + +combineExamples :: + forall blk. + (forall a. Labelled a -> Labelled a -> Labelled a) + -> Examples blk + -> Examples blk + -> Examples blk +combineExamples f e1 e2 = Examples { + exampleBlock = combine exampleBlock + , exampleSerialisedBlock = combine exampleSerialisedBlock + , exampleHeader = combine exampleHeader + , exampleSerialisedHeader = combine exampleSerialisedHeader + , exampleHeaderHash = combine exampleHeaderHash + , exampleGenTx = combine exampleGenTx + , exampleGenTxId = combine exampleGenTxId + , exampleApplyTxErr = combine exampleApplyTxErr + , exampleQuery = combine exampleQuery + , exampleResult = combine exampleResult + , exampleAnnTip = combine exampleAnnTip + , exampleLedgerState = combine exampleLedgerState + , exampleChainDepState = combine exampleChainDepState + , exampleExtLedgerState = combine exampleExtLedgerState + , exampleSlotNo = combine exampleSlotNo + } + where + combine :: (Examples blk -> Labelled a) -> Labelled a + combine getField = f (getField e1) (getField e2) + +instance Semigroup (Examples blk) where + (<>) = combineExamples (<>) + +instance Monoid (Examples blk) where + mempty = emptyExamples + mappend = (<>) + +mapExamples :: + forall blk. + (forall a. Labelled a -> Labelled a) + -> Examples blk + -> Examples blk +mapExamples f = combineExamples (const f) mempty + +-- | Add the given prefix to each labelled example. +-- +-- When a label is empty, the prefix is used as the label. If the label is not +-- empty, the prefix and @_@ are prepended. +prefixExamples :: String -> Examples blk -> Examples blk +prefixExamples prefix = mapExamples addPrefix + where + addPrefix :: Labelled a -> Labelled a + addPrefix l = [ + (Just label, x) + | (mbLabel, x) <- l + , let label = case mbLabel of + Nothing -> prefix + Just lbl -> prefix <> "_" <> lbl + ] + +{------------------------------------------------------------------------------- + Labelling +-------------------------------------------------------------------------------} + +type Labelled a = [(Maybe String, a)] + +unlabelled :: a -> Labelled a +unlabelled x = [(Nothing, x)] + +labelled :: [(String, a)] -> Labelled a +labelled = map (first Just) 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 index 8c95114496..43ff13acc6 100644 --- 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,14 +1,10 @@ {-# 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 #-} @@ -30,18 +26,11 @@ -- In particular, if we introduce golden tests in new suites, we need to add -- a line in the nix configuration above similar to the previous ones. module Test.Util.Serialisation.Golden ( - Examples (..) - , Labelled - , ToGoldenDirectory (..) - , combineExamples + ToGoldenDirectory (..) , goldenTest_SerialiseDisk , goldenTest_SerialiseNodeToClient , goldenTest_SerialiseNodeToNode , goldenTest_all - , labelled - , mapExamples - , prefixExamples - , unlabelled ) where import Cardano.Prelude (forceElemsToWHNF) @@ -58,16 +47,10 @@ import Data.List (nub) import qualified Data.Map.Strict as Map import Data.Proxy (Proxy (..)) import GHC.Stack (HasCallStack) -import Ouroboros.Consensus.Block (BlockProtocol, CodecConfig, Header, - HeaderHash, SlotNo, SomeSecond) -import Ouroboros.Consensus.HeaderValidation (AnnTip) -import Ouroboros.Consensus.Ledger.Abstract (LedgerState) -import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState, - encodeExtLedgerState) -import Ouroboros.Consensus.Ledger.Query (BlockQuery, QueryVersion, +import Ouroboros.Consensus.Block (CodecConfig) +import Ouroboros.Consensus.Ledger.Extended (encodeExtLedgerState) +import Ouroboros.Consensus.Ledger.Query (QueryVersion, nodeToClientVersionToQueryVersion) -import Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr, GenTx, - GenTxId) import Ouroboros.Consensus.Node.NetworkProtocolVersion (HasNetworkProtocolVersion (..), SupportedNetworkProtocolVersion (..)) @@ -77,18 +60,16 @@ import Ouroboros.Consensus.Node.Run (SerialiseDiskConstraints, import Ouroboros.Consensus.Node.Serialisation (SerialiseNodeToClient (..), SerialiseNodeToNode (..), SerialiseResult (..)) -import Ouroboros.Consensus.Protocol.Abstract (ChainDepState) -import Ouroboros.Consensus.Storage.Serialisation (EncodeDisk (..), - SerialisedHeader) +import Ouroboros.Consensus.Storage.Serialisation (EncodeDisk (..)) import Ouroboros.Consensus.Util.CBOR (decodeAsFlatTerm) import Ouroboros.Consensus.Util.Condense (Condense (..)) -import Ouroboros.Network.Block (Serialised) import System.Directory (createDirectoryIfMissing) import System.FilePath (takeDirectory, ()) import Test.Cardano.Ledger.Binary.TreeDiff (CBORBytes (..), diffExpr) import Test.Tasty import Test.Tasty.Golden.Advanced (goldenTest) -import Test.Util.Serialisation.Roundtrip (SomeResult (..)) +import Test.Util.Serialisation.Examples (Examples (..), Labelled) +import Test.Util.Serialisation.SomeResult (SomeResult (..)) {------------------------------------------------------------------------------- Golden test @@ -204,112 +185,6 @@ goldenTests testName examples enc goldenFolder labels :: [Maybe String] labels = map fst examples -{------------------------------------------------------------------------------- - Examples --------------------------------------------------------------------------------} - -type Labelled a = [(Maybe String, a)] - -unlabelled :: a -> Labelled a -unlabelled x = [(Nothing, x)] - -labelled :: [(String, a)] -> Labelled a -labelled = map (first Just) - -data Examples blk = Examples { - exampleBlock :: Labelled blk - , exampleSerialisedBlock :: Labelled (Serialised blk) - , exampleHeader :: Labelled (Header blk) - , exampleSerialisedHeader :: Labelled (SerialisedHeader blk) - , exampleHeaderHash :: Labelled (HeaderHash blk) - , exampleGenTx :: Labelled (GenTx blk) - , exampleGenTxId :: Labelled (GenTxId blk) - , exampleApplyTxErr :: Labelled (ApplyTxErr blk) - , exampleQuery :: Labelled (SomeSecond BlockQuery blk) - , exampleResult :: Labelled (SomeResult blk) - , exampleAnnTip :: Labelled (AnnTip blk) - , exampleLedgerState :: Labelled (LedgerState blk) - , exampleChainDepState :: Labelled (ChainDepState (BlockProtocol blk)) - , exampleExtLedgerState :: Labelled (ExtLedgerState blk) - , exampleSlotNo :: Labelled SlotNo - } - -emptyExamples :: Examples blk -emptyExamples = Examples { - exampleBlock = mempty - , exampleSerialisedBlock = mempty - , exampleHeader = mempty - , exampleSerialisedHeader = mempty - , exampleHeaderHash = mempty - , exampleGenTx = mempty - , exampleGenTxId = mempty - , exampleApplyTxErr = mempty - , exampleQuery = mempty - , exampleResult = mempty - , exampleAnnTip = mempty - , exampleLedgerState = mempty - , exampleChainDepState = mempty - , exampleExtLedgerState = mempty - , exampleSlotNo = mempty - } - -combineExamples :: - forall blk. - (forall a. Labelled a -> Labelled a -> Labelled a) - -> Examples blk - -> Examples blk - -> Examples blk -combineExamples f e1 e2 = Examples { - exampleBlock = combine exampleBlock - , exampleSerialisedBlock = combine exampleSerialisedBlock - , exampleHeader = combine exampleHeader - , exampleSerialisedHeader = combine exampleSerialisedHeader - , exampleHeaderHash = combine exampleHeaderHash - , exampleGenTx = combine exampleGenTx - , exampleGenTxId = combine exampleGenTxId - , exampleApplyTxErr = combine exampleApplyTxErr - , exampleQuery = combine exampleQuery - , exampleResult = combine exampleResult - , exampleAnnTip = combine exampleAnnTip - , exampleLedgerState = combine exampleLedgerState - , exampleChainDepState = combine exampleChainDepState - , exampleExtLedgerState = combine exampleExtLedgerState - , exampleSlotNo = combine exampleSlotNo - } - where - combine :: (Examples blk -> Labelled a) -> Labelled a - combine getField = f (getField e1) (getField e2) - -instance Semigroup (Examples blk) where - (<>) = combineExamples (<>) - -instance Monoid (Examples blk) where - mempty = emptyExamples - mappend = (<>) - -mapExamples :: - forall blk. - (forall a. Labelled a -> Labelled a) - -> Examples blk - -> Examples blk -mapExamples f = combineExamples (const f) mempty - --- | Add the given prefix to each labelled example. --- --- When a label is empty, the prefix is used as the label. If the label is not --- empty, the prefix and @_@ are prepended. -prefixExamples :: String -> Examples blk -> Examples blk -prefixExamples prefix = mapExamples addPrefix - where - addPrefix :: Labelled a -> Labelled a - addPrefix l = [ - (Just label, x) - | (mbLabel, x) <- l - , let label = case mbLabel of - Nothing -> prefix - Just lbl -> prefix <> "_" <> lbl - ] - {------------------------------------------------------------------------------- Skeletons -------------------------------------------------------------------------------} 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 index d3d0f24b55..01a08f63b1 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/Roundtrip.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/Roundtrip.hs @@ -20,7 +20,6 @@ module Test.Util.Serialisation.Roundtrip ( -- * Test skeleton , Arbitrary' , Coherent (..) - , SomeResult (..) , WithVersion (..) , prop_hashSize , roundtrip_ConvertRawHash @@ -29,27 +28,39 @@ 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.Read (deserialiseFromBytes) +import Codec.CBOR.FlatTerm (toFlatTerm, validFlatTerm) +import Codec.CBOR.Read (DeserialiseFailure, 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 (..)) @@ -62,8 +73,12 @@ 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 @@ -78,31 +93,75 @@ 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' :: (Eq a, Show a) +roundtrip' :: forall a. + (Eq a, Show a) => (a -> Encoding) -- ^ @enc@ -> (forall s. Decoder s (Lazy.ByteString -> a)) -> a -> Property -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 +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) where - bs = toLazyByteString (enc a) + (?!) :: 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 toBase16 :: Lazy.ByteString -> String toBase16 = Char8.unpack . Base16.encode + checkRoundtripResult :: Either String () -> Property + checkRoundtripResult (Left str) = counterexample str False + checkRoundtripResult (Right ()) = property () + {------------------------------------------------------------------------------ Test skeleton ------------------------------------------------------------------------------} @@ -593,23 +652,56 @@ decodeThroughSerialised dec decSerialised = do serialised <- decSerialised fromSerialised dec serialised -{------------------------------------------------------------------------------- - SomeResult --------------------------------------------------------------------------------} +{------------------------------------------------------------------------------ + Roundtrip tests for examples +------------------------------------------------------------------------------} --- | To easily generate all the possible @result@s of the 'Query' GADT, we --- introduce an existential that also bundles the corresponding 'Query' as --- evidence. We also capture 'Eq', 'Show', and 'Typeable' constraints, as we --- need them in the tests. -data SomeResult blk where - SomeResult :: (Eq result, Show result, Typeable result) - => BlockQuery blk result -> result -> SomeResult blk - -instance Show (SomeResult blk) where - show (SomeResult _ result) = show result - -instance Eq (SomeResult blk) where - SomeResult _ (res1 :: result1) == SomeResult _ (res2 :: result2) = - case eqT @result1 @result2 of - Nothing -> False - Just Refl -> res1 == res2 +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) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/SomeResult.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/SomeResult.hs new file mode 100644 index 0000000000..c319c2abd6 --- /dev/null +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/SomeResult.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Util.Serialisation.SomeResult (SomeResult (..)) where + +import Data.Typeable +import Ouroboros.Consensus.Ledger.Query (BlockQuery) + +-- | To easily generate all the possible @result@s of the 'Query' GADT, we +-- introduce an existential that also bundles the corresponding 'Query' as +-- evidence. We also capture 'Eq', 'Show', and 'Typeable' constraints, as we +-- need them in the tests. +data SomeResult blk where + SomeResult :: (Eq result, Show result, Typeable result) + => BlockQuery blk result -> result -> SomeResult blk + +instance Show (SomeResult blk) where + show (SomeResult _ result) = show result + +instance Eq (SomeResult blk) where + SomeResult _ (res1 :: result1) == SomeResult _ (res2 :: result2) = + case eqT @result1 @result2 of + Nothing -> False + Just Refl -> res1 == res2