Add LSQ leashing 0.30.0.1

cabal.project

@@ -49,3 +49,11 @@ if impl (ghc >= 9.12)
   allow-newer:
     -- https://github.com/kapralVV/Unique/issues/11
     , Unique:hashable
+
+source-repository-package
+    type: git
+    location: https://github.com/tweag/ouroboros-network
+    tag: 461bbd3f6a27bc282d8a2b7c54e9ef929f30efb0 
+    --sha256: sha256-lEw68KGx16CkBktEeS4xyth6zh9doLewQqxHAiUrxcQ=
+    subdir:
+      ouroboros-network-protocols

flake.nix

@@ -51,7 +51,7 @@
       supportedSystems = [
         "x86_64-linux"
         "x86_64-darwin"
-        #"aarch64-linux"
+        "aarch64-linux"
         "aarch64-darwin"
       ];
     in

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

@@ -134,7 +134,7 @@ mkHandlers ::
   NodeKernelArgs m addrNTN addrNTC blk ->
   NodeKernel m addrNTN addrNTC blk ->
   Handlers m addrNTC blk
-mkHandlers NodeKernelArgs{cfg, tracers} NodeKernel{getChainDB, getMempool} =
+mkHandlers NodeKernelArgs{cfg, tracers} NodeKernel{getLsqLeashingStateVar, getChainDB, getMempool} =
   Handlers
     { hChainSyncServer =
         chainSyncBlocksServer
@@ -144,9 +144,12 @@ mkHandlers NodeKernelArgs{cfg, tracers} NodeKernel{getChainDB, getMempool} =
         localTxSubmissionServer
           (Node.localTxSubmissionServerTracer tracers)
           getMempool
-    , hStateQueryServer =
-        localStateQueryServer (ExtLedgerCfg cfg)
-          . ChainDB.getReadOnlyForkerAtPoint getChainDB
+    , hStateQueryServer = \rr ->
+        localStateQueryServer
+          (ExtLedgerCfg cfg)
+          getLsqLeashingStateVar
+          (ChainDB.getCurrentChainWithTime getChainDB)
+          (ChainDB.getReadOnlyForkerAtPoint getChainDB $ rr) 
     , hTxMonitorServer =
         localTxMonitorServer
           getMempool

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

@@ -71,7 +71,7 @@ import qualified Codec.CBOR.Encoding as CBOR
 import Codec.Serialise (DeserialiseFailure)
 import qualified Control.Concurrent.Class.MonadSTM.Strict as StrictSTM
 import Control.DeepSeq (NFData)
-import Control.Monad (forM_, when)
+import Control.Monad (forM_, when, join)
 import Control.Monad.Class.MonadTime.SI (MonadTime)
 import Control.Monad.Class.MonadTimer.SI (MonadTimer)
 import Control.ResourceRegistry
@@ -83,6 +83,7 @@ import Data.Hashable (Hashable)
 import Data.Kind (Type)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
+import Data.Set (Set)
 import Data.Maybe (fromMaybe, isNothing)
 import Data.Time (NominalDiffTime)
 import Data.Typeable (Typeable)
@@ -172,6 +173,7 @@ import Ouroboros.Network.PeerSelection.PeerSharing.Codec
   )
 import Ouroboros.Network.Protocol.ChainSync.Codec (timeLimitsChainSync)
 import Ouroboros.Network.RethrowPolicy
+import Ouroboros.Network.Protocol.LocalStateQuery.Type(LeashID)
 import qualified SafeWildCards
 import System.Exit (ExitCode (..))
 import System.FS.API (SomeHasFS (..))
@@ -234,6 +236,7 @@ data RunNodeArgs m addrNTN addrNTC blk = RunNodeArgs
   , rnGetUseBootstrapPeers :: STM m UseBootstrapPeers
   , rnGenesisConfig :: GenesisConfig
   , rnMempoolTimeoutConfig :: Maybe Mempool.MempoolTimeoutConfig
+  , rnCrucialLsqClients :: Set LeashID
   }
 
 -- | Arguments that usually only tests /directly/ specify.
@@ -321,6 +324,7 @@ data LowLevelRunNodeArgs m addrNTN addrNTC blk
   , llrnPublicPeerSelectionStateVar :: StrictSTM.StrictTVar m (PublicPeerSelectionState addrNTN)
   , llrnLdbFlavorArgs :: Complete LedgerDbFlavorArgs m
   -- ^ The flavor arguments
+  , llrnCrucialLsqClients :: Set LeashID
   }
 
 data NodeDatabasePaths
@@ -504,8 +508,12 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} =
                   systemStart
                   (blockchainTimeTracer rnTraceConsensus)
 
-          (genesisArgs, setLoEinChainDbArgs) <-
-            mkGenesisNodeKernelArgs llrnGenesisConfig
+          let genesisArgs = mkGenesisNodeKernelArgs llrnGenesisConfig
+          varGetLoEFragment <- newTVarIO $ pure ChainDB.LoEDisabled
+          let setLoEinChainDbArgs argsCfg = argsCfg
+                    { ChainDB.cdbsArgs =
+                      (ChainDB.cdbsArgs argsCfg) { ChainDB.cdbsLoE = join $ readTVarIO varGetLoEFragment }
+                    } 
 
           let maybeValidateAll
                 | lastShutDownWasClean =
@@ -585,6 +593,8 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} =
                   genesisArgs
                   DiffusionPipeliningOn
                   rnMempoolTimeoutConfig
+                  varGetLoEFragment
+                  llrnCrucialLsqClients
             nodeKernel <- initNodeKernel nodeKernelArgs
             rnNodeKernelHook registry nodeKernel
             churnModeVar <- StrictSTM.newTVarIO ChurnModeNormal
@@ -858,9 +868,11 @@ mkNodeKernelArgs ::
   GSM.MarkerFileView m ->
   STM m UseBootstrapPeers ->
   StrictSTM.StrictTVar m (PublicPeerSelectionState addrNTN) ->
-  GenesisNodeKernelArgs m blk ->
+  GenesisNodeKernelArgs ->
   DiffusionPipeliningSupport ->
   Maybe Mempool.MempoolTimeoutConfig ->
+  StrictTVar m (ChainDB.GetLoEFragment m blk) ->
+  Set LeashID ->
   m (NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk)
 mkNodeKernelArgs
   registry
@@ -880,7 +892,9 @@ mkNodeKernelArgs
   publicPeerSelectionStateVar
   genesisArgs
   getDiffusionPipeliningSupport
-  mempoolTimeoutConfig =
+  mempoolTimeoutConfig
+  varGetLoEFragment
+  crucialLsqClients =
     do
       let (kaRng, psRng) = split rng
       return
@@ -911,6 +925,8 @@ mkNodeKernelArgs
           , publicPeerSelectionStateVar
           , genesisArgs
           , getDiffusionPipeliningSupport
+          , varGetLoEFragment
+          , crucialLsqClients
           }
 
 -- | We allow the user running the node to customise the 'NodeKernelArgs'
@@ -1057,6 +1073,7 @@ stdLowLevelRunNodeArgsIO
             Diffusion.dcPublicPeerSelectionVar srnDiffusionConfiguration
         , llrnLdbFlavorArgs =
             srnLdbFlavorArgs
+        , llrnCrucialLsqClients = mempty
         }
    where
     networkMagic :: NetworkMagic

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

@@ -11,26 +11,22 @@ module Ouroboros.Consensus.Node.Genesis
   ( -- * 'GenesisConfig'
     GenesisConfig (..)
   , GenesisConfigFlags (..)
-  , LoEAndGDDConfig (..)
+  , GDDConfig (..)
   , defaultGenesisConfigFlags
   , disableGenesisConfig
   , enableGenesisConfigDefault
   , mkGenesisConfig
 
     -- * NodeKernel helpers
   , GenesisNodeKernelArgs (..)
-  , LoEAndGDDNodeKernelArgs (..)
+  , GDDNodeKernelArgs (..)
   , mkGenesisNodeKernelArgs
-  , setGetLoEFragment
   ) where
 
-import Control.Monad (join)
 import Data.Maybe (fromMaybe)
-import Data.Traversable (for)
-import Data.Typeable (Typeable)
+import Data.Functor ((<&>))
 import GHC.Generics (Generic)
 import Ouroboros.Consensus.Block
-import Ouroboros.Consensus.HeaderValidation (HeaderWithTime (..))
 import Ouroboros.Consensus.MiniProtocol.ChainSync.Client
   ( CSJConfig (..)
   , CSJEnabledConfig (..)
@@ -40,23 +36,16 @@ import Ouroboros.Consensus.MiniProtocol.ChainSync.Client
 import Ouroboros.Consensus.MiniProtocol.ChainSync.Client.HistoricityCheck
   ( HistoricityCutoff (..)
   )
-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
 import Ouroboros.Network.BlockFetch
   ( GenesisBlockFetchConfiguration (..)
   )
 
--- | Whether to en-/disable the Limit on Eagerness and the Genesis Density
+-- | Whether to en-/disable the Genesis Density
 -- Disconnector.
-data LoEAndGDDConfig a
-  = LoEAndGDDEnabled !a
-  | LoEAndGDDDisabled
+data GDDConfig a =
+    GDDEnabled !a
+  | GDDDisabled
   deriving stock (Eq, Generic, Show, Functor, Foldable, Traversable)
 
 -- | Aggregating the various configs for Genesis-related subcomponents.
@@ -67,15 +56,15 @@ data GenesisConfig = GenesisConfig
   { gcBlockFetchConfig :: !GenesisBlockFetchConfiguration
   , gcChainSyncLoPBucketConfig :: !ChainSyncLoPBucketConfig
   , gcCSJConfig :: !CSJConfig
-  , gcLoEAndGDDConfig :: !(LoEAndGDDConfig LoEAndGDDParams)
+  , gcGDDConfig :: !(GDDConfig GDDParams)
   , 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
+  , gcfEnableGDD :: Bool
   , gcfEnableLoP :: Bool
   , gcfBlockFetchGracePeriod :: Maybe DiffTime
   , gcfBucketCapacity :: Maybe Integer
@@ -89,7 +78,7 @@ defaultGenesisConfigFlags :: GenesisConfigFlags
 defaultGenesisConfigFlags =
   GenesisConfigFlags
     { gcfEnableCSJ = True
-    , gcfEnableLoEAndGDD = True
+    , gcfEnableGDD = True
     , gcfEnableLoP = True
     , gcfBlockFetchGracePeriod = Nothing
     , gcfBucketCapacity = Nothing
@@ -115,7 +104,7 @@ mkGenesisConfig Nothing =
           }
     , gcChainSyncLoPBucketConfig = ChainSyncLoPBucketDisabled
     , gcCSJConfig = CSJDisabled
-    , gcLoEAndGDDConfig = LoEAndGDDDisabled
+    , gcGDDConfig = GDDDisabled
     , gcHistoricityCutoff = Nothing
     }
 mkGenesisConfig (Just cfg) =
@@ -141,10 +130,10 @@ mkGenesisConfig (Just cfg) =
                 { csjcJumpSize
                 }
           else CSJDisabled
-    , gcLoEAndGDDConfig =
-        if gcfEnableLoEAndGDD
-          then LoEAndGDDEnabled LoEAndGDDParams{lgpGDDRateLimit}
-          else LoEAndGDDDisabled
+    , gcGDDConfig =
+        if gcfEnableGDD
+          then GDDEnabled GDDParams{lgpGDDRateLimit}
+          else GDDDisabled
     , -- 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.
@@ -154,7 +143,7 @@ mkGenesisConfig (Just cfg) =
   GenesisConfigFlags
     { gcfEnableLoP
     , gcfEnableCSJ
-    , gcfEnableLoEAndGDD
+    , gcfEnableGDD
     , gcfBlockFetchGracePeriod
     , gcfBucketCapacity
     , gcfBucketRate
@@ -189,7 +178,7 @@ mkGenesisConfig (Just cfg) =
   csjcJumpSize = fromMaybe defaultCSJJumpSize gcfCSJJumpSize
   lgpGDDRateLimit = fromMaybe defaultGDDRateLimit gcfGDDRateLimit
 
-newtype LoEAndGDDParams = LoEAndGDDParams
+newtype GDDParams = GDDParams
   { lgpGDDRateLimit :: DiffTime
   -- ^ How often to evaluate GDD. 0 means as soon as possible.
   -- Otherwise, no faster than once every T seconds, where T is the
@@ -198,81 +187,21 @@ newtype LoEAndGDDParams = LoEAndGDDParams
   deriving stock (Eq, Generic, Show)
 
 -- | Genesis-related arguments needed by the NodeKernel initialization logic.
-data GenesisNodeKernelArgs m blk = GenesisNodeKernelArgs
-  { gnkaLoEAndGDDArgs :: !(LoEAndGDDConfig (LoEAndGDDNodeKernelArgs m blk))
+data GenesisNodeKernelArgs = GenesisNodeKernelArgs
+  { gnkaGDDArgs :: !(GDDConfig GDDNodeKernelArgs)
   }
 
-data LoEAndGDDNodeKernelArgs m blk = LoEAndGDDNodeKernelArgs
-  { lgnkaLoEFragmentTVar :: !(StrictTVar m (ChainDB.GetLoEFragment m blk))
-  -- ^ 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.
-  , lgnkaGDDRateLimit :: DiffTime
+data GDDNodeKernelArgs = GDDNodeKernelArgs
+  { lgnkaGDDRateLimit :: DiffTime
   }
 
--- | Create the initial 'GenesisNodeKernelArgs" (with a temporary
--- 'ChainDB.GetLoEFragment' that will be replaced via 'setGetLoEFragment') and a
--- function to update the 'ChainDbArgs' accordingly.
+-- | Create the initial 'GenesisNodeKernelArgs" .
 mkGenesisNodeKernelArgs ::
-  forall m blk.
-  (IOLike m, GetHeader blk, Typeable blk) =>
   GenesisConfig ->
-  m
-    ( GenesisNodeKernelArgs m blk
-    , Complete ChainDbArgs m blk -> Complete ChainDbArgs m blk
-    )
-mkGenesisNodeKernelArgs gcfg = do
-  gnkaLoEAndGDDArgs <- for (gcLoEAndGDDConfig gcfg) $ \p -> do
-    loeFragmentTVar <-
-      newTVarIO $
-        pure $
-          -- Use the most conservative LoE fragment until 'setGetLoEFragment'
-          -- is called.
-          ChainDB.LoEEnabled $
-            AF.Empty AF.AnchorGenesis
-    pure
-      LoEAndGDDNodeKernelArgs
-        { lgnkaLoEFragmentTVar = loeFragmentTVar
-        , lgnkaGDDRateLimit = lgpGDDRateLimit p
-        }
-  let updateChainDbArgs = case gnkaLoEAndGDDArgs of
-        LoEAndGDDDisabled -> id
-        LoEAndGDDEnabled lgnkArgs -> \cfg ->
-          cfg
-            { ChainDB.cdbsArgs =
-                (ChainDB.cdbsArgs cfg){ChainDB.cdbsLoE = getLoEFragment}
-            }
-         where
-          getLoEFragment = join $ readTVarIO $ lgnkaLoEFragmentTVar lgnkArgs
-  pure (GenesisNodeKernelArgs{gnkaLoEAndGDDArgs}, updateChainDbArgs)
-
--- | Set 'gnkaGetLoEFragment' to the actual logic for determining the current
--- LoE fragment.
-setGetLoEFragment ::
-  forall m blk.
-  (IOLike m, GetHeader blk, Typeable blk) =>
-  STM m GSM.GsmState ->
-  -- | The LoE fragment.
-  STM m (AnchoredFragment (HeaderWithTime blk)) ->
-  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 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.
-        GSM.Syncing ->
-          ChainDB.LoEEnabled <$> readLoEFragment
-        -- When we are caught up, the LoE is disabled.
-        GSM.CaughtUp ->
-          pure ChainDB.LoEDisabled
+  GenesisNodeKernelArgs
+mkGenesisNodeKernelArgs gcfg =
+  let gnkaGDDArgs = (gcGDDConfig gcfg) <&> \p ->
+            GDDNodeKernelArgs
+              { lgnkaGDDRateLimit = lgpGDDRateLimit p
+              }
+  in GenesisNodeKernelArgs{gnkaGDDArgs}