Generalize chainSyncState to peerState in the GSM

Author: agustinmista

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

@@ -56,8 +56,6 @@ 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
 import System.FS.API
   ( HasFS
   , createDirectoryIfMissing
@@ -97,7 +95,7 @@ data CandidateVersusSelection
     WhetherCandidateIsBetter !Bool
   deriving (Eq, Show)
 
-data GsmView m upstreamPeer selection chainSyncState = GsmView
+data GsmView m upstreamPeer selection peerState = GsmView
   { antiThunderingHerd :: Maybe StdGen
   -- ^ An initial seed used to randomly increase 'minCaughtUpDuration' by up
   -- to 15% every transition from Syncing to CaughtUp, in order to avoid a
@@ -108,13 +106,13 @@ data GsmView m upstreamPeer selection chainSyncState = GsmView
       STM
         m
         ( selection ->
-          chainSyncState ->
+          peerState ->
           CandidateVersusSelection
         )
   -- ^ Whether the candidate from the @chainSyncState@ is preferable to the
   -- selection. This can depend on external state (Peras certificates boosting
   -- blocks).
-  , peerIsIdle :: chainSyncState -> Bool
+  , peerIsIdle :: peerState -> Bool
   , durationUntilTooOld :: Maybe (selection -> m DurationFromNow)
   -- ^ How long from now until the selection will be so old that the node
   -- should exit the @CaughtUp@ state
@@ -123,10 +121,8 @@ data GsmView m upstreamPeer selection chainSyncState = GsmView
   , equivalent :: selection -> selection -> Bool
   -- ^ Whether the two selections are equivalent for the purpose of the
   -- Genesis State Machine
-  , getChainSyncStates ::
-      STM m (Map.Map upstreamPeer (StrictTVar m chainSyncState))
-  -- ^ The current ChainSync state with the latest candidates from the
-  -- upstream peers
+  , getPeerStates :: STM m (Map.Map upstreamPeer peerState)
+  -- ^ The current peer state with the latest candidates from the upstream peers
   , getCurrentSelection :: STM m selection
   -- ^ The node's current selection
   , minCaughtUpDuration :: NominalDiffTime
@@ -244,7 +240,7 @@ realGsmEntryPoints tracerArgs gsmView =
     , peerIsIdle
     , durationUntilTooOld
     , equivalent
-    , getChainSyncStates
+    , getPeerStates
     , getCurrentSelection
     , minCaughtUpDuration
     , setCaughtUpPersistentMark
@@ -370,12 +366,13 @@ realGsmEntryPoints tracerArgs gsmView =
 
   blockUntilCaughtUp :: STM m (TraceGsmEvent tracedSelection)
   blockUntilCaughtUp = do
-    -- STAGE 1: all ChainSync clients report no subsequent headers
-    varsState <- getChainSyncStates
-    states <- traverse StrictSTM.readTVar varsState
+    -- STAGE 1: all peers are idle, which means that
+    --   * all ChainSync clients report no subsequent headers, and
+    --   * all PerasCertDiffusion clients report no subsequent certificates
+    peerStates <- getPeerStates
     check $
-      not (Map.null states)
-        && all peerIsIdle states
+      not (Map.null peerStates)
+        && all peerIsIdle peerStates
 
     -- STAGE 2: no candidate is better than the node's current
     -- selection
@@ -388,16 +385,15 @@ realGsmEntryPoints tracerArgs gsmView =
     -- block; general Praos reasoning ensures that won't take particularly
     -- long.
     selection <- getCurrentSelection
-    candidates <- traverse StrictSTM.readTVar varsState
     candidateOverSelection <- getCandidateOverSelection
     let ok candidate =
           WhetherCandidateIsBetter False
             == candidateOverSelection selection candidate
-    check $ all ok candidates
+    check $ all ok peerStates
 
     pure $
       GsmEventEnterCaughtUp
-        (Map.size states)
+        (Map.size peerStates)
         (cnvSelection selection)
 
   -- STAGE 3: the previous stages weren't so slow that the idler

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

@@ -292,7 +292,7 @@ initNodeKernel
                       <&> \wd (_headers, lst) ->
                         GSM.getDurationUntilTooOld wd (getTipSlot lst)
                 , GSM.equivalent = (==) `on` (AF.headPoint . fst)
-                , GSM.getChainSyncStates = fmap cschState <$> cschcMap varChainSyncHandles
+                , GSM.getPeerStates = traverse (readTVar . cschState) =<< cschcMap varChainSyncHandles
                 , GSM.getCurrentSelection = do
                     headers <- ChainDB.getCurrentChainWithTime chainDB
                     extLedgerState <- ChainDB.getCurrentLedger chainDB

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/GSM.hs

@@ -142,7 +142,7 @@ setupGsm isHaaSatisfied vars = do
       , GSM.peerIsIdle = isIdling
       , GSM.durationUntilTooOld = Just durationUntilTooOld
       , GSM.equivalent = (==) -- unsound, but harmless in this test
-      , GSM.getChainSyncStates = readTVar varStates
+      , GSM.getPeerStates = traverse readTVar =<< readTVar varStates
       , GSM.getCurrentSelection = readTVar varSelection
       , GSM.minCaughtUpDuration = thrashLimit
       , GSM.setCaughtUpPersistentMark = \b ->

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/LoE/CaughtUp.hs

@@ -283,7 +283,7 @@ mkGsmEntryPoints varChainSyncHandles chainDB writeGsmState =
       { GSM.getCandidateOverSelection = pure candidateOverSelection
       , GSM.peerIsIdle = csIdling
       , GSM.equivalent = (==) `on` AF.headPoint
-      , GSM.getChainSyncStates = fmap cschState <$> cschcMap varChainSyncHandles
+      , GSM.getPeerStates = traverse readTVar =<< fmap cschState <$> cschcMap varChainSyncHandles
       , GSM.getCurrentSelection = ChainDB.getCurrentChain chainDB
       , -- Make sure that we stay in CaughtUp for the duration of the test once we
         -- have entered it.