Implement a GDD governor

ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs

@@ -43,6 +43,7 @@ module Ouroboros.Consensus.Byron.Ledger.Ledger (
 
 import qualified Cardano.Chain.Block as CC
 import qualified Cardano.Chain.Byron.API as CC
+import qualified Cardano.Chain.Common as Gen
 import qualified Cardano.Chain.Genesis as Gen
 import qualified Cardano.Chain.Update as Update
 import qualified Cardano.Chain.Update.Validation.Endorsement as UPE
@@ -74,6 +75,8 @@ import           Ouroboros.Consensus.Config
 import           Ouroboros.Consensus.Forecast
 import           Ouroboros.Consensus.HardFork.Abstract
 import qualified Ouroboros.Consensus.HardFork.History as HardFork
+import           Ouroboros.Consensus.HardFork.History.EraParams
+                     (EraParams (eraGenesisWin))
 import           Ouroboros.Consensus.HeaderValidation
 import           Ouroboros.Consensus.Ledger.Abstract
 import           Ouroboros.Consensus.Ledger.CommonProtocolParams
@@ -278,6 +281,7 @@ byronEraParams genesis = HardFork.EraParams {
       eraEpochSize  = fromByronEpochSlots $ Gen.configEpochSlots genesis
     , eraSlotLength = fromByronSlotLength $ genesisSlotLength genesis
     , eraSafeZone   = HardFork.StandardSafeZone (2 * k)
+    , eraGenesisWin = GenesisWindow (2 * k)
     }
   where
     SecurityParam k = genesisSecurityParam genesis
@@ -288,6 +292,7 @@ byronEraParamsNeverHardForks genesis = HardFork.EraParams {
       eraEpochSize  = fromByronEpochSlots $ Gen.configEpochSlots genesis
     , eraSlotLength = fromByronSlotLength $ genesisSlotLength genesis
     , eraSafeZone   = HardFork.UnsafeIndefiniteSafeZone
+    , eraGenesisWin = GenesisWindow (2 * Gen.unBlockCount (Gen.configK genesis))
     }
 
 instance HasHardForkHistory ByronBlock where

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

@@ -134,6 +134,7 @@ shelleyEraParams genesis = HardFork.EraParams {
       eraEpochSize  = SL.sgEpochLength genesis
     , eraSlotLength = mkSlotLength $ SL.fromNominalDiffTimeMicro $ SL.sgSlotLength genesis
     , eraSafeZone   = HardFork.StandardSafeZone stabilityWindow
+    , eraGenesisWin = GenesisWindow stabilityWindow
     }
   where
     stabilityWindow =
@@ -147,7 +148,13 @@ shelleyEraParamsNeverHardForks genesis = HardFork.EraParams {
       eraEpochSize  = SL.sgEpochLength genesis
     , eraSlotLength = mkSlotLength $ SL.fromNominalDiffTimeMicro $ SL.sgSlotLength genesis
     , eraSafeZone   = HardFork.UnsafeIndefiniteSafeZone
+    , eraGenesisWin = GenesisWindow stabilityWindow
     }
+  where
+    stabilityWindow =
+        SL.computeStabilityWindow
+          (SL.sgSecurityParam genesis)
+          (SL.sgActiveSlotCoeff genesis)
 
 mkShelleyLedgerConfig ::
      SL.ShelleyGenesis (EraCrypto era)

ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/Generators.hs

@@ -554,6 +554,7 @@ instance Arbitrary History.EraParams where
       <$> (EpochSize <$> arbitrary)
       <*> arbitrary
       <*> arbitrary
+      <*> (GenesisWindow <$> arbitrary)
 
 instance Arbitrary History.EraSummary where
   arbitrary = History.EraSummary

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

@@ -218,6 +218,7 @@ test-suite consensus-test
     Test.Consensus.Genesis.Setup.Classifiers
     Test.Consensus.Genesis.Setup.GenChains
     Test.Consensus.Genesis.Tests
+    Test.Consensus.Genesis.Tests.DensityDisconnect
     Test.Consensus.Genesis.Tests.LoE
     Test.Consensus.Genesis.Tests.LongRangeAttack
     Test.Consensus.Genesis.Tests.LoP

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

@@ -571,10 +571,11 @@ mkApps kernel Tracers {..} mkCodecs ByteLimits {..} genChainSyncTimeout lopBucke
             (CsClient.defaultChainDbView (getChainDB kernel))
             (getNodeCandidates kernel)
             (getNodeIdlers     kernel)
+            (getChainSyncHandles kernel)
             them
             version
             lopBucketConfig
-            $ \varCandidate (startIdling, stopIdling) (pauseLoPBucket, resumeLoPBucket, grantLoPToken) -> do
+            $ \varCandidate (startIdling, stopIdling) (pauseLoPBucket, resumeLoPBucket, grantLoPToken) setTheirTip setLatestSlot -> do
               chainSyncTimeout <- genChainSyncTimeout
               (r, trailing) <-
                 runPipelinedPeerWithLimits
@@ -597,6 +598,8 @@ mkApps kernel Tracers {..} mkCodecs ByteLimits {..} genChainSyncTimeout lopBucke
                         , CsClient.pauseLoPBucket
                         , CsClient.resumeLoPBucket
                         , CsClient.grantLoPToken
+                        , CsClient.setTheirTip
+                        , CsClient.setLatestSlot
                         }
               return (ChainSyncInitiatorResult r, trailing)
 

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

@@ -60,6 +60,8 @@ import           Ouroboros.Consensus.Ledger.SupportsPeerSelection
 import           Ouroboros.Consensus.Ledger.SupportsProtocol
 import           Ouroboros.Consensus.Mempool
 import qualified Ouroboros.Consensus.MiniProtocol.BlockFetch.ClientInterface as BlockFetchClientInterface
+import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client
+                     (ChainSyncClientHandle)
 import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client.InFutureCheck
                      (SomeHeaderInFutureCheck)
 import           Ouroboros.Consensus.Node.GSM (GsmNodeKernelArgs (..))
@@ -133,6 +135,8 @@ data NodeKernel m addrNTN addrNTC blk = NodeKernel {
       -- headers beyond their current candidate
     , getNodeIdlers           :: StrictTVar m (Set (ConnectionId addrNTN))
 
+    , getChainSyncHandles    :: StrictTVar m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
+
       -- | Read the current peer sharing registry, used for interacting with
       -- the PeerSharing protocol
     , getPeerSharingRegistry  :: PeerSharingRegistry addrNTN m
@@ -250,6 +254,8 @@ initNodeKernel args@NodeKernelArgs { registry, cfg, tracers
         fetchClientRegistry
         blockFetchConfiguration
 
+    varChainSyncHandles <- newTVarIO mempty
+
     return NodeKernel
       { getChainDB              = chainDB
       , getMempool              = mempool
@@ -258,6 +264,7 @@ initNodeKernel args@NodeKernelArgs { registry, cfg, tracers
       , getFetchMode            = readFetchMode blockFetchInterface
       , getLedgerStateJudgement = readTVar varLedgerJudgement
       , getNodeCandidates       = varCandidates
+      , getChainSyncHandles     = varChainSyncHandles
       , getNodeIdlers           = varIdlers
       , getPeerSharingRegistry  = peerSharingRegistry
       , getTracers              = tracers