Add a BlockFetch leashing attack

ouroboros-consensus-diffusion/changelog.d/20240531_155304_alexander.esgen_milestone_13.md

@@ -0,0 +1,12 @@
+### Breaking
+
+- Integrated all Genesis components into the NodeKernel. In particular,
+  `RunNodeArgs` now has a new field
+
+  ```haskell
+  rnGenesisConfig :: GenesisConfig
+  ```
+
+  This can be set to `Ouroboros.Consensus.Node.Genesis.disableGenesisConfig` to
+  keep the Praos behavior, or to `enableGenesisConfigDefault` to enable Genesis
+  with preliminary parameter choices.

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

@@ -65,6 +65,7 @@ library
     Ouroboros.Consensus.Node.Exit
     Ouroboros.Consensus.Node.ExitPolicy
     Ouroboros.Consensus.Node.GSM
+    Ouroboros.Consensus.Node.Genesis
     Ouroboros.Consensus.Node.Recovery
     Ouroboros.Consensus.Node.RethrowPolicy
     Ouroboros.Consensus.Node.Tracers
@@ -242,6 +243,7 @@ test-suite consensus-test
     Test.Consensus.Network.AnchoredFragment.Extras
     Test.Consensus.Node
     Test.Consensus.PeerSimulator.BlockFetch
+    Test.Consensus.PeerSimulator.CSJInvariants
     Test.Consensus.PeerSimulator.ChainSync
     Test.Consensus.PeerSimulator.Config
     Test.Consensus.PeerSimulator.Handlers
@@ -266,6 +268,7 @@ test-suite consensus-test
     Test.Consensus.PointSchedule.SinglePeer
     Test.Consensus.PointSchedule.SinglePeer.Indices
     Test.Consensus.PointSchedule.Tests
+    Test.Util.PartialAccessors
     Test.Util.TersePrinting
 
   build-depends:

ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs

@@ -41,7 +41,7 @@ import qualified Codec.CBOR.Decoding as CBOR
 import           Codec.CBOR.Encoding (Encoding)
 import qualified Codec.CBOR.Encoding as CBOR
 import           Codec.CBOR.Read (DeserialiseFailure)
-import           Control.Concurrent.Class.MonadSTM.Strict.TVar as TVar.Unchecked
+import qualified Control.Concurrent.Class.MonadSTM.Strict.TVar as TVar.Unchecked
 import           Control.Monad.Class.MonadTime.SI (MonadTime)
 import           Control.Monad.Class.MonadTimer.SI (MonadTimer)
 import           Control.Tracer
@@ -570,6 +570,7 @@ mkApps kernel Tracers {..} mkCodecs ByteLimits {..} genChainSyncTimeout lopBucke
             (contramap (TraceLabelPeer them) (Node.chainSyncClientTracer (getTracers kernel)))
             (CsClient.defaultChainDbView (getChainDB kernel))
             (getChainSyncHandles kernel)
+            (getGsmState       kernel)
             them
             version
             lopBucketConfig

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

@@ -80,15 +80,15 @@ import           Ouroboros.Consensus.Fragment.InFuture (CheckInFuture,
                      ClockSkew)
 import qualified Ouroboros.Consensus.Fragment.InFuture as InFuture
 import           Ouroboros.Consensus.Ledger.Extended (ExtLedgerState (..))
-import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client
-                     (CSJConfig (..), ChainSyncLoPBucketConfig (..))
 import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.InFutureCheck as InFutureCheck
 import qualified Ouroboros.Consensus.Network.NodeToClient as NTC
 import qualified Ouroboros.Consensus.Network.NodeToNode as NTN
 import           Ouroboros.Consensus.Node.DbLock
 import           Ouroboros.Consensus.Node.DbMarker
 import           Ouroboros.Consensus.Node.ErrorPolicy
 import           Ouroboros.Consensus.Node.ExitPolicy
+import           Ouroboros.Consensus.Node.Genesis (GenesisConfig (..),
+                     GenesisNodeKernelArgs, mkGenesisNodeKernelArgs)
 import           Ouroboros.Consensus.Node.GSM (GsmNodeKernelArgs (..))
 import qualified Ouroboros.Consensus.Node.GSM as GSM
 import           Ouroboros.Consensus.Node.InitStorage
@@ -193,6 +193,8 @@ data RunNodeArgs m addrNTN addrNTC blk (p2p :: Diffusion.P2P) = RunNodeArgs {
     , rnPeerSharing :: PeerSharing
 
     , rnGetUseBootstrapPeers :: STM m UseBootstrapPeers
+
+    , rnGenesisConfig :: GenesisConfig
     }
 
 
@@ -249,11 +251,7 @@ data LowLevelRunNodeArgs m addrNTN addrNTC versionDataNTN versionDataNTC blk
       -- | See 'NTN.ChainSyncTimeout'
     , llrnChainSyncTimeout :: m NTN.ChainSyncTimeout
 
-      -- | See 'CsClient.ChainSyncLoPBucketConfig'
-    , llrnChainSyncLoPBucketConfig :: ChainSyncLoPBucketConfig
-
-      -- | See 'CsClient.CSJConfig'
-    , llrnCSJConfig :: CSJConfig
+    , llrnGenesisConfig :: GenesisConfig
 
       -- | How to run the data diffusion applications
       --
@@ -413,6 +411,9 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} =
                          llrnMaxClockSkew
                          systemTime
 
+        (genesisArgs, setLoEinChainDbArgs) <-
+          mkGenesisNodeKernelArgs llrnGenesisConfig
+
         let maybeValidateAll
               | lastShutDownWasClean
               = id
@@ -428,7 +429,8 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} =
                      initLedger
                      llrnMkHasFS
                      llrnChainDbArgsDefaults
-                     (  maybeValidateAll
+                     (  setLoEinChainDbArgs
+                      . maybeValidateAll
                       . llrnCustomiseChainDbArgs
                      )
 
@@ -474,6 +476,7 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} =
                     gsmMarkerFileView
                     rnGetUseBootstrapPeers
                     llrnPublicPeerSelectionStateVar
+                    genesisArgs
           nodeKernel <- initNodeKernel nodeKernelArgs
           rnNodeKernelHook registry nodeKernel
 
@@ -521,8 +524,8 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} =
           (NTN.defaultCodecs codecConfig version encAddrNTN decAddrNTN)
           NTN.byteLimits
           llrnChainSyncTimeout
-          llrnChainSyncLoPBucketConfig
-          llrnCSJConfig
+          (gcChainSyncLoPBucketConfig llrnGenesisConfig)
+          (gcCSJConfig llrnGenesisConfig)
           (reportMetric Diffusion.peerMetricsConfiguration peerMetrics)
           (NTN.mkHandlers nodeKernelArgs nodeKernel)
 
@@ -629,7 +632,7 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} =
               LedgerPeersConsensusInterface {
                   lpGetLatestSlot = getImmTipSlot kernel,
                   lpGetLedgerPeers = fromMaybe [] <$> getPeersFromCurrentLedger kernel (const True),
-                  lpGetLedgerStateJudgement = getLedgerStateJudgement kernel
+                  lpGetLedgerStateJudgement = GSM.gsmStateToLedgerJudgement <$> getGsmState kernel
                 },
             Diffusion.daUpdateOutboundConnectionsState =
               let varOcs = getOutboundConnectionsState kernel in \newOcs -> do
@@ -711,6 +714,7 @@ mkNodeKernelArgs ::
   -> GSM.MarkerFileView m
   -> STM m UseBootstrapPeers
   -> StrictSTM.StrictTVar m (Diffusion.PublicPeerSelectionState addrNTN)
+  -> GenesisNodeKernelArgs m blk
   -> m (NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk)
 mkNodeKernelArgs
   registry
@@ -727,6 +731,7 @@ mkNodeKernelArgs
   gsmMarkerFileView
   getUseBootstrapPeers
   publicPeerSelectionStateVar
+  genesisArgs
   = do
     let (kaRng, psRng) = split rng
     return NodeKernelArgs
@@ -751,6 +756,7 @@ mkNodeKernelArgs
       , keepAliveRng = kaRng
       , peerSharingRng = psRng
       , publicPeerSelectionStateVar
+      , genesisArgs
       }
 
 -- | We allow the user running the node to customise the 'NodeKernelArgs'
@@ -852,6 +858,7 @@ stdLowLevelRunNodeArgsIO ::
 stdLowLevelRunNodeArgsIO RunNodeArgs{ rnProtocolInfo
                                     , rnEnableP2P
                                     , rnPeerSharing
+                                    , rnGenesisConfig
                                     }
                          $(SafeWildCards.fields 'StdRunNodeArgs) = do
     llrnBfcSalt               <- stdBfcSaltIO
@@ -860,8 +867,7 @@ stdLowLevelRunNodeArgsIO RunNodeArgs{ rnProtocolInfo
     pure LowLevelRunNodeArgs
       { llrnBfcSalt
       , llrnChainSyncTimeout = fromMaybe Diffusion.defaultChainSyncTimeout srnChainSyncTimeout
-      , llrnChainSyncLoPBucketConfig = ChainSyncLoPBucketDisabled
-      , llrnCSJConfig = CSJDisabled
+      , llrnGenesisConfig = rnGenesisConfig
       , llrnCustomiseHardForkBlockchainTimeArgs = id
       , llrnGsmAntiThunderingHerd
       , llrnKeepAliveRng

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

@@ -19,11 +19,13 @@ module Ouroboros.Consensus.Node.GSM (
     -- * Auxiliaries
   , TraceGsmEvent (..)
   , gsmStateToLedgerJudgement
-  , initializationLedgerJudgement
+  , initializationGsmState
     -- * Constructors
   , realDurationUntilTooOld
   , realGsmEntryPoints
   , realMarkerFileView
+    -- * Re-exported
+  , module Ouroboros.Consensus.Node.GsmState
   ) where
 
 import qualified Cardano.Slotting.Slot as Slot
@@ -43,6 +45,7 @@ import qualified Ouroboros.Consensus.HardFork.Abstract as HardFork
 import qualified Ouroboros.Consensus.HardFork.History as HardFork
 import qualified Ouroboros.Consensus.HardFork.History.Qry as Qry
 import qualified Ouroboros.Consensus.Ledger.Basics as L
+import           Ouroboros.Consensus.Node.GsmState
 import           Ouroboros.Consensus.Storage.ChainDB.API (ChainDB)
 import           Ouroboros.Consensus.Util.NormalForm.StrictTVar (StrictTVar)
 import qualified Ouroboros.Consensus.Util.NormalForm.StrictTVar as StrictSTM
@@ -80,19 +83,6 @@ data CandidateVersusSelection =
     -- ^ Whether the candidate is better than the selection
   deriving (Eq, Show)
 
--- | Current state of the Genesis State Machine
-data GsmState =
-    PreSyncing
-    -- ^ We are syncing, and the Honest Availability Assumption is not
-    -- satisfied.
-  |
-    Syncing
-    -- ^ We are syncing, and the Honest Availability Assumption is satisfied.
-  |
-    CaughtUp
-    -- ^ We are caught-up.
-  deriving (Eq, Show, Read)
-
 data GsmView m upstreamPeer selection chainSyncState = GsmView {
     antiThunderingHerd        :: Maybe StdGen
     -- ^ An initial seed used to randomly increase 'minCaughtUpDuration' by up
@@ -168,34 +158,34 @@ data GsmEntryPoints m = GsmEntryPoints {
 
 -----
 
--- | Determine the initial 'LedgerStateJudgment'
+-- | Determine the initial 'GsmState'
 --
 -- Also initializes the persistent marker file.
-initializationLedgerJudgement ::
+initializationGsmState ::
      ( L.GetTip (L.LedgerState blk)
      , Monad m
      )
   => m (L.LedgerState blk)
   -> Maybe (WrapDurationUntilTooOld m blk)
      -- ^ 'Nothing' if @blk@ has no age limit
   -> MarkerFileView m
-  -> m LedgerStateJudgement
-initializationLedgerJudgement
+  -> m GsmState
+initializationGsmState
     getCurrentLedger
     mbDurationUntilTooOld
     markerFileView
   = do
     wasCaughtUp <- hasMarkerFile markerFileView
-    if not wasCaughtUp then pure TooOld else do
+    if not wasCaughtUp then pure PreSyncing else do
         case mbDurationUntilTooOld of
-            Nothing -> return YoungEnough
+            Nothing -> return CaughtUp
             Just wd -> do
                 sno <- L.getTipSlot <$> getCurrentLedger
                 getDurationUntilTooOld wd sno >>= \case
-                    After{}     -> return YoungEnough
+                    After{}     -> return CaughtUp
                     Already     -> do
                         removeMarkerFile markerFileView
-                        return TooOld
+                        return PreSyncing
 
 -- | For 'LedgerStateJudgement' as used in the Diffusion layer, there is no
 -- difference between 'PreSyncing' and 'Syncing'.

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

@@ -0,0 +1,129 @@
+{-# LANGUAGE DeriveTraversable   #-}
+{-# LANGUAGE DerivingStrategies  #-}
+{-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE NamedFieldPuns      #-}
+{-# LANGUAGE NumericUnderscores  #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Ouroboros.Consensus.Node.Genesis (
+    -- * 'GenesisConfig'
+    GenesisConfig (..)
+  , LoEAndGDDConfig (..)
+  , disableGenesisConfig
+  , enableGenesisConfigDefault
+    -- * NodeKernel helpers
+  , GenesisNodeKernelArgs (..)
+  , mkGenesisNodeKernelArgs
+  , setGetLoEFragment
+  ) where
+
+import           Control.Monad (join)
+import           Data.Traversable (for)
+import           Ouroboros.Consensus.Block
+import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client
+                     (CSJConfig (..), CSJEnabledConfig (..),
+                     ChainSyncLoPBucketConfig (..),
+                     ChainSyncLoPBucketEnabledConfig (..))
+import qualified Ouroboros.Consensus.Node.GsmState as GSM
+import           Ouroboros.Consensus.Storage.ChainDB (ChainDbArgs)
+import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB
+import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Args as ChainDB
+import           Ouroboros.Consensus.Util.Args
+import           Ouroboros.Consensus.Util.IOLike
+import           Ouroboros.Network.AnchoredFragment (AnchoredFragment)
+import qualified Ouroboros.Network.AnchoredFragment as AF
+
+-- | Whether to en-/disable the Limit on Eagerness and the Genesis Density
+-- Disconnector.
+data LoEAndGDDConfig a =
+    LoEAndGDDEnabled !a
+  | LoEAndGDDDisabled
+  deriving stock (Show, Functor, Foldable, Traversable)
+
+-- | Aggregating the various configs for Genesis-related subcomponents.
+data GenesisConfig = GenesisConfig {
+    gcChainSyncLoPBucketConfig :: !ChainSyncLoPBucketConfig
+  , gcCSJConfig                :: !CSJConfig
+  , gcLoEAndGDDConfig          :: !(LoEAndGDDConfig ())
+  }
+
+-- TODO justification/derivation from other parameters
+enableGenesisConfigDefault :: GenesisConfig
+enableGenesisConfigDefault = GenesisConfig {
+      gcChainSyncLoPBucketConfig = ChainSyncLoPBucketEnabled ChainSyncLoPBucketEnabledConfig {
+          csbcCapacity = 100_000 -- number of tokens
+        , csbcRate     = 500 -- tokens per second leaking, 1/2ms
+        }
+    , gcCSJConfig = CSJEnabled CSJEnabledConfig {
+          csjcJumpSize = 3 * 2160 * 20 -- mainnet forecast range
+        }
+    , gcLoEAndGDDConfig = LoEAndGDDEnabled ()
+    }
+
+-- | Disable all Genesis components, yielding Praos behavior.
+disableGenesisConfig :: GenesisConfig
+disableGenesisConfig = GenesisConfig {
+      gcChainSyncLoPBucketConfig = ChainSyncLoPBucketDisabled
+    , gcCSJConfig                = CSJDisabled
+    , gcLoEAndGDDConfig          = LoEAndGDDDisabled
+    }
+
+-- | Genesis-related arguments needed by the NodeKernel initialization logic.
+data GenesisNodeKernelArgs m blk = GenesisNodeKernelArgs {
+    -- | A TVar containing an action that returns the 'ChainDB.GetLoEFragment'
+    -- action. We use this extra indirection to update this action after we
+    -- opened the ChainDB (which happens before we initialize the NodeKernel).
+    -- After that, this TVar will not be modified again.
+    gnkaGetLoEFragment :: !(LoEAndGDDConfig (StrictTVar m (ChainDB.GetLoEFragment m blk)))
+  }
+
+-- | Create the initial 'GenesisNodeKernelArgs" (with a temporary
+-- 'ChainDB.GetLoEFragment' that will be replaced via 'setGetLoEFragment') and a
+-- function to update the 'ChainDbArgs' accordingly.
+mkGenesisNodeKernelArgs ::
+     forall m blk. (IOLike m, GetHeader blk)
+  => GenesisConfig
+  -> m ( GenesisNodeKernelArgs m blk
+       , Complete ChainDbArgs m blk -> Complete ChainDbArgs m blk
+       )
+mkGenesisNodeKernelArgs gcfg = do
+    gnkaGetLoEFragment <- for (gcLoEAndGDDConfig gcfg) $ \() ->
+        newTVarIO $ pure $
+          -- Use the most conservative LoE fragment until 'setGetLoEFragment'
+          -- is called.
+          ChainDB.LoEEnabled $ AF.Empty AF.AnchorGenesis
+    let updateChainDbArgs = case gnkaGetLoEFragment of
+          LoEAndGDDDisabled -> id
+          LoEAndGDDEnabled varGetLoEFragment -> \cfg ->
+            cfg { ChainDB.cdbsArgs =
+                  (ChainDB.cdbsArgs cfg) { ChainDB.cdbsLoE = getLoEFragment }
+                }
+            where
+              getLoEFragment = join $ readTVarIO varGetLoEFragment
+    pure (GenesisNodeKernelArgs {gnkaGetLoEFragment}, updateChainDbArgs)
+
+-- | Set 'gnkaGetLoEFragment' to the actual logic for determining the current
+-- LoE fragment.
+setGetLoEFragment ::
+     forall m blk. (IOLike m, GetHeader blk)
+  => STM m GSM.GsmState
+  -> STM m (AnchoredFragment (Header blk))
+     -- ^ The LoE fragment.
+  -> StrictTVar m (ChainDB.GetLoEFragment m blk)
+  -> m ()
+setGetLoEFragment readGsmState readLoEFragment varGetLoEFragment =
+    atomically $ writeTVar varGetLoEFragment getLoEFragment
+  where
+    getLoEFragment :: ChainDB.GetLoEFragment m blk
+    getLoEFragment = atomically $ readGsmState >>= \case
+        -- When the HAA can currently not be guaranteed, we should not select
+        -- any blocks that would cause our immutable tip to advance, so we
+        -- return the most conservative LoE fragment.
+        GSM.PreSyncing ->
+          pure $ ChainDB.LoEEnabled $ AF.Empty AF.AnchorGenesis
+        -- When we are syncing, return the current LoE fragment.
+        GSM.Syncing    ->
+          ChainDB.LoEEnabled <$> readLoEFragment
+        -- When we are caught up, the LoE is disabled.
+        GSM.CaughtUp   ->
+          pure ChainDB.LoEDisabled