wip: a mechanism for checking whether k is consistent between constit…

…uent eras of the hfc

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs

@@ -202,13 +202,17 @@ instance PraosCrypto c => HasPartialConsensusConfig (Praos c) where
 
   toPartialConsensusConfig _ = praosParams
 
+  partialConsensusConfigSecurityParam _ = praosSecurityParam
+
 instance SL.PraosCrypto c => HasPartialConsensusConfig (TPraos c) where
   type PartialConsensusConfig (TPraos c) = TPraosParams
 
   completeConsensusConfig _ tpraosEpochInfo tpraosParams = TPraosConfig {..}
 
   toPartialConsensusConfig _ = tpraosParams
 
+  partialConsensusConfigSecurityParam _ = tpraosSecurityParam
+
 data ShelleyPartialLedgerConfig era = ShelleyPartialLedgerConfig {
       -- | We cache the non-partial ledger config containing a dummy
       -- 'EpochInfo' that needs to be replaced with the correct one.

ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal

@@ -58,6 +58,7 @@ library
     Ouroboros.Consensus.Node.ExitPolicy
     Ouroboros.Consensus.Node.Recovery
     Ouroboros.Consensus.Node.RethrowPolicy
+    Ouroboros.Consensus.Node.StartupWarning
     Ouroboros.Consensus.Node.Tracers
     Ouroboros.Consensus.NodeKernel
 

ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs

@@ -87,8 +87,10 @@ import           Ouroboros.Consensus.Node.ProtocolInfo
 import           Ouroboros.Consensus.Node.Recovery
 import           Ouroboros.Consensus.Node.RethrowPolicy
 import           Ouroboros.Consensus.Node.Run
+import           Ouroboros.Consensus.Node.StartupWarning
 import           Ouroboros.Consensus.Node.Tracers
 import           Ouroboros.Consensus.NodeKernel
+import           Ouroboros.Consensus.Protocol.Abstract (protocolSecurityParamConsistencyCheck)
 import           Ouroboros.Consensus.Storage.ChainDB (ChainDB, ChainDbArgs)
 import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB
 import           Ouroboros.Consensus.Storage.ImmutableDB (ChunkInfo,
@@ -364,6 +366,11 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} =
                   , ChainDB.cdbVolatileDbValidation  = ValidateAll
                   }
 
+        case protocolSecurityParamConsistencyCheck (topLevelConfigProtocol cfg) of
+          Nothing -> pure ()
+          Just ks -> traceWith (consensusSanityCheckTracer rnTraceConsensus) $
+            InconsistentSecurityParam ks
+
         chainDB <- openChainDB registry inFuture cfg initLedger
                   llrnChainDbArgsDefaults customiseChainDbArgs'
 

ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/StartupWarning.hs

@@ -0,0 +1,10 @@
+module Ouroboros.Consensus.Node.StartupWarning
+  ( StartupWarning (..)
+  ) where
+
+import Data.List.NonEmpty (NonEmpty)
+import Ouroboros.Consensus.Config.SecurityParam
+
+data StartupWarning
+  = InconsistentSecurityParam (NonEmpty SecurityParam)
+  deriving (Show, Eq)

ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs

@@ -41,6 +41,8 @@ import           Ouroboros.Network.TxSubmission.Inbound
                      (TraceTxSubmissionInbound)
 import           Ouroboros.Network.TxSubmission.Outbound
                      (TraceTxSubmissionOutbound)
+import           Ouroboros.Consensus.Node.StartupWarning
+                     (StartupWarning)
 
 {-------------------------------------------------------------------------------
   All tracers of a node bundled together
@@ -61,6 +63,7 @@ data Tracers' remotePeer localPeer blk f = Tracers
   , blockchainTimeTracer          :: f (TraceBlockchainTimeEvent UTCTime)
   , forgeStateInfoTracer          :: f (TraceLabelCreds (ForgeStateInfo blk))
   , keepAliveClientTracer         :: f (TraceKeepAliveClient remotePeer)
+  , consensusSanityCheckTracer    :: f StartupWarning
   , consensusErrorTracer          :: f SomeException
   }
 
@@ -81,6 +84,7 @@ instance (forall a. Semigroup (f a))
       , blockchainTimeTracer          = f blockchainTimeTracer
       , forgeStateInfoTracer          = f forgeStateInfoTracer
       , keepAliveClientTracer         = f keepAliveClientTracer
+      , consensusSanityCheckTracer    = f consensusSanityCheckTracer
       , consensusErrorTracer          = f consensusErrorTracer
       }
     where
@@ -109,6 +113,7 @@ nullTracers = Tracers
     , blockchainTimeTracer          = nullTracer
     , forgeStateInfoTracer          = nullTracer
     , keepAliveClientTracer         = nullTracer
+    , consensusSanityCheckTracer    = nullTracer
     , consensusErrorTracer          = nullTracer
     }
 
@@ -140,6 +145,7 @@ showTracers tr = Tracers
     , blockchainTimeTracer          = showTracing tr
     , forgeStateInfoTracer          = showTracing tr
     , keepAliveClientTracer         = showTracing tr
+    , consensusSanityCheckTracer    = showTracing tr
     , consensusErrorTracer          = showTracing tr
     }
 

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs

@@ -114,6 +114,7 @@ instance ConsensusProtocol ProtocolA where
       else Nothing
 
   protocolSecurityParam = cfgA_k
+  protocolSecurityParamConsistencyCheck _ = Nothing
 
   tickChainDepState     _ _ _ _ = TickedTrivial
   updateChainDepState   _ _ _ _ = return ()

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs

@@ -100,6 +100,7 @@ instance ConsensusProtocol ProtocolB where
       else Nothing
 
   protocolSecurityParam = cfgB_k
+  protocolSecurityParamConsistencyCheck _ = Nothing
 
   tickChainDepState     _ _ _ _ = TickedTrivial
   updateChainDepState   _ _ _ _ = return ()

ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs

@@ -366,6 +366,7 @@ instance PraosCrypto c => ConsensusProtocol (Praos c) where
   type ValidateView (Praos c) = PraosValidateView c
 
   protocolSecurityParam = praosSecurityParam . praosParams
+  protocolSecurityParamConsistencyCheck _ = Nothing
 
   checkIsLeader
     cfg

ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/TPraos.hs

@@ -293,6 +293,7 @@ instance SL.PraosCrypto c => ConsensusProtocol (TPraos c) where
   type ValidateView  (TPraos c) = TPraosValidateView c
 
   protocolSecurityParam = tpraosSecurityParam . tpraosParams
+  protocolSecurityParamConsistencyCheck _ = Nothing
 
   checkIsLeader cfg PraosCanBeLeader{..} slot cs = do
       -- First, check whether we're in the overlay schedule

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/PartialConfig.hs

@@ -62,6 +62,8 @@ class ( ConsensusProtocol p
     -> PartialConsensusConfig p
   toPartialConsensusConfig _ = id
 
+  partialConsensusConfigSecurityParam :: proxy p -> PartialConsensusConfig p -> SecurityParam
+
 -- | Partial ledger config
 class ( UpdateLedger blk
       , NoThunks (PartialLedgerConfig blk)

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs

@@ -12,6 +12,7 @@
 {-# LANGUAGE TypeApplications           #-}
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE TypeOperators              #-}
+{-# LANGUAGE UndecidableInstances       #-}
 
 {-# OPTIONS_GHC -Wno-orphans #-}
 
@@ -29,9 +30,11 @@ module Ouroboros.Consensus.HardFork.Combinator.Protocol (
   , Ticked (..)
   ) where
 
+import           Data.List.NonEmpty (NonEmpty (..), nub)
 import           Control.Monad.Except
 import           Data.Functor.Product
 import           Data.SOP.BasicFunctors
+import           Data.SOP.Constraint
 import           Data.SOP.Index
 import           Data.SOP.InPairs (InPairs (..))
 import qualified Data.SOP.InPairs as InPairs
@@ -112,6 +115,13 @@ instance CanHardFork xs => ConsensusProtocol (HardForkProtocol xs) where
   -- Security parameter must be equal across /all/ eras
   protocolSecurityParam = hardForkConsensusConfigK
 
+  protocolSecurityParamConsistencyCheck HardForkConsensusConfig {..} = do
+    let allSecurityParams = hardForkConsensusConfigK :|
+          perEraConsensusConfigSecurityParams hardForkConsensusConfigPerEra
+    case nub allSecurityParams of
+      _ :| [] -> Nothing
+      _ -> Just allSecurityParams
+
 {-------------------------------------------------------------------------------
   BlockSupportsProtocol
 -------------------------------------------------------------------------------}
@@ -366,6 +376,16 @@ injectValidationErr index =
     . injectNS index
     . WrapValidationErr
 
+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 [ partialConsensusConfigSecurityParam (Proxy @(BlockProtocol a)) c ]
+
 {-------------------------------------------------------------------------------
   Instances
 -------------------------------------------------------------------------------}

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/Abstract.hs

@@ -11,6 +11,7 @@ module Ouroboros.Consensus.Protocol.Abstract (
   , SecurityParam (..)
   ) where
 
+import           Data.List.NonEmpty
 import           Control.Monad.Except
 import           Data.Kind (Type)
 import           Data.Typeable (Typeable)
@@ -170,6 +171,9 @@ class ( Show (ChainDepState   p)
   -- | We require that protocols support a @k@ security parameter
   protocolSecurityParam :: ConsensusConfig p -> SecurityParam
 
+  protocolSecurityParamConsistencyCheck :: ConsensusConfig p
+                                        -> Maybe (NonEmpty SecurityParam)
+
 -- | Compare a candidate chain to our own
 --
 -- If both chains are equally preferable, the Ouroboros class of consensus

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/BFT.hs

@@ -130,6 +130,7 @@ instance BftCrypto c => ConsensusProtocol (Bft c) where
   type CanBeLeader   (Bft c) = CoreNodeId
 
   protocolSecurityParam = bftSecurityParam . bftParams
+  protocolSecurityParamConsistencyCheck _ = Nothing
 
   checkIsLeader BftConfig{..} (CoreNodeId i) (SlotNo n) _ =
       if n `mod` numCoreNodes == i

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/ModChainSel.hs

@@ -40,5 +40,7 @@ instance ( ConsensusProtocol p
     updateChainDepState   = updateChainDepState   . mcsConfigP
     reupdateChainDepState = reupdateChainDepState . mcsConfigP
     protocolSecurityParam = protocolSecurityParam . mcsConfigP
+    protocolSecurityParamConsistencyCheck =
+        protocolSecurityParamConsistencyCheck . mcsConfigP
 
 instance ConsensusProtocol p => NoThunks (ConsensusConfig (ModChainSel p s))

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/PBFT.hs

@@ -292,6 +292,7 @@ instance PBftCrypto c => ConsensusProtocol (PBft c) where
   type CanBeLeader   (PBft c) = PBftCanBeLeader c
 
   protocolSecurityParam = pbftSecurityParam . pbftParams
+  protocolSecurityParamConsistencyCheck _ = Nothing
 
   checkIsLeader PBftConfig{pbftParams}
                 PBftCanBeLeader{..}

ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Protocol/LeaderSchedule.hs

@@ -46,6 +46,8 @@ instance ConsensusProtocol p => ConsensusProtocol (WithLeaderSchedule p) where
   type CanBeLeader   (WithLeaderSchedule p) = ()
 
   protocolSecurityParam = protocolSecurityParam . wlsConfigP
+  protocolSecurityParamConsistencyCheck =
+    protocolSecurityParamConsistencyCheck . wlsConfigP
 
   checkIsLeader WLSConfig{..} () slot _ =
     case Map.lookup slot $ getLeaderSchedule wlsConfigSchedule of