Add the pre-Genesis State Machine for bootstrap peers (#808)

The Genesis SoW will deliver a proper GSM. In the interim, this PR defines a GSM that is suitable for use with the bootstrap-peers intermediate solution (see IntersectMBO/ouroboros-network#4555). The relevant high-level specification is rendered here https://ouroboros-consensus.cardano.intersectmbo.org/docs/for-developers/BootstrapPeersIER
IntersectMBO · Feb 22, 2024 · ca23fa5 · ca23fa5
2 parents 937dd07 + 00ff278
commit ca23fa5
Show file tree

Hide file tree

Showing 23 changed files with 2,175 additions and 77 deletions.
diff --git a/cabal.project b/cabal.project
@@ -31,3 +31,23 @@ tests: true
 benchmarks: true
 
 import: ./asserts.cabal
+
+source-repository-package
+    type: git
+    location: https://github.com/input-output-hk/ouroboros-network/
+    tag: 8ab444850b9d654110cd751a17c21db814bba593
+    subdir: monoidal-synchronisation
+            network-mux
+            ouroboros-network
+            ouroboros-network-api
+            ouroboros-network-framework
+            ouroboros-network-protocols
+            ouroboros-network-testing
+    --sha256: 1vw8r8csa6lq4330bwgddxa4nl2m1pw1ps5y6l7lw2zw3xdlr0hf
+
+source-repository-package
+    type: git
+    location: https://github.com/input-output-hk/io-sim
+    tag: 85d633d6f9c76ffb678b36396c8fd39b2ff7219e
+    subdir: io-sim
+    --sha256: 10f54xg88wq2w7ylg3n33f1yiswd6w4dam7fvl12raiqj0rk21qm
diff --git a/...os-consensus-diffusion/changelog.d/20240220_122811_nick.frisby_bootstrap_gsm.md b/...os-consensus-diffusion/changelog.d/20240220_122811_nick.frisby_bootstrap_gsm.md
@@ -0,0 +1,34 @@
+<!--
+A new scriv changelog fragment.
+
+Uncomment the section that is right (remove the HTML comment wrapper).
+-->
+
+<!--
+### Patch
+
+- A bullet item for the Patch category.
+
+-->
+
+### Non-Breaking
+
+- Added `getImmTipSlot` to `NodeKernel` exports.
+
+### Breaking
+
+- Added the Genesis State Machine (GSM), though for now it is merely the
+  simpler [Bootstrap Peers State
+  Machine](https://ouroboros-consensus.cardano.intersectmbo.org/docs/for-developers/BootstrapPeersIER).
+
+- Added `rnGetUseBootstrapPeers` to `RunNodeArgs`, for dynamically
+  enabling/disabling the GSM. The proper GSM must always be running, despite
+  the TVar it owns being ignored when it's disabled, since it may be enabled at
+  any time.
+
+- Added `llrnMaxCaughtUpAge` to the low-level args; defaults to 20min.
+
+- Added `gsmTracer` to the node's tracers.
+
+- Added `getNodeIdlers` to the `NodeKernel` interface; tracking peers that have
+  last sent `MsgAwaitReply`.
diff --git a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal
@@ -56,6 +56,7 @@ library
     Ouroboros.Consensus.Node.ErrorPolicy
     Ouroboros.Consensus.Node.Exit
     Ouroboros.Consensus.Node.ExitPolicy
+    Ouroboros.Consensus.Node.GSM
     Ouroboros.Consensus.Node.Recovery
     Ouroboros.Consensus.Node.RethrowPolicy
     Ouroboros.Consensus.Node.Tracers
@@ -69,6 +70,7 @@ library
   build-depends:
     , base                         >=4.14   && <4.20
     , bytestring                   >=0.10   && <0.13
+    , cardano-slotting
     , cborg                        ^>=0.2.2
     , containers                   >=0.5    && <0.7
     , contra-tracer
@@ -217,9 +219,12 @@ test-suite consensus-test
     Test.Consensus.Genesis.Setup.GenChains
     Test.Consensus.Genesis.Tests
     Test.Consensus.Genesis.Tests.LongRangeAttack
+    Test.Consensus.GSM
+    Test.Consensus.GSM.Model
     Test.Consensus.HardFork.Combinator
     Test.Consensus.HardFork.Combinator.A
     Test.Consensus.HardFork.Combinator.B
+    Test.Consensus.IOSimQSM.Test.StateMachine.Sequential
     Test.Consensus.Network.AnchoredFragment.Extras
     Test.Consensus.Network.Driver.Limits.Extras
     Test.Consensus.Node
@@ -255,18 +260,22 @@ test-suite consensus-test
     , ouroboros-network-framework
     , ouroboros-network-mock
     , ouroboros-network-protocols
+    , pretty-show
     , QuickCheck
+    , quickcheck-state-machine:no-vendored-treediff
     , quiet
     , serialise
     , si-timers
     , sop-extras
+    , strict-checked-vars
     , strict-sop-core
     , strict-stm
     , tasty
     , tasty-hunit
     , tasty-quickcheck
     , temporary
     , time
+    , tree-diff
     , typed-protocols
     , typed-protocols-examples
     , unstable-diffusion-testlib

diff --git a/...sus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs b/...sus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs
@@ -569,8 +569,9 @@ mkApps kernel Tracers {..} mkCodecs ByteLimits {..} genChainSyncTimeout ReportPe
             (contramap (TraceLabelPeer them) (Node.chainSyncClientTracer (getTracers kernel)))
             (CsClient.defaultChainDbView (getChainDB kernel))
             (getNodeCandidates kernel)
+            (getNodeIdlers     kernel)
             them
-            version $ \varCandidate -> do
+            version $ \varCandidate (startIdling, stopIdling) -> do
               chainSyncTimeout <- genChainSyncTimeout
               (r, trailing) <-
                 runPipelinedPeerWithLimits
@@ -588,6 +589,8 @@ mkApps kernel Tracers {..} mkCodecs ByteLimits {..} genChainSyncTimeout ReportPe
                         , CsClient.controlMessageSTM
                         , CsClient.headerMetricsTracer = TraceLabelPeer them `contramap` reportHeader
                         , CsClient.varCandidate
+                        , CsClient.startIdling
+                        , CsClient.stopIdling
                         }
               return (ChainSyncInitiatorResult r, trailing)
 

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
@@ -21,6 +21,7 @@ module Ouroboros.Consensus.Node (
   , StdRunNodeArgs (..)
   , stdBfcSaltIO
   , stdChainSyncTimeout
+  , stdGsmAntiThunderingHerdIO
   , stdKeepAliveRngIO
   , stdLowLevelRunNodeArgsIO
   , stdMkChainDbHasFS
@@ -66,6 +67,7 @@ import           Data.Hashable (Hashable)
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import           Data.Maybe (fromMaybe, isNothing)
+import           Data.Time (NominalDiffTime)
 import           Data.Typeable (Typeable)
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.BlockchainTime hiding (getSystemStart)
@@ -82,6 +84,8 @@ import           Ouroboros.Consensus.Node.DbLock
 import           Ouroboros.Consensus.Node.DbMarker
 import           Ouroboros.Consensus.Node.ErrorPolicy
 import           Ouroboros.Consensus.Node.ExitPolicy
+import           Ouroboros.Consensus.Node.GSM (GsmNodeKernelArgs (..))
+import qualified Ouroboros.Consensus.Node.GSM as GSM
 import           Ouroboros.Consensus.Node.InitStorage
 import           Ouroboros.Consensus.Node.NetworkProtocolVersion
 import           Ouroboros.Consensus.Node.ProtocolInfo
@@ -116,6 +120,7 @@ import           Ouroboros.Network.NodeToNode (DiffusionMode (..),
                      ExceptionInHandler (..), MiniProtocolParameters,
                      NodeToNodeVersionData (..), RemoteAddress, Socket,
                      blockFetchPipeliningMax, defaultMiniProtocolParameters)
+import           Ouroboros.Network.PeerSelection.Bootstrap (UseBootstrapPeers)
 import           Ouroboros.Network.PeerSelection.LedgerPeers
                      (LedgerPeersConsensusInterface (..))
 import           Ouroboros.Network.PeerSelection.PeerMetric (PeerMetrics,
@@ -185,6 +190,8 @@ data RunNodeArgs m addrNTN addrNTC blk (p2p :: Diffusion.P2P) = RunNodeArgs {
 
       -- | Network PeerSharing miniprotocol willingness flag
     , rnPeerSharing :: PeerSharing
+
+    , rnGetUseBootstrapPeers :: STM m UseBootstrapPeers
     }
 
 -- | Arguments that usually only tests /directly/ specify.
@@ -222,6 +229,9 @@ data LowLevelRunNodeArgs m addrNTN addrNTC versionDataNTN versionDataNTC blk
       -- | Ie 'bfcSalt'
     , llrnBfcSalt :: Int
 
+      -- | Ie 'gsmAntiThunderingHerd'
+    , llrnGsmAntiThunderingHerd :: StdGen
+
       -- | Ie 'keepAliveRng'
     , llrnKeepAliveRng :: StdGen
 
@@ -255,6 +265,10 @@ data LowLevelRunNodeArgs m addrNTN addrNTC versionDataNTN versionDataNTC blk
       -- | node-to-client protocol versions to run.
     , llrnNodeToClientVersions :: Map NodeToClientVersion (BlockNodeToClientVersion blk)
 
+      -- | If the volatile tip is older than this, then the node will exit the
+      -- @CaughtUp@ state.
+    , llrnMaxCaughtUpAge :: NominalDiffTime
+
       -- | Maximum clock skew
     , llrnMaxClockSkew :: ClockSkew
     }
@@ -365,8 +379,15 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} =
                   , ChainDB.cdbVolatileDbValidation  = ValidateAll
                   }
 
-        chainDB <- openChainDB registry inFuture cfg initLedger
-                  llrnChainDbArgsDefaults customiseChainDbArgs'
+        let finalChainDbArgs =
+              mkFinalChainDbArgs
+                registry
+                inFuture
+                cfg
+                initLedger
+                llrnChainDbArgsDefaults
+                customiseChainDbArgs'
+        chainDB <- ChainDB.openDB finalChainDbArgs
 
         continueWithCleanChainDB chainDB $ do
           btime <-
@@ -385,17 +406,30 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} =
               , hfbtMaxClockRewind = secondsToNominalDiffTime 20
               }
 
-          nodeKernelArgs <-
-              fmap (nodeKernelArgsEnforceInvariants . llrnCustomiseNodeKernelArgs) $
-              mkNodeKernelArgs
-                registry
-                llrnBfcSalt
-                llrnKeepAliveRng
-                cfg
-                rnTraceConsensus
-                btime
-                (InFutureCheck.realHeaderInFutureCheck llrnMaxClockSkew systemTime)
-                chainDB
+          nodeKernelArgs <- do
+              durationUntilTooOld <- GSM.realDurationUntilTooOld
+                (configLedger cfg)
+                (ledgerState <$> ChainDB.getCurrentLedger chainDB)
+                llrnMaxCaughtUpAge
+                systemTime
+              let gsmMarkerFileView =
+                    case ChainDB.cdbHasFSGsmDB finalChainDbArgs of
+                        SomeHasFS x -> GSM.realMarkerFileView chainDB x
+              fmap (nodeKernelArgsEnforceInvariants . llrnCustomiseNodeKernelArgs)
+                $ mkNodeKernelArgs
+                    registry
+                    llrnBfcSalt
+                    llrnGsmAntiThunderingHerd
+                    llrnKeepAliveRng
+                    cfg
+                    rnTraceConsensus
+                    btime
+                    (InFutureCheck.realHeaderInFutureCheck llrnMaxClockSkew systemTime)
+                    chainDB
+                    llrnMaxCaughtUpAge
+                    (Just durationUntilTooOld)
+                    gsmMarkerFileView
+                    rnGetUseBootstrapPeers
           nodeKernel <- initNodeKernel nodeKernelArgs
           rnNodeKernelHook registry nodeKernel
 
@@ -550,8 +584,11 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} =
                 | (version, blockVersion) <- Map.toList llrnNodeToClientVersions
                 ],
             Diffusion.daLedgerPeersCtx =
-              LedgerPeersConsensusInterface
-                (getPeersFromCurrentLedgerAfterSlot kernel)
+              LedgerPeersConsensusInterface {
+                  lpGetLatestSlot = getImmTipSlot kernel,
+                  lpGetLedgerPeers = fromMaybe [] <$> getPeersFromCurrentLedger kernel (const True),
+                  lpGetLedgerStateJudgement = getLedgerStateJudgement kernel
+                }
           }
 
         localRethrowPolicy :: RethrowPolicy
@@ -599,13 +636,25 @@ openChainDB ::
       -- ^ Customise the 'ChainDbArgs'
   -> m (ChainDB m blk)
 openChainDB registry inFuture cfg initLedger defArgs customiseArgs =
-    ChainDB.openDB args
-  where
-    args :: ChainDbArgs Identity m blk
-    args = customiseArgs $
-             mkChainDbArgs registry inFuture cfg initLedger
-             (nodeImmutableDbChunkInfo (configStorage cfg))
-             defArgs
+    ChainDB.openDB
+  $ mkFinalChainDbArgs registry inFuture cfg initLedger defArgs customiseArgs
+
+mkFinalChainDbArgs
+  :: forall m blk. (RunNode blk, IOLike m)
+  => ResourceRegistry m
+  -> CheckInFuture m blk
+  -> TopLevelConfig blk
+  -> ExtLedgerState blk
+     -- ^ Initial ledger
+  -> ChainDbArgs Defaults m blk
+  -> (ChainDbArgs Identity m blk -> ChainDbArgs Identity m blk)
+      -- ^ Customise the 'ChainDbArgs'
+  -> ChainDbArgs Identity m blk
+mkFinalChainDbArgs registry inFuture cfg initLedger defArgs customiseArgs =
+    customiseArgs $
+      mkChainDbArgs registry inFuture cfg initLedger
+      (nodeImmutableDbChunkInfo (configStorage cfg))
+      defArgs
 
 mkChainDbArgs ::
      forall m blk. (RunNode blk, IOLike m)
@@ -639,21 +688,31 @@ mkNodeKernelArgs ::
   => ResourceRegistry m
   -> Int
   -> StdGen
+  -> StdGen
   -> TopLevelConfig blk
   -> Tracers m (ConnectionId addrNTN) (ConnectionId addrNTC) blk
   -> BlockchainTime m
   -> InFutureCheck.SomeHeaderInFutureCheck m blk
   -> ChainDB m blk
+  -> NominalDiffTime
+  -> Maybe (GSM.WrapDurationUntilTooOld m blk)
+  -> GSM.MarkerFileView m
+  -> STM m UseBootstrapPeers
   -> m (NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk)
 mkNodeKernelArgs
   registry
   bfcSalt
+  gsmAntiThunderingHerd
   keepAliveRng
   cfg
   tracers
   btime
   chainSyncFutureCheck
   chainDB
+  maxCaughtUpAge
+  gsmDurationUntilTooOld
+  gsmMarkerFileView
+  getUseBootstrapPeers
   = do
     return NodeKernelArgs
       { tracers
@@ -668,6 +727,13 @@ mkNodeKernelArgs
       , miniProtocolParameters  = defaultMiniProtocolParameters
       , blockFetchConfiguration = defaultBlockFetchConfiguration
       , keepAliveRng
+      , gsmArgs = GsmNodeKernelArgs {
+          gsmAntiThunderingHerd
+        , gsmDurationUntilTooOld
+        , gsmMarkerFileView
+        , gsmMinCaughtUpDuration = maxCaughtUpAge
+        }
+      , getUseBootstrapPeers
       }
   where
     defaultBlockFetchConfiguration :: BlockFetchConfiguration
@@ -719,6 +785,9 @@ stdMkChainDbHasFS rootPath (ChainDB.RelativeMountPoint relPath) =
 stdBfcSaltIO :: IO Int
 stdBfcSaltIO = randomIO
 
+stdGsmAntiThunderingHerdIO :: IO StdGen
+stdGsmAntiThunderingHerdIO = newStdGen
+
 stdKeepAliveRngIO :: IO StdGen
 stdKeepAliveRngIO = newStdGen
 
@@ -836,12 +905,14 @@ stdLowLevelRunNodeArgsIO RunNodeArgs{ rnProtocolInfo
                                     , rnPeerSharing
                                     }
                          StdRunNodeArgs{..} = do
-    llrnBfcSalt      <- stdBfcSaltIO
-    llrnKeepAliveRng <- stdKeepAliveRngIO
+    llrnBfcSalt               <- stdBfcSaltIO
+    llrnGsmAntiThunderingHerd <- stdGsmAntiThunderingHerdIO
+    llrnKeepAliveRng          <- stdKeepAliveRngIO
     pure LowLevelRunNodeArgs
       { llrnBfcSalt
       , llrnChainSyncTimeout = fromMaybe stdChainSyncTimeout srnChainSyncTimeout
       , llrnCustomiseHardForkBlockchainTimeArgs = id
+      , llrnGsmAntiThunderingHerd
       , llrnKeepAliveRng
       , llrnChainDbArgsDefaults =
           updateChainDbDefaults $ ChainDB.defaultArgs mkHasFS
@@ -878,6 +949,7 @@ stdLowLevelRunNodeArgsIO RunNodeArgs{ rnProtocolInfo
             (supportedNodeToClientVersions (Proxy @blk))
       , llrnWithCheckedDB =
           stdWithCheckedDB (Proxy @blk) srnDatabasePath networkMagic
+      , llrnMaxCaughtUpAge = secondsToNominalDiffTime $ 20 * 60   -- 20 min
       , llrnMaxClockSkew =
           InFuture.defaultClockSkew
       }