From 8448a91a0ac2f0741d80416ca6c8f9d3370c5bf6 Mon Sep 17 00:00:00 2001 From: Fraser Murray Date: Wed, 10 Jan 2024 12:12:33 +0000 Subject: [PATCH] Add sanity checks for the current node configuration on node startup Currently the only supported sanity check is that k (the security parameter) is consistent between eras, and traces a SanityCheckIssue exception if it isn't --- ...440_fraser.murray_startup_sanity_checks.md | 27 ++++++ .../ouroboros-consensus-cardano.cabal | 1 + .../byron/Ouroboros/Consensus/Byron/Node.hs | 4 + .../Ouroboros/Consensus/Shelley/Node.hs | 11 ++- .../Ouroboros/Consensus/Shelley/ShelleyHFC.hs | 4 +- .../Ouroboros/Consensus/ByronDual/Node.hs | 3 + .../test/cardano-test/Main.hs | 2 + .../Consensus/Cardano/SupportsSanityCheck.hs | 81 ++++++++++++++++++ ...158_fraser.murray_startup_sanity_checks.md | 24 ++++++ .../Ouroboros/Consensus/Node.hs | 5 +- .../Ouroboros/Consensus/Node/Tracers.hs | 4 + .../Test/Consensus/HardFork/Combinator.hs | 2 + ...614_fraser.murray_startup_sanity_checks.md | 24 ++++++ ...158_fraser.murray_startup_sanity_checks.md | 22 +++++ ouroboros-consensus/ouroboros-consensus.cabal | 3 + .../Ouroboros/Consensus/Block.hs | 1 + .../Consensus/Block/SupportsSanityCheck.hs | 82 +++++++++++++++++++ .../Consensus/HardFork/Combinator/Node.hs | 1 + .../HardFork/Combinator/Node/SanityCheck.hs | 36 ++++++++ .../Ouroboros/Consensus/Node/Run.hs | 1 + .../Test/Util/SanityCheck.hs | 21 +++++ .../Ouroboros/Consensus/Mock/Node.hs | 3 + 22 files changed, 357 insertions(+), 5 deletions(-) create mode 100644 ouroboros-consensus-cardano/changelog.d/20240214_182440_fraser.murray_startup_sanity_checks.md create mode 100644 ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/SupportsSanityCheck.hs create mode 100644 ouroboros-consensus-diffusion/changelog.d/20240207_130158_fraser.murray_startup_sanity_checks.md create mode 100644 ouroboros-consensus-protocol/changelog.d/20240207_130614_fraser.murray_startup_sanity_checks.md create mode 100644 ouroboros-consensus/changelog.d/20240207_130158_fraser.murray_startup_sanity_checks.md create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsSanityCheck.hs create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Node/SanityCheck.hs create mode 100644 ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/SanityCheck.hs diff --git a/ouroboros-consensus-cardano/changelog.d/20240214_182440_fraser.murray_startup_sanity_checks.md b/ouroboros-consensus-cardano/changelog.d/20240214_182440_fraser.murray_startup_sanity_checks.md new file mode 100644 index 0000000000..cc55435a58 --- /dev/null +++ b/ouroboros-consensus-cardano/changelog.d/20240214_182440_fraser.murray_startup_sanity_checks.md @@ -0,0 +1,27 @@ + + + + + + + diff --git a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal index a487ec0a41..67601462a7 100644 --- a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal +++ b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal @@ -422,6 +422,7 @@ test-suite cardano-test Test.Consensus.Cardano.MiniProtocol.LocalTxSubmission.Server Test.Consensus.Cardano.Serialisation Test.Consensus.Cardano.SupportedNetworkProtocolVersion + Test.Consensus.Cardano.SupportsSanityCheck Test.ThreadNet.AllegraMary Test.ThreadNet.Cardano Test.ThreadNet.MaryAlonzo diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs index 0811eaea18..9f5f868d99 100644 --- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs +++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs @@ -288,6 +288,10 @@ instance NodeInitStorage ByronBlock where instance BlockSupportsMetrics ByronBlock where isSelfIssued = isSelfIssuedConstUnknown +instance BlockSupportsSanityCheck ByronBlock where + configAllSecurityParams = + pure . pbftSecurityParam . pbftParams . topLevelConfigProtocol + deriving via SelectViewDiffusionPipelining ByronBlock instance BlockSupportsDiffusionPipelining ByronBlock diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node.hs index e82b2a3693..ab0e23cd81 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node.hs @@ -32,10 +32,12 @@ import qualified Cardano.Ledger.Shelley.API as SL import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Config import Ouroboros.Consensus.Ledger.SupportsProtocol (LedgerSupportsProtocol) import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.Node.Run +import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.TPraos import Ouroboros.Consensus.Shelley.Eras (EraCrypto) import Ouroboros.Consensus.Shelley.Ledger @@ -104,6 +106,11 @@ instance ShelleyCompatible proto era => BlockSupportsMetrics (ShelleyBlock proto (SL.VKey 'SL.BlockIssuer (EraCrypto era)) issuerVKeys = shelleyBlockIssuerVKeys cfg +instance ConsensusProtocol proto => BlockSupportsSanityCheck (ShelleyBlock proto era) where + configAllSecurityParams = pure . protocolSecurityParam . topLevelConfigProtocol -instance (ShelleyCompatible proto era, LedgerSupportsProtocol (ShelleyBlock proto era)) - => RunNode (ShelleyBlock proto era) +instance + ( ShelleyCompatible proto era + , LedgerSupportsProtocol (ShelleyBlock proto era) + , BlockSupportsSanityCheck (ShelleyBlock proto era) + ) => RunNode (ShelleyBlock proto era) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs index 1e8b44ffc8..1d6e1334f9 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs @@ -162,8 +162,8 @@ shelleyTransition ShelleyPartialLedgerConfig{..} return newPParamsEpochNo instance - ( ShelleyCompatible proto era, - LedgerSupportsProtocol (ShelleyBlock proto era) + ( ShelleyCompatible proto era + , LedgerSupportsProtocol (ShelleyBlock proto era) ) => SingleEraBlock (ShelleyBlock proto era) where singleEraTransition pcfg _eraParams _eraStart ledgerState = -- TODO: We might be evaluating 'singleEraTransition' more than once when diff --git a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs index b3a9d1f127..8016c9236f 100644 --- a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs +++ b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs @@ -249,6 +249,9 @@ instance NodeInitStorage DualByronBlock where instance BlockSupportsMetrics DualByronBlock where isSelfIssued = isSelfIssuedConstUnknown +instance BlockSupportsSanityCheck DualByronBlock where + configAllSecurityParams = pure . configSecurityParam + deriving via SelectViewDiffusionPipelining DualByronBlock instance BlockSupportsDiffusionPipelining DualByronBlock diff --git a/ouroboros-consensus-cardano/test/cardano-test/Main.hs b/ouroboros-consensus-cardano/test/cardano-test/Main.hs index 3b4dbb5037..4e67cb2095 100644 --- a/ouroboros-consensus-cardano/test/cardano-test/Main.hs +++ b/ouroboros-consensus-cardano/test/cardano-test/Main.hs @@ -7,6 +7,7 @@ import qualified Test.Consensus.Cardano.Golden import qualified Test.Consensus.Cardano.MiniProtocol.LocalTxSubmission.Server import qualified Test.Consensus.Cardano.Serialisation import qualified Test.Consensus.Cardano.SupportedNetworkProtocolVersion +import qualified Test.Consensus.Cardano.SupportsSanityCheck import Test.Tasty import qualified Test.ThreadNet.AllegraMary import qualified Test.ThreadNet.Cardano @@ -28,6 +29,7 @@ tests = , Test.Consensus.Cardano.Golden.tests , Test.Consensus.Cardano.Serialisation.tests , Test.Consensus.Cardano.SupportedNetworkProtocolVersion.tests + , Test.Consensus.Cardano.SupportsSanityCheck.tests , Test.ThreadNet.AllegraMary.tests , Test.ThreadNet.Cardano.tests , Test.ThreadNet.MaryAlonzo.tests diff --git a/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/SupportsSanityCheck.hs b/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/SupportsSanityCheck.hs new file mode 100644 index 0000000000..3fe4ef9166 --- /dev/null +++ b/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/SupportsSanityCheck.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE NamedFieldPuns #-} +module Test.Consensus.Cardano.SupportsSanityCheck (tests) where + +import Ouroboros.Consensus.Cardano.Block +import Ouroboros.Consensus.Config +import Ouroboros.Consensus.HardFork.Combinator.Basics +import Ouroboros.Consensus.Node.ProtocolInfo +import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol () +import Test.Consensus.Cardano.ProtocolInfo +import qualified Test.QuickCheck as QC +import qualified Test.QuickCheck.Gen as Gen +import Test.Tasty +import Test.Tasty.QuickCheck +import qualified Test.ThreadNet.Infra.Shelley as Shelley +import Test.Util.SanityCheck + +tests :: TestTree +tests = testGroup "SupportsSanityCheck" + [ testProperty "cardano block top level config passes a sanity check" prop_cardanoBlockSanityChecks + , testProperty "intentionally-misconfigured top level config fails a sanity check" prop_intentionallyBrokenConfigDoesNotSanityCheck + ] + +prop_cardanoBlockSanityChecks :: QC.Property +prop_cardanoBlockSanityChecks = + forAllBlind genSimpleTestProtocolInfo (prop_sanityChecks . pInfoConfig) + +prop_intentionallyBrokenConfigDoesNotSanityCheck :: QC.Property +prop_intentionallyBrokenConfigDoesNotSanityCheck = + forAllBlind genSimpleTestProtocolInfo $ \pinfo -> + let saneTopLevelConfig = + pInfoConfig pinfo + brokenConfig = breakTopLevelConfig saneTopLevelConfig + in expectFailure $ prop_sanityChecks brokenConfig + +breakTopLevelConfig :: TopLevelConfig (CardanoBlock StandardCrypto) -> TopLevelConfig (CardanoBlock StandardCrypto) +breakTopLevelConfig tlc = + let TopLevelConfig{topLevelConfigProtocol} = tlc + HardForkConsensusConfig{hardForkConsensusConfigK} = topLevelConfigProtocol + SecurityParam k = hardForkConsensusConfigK + in tlc + { topLevelConfigProtocol = topLevelConfigProtocol + { hardForkConsensusConfigK = SecurityParam (succ k) + } + } + +genSimpleTestProtocolInfo :: Gen (ProtocolInfo (CardanoBlock StandardCrypto)) +genSimpleTestProtocolInfo = do + setup <- arbitrary + pure $ + mkSimpleTestProtocolInfo + (decentralizationParam setup) + (securityParam setup) + (byronSlotLength setup) + (shelleySlotLength setup) + (hardForkSpec setup) + +data SimpleTestProtocolInfoSetup = SimpleTestProtocolInfoSetup + { decentralizationParam :: Shelley.DecentralizationParam + , securityParam :: SecurityParam + , byronSlotLength :: ByronSlotLengthInSeconds + , shelleySlotLength :: ShelleySlotLengthInSeconds + , hardForkSpec :: HardForkSpec + } + +instance Arbitrary SimpleTestProtocolInfoSetup where + arbitrary = do + SimpleTestProtocolInfoSetup + <$> arbitrary + <*> genSecurityParam + <*> genByronSlotLength + <*> genShelleySlotLength + <*> genHardForkSpec + where + genSecurityParam = + SecurityParam <$> Gen.choose (8, 12) + genByronSlotLength = + ByronSlotLengthInSeconds <$> Gen.choose (1, 4) + genShelleySlotLength = + ShelleySlotLengthInSeconds <$> Gen.choose (1, 4) + genHardForkSpec = + hardForkInto <$> Gen.chooseEnum (Byron, Conway) diff --git a/ouroboros-consensus-diffusion/changelog.d/20240207_130158_fraser.murray_startup_sanity_checks.md b/ouroboros-consensus-diffusion/changelog.d/20240207_130158_fraser.murray_startup_sanity_checks.md new file mode 100644 index 0000000000..649f00ed64 --- /dev/null +++ b/ouroboros-consensus-diffusion/changelog.d/20240207_130158_fraser.murray_startup_sanity_checks.md @@ -0,0 +1,24 @@ + + + + +### Non-Breaking + +- Adds a Tracer for startup sanity check warnings in Ouroboros.Consensus.Node.Tracers (see BlockSupportsSanityCheck in ouroboros-consensus) + + + diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs index f6cc42eea1..c77fdbac81 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs @@ -60,7 +60,7 @@ import qualified Codec.CBOR.Encoding as CBOR import Codec.Serialise (DeserialiseFailure) import qualified Control.Concurrent.Class.MonadSTM.Strict as StrictSTM import Control.DeepSeq (NFData) -import Control.Monad (when) +import Control.Monad (forM_, when) import Control.Monad.Class.MonadTime.SI (MonadTime) import Control.Monad.Class.MonadTimer.SI (MonadTimer) import Control.Tracer (Tracer, contramap, traceWith) @@ -422,6 +422,9 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} = -- ChainDB to detect and recover from any disk corruption. = ChainDB.ensureValidateAll + forM_ (sanityCheckConfig cfg) $ \issue -> + traceWith (consensusSanityCheckTracer rnTraceConsensus) issue + (chainDB, finalArgs) <- openChainDB registry inFuture diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs index 59e4052d92..8b93417d0c 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs @@ -64,6 +64,7 @@ data Tracers' remotePeer localPeer blk f = Tracers , blockchainTimeTracer :: f (TraceBlockchainTimeEvent UTCTime) , forgeStateInfoTracer :: f (TraceLabelCreds (ForgeStateInfo blk)) , keepAliveClientTracer :: f (TraceKeepAliveClient remotePeer) + , consensusSanityCheckTracer :: f SanityCheckIssue , consensusErrorTracer :: f SomeException , gsmTracer :: f (TraceGsmEvent (Tip blk)) , gddTracer :: f (TraceGDDEvent remotePeer blk) @@ -86,6 +87,7 @@ instance (forall a. Semigroup (f a)) , blockchainTimeTracer = f blockchainTimeTracer , forgeStateInfoTracer = f forgeStateInfoTracer , keepAliveClientTracer = f keepAliveClientTracer + , consensusSanityCheckTracer = f consensusSanityCheckTracer , consensusErrorTracer = f consensusErrorTracer , gsmTracer = f gsmTracer , gddTracer = f gddTracer @@ -116,6 +118,7 @@ nullTracers = Tracers , blockchainTimeTracer = nullTracer , forgeStateInfoTracer = nullTracer , keepAliveClientTracer = nullTracer + , consensusSanityCheckTracer = nullTracer , consensusErrorTracer = nullTracer , gsmTracer = nullTracer , gddTracer = nullTracer @@ -149,6 +152,7 @@ showTracers tr = Tracers , blockchainTimeTracer = showTracing tr , forgeStateInfoTracer = showTracing tr , keepAliveClientTracer = showTracing tr + , consensusSanityCheckTracer = showTracing tr , consensusErrorTracer = showTracing tr , gsmTracer = showTracing tr , gddTracer = showTracing tr diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs index 1de4441d75..d3835e09b5 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs @@ -62,6 +62,7 @@ import Test.ThreadNet.Util.NodeToNodeVersion import Test.ThreadNet.Util.NodeTopology import Test.ThreadNet.Util.Seed import Test.Util.HardFork.Future +import Test.Util.SanityCheck (prop_sanityChecks) import Test.Util.Slots (NumSlots (..)) import Test.Util.Time (dawnOfTime) @@ -132,6 +133,7 @@ prop_simple_hfc_convergence testSetup@TestSetup{..} = counterexample ("eraSizeA: " <> show eraSizeA) $ tabulate "epochs in era A" [labelEraSizeA] $ prop_general args testOutput .&&. + prop_sanityChecks (topLevelConfig (CoreNodeId 0)) .&&. prop_allExpectedBlocks where k :: SecurityParam diff --git a/ouroboros-consensus-protocol/changelog.d/20240207_130614_fraser.murray_startup_sanity_checks.md b/ouroboros-consensus-protocol/changelog.d/20240207_130614_fraser.murray_startup_sanity_checks.md new file mode 100644 index 0000000000..ea9980ba3e --- /dev/null +++ b/ouroboros-consensus-protocol/changelog.d/20240207_130614_fraser.murray_startup_sanity_checks.md @@ -0,0 +1,24 @@ + + + + +### Non-Breaking + +- ProtocolConfigHasSecurityParam instances for Praos and TPraos + + + diff --git a/ouroboros-consensus/changelog.d/20240207_130158_fraser.murray_startup_sanity_checks.md b/ouroboros-consensus/changelog.d/20240207_130158_fraser.murray_startup_sanity_checks.md new file mode 100644 index 0000000000..eed00c132f --- /dev/null +++ b/ouroboros-consensus/changelog.d/20240207_130158_fraser.murray_startup_sanity_checks.md @@ -0,0 +1,22 @@ + + + +### Non-Breaking + +- Add BlockSupportsSanityCheck to check for common configuration issues which may manifest themselves in unusual but not necessarily immediately obvious ways. For now it only checks that `k` is the same across all eras. + + diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index 695668cff9..92f49e658b 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -77,6 +77,7 @@ library Ouroboros.Consensus.Block.SupportsDiffusionPipelining Ouroboros.Consensus.Block.SupportsMetrics Ouroboros.Consensus.Block.SupportsProtocol + Ouroboros.Consensus.Block.SupportsSanityCheck Ouroboros.Consensus.BlockchainTime Ouroboros.Consensus.BlockchainTime.API Ouroboros.Consensus.BlockchainTime.WallClock.Default @@ -121,6 +122,7 @@ library Ouroboros.Consensus.HardFork.Combinator.Node.DiffusionPipelining Ouroboros.Consensus.HardFork.Combinator.Node.InitStorage Ouroboros.Consensus.HardFork.Combinator.Node.Metrics + Ouroboros.Consensus.HardFork.Combinator.Node.SanityCheck Ouroboros.Consensus.HardFork.Combinator.PartialConfig Ouroboros.Consensus.HardFork.Combinator.Protocol Ouroboros.Consensus.HardFork.Combinator.Protocol.ChainSel @@ -359,6 +361,7 @@ library unstable-consensus-testlib Test.Util.Range Test.Util.RefEnv Test.Util.SOP + Test.Util.SanityCheck Test.Util.Schedule Test.Util.Serialisation.Examples Test.Util.Serialisation.Golden diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block.hs index 9fd659acf8..e9cccfdc24 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block.hs @@ -9,3 +9,4 @@ import Ouroboros.Consensus.Block.RealPoint as X import Ouroboros.Consensus.Block.SupportsDiffusionPipelining as X import Ouroboros.Consensus.Block.SupportsMetrics as X import Ouroboros.Consensus.Block.SupportsProtocol as X +import Ouroboros.Consensus.Block.SupportsSanityCheck as X diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsSanityCheck.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsSanityCheck.hs new file mode 100644 index 0000000000..90eb7fe748 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsSanityCheck.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE LambdaCase #-} +-- | This module adds support for sanity checking consensus configuration +-- on node startup. These checks should primarily look for unusual +-- configuration choices that may point to an accidentally-misconfigured node +-- and quietly cause problems, rather than incoherent configurations that will +-- result in fatal errors at a later point. +-- +-- While in most situations they can be handled as fatal issues, there are +-- situations when intentionally configuring a node "weirdly" can be useful, +-- and so the user should be able to opt out of the sanity checks at their +-- own peril. +module Ouroboros.Consensus.Block.SupportsSanityCheck ( + BlockSupportsSanityCheck (..) + , SanityCheckIssue (..) + , checkSecurityParamConsistency + , sanityCheckConfig + ) where + +import Control.Exception +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe (catMaybes) +import Ouroboros.Consensus.Config (TopLevelConfig) +import Ouroboros.Consensus.Config.SecurityParam + +-- | An issue found in the 'TopLevelConfig' for a block. See 'displayException' +-- for human-readable descriptions of each of these cases, especially when +-- presenting these to users. +data SanityCheckIssue + -- | Configuration contains multiple security parameters. This may cause + -- strange behaviour around era boundaries. + = InconsistentSecurityParam (NonEmpty SecurityParam) + deriving (Show, Eq) + +instance Exception SanityCheckIssue where + displayException = \case + InconsistentSecurityParam ks -> mconcat + [ "InconsistentSecurityParam: " + , "SecurityParams (K) were found to be inconsistent between constituent " + , "eras of a HardForkBlock: " + , show (NonEmpty.toList ks) + ] + +-- | 'BlockSupportsSanityCheck' provides evidence that a block can be sanity +-- checked for common issues on node startup. 'sanityCheckConfig', which runs +-- performs each check and returns a list with each 'SanityCheckIssue' found, +-- should be preferred over using these methods directly. +class BlockSupportsSanityCheck blk where + + -- | Generate a 'NonEmpty' list of security parameters for a given block type. + -- For individual eras' block types, this is simply a singleton list + -- containing the chosen 'SecurityParam', but combined block types (i.e. + -- the 'HardForkCombinator') will return all of their constituent eras' + -- configurations' security parameters. + configAllSecurityParams + :: TopLevelConfig blk + -> NonEmpty SecurityParam + +-- | Check a 'TopLevelConfig' for any inconsistency in constituent choices for +-- 'SecurityParam' (colloquially @k@). For a block type to be considered +-- "sane" in this regard, its configuration's security parameter as well as +-- all of its childrens' configurations (if applicable) should be the same. +checkSecurityParamConsistency + :: BlockSupportsSanityCheck blk + => TopLevelConfig blk + -> Maybe SanityCheckIssue +checkSecurityParamConsistency cfg = do + let allParams = configAllSecurityParams cfg + if allSame allParams + then Nothing + else Just (InconsistentSecurityParam allParams) + +allSame :: Eq a => NonEmpty a -> Bool +allSame (x :| xs) = all (x ==) xs + +-- | Run all supported sanity checks on a given 'TopLevelConfig'. +sanityCheckConfig + :: BlockSupportsSanityCheck blk + => TopLevelConfig blk + -> [SanityCheckIssue] +sanityCheckConfig cfg = + catMaybes [checkSecurityParamConsistency cfg] diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Node.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Node.hs index 53e574a33b..a1cf173384 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Node.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Node.hs @@ -22,6 +22,7 @@ import Ouroboros.Consensus.HardFork.Combinator.Ledger.PeerSelection () import Ouroboros.Consensus.HardFork.Combinator.Node.DiffusionPipelining () import Ouroboros.Consensus.HardFork.Combinator.Node.InitStorage () import Ouroboros.Consensus.HardFork.Combinator.Node.Metrics () +import Ouroboros.Consensus.HardFork.Combinator.Node.SanityCheck () import Ouroboros.Consensus.HardFork.Combinator.Serialisation import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.Run diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Node/SanityCheck.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Node/SanityCheck.hs new file mode 100644 index 0000000000..9f2a0c5b0d --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Node/SanityCheck.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-orphans #-} +module Ouroboros.Consensus.HardFork.Combinator.Node.SanityCheck () where + +import Data.List.NonEmpty (NonEmpty (..)) +import Data.SOP.BasicFunctors +import Data.SOP.Constraint +import Data.SOP.Strict +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Config +import Ouroboros.Consensus.HardFork.Combinator.Abstract +import Ouroboros.Consensus.HardFork.Combinator.AcrossEras +import Ouroboros.Consensus.HardFork.Combinator.Basics +import Ouroboros.Consensus.HardFork.Combinator.PartialConfig +import Ouroboros.Consensus.HardFork.History.EpochInfo +import Ouroboros.Consensus.Protocol.Abstract + +instance CanHardFork xs => BlockSupportsSanityCheck (HardForkBlock xs) where + configAllSecurityParams tlc = + let configProtocol = topLevelConfigProtocol tlc in + hardForkConsensusConfigK configProtocol :| + perEraConsensusConfigSecurityParams (hardForkConsensusConfigPerEra configProtocol) + +perEraConsensusConfigSecurityParams + :: All SingleEraBlock xs + => PerEraConsensusConfig xs -> [SecurityParam] +perEraConsensusConfigSecurityParams (PerEraConsensusConfig xs) = + unK $ hctraverse_ (Proxy @SingleEraBlock) go xs + where + go :: forall a . SingleEraBlock a + => WrapPartialConsensusConfig a -> K [SecurityParam] () + go (WrapPartialConsensusConfig c) = + K [ protocolSecurityParam (completeConsensusConfig (Proxy @(BlockProtocol a)) dummyEpochInfo c) ] diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Run.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Run.hs index 97c2eba210..1fe2ae42ee 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Run.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Run.hs @@ -93,6 +93,7 @@ class ( LedgerSupportsProtocol blk , NodeInitStorage blk , BlockSupportsMetrics blk , BlockSupportsDiffusionPipelining blk + , BlockSupportsSanityCheck blk , Show (CannotForge blk) , Show (ForgeStateInfo blk) , Show (ForgeStateUpdateError blk) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/SanityCheck.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/SanityCheck.hs new file mode 100644 index 0000000000..eb6a9564e1 --- /dev/null +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/SanityCheck.hs @@ -0,0 +1,21 @@ +module Test.Util.SanityCheck ( + prop_sanityChecks + , prop_securityParamConsistent + ) where + +import Ouroboros.Consensus.Block.SupportsSanityCheck +import Ouroboros.Consensus.Config +import Test.Tasty.QuickCheck +import Test.Util.Orphans.Arbitrary () + +prop_sanityChecks + :: BlockSupportsSanityCheck blk + => TopLevelConfig blk -> Property +prop_sanityChecks cfg = + sanityCheckConfig cfg === [] + +prop_securityParamConsistent + :: BlockSupportsSanityCheck blk + => TopLevelConfig blk -> Property +prop_securityParamConsistent cfg = + checkSecurityParamConsistency cfg === Nothing diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node.hs index 0a4d30a7f9..14c8948ded 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node.hs @@ -60,6 +60,9 @@ deriving via SelectViewDiffusionPipelining (SimpleBlock c ext) instance , Show (SelectView (BlockProtocol (SimpleBlock c ext))) ) => BlockSupportsDiffusionPipelining (SimpleBlock c ext) +instance ConsensusProtocol (BlockProtocol (SimpleBlock c ext)) => BlockSupportsSanityCheck (SimpleBlock c ext) where + configAllSecurityParams = pure . configSecurityParam + instance ( LedgerSupportsProtocol (SimpleBlock SimpleMockCrypto ext) , Show (CannotForge (SimpleBlock SimpleMockCrypto ext)) , Show (ForgeStateInfo (SimpleBlock SimpleMockCrypto ext))