TOSQUASH a much smaller change

Author: nfrisby

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

@@ -80,7 +80,6 @@ import           Control.Monad.Class.MonadTimer (MonadTimer)
 import           Control.Monad.Except (runExcept, throwError)
 import           Control.Tracer
 import           Data.Foldable (traverse_)
-import           Data.Function (fix)
 import           Data.Functor ((<&>))
 import           Data.Kind (Type)
 import           Data.Map.Strict (Map)
@@ -406,15 +405,15 @@ bracketChainSyncClient
       let handle = ChainSyncClientHandle {
               cschGDDKill = throwTo tid DensityTooLow
             , cschOnGsmStateChanged = \gsmTransition time -> do
-                  updateLopBucketConfig lopBucket gsmTransition time
-                  pure $ pure ()
+                updateLopBucketConfig lopBucket gsmTransition time
+                pure $ pure ()
             , cschState
             , cschJumping
             , cschJumpInfo
             }
           insertHandle = atomicallyWithMonotonicTime $ \time -> do
-            initialGsmState <- getGsmState
-            initializeLopBucketConfig lopBucket initialGsmState time
+            gsmState <- getGsmState
+            initializeLopBucketConfig lopBucket gsmState time
             cschcAddHandle varHandles peer handle
           deleteHandle = atomically $ cschcRemoveHandle varHandles peer
       bracket_ insertHandle deleteHandle $ f Jumping.noJumping
@@ -427,35 +426,34 @@ bracketChainSyncClient
     acquireContext lopBucket cschState (CSJEnabledConfig jumpSize) = do
         tid <- myThreadId
         atomicallyWithMonotonicTime $ \time -> do
-          initialGsmState <- getGsmState
-          initializeLopBucketConfig lopBucket initialGsmState time
+          gsmState <- getGsmState
+          initializeLopBucketConfig lopBucket gsmState time
           cschJumpInfo <- newTVar Nothing
           context <- Jumping.makeContext varHandles jumpSize tracerCsj
-          Jumping.registerClient context peer cschState $ \cschJumping ->
-            fix $ \handle -> ChainSyncClientHandle   -- NB @handle@ only occurs under a lambda
+          Jumping.registerClient gsmState context peer cschState $ \cschJumping ->
+            ChainSyncClientHandle
               { cschGDDKill = throwTo tid DensityTooLow
               , cschOnGsmStateChanged = \gsmTransition time' -> do
                   updateLopBucketConfig lopBucket gsmTransition time'
-                  let peerContext =
-                        context {Jumping.peer = peer, Jumping.handle = handle}
                   -- 'cschJumpInfo' does not need to be reset. The ChainSync
-                  -- client constantly updates it, even when its not
-                  -- registered with CSJ. That's necessary: when this peer
-                  -- /re-registers/, it might immediately be the Dynamo, and
-                  -- the Dynamo must not have 'Nothing' in its
-                  -- 'cschJumpInfo'.
+                  -- client constantly updates it, even when its not engaged
+                  -- with CSJ. That's necessary: when this peer /re-engages/,
+                  -- it might immediately be the Dynamo, and the Dynamo must
+                  -- not have 'Nothing' in its 'cschJumpInfo'.
                   case gsmTransition of
                     PreSyncingSyncing  -> pure $ pure ()
-                    SyncingCaughtUp    -> do
-                      writeTVar cschJumping $ Disengaged DisengagedDone
-                         -- The GSM only transitions to CaughtUp if all peers
-                         -- have send MsgAwaitReply, so DisengagedDone is
-                         -- correct here.
-                      mbEv <- Jumping.unregisterClient peerContext
-                      pure $ traverse_ (traceWith (Jumping.tracer peerContext)) mbEv
+                    SyncingCaughtUp    ->
+                      -- The GSM only transitions to CaughtUp if all peers have
+                      -- sent MsgAwaitReply, so all peers are already
+                      -- disengaged.
+                      pure $ pure ()
                     CaughtUpPreSyncing -> do
-                      mbEv <- Jumping.reregisterClient peerContext
-                      pure $ traverse_ (traceWith (Jumping.tracer peerContext)) mbEv
+                      -- TODO do we want to do something more sophisticated
+                      -- than just letting a race condition determine the
+                      -- Dynamo?
+                      (csjState, mbEv) <- Jumping.engageClient context cschState
+                      writeTVar cschJumping csjState
+                      pure $ traverse_ (traceWith (Jumping.tracer context)) mbEv
                     SyncingPreSyncing  -> pure $ pure ()
               , cschState
               , cschJumping

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

@@ -186,12 +186,12 @@ module Ouroboros.Consensus.MiniProtocol.ChainSync.Client.Jumping (
   , TraceCsjReason (..)
   , TraceEventCsj (..)
   , TraceEventDbf (..)
+  , engageClient
   , getDynamo
   , makeContext
   , mkJumping
   , noJumping
   , registerClient
-  , reregisterClient
   , rotateDynamo
   , unregisterClient
   ) where
@@ -212,6 +212,8 @@ import           Data.Void (absurd)
 import           GHC.Generics (Generic)
 import           Ouroboros.Consensus.Block (HasHeader (getHeaderFields), Header,
                      Point (..), castPoint, pointSlot, succWithOrigin)
+import           Ouroboros.Consensus.Node.GsmState (GsmState)
+import qualified Ouroboros.Consensus.Node.GsmState as GSM
 import           Ouroboros.Consensus.Ledger.SupportsProtocol
                      (LedgerSupportsProtocol)
 import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client.State
@@ -781,48 +783,42 @@ registerClient ::
   ( LedgerSupportsProtocol blk,
     IOLike m
   ) =>
+  GsmState ->
   Context m peer blk ->
   peer ->
   StrictTVar m (ChainSyncState blk) ->
   -- | A function to make a client handle from a jumping state.
   (StrictTVar m (ChainSyncJumpingState m blk) -> ChainSyncClientHandle m blk) ->
   STM m (PeerContext m peer blk, Maybe (TraceEventCsj peer blk))
-registerClient context peer csState mkHandle = do
-  (csjState, mbEv) <- getDynamo (handlesCol context) >>= \case
-    Nothing -> do
-      fragment <- csCandidate <$> readTVar csState
-      pure (Dynamo DynamoStarted $ pointSlot $ AF.anchorPoint fragment, Just InitializedAsDynamo)
-    Just (_, handle) -> do
-      mJustInfo <- readTVar (cschJumpInfo handle)
-      (\x -> (x, Nothing)) <$> newJumper mJustInfo (Happy FreshJumper Nothing)
+registerClient gsmState context peer csState mkHandle = do
+  (csjState, mbEv) <- case gsmState of
+    GSM.CaughtUp -> pure (Disengaged DisengagedDone, Nothing)
+    GSM.PreSyncing -> engageClient context csState
+    GSM.Syncing -> engageClient context csState
   cschJumping <- newTVar csjState
   let handle = mkHandle cschJumping
   cschcAddHandle (handlesCol context) peer handle
   pure (context {peer, handle}, mbEv)
 
--- | Same as 'registerClient', but for a peer that had been previously disengaged.
+-- | Adds a client to the overall CSJ state
 --
--- This is specifically used for when the GSM transitions from
--- 'Ouroboros.Consensus.Node.GsmState.CaughtUp' back to
--- 'Ouroboros.Consensus.Node.GsmState.PreSyncing'.
-reregisterClient ::
+-- This client can be either a fresh peer or a peer that had previously
+-- disengaged.
+engageClient ::
   ( LedgerSupportsProtocol blk,
     IOLike m
   ) =>
-  PeerContext m peer blk ->
-  STM m (Maybe (TraceEventCsj peer blk))
-reregisterClient peerContext = do
-  let h = handle peerContext
-  (csjState, mbEv) <- getDynamo (handlesCol peerContext) >>= \case
+  Context m peer blk ->
+  StrictTVar m (ChainSyncState blk) ->
+  STM m (ChainSyncJumpingState m blk, Maybe (TraceEventCsj peer blk))
+engageClient context csState = do
+  getDynamo (handlesCol context) >>= \case
     Nothing -> do
-      fragment <- csCandidate <$> readTVar (cschState h)
+      fragment <- csCandidate <$> readTVar csState
       pure (Dynamo DynamoStarted $ pointSlot $ AF.anchorPoint fragment, Just InitializedAsDynamo)
-    Just (_, dynHandle) -> do
-      mJustInfo <- readTVar (cschJumpInfo dynHandle)
+    Just (_, handle) -> do
+      mJustInfo <- readTVar (cschJumpInfo handle)
       (\x -> (x, Nothing)) <$> newJumper mJustInfo (Happy FreshJumper Nothing)
-  writeTVar (cschJumping h) csjState
-  cschcAddHandle (handlesCol peerContext) (peer peerContext) h
-  pure mbEv
 
 -- | Unregister a client from a 'PeerContext'; this might trigger the election
 -- of a new dynamo or objector if the peer was one of these two.