Update Genesis configuration

* Move Genesis-specific BlockFetch config to GenesisConfig
* Introduce GenesisConfigFlags for interaction with config files/CLI
* Add missing instances for Genesis configuration

Author: nbacquey

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

@@ -1,24 +1,31 @@
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Ouroboros.Consensus.Node.Genesis (
     -- * 'GenesisConfig'
     GenesisConfig (..)
+  , GenesisConfigFlags (..)
   , LoEAndGDDConfig (..)
+  , defaultGenesisConfigFlags
   , disableGenesisConfig
   , enableGenesisConfigDefault
+  , mkGenesisConfig
     -- * NodeKernel helpers
   , GenesisNodeKernelArgs (..)
   , mkGenesisNodeKernelArgs
   , setGetLoEFragment
   ) where
 
 import           Control.Monad (join)
+import           Data.Maybe (fromMaybe)
 import           Data.Traversable (for)
+import           GHC.Generics (Generic)
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client
                      (CSJConfig (..), CSJEnabledConfig (..),
@@ -34,47 +41,111 @@ import           Ouroboros.Consensus.Util.Args
 import           Ouroboros.Consensus.Util.IOLike
 import           Ouroboros.Network.AnchoredFragment (AnchoredFragment)
 import qualified Ouroboros.Network.AnchoredFragment as AF
+import           Ouroboros.Network.BlockFetch
+                     (GenesisBlockFetchConfiguration (..))
 
 -- | 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)
+  deriving stock (Eq, Generic, Show, Functor, Foldable, Traversable)
 
 -- | Aggregating the various configs for Genesis-related subcomponents.
-data GenesisConfig = GenesisConfig {
-    gcChainSyncLoPBucketConfig :: !ChainSyncLoPBucketConfig
+--
+-- Usually, 'enableGenesisConfigDefault' or 'disableGenesisConfig' can be used.
+-- See the haddocks of the types of the individual fields for details.
+data GenesisConfig = GenesisConfig
+  { gcBlockFetchConfig         :: !GenesisBlockFetchConfiguration
+  , gcChainSyncLoPBucketConfig :: !ChainSyncLoPBucketConfig
   , gcCSJConfig                :: !CSJConfig
   , gcLoEAndGDDConfig          :: !(LoEAndGDDConfig ())
   , gcHistoricityCutoff        :: !(Maybe HistoricityCutoff)
+  } deriving stock (Eq, Generic, Show)
+
+-- | Genesis configuration flags and low-level args, as parsed from config file or CLI
+data GenesisConfigFlags = GenesisConfigFlags
+  { gcfEnableCSJ           :: Bool
+  , gcfEnableLoEAndGDD     :: Bool
+  , gcfEnableLoP           :: Bool
+  , gcfBulkSyncGracePeriod :: Maybe Integer
+  , gcfBucketCapacity      :: Maybe Integer
+  , gcfBucketRate          :: Maybe Integer
+  , gcfCSJJumpSize         :: Maybe Integer
+  } deriving stock (Eq, Generic, Show)
+
+defaultGenesisConfigFlags :: GenesisConfigFlags
+defaultGenesisConfigFlags = GenesisConfigFlags
+  { gcfEnableCSJ            = True
+  , gcfEnableLoEAndGDD      = True
+  , gcfEnableLoP            = True
+  , gcfBulkSyncGracePeriod  = Nothing
+  , gcfBucketCapacity       = Nothing
+  , gcfBucketRate           = Nothing
+  , gcfCSJJumpSize          = Nothing
   }
 
--- 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 ()
-      -- Duration in seconds of one Cardano mainnet Shelley stability window
-      -- (3k/f slots times one second per slot) plus one extra hour as a
-      -- safety margin.
-    , gcHistoricityCutoff = Just $ HistoricityCutoff $ 3 * 2160 * 20 + 3600
-    }
+enableGenesisConfigDefault = mkGenesisConfig $ Just defaultGenesisConfigFlags
 
 -- | Disable all Genesis components, yielding Praos behavior.
 disableGenesisConfig :: GenesisConfig
-disableGenesisConfig = GenesisConfig {
-      gcChainSyncLoPBucketConfig = ChainSyncLoPBucketDisabled
+disableGenesisConfig = mkGenesisConfig Nothing
+
+mkGenesisConfig :: Maybe GenesisConfigFlags -> GenesisConfig
+mkGenesisConfig Nothing = -- disable Genesis
+  GenesisConfig
+    { gcBlockFetchConfig = GenesisBlockFetchConfiguration
+        { gbfcBulkSyncGracePeriod = 0 -- no grace period when Genesis is disabled
+        }
+    , gcChainSyncLoPBucketConfig = ChainSyncLoPBucketDisabled
     , gcCSJConfig                = CSJDisabled
     , gcLoEAndGDDConfig          = LoEAndGDDDisabled
     , gcHistoricityCutoff        = Nothing
     }
+mkGenesisConfig (Just GenesisConfigFlags{..}) =
+  GenesisConfig
+    { gcBlockFetchConfig = GenesisBlockFetchConfiguration
+        { gbfcBulkSyncGracePeriod
+        }
+    , gcChainSyncLoPBucketConfig = if gcfEnableLoP
+        then ChainSyncLoPBucketEnabled ChainSyncLoPBucketEnabledConfig
+          { csbcCapacity
+          , csbcRate
+          }
+        else ChainSyncLoPBucketDisabled
+    , gcCSJConfig = if gcfEnableCSJ
+        then CSJEnabled CSJEnabledConfig
+          { csjcJumpSize
+          }
+        else CSJDisabled
+    , gcLoEAndGDDConfig = if gcfEnableLoEAndGDD
+        then LoEAndGDDEnabled ()
+        else LoEAndGDDDisabled
+    , -- Duration in seconds of one Cardano mainnet Shelley stability window
+      -- (3k/f slots times one second per slot) plus one extra hour as a
+      -- safety margin.
+      gcHistoricityCutoff = Just $ HistoricityCutoff $ 3 * 2160 * 20 + 3600
+    }
+  where
+    -- The minimum amount of time during which the Genesis BlockFetch logic will
+    -- download blocks from a specific peer (even if it is not performing well
+    -- during that period).
+    defaultBulkSyncGracePeriod = 10 -- seconds
+
+    -- LoP parameters. Empirically, it takes less than 1ms to validate a header,
+    -- so leaking one token per 2ms is conservative. The capacity of 100_000
+    -- tokens corresponds to 200s, which is definitely enough to handle long GC
+    -- pauses; we could even make this more conservative.
+    defaultCapacity = 100_000 -- number of tokens
+    defaultRate     = 500 -- tokens per second leaking, 1/2ms
+
+    defaultCSJJumpSize = 3 * 2160 * 20 -- mainnet forecast range
+
+    gbfcBulkSyncGracePeriod = fromInteger $ fromMaybe defaultBulkSyncGracePeriod gcfBulkSyncGracePeriod
+    csbcCapacity            = fromInteger $ fromMaybe defaultCapacity gcfBucketCapacity
+    csbcRate                = fromInteger $ fromMaybe defaultRate gcfBucketRate
+    csjcJumpSize            = fromInteger $ fromMaybe defaultCSJJumpSize gcfCSJJumpSize
 
 -- | Genesis-related arguments needed by the NodeKernel initialization logic.
 data GenesisNodeKernelArgs m blk = GenesisNodeKernelArgs {
@@ -124,9 +195,10 @@ setGetLoEFragment readGsmState readLoEFragment varGetLoEFragment =
   where
     getLoEFragment :: ChainDB.GetLoEFragment m blk
     getLoEFragment = atomically $ readGsmState >>= \case
-        -- When the Honest Availability Assumption cannot currently be guaranteed, we should not select
-        -- any blocks that would cause our immutable tip to advance, so we
-        -- return the most conservative LoE fragment.
+        -- When the Honest Availability Assumption cannot currently 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.

ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs

@@ -1019,6 +1019,7 @@ runThreadNetwork systemTime ThreadNetworkArgs
                                                   -- interval which doesn't play nice with
                                                   -- blockfetch descision interval.
                 , bfcSalt                   = 0
+                , bfcGenesisBFConfig        = gcBlockFetchConfig enableGenesisConfigDefault
                 }
             , gsmArgs                 = GSM.GsmNodeKernelArgs {
                   gsmAntiThunderingHerd  = kaRng

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs

@@ -98,13 +98,20 @@ startBlockFetchLogic registry tracer chainDb fetchClientRegistry csHandlesCol =
             (pure FetchModeDeadline)
             DiffusionPipeliningOn
 
+        bfcGenesisBFConfig = if enableChainSelStarvation
+          then GenesisBlockFetchConfiguration
+            { gbfcBulkSyncGracePeriod = 1000000 -- (more than 11 days)
+            }
+          else gcBlockFetchConfig enableGenesisConfigDefault
+
         -- Values taken from
         -- ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs
         blockFetchCfg = BlockFetchConfiguration
           { bfcMaxConcurrencyDeadline = 50 -- unused because of @pure FetchModeBulkSync@ above
           , bfcMaxRequestsInflight = 10
           , bfcDecisionLoopInterval = 0
           , bfcSalt = 0
+          , bfcBulkSyncGracePeriod
           }
 
     void $ forkLinkedThread registry "BlockFetchLogic" $

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs

@@ -167,7 +167,7 @@ data ChainSyncLoPBucketEnabledConfig = ChainSyncLoPBucketEnabledConfig {
     csbcCapacity :: Integer,
     -- | The rate of the bucket (think tokens per second).
     csbcRate     :: Rational
-  }
+  } deriving stock (Eq, Generic, Show)
 
 -- | Configuration of the leaky bucket.
 data ChainSyncLoPBucketConfig
@@ -178,6 +178,7 @@ data ChainSyncLoPBucketConfig
   |
     -- | Enable the leaky bucket.
     ChainSyncLoPBucketEnabled ChainSyncLoPBucketEnabledConfig
+  deriving stock (Eq, Generic, Show)
 
 -- | Configuration of ChainSync Jumping
 data CSJConfig
@@ -188,6 +189,7 @@ data CSJConfig
   |
     -- | Enable ChainSync Jumping
     CSJEnabled CSJEnabledConfig
+  deriving stock (Eq, Generic, Show)
 
 newtype CSJEnabledConfig = CSJEnabledConfig {
   -- | The _ideal_ size for ChainSync jumps. Note that the algorithm
@@ -207,7 +209,7 @@ newtype CSJEnabledConfig = CSJEnabledConfig {
   -- window has a higher change that dishonest peers can delay syncing by a
   -- small margin (around 2 minutes per dishonest peer with mainnet parameters).
   csjcJumpSize       :: SlotNo
-}
+} deriving stock (Eq, Generic, Show)
 
 defaultChainDbView ::
      (IOLike m, LedgerSupportsProtocol blk)

ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs

@@ -53,9 +53,9 @@ import           Ouroboros.Network.AnchoredFragment (AnchoredFragment)
 import qualified Ouroboros.Network.AnchoredFragment as AF
 import           Ouroboros.Network.BlockFetch (BlockFetchConfiguration (..),
                      BlockFetchConsensusInterface (..), FetchMode (..),
-                     blockFetchLogic, bracketFetchClient,
-                     bracketKeepAliveClient, bracketSyncWithFetchClient,
-                     newFetchClientRegistry)
+                     GenesisBlockFetchConfiguration (..), blockFetchLogic,
+                     bracketFetchClient, bracketKeepAliveClient,
+                     bracketSyncWithFetchClient, newFetchClientRegistry)
 import           Ouroboros.Network.BlockFetch.Client (blockFetchClient)
 import           Ouroboros.Network.ControlMessage (ControlMessage (..))
 import           Ouroboros.Network.Mock.Chain (Chain)
@@ -371,6 +371,8 @@ instance Arbitrary BlockFetchClientTestSetup where
             bfcBulkSyncGracePeriod = 10
         bfcMaxRequestsInflight <- chooseEnum (2, 10)
         bfcSalt                <- arbitrary
+        gbfcBulkSyncGracePeriod <- fromIntegral <$> chooseInteger (5, 60)
+        let bfcGenesisBFConfig = GenesisBlockFetchConfiguration {..}
         pure BlockFetchConfiguration {..}
       pure BlockFetchClientTestSetup {..}
     where