From 295a19bd4c9ef8e59bf9446ac88bd225d53a3167 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Fri, 11 Apr 2025 14:01:12 +0200 Subject: [PATCH 01/20] Inbound governor information channel tracer This change replaces the mechanism heavily relying on STM to track remote activity by the inbound governor. Some performance tests indicate that there is a not-insignificant performance penalty with that approach. In the new approach, the inbound governor creates a tracer which is passed via the connection manager to the connection handler. The handler joins this tracer with the mux tracer such that the muxer main thread, via various traces, writes to the information channel queue of events such as remote promotions/demotions and mux stopping/erroring. Each connection maintains a count of remote hot/non-hot responders which are adjusted by the appropriate traces, and informing the inbound governor of relevant state changes that need to be performed. Change RemoteIdle tag: * The change is motivated by the need of the new tracer to ensure proper sequencing of events on the queue. In case a connection is expired and responder startup is demanded, the tracer will retry until the connection is RemoteCold to register the promotion, or abort when the connection is dropped (CM CommitTr returned). --- .../src/Ouroboros/Network/InboundGovernor.hs | 131 ++++++++++++++++++ .../Network/InboundGovernor/State.hs | 14 +- 2 files changed, 142 insertions(+), 3 deletions(-) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs index 39a4c5932ce..1fa2a4f27ef 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs @@ -32,6 +32,7 @@ module Ouroboros.Network.InboundGovernor -- * Re-exports , Transition' (..) , TransitionTrace' (..) + , ResponderCounters (..) -- * API's exported for testing purposes , maturedPeers ) where @@ -566,6 +567,136 @@ with inboundGovernorLoop var state'' +-- | The tracer embedded with the mux tracer by the connection handler +-- for inbound or outbound duplex connections for efficient tracking +-- of inbound governor transitions for a given peer +-- +inboundGovernorMuxTracer + :: (MonadSTM m, Ord peerAddr) + => InboundGovernorInfoChannel muxMode initiatorCtx peerAddr versionData ByteString m a b + -> (versionData -> DataFlow) + -> StrictTVar m (State muxMode initiatorCtx peerAddr versionData m a b) + -> StrictTVar m Bool + -> StrictTVar m (StrictMaybe ResponderCounters) + -> Tracer m (Mux.WithBearer (ConnectionId peerAddr) Mux.Trace) +inboundGovernorMuxTracer infoChannel connectionDataFlow stateVar activeVar countersVar = + Tracer \(Mux.WithBearer peer trace) -> do + -- hello from muxer main thread + -- code here is running in the context of the connection handler/muxer + -- so care must be taken not to deadlock ourselves + active <- readTVarIO activeVar + case (trace, active) of + (_, True) | Just miniProtocolNum <- miniProtocolStarted trace -> atomically do + connections <- connections <$> readTVar stateVar + mCounters <- readTVar countersVar + case (Map.lookup peer connections, mCounters) of + (Just (ConnectionState { csRemoteState, csMiniProtocolMap }), + SJust rc@ResponderCounters { numTraceHotResponders, + numTraceNonHotResponders }) -> do + let miniProtocolTemp = getProtocolTemp miniProtocolNum csMiniProtocolMap + commit = do + case (numTraceNonHotResponders, numTraceHotResponders) of + (0, 0) -> InfoChannel.writeMessage infoChannel + (AwakeRemote peer) + _ -> pure () + case (miniProtocolTemp, numTraceHotResponders) of + (Hot, 0) -> InfoChannel.writeMessage infoChannel + (RemotePromotedToHot peer) + _ -> pure () + case miniProtocolTemp of + Hot -> writeTVar countersVar $ + SJust rc { numTraceHotResponders = + succ numTraceHotResponders } + _orNot -> writeTVar countersVar $ + SJust rc { numTraceNonHotResponders = + succ numTraceNonHotResponders } + + case csRemoteState of + -- we retry on expired because we let the IG + -- loop handle this peer. If the connection is released, + -- and CM reports CommitTr, this peer will disappear + -- from the connections so on retry we will hit the + -- _otherwise clause instead and promotion will fail, + -- as it should. Otherwise, if KeepTr is returned, + -- we can handle 'AwakeRemote' from this peer. + RemoteIdle timeoutSTM -> do + expired <- timeoutSTM + if expired then retry else commit + _ -> commit + + _otherwise -> writeTVar countersVar SNothing + + (_, True) | Just miniProtocolNum <- miniProtocolTerminated trace -> atomically do + connections <- connections <$> readTVar stateVar + mCounters <- readTVar countersVar + case (Map.lookup peer connections, mCounters) of + (Just (ConnectionState { csMux, + csVersionData, + csMiniProtocolMap, + csCompletionMap }), + SJust rc@ResponderCounters { numTraceHotResponders, + numTraceNonHotResponders }) -> do + InfoChannel.writeMessage infoChannel $ + MiniProtocolTerminated $ Terminated { + tConnId = peer, + tMux = csMux, + tMiniProtocolData = csMiniProtocolMap Map.! miniProtocolNum, + tDataFlow = connectionDataFlow csVersionData, + tResult = csCompletionMap Map.! miniProtocolNum } + case trace of + Mux.TraceCleanExit {} -> do + let miniProtocolTemp = getProtocolTemp miniProtocolNum csMiniProtocolMap + case (miniProtocolTemp, numTraceHotResponders) of + (Hot, 1) -> InfoChannel.writeMessage infoChannel + (RemoteDemotedToWarm peer) + _ -> pure () + when (numTraceHotResponders + numTraceNonHotResponders == 1) $ + InfoChannel.writeMessage infoChannel + (WaitIdleRemote peer) + case miniProtocolTemp of + Hot -> writeTVar countersVar $ + SJust rc { numTraceHotResponders = + pred numTraceHotResponders } + _orNot -> writeTVar countersVar $ + SJust rc { numTraceNonHotResponders = + pred numTraceNonHotResponders } + + _otherwise -> writeTVar countersVar SNothing + + _otherwise -> writeTVar countersVar SNothing + + + (_, True) | True <- muxStopped trace -> atomically do + State { connections } <- readTVar stateVar + case Map.lookup peer connections of + Just ConnectionState {csMux} -> + InfoChannel.writeMessage infoChannel $ + MuxFinished peer (Mux.stopped csMux) + _otherwise -> pure () + writeTVar countersVar SNothing + + _otherwise -> return () + where + muxStopped = \case + Mux.TraceStopped -> True + Mux.TraceState Mux.Dead -> True + _otherwise -> False + + getProtocolTemp miniProtocolNum csMiniProtocolMap = + let miniData = csMiniProtocolMap Map.! miniProtocolNum + in mpdMiniProtocolTemp miniData + + miniProtocolTerminated = \case + Mux.TraceCleanExit miniProtocolNum Mux.ResponderDir -> Just miniProtocolNum + Mux.TraceExceptionExit miniProtocolNum Mux.ResponderDir _e -> Just miniProtocolNum + _otherwise -> Nothing + + miniProtocolStarted = \case + -- is any responder started eagerly??? + Mux.TraceStartEagerly miniProtocolNum Mux.ResponderDir -> Just miniProtocolNum + Mux.TraceStartedOnDemand miniProtocolNum Mux.ResponderDir -> Just miniProtocolNum + _otherwise -> Nothing + -- | Run a responder mini-protocol. -- diff --git a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/State.hs b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/State.hs index 445ff4f812f..1cb7b6ac10d 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/State.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/State.hs @@ -15,6 +15,7 @@ module Ouroboros.Network.InboundGovernor.State , mkPublicState , State (..) , ConnectionState (..) + , ResponderCounters (..) , Counters (..) , counters , unregisterConnection @@ -186,9 +187,16 @@ data ConnectionState muxMode initiatorCtx peerAddr versionData m a b = Connectio -- | State of the connection. -- csRemoteState :: !(RemoteState m) - } +-- | The IG maintains a state of the number of hot and warm +-- miniprotocol responders to track transitions and notify +-- the connection manager for interesting events. +-- +data ResponderCounters = ResponderCounters { + numTraceHotResponders :: !Int, + numTraceNonHotResponders :: !Int + } -- -- State management functions @@ -259,11 +267,11 @@ data RemoteState m -- | After @DemotedToCold^{dataFlow}_{Remote}@ is detected. This state -- corresponds to 'InboundIdleState'. In this state we are checking -- if the responder protocols are idle during protocol idle timeout - -- (represented by an 'STM' action) + -- (represented by an 'STM' with a boolean representing expired timeout state) -- -- 'RemoteIdle' is the initial state of an accepted a connection. -- - | RemoteIdle !(STM m ()) + | RemoteIdle !(STM m Bool) -- | The 'RemoteCold' state for 'Duplex' connections allows us to have -- responders started using the on-demand strategy. This assures that once From 546f27958ae15230691bb0c5270a4db90c24853b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Wed, 9 Apr 2025 14:50:14 +0200 Subject: [PATCH 02/20] Information Channel changes Moved 'InboundGovernorInfoChannel` to InboundGovernor Change IG information channel queue bound Previously, the queue was only used to communicate new connections to the inbound governor. The queue is now used to also notify the IG of muxer events so it will be busier. --- .../InformationChannel.hs | 28 ++++++++----------- 1 file changed, 11 insertions(+), 17 deletions(-) rename ouroboros-network-framework/src/Ouroboros/Network/{ConnectionManager => InboundGovernor}/InformationChannel.hs (56%) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/InformationChannel.hs b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/InformationChannel.hs similarity index 56% rename from ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/InformationChannel.hs rename to ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/InformationChannel.hs index a133382ec4c..ae59d1df606 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/InformationChannel.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/InformationChannel.hs @@ -1,9 +1,10 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-} -module Ouroboros.Network.ConnectionManager.InformationChannel + +module Ouroboros.Network.InboundGovernor.InformationChannel ( InformationChannel (..) - , InboundGovernorInfoChannel , newInformationChannel ) where @@ -11,10 +12,6 @@ import Control.Concurrent.Class.MonadSTM.Strict import Data.Functor (($>)) import GHC.Natural (Natural) -import Network.Mux qualified as Mux -import Ouroboros.Network.ConnectionHandler (Handle) -import Ouroboros.Network.Context (ResponderContext) -import Ouroboros.Network.InboundGovernor.Event (NewConnectionInfo) -- | Information channel. -- @@ -24,20 +21,16 @@ data InformationChannel a m = -- readMessage :: STM m a, + -- | Efficiently flush all values from the channel + -- for batch processing + -- + readMessages :: STM m [a], + -- | Write a value to the channel. -- writeMessage :: a -> STM m () } --- | A channel which instantiates to 'NewConnectionInfo' and --- 'Handle'. --- --- * /Producer:/ connection manger for duplex outbound connections. --- * /Consumer:/ inbound governor. --- -type InboundGovernorInfoChannel (muxMode :: Mux.Mode) initiatorCtx peerAddr versionData bytes m a b = - InformationChannel (NewConnectionInfo peerAddr (Handle muxMode initiatorCtx (ResponderContext peerAddr) versionData bytes m a b)) m - -- | Create a new 'InformationChannel' backed by a `TBQueue`. -- @@ -50,11 +43,12 @@ newInformationChannel = do >>= \q -> labelTBQueue q "server-cc" $> q pure $ InformationChannel { readMessage = readTBQueue channel, - writeMessage = writeTBQueue channel + readMessages = flushTBQueue channel, + writeMessage = \(!a) -> writeTBQueue channel a } -- | The 'InformationChannel's 'TBQueue' depth. -- cc_QUEUE_BOUND :: Natural -cc_QUEUE_BOUND = 10 +cc_QUEUE_BOUND = 100 From 6f3365915bc7d5cbfc31b8ee3e2be7e6f3301ef4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Mon, 31 Mar 2025 12:18:52 +0200 Subject: [PATCH 03/20] General inbound governor changes Applies the connection handler builder to the new IG tracer and passes the result to the withConnectionManager continuation. The connection manager forks this tracer-augmented handler for new connections so that the inbound governor can be efficiently notified of remote activity by tracing performed by mux. The information channel queue is drained one last time after the inbound governor thread finishes. This is to avoid a deadlock where the queue becomes full, potentially preventing connection handlers from performing their cleanup routine. This is important when shutting down, where the connection manager is waiting for all connection handlers to finish. Refactor InboundGovernor interface Rework IG loop Process all the info channel events from the queue in one step of the IG loop. The queue events arrive from the CM (new connection) or from the tracer which tracks miniprotocol responder activity and mux start/stop. Move the remnants of the deleted Event module * Most of the functionality of the Event is unneeded anymore and the module is removed, with its still useful remnant moved here. Updates reflecting changes to 'RemoteIdle' tag were applied. --- .../ouroboros-network-framework.cabal | 4 +- .../src/Ouroboros/Network/InboundGovernor.hs | 322 ++++++++++---- .../Network/InboundGovernor/Event.hs | 401 ------------------ 3 files changed, 244 insertions(+), 483 deletions(-) delete mode 100644 ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/Event.hs diff --git a/ouroboros-network-framework/ouroboros-network-framework.cabal b/ouroboros-network-framework/ouroboros-network-framework.cabal index d89900d161e..4cea783cfff 100644 --- a/ouroboros-network-framework/ouroboros-network-framework.cabal +++ b/ouroboros-network-framework/ouroboros-network-framework.cabal @@ -31,7 +31,6 @@ library Ouroboros.Network.ConnectionId Ouroboros.Network.ConnectionManager.ConnMap Ouroboros.Network.ConnectionManager.Core - Ouroboros.Network.ConnectionManager.InformationChannel Ouroboros.Network.ConnectionManager.State Ouroboros.Network.ConnectionManager.Types Ouroboros.Network.Context @@ -41,7 +40,7 @@ library Ouroboros.Network.Driver.Stateful Ouroboros.Network.IOManager Ouroboros.Network.InboundGovernor - Ouroboros.Network.InboundGovernor.Event + Ouroboros.Network.InboundGovernor.InformationChannel Ouroboros.Network.InboundGovernor.State Ouroboros.Network.Mux Ouroboros.Network.MuxMode @@ -68,6 +67,7 @@ library Win32-network ^>=0.2, base >=4.12 && <4.22, bytestring >=0.10 && <0.13, + cardano-strict-containers, cborg >=0.2.1 && <0.3, containers >=0.5 && <0.8, contra-tracer, diff --git a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs index 1fa2a4f27ef..1fc99e7a3d3 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs @@ -1,13 +1,15 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} -- 'runResponder' is using a redundant constraint. {-# OPTIONS_GHC -Wno-redundant-constraints #-} @@ -25,6 +27,8 @@ module Ouroboros.Network.InboundGovernor -- * Trace , Trace (..) , Debug (..) + , Event (..) + , NewConnectionInfo (..) , RemoteSt (..) , RemoteTransition , RemoteTransitionTrace @@ -41,19 +45,20 @@ import Control.Applicative (Alternative) import Control.Concurrent.Class.MonadSTM qualified as LazySTM import Control.Concurrent.Class.MonadSTM.Strict import Control.Exception (SomeAsyncException (..)) -import Control.Monad (foldM) +import Control.Monad (foldM, forM_, forever, when) import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadThrow import Control.Monad.Class.MonadTime.SI import Control.Monad.Class.MonadTimer.SI -import Control.Tracer (Tracer, traceWith) +import Control.Tracer (Tracer (..), traceWith) import Data.Bifunctor (first) import Data.ByteString.Lazy (ByteString) import Data.Cache import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map +import Data.Maybe.Strict import Data.Monoid.Synchronisation import Data.OrdPSQ (OrdPSQ) import Data.OrdPSQ qualified as OrdPSQ @@ -62,19 +67,17 @@ import Data.Set qualified as Set import Data.Void (Void) import Network.Mux qualified as Mux +import Network.Mux.Types qualified as Mux import Ouroboros.Network.ConnectionHandler -import Ouroboros.Network.ConnectionManager.InformationChannel - (InboundGovernorInfoChannel) -import Ouroboros.Network.ConnectionManager.InformationChannel qualified as InfoChannel import Ouroboros.Network.ConnectionManager.Types import Ouroboros.Network.Context -import Ouroboros.Network.InboundGovernor.Event +import Ouroboros.Network.InboundGovernor.InformationChannel (InformationChannel) +import Ouroboros.Network.InboundGovernor.InformationChannel qualified as InfoChannel import Ouroboros.Network.InboundGovernor.State import Ouroboros.Network.Mux import Ouroboros.Network.Server.RateLimiting - -- | Period of time after which a peer transitions from a fresh to a mature one, -- see `matureDuplexPeers` and `freshDuplexPeers`. -- @@ -89,7 +92,9 @@ inactionTimeout :: DiffTime inactionTimeout = 31.415927 -data Arguments muxMode socket initiatorCtx peerAddr versionNumber versionData m a b = Arguments { +data Arguments muxMode handlerTrace socket peerAddr initiatorCtx responderCtx + handle handleError versionNumber versionData bytes m a b x = + Arguments { transitionTracer :: Tracer m (RemoteTransitionTrace peerAddr), -- ^ transition tracer tracer :: Tracer m (Trace peerAddr), @@ -104,11 +109,20 @@ data Arguments muxMode socket initiatorCtx peerAddr versionNumber versionData m idleTimeout :: Maybe DiffTime, -- ^ protocol idle timeout. The remote site must restart a mini-protocol -- within given timeframe (Nothing indicates no timeout). - connectionManager :: MuxConnectionManager muxMode socket initiatorCtx - (ResponderContext peerAddr) peerAddr - versionData versionNumber - ByteString m a b - -- ^ connection manager + withConnectionManager + :: ConnectionHandler muxMode handlerTrace socket peerAddr handle handleError versionNumber versionData m + -> (ConnectionManager muxMode socket peerAddr handle handleError m -> m x) + -> m x, + -- ^ connection manager continuation + mkConnectionHandler + :: ( StrictTVar m (StrictMaybe ResponderCounters) + -> Tracer m (Mux.WithBearer (ConnectionId peerAddr) Mux.Trace)) + -> ConnectionHandler muxMode handlerTrace socket peerAddr handle handleError versionNumber versionData m + -- ^ Connection handler builder, which injects a special tracer + -- created here and routed into the muxer via the connection manager. + -- The purpose is to inform the IG loop + -- of miniprotocol responder activity such that proper and efficient + -- peer cold/warm/hot transitions can be tracked. } @@ -127,7 +141,8 @@ data Arguments muxMode socket initiatorCtx peerAddr versionNumber versionData m -- The first one is used in data diffusion for /Node-To-Node protocol/, while the -- other is useful for running a server for the /Node-To-Client protocol/. -- -with :: forall (muxMode :: Mux.Mode) socket initiatorCtx peerAddr versionData versionNumber m a b x. +with :: forall (muxMode :: Mux.Mode) socket peerAddr initiatorCtx responderCtx + handle handlerTrace handleError versionData versionNumber bytes m a b x. ( Alternative (STM m) , MonadAsync m , MonadCatch m @@ -140,31 +155,53 @@ with :: forall (muxMode :: Mux.Mode) socket initiatorCtx peerAddr versionData ve , MonadMask m , Ord peerAddr , HasResponder muxMode ~ True + , MonadTraceSTM m + , MonadFork m + , MonadDelay m + , Show peerAddr ) - => Arguments muxMode socket initiatorCtx peerAddr versionNumber versionData m a b - -> (Async m Void -> m (PublicState peerAddr versionData) -> m x) + => Arguments muxMode handlerTrace socket peerAddr initiatorCtx responderCtx + handle handleError versionNumber versionData bytes m a b x + -> ( Async m Void + -> m (PublicState peerAddr versionData) + -> ConnectionManager muxMode socket peerAddr handle handleError m + -> m x) -> m x with Arguments { - transitionTracer = trTracer, - tracer = tracer, - debugTracer = debugTracer, - connectionDataFlow = connectionDataFlow, - infoChannel = infoChannel, - idleTimeout = idleTimeout, - connectionManager = connectionManager + transitionTracer = trTracer, + tracer, + debugTracer, + connectionDataFlow, + idleTimeout, + infoChannel, + withConnectionManager, + mkConnectionHandler } k = do - labelThisThread "inbound-governor" - var <- newTVarIO (mkPublicState emptyState) - withAsync ((do - labelThisThread "inbound-governor-loop" - inboundGovernorLoop var emptyState) - `catch` - handleError var) $ + stateVar <- newTVarIO emptyState + active <- newTVarIO True -- ^ inbound governor status: True = Active + let connectionHandler = + mkConnectionHandler $ inboundGovernorMuxTracer infoChannel + connectionDataFlow + stateVar + active + withConnectionManager connectionHandler \connectionManager -> + withAsync + ( labelThisThread "inbound-governor-loop" >> + forever (inboundGovernorStep connectionManager stateVar >> yield) + `catch` \e -> do + -- following the next statement, the ig tracer will no longer + -- write to the info channel queue. + atomically $ writeTVar active False + -- To avoid the risk of a full information channel queue + -- and blocking on mux traces which will prevent connection cleanup, + -- we drain it here just in case one last time. + _ <- atomically $ InfoChannel.readMessages infoChannel + handleError stateVar e) \thread -> - k thread (readTVarIO var) + k thread (mkPublicState <$> readTVarIO stateVar) connectionManager where emptyState :: State muxMode initiatorCtx peerAddr versionData m a b emptyState = State { @@ -179,11 +216,11 @@ with -- NOTE: `inboundGovernorLoop` doesn't throw synchronous exceptions, this is -- just need to handle asynchronous exceptions. handleError - :: StrictTVar m (PublicState peerAddr versionData) + :: StrictTVar m (State muxMode initiatorCtx peerAddr versionData m a b) -> SomeException -> m Void handleError var e = do - PublicState { remoteStateMap } <- readTVarIO var + PublicState { remoteStateMap } <- mkPublicState <$> readTVarIO var _ <- Map.traverseWithKey (\connId remoteSt -> traceWith trTracer $ @@ -194,46 +231,48 @@ with remoteStateMap throwIO e - -- The inbound protocol governor recursive loop. The 'connections' is - -- updated as we recurse. - -- - inboundGovernorLoop - :: StrictTVar m (PublicState peerAddr versionData) - -> State muxMode initiatorCtx peerAddr versionData m a b - -> m Void - inboundGovernorLoop var !state = do + -- The inbound protocol governor single step, which may + -- process multipe events from the information channel + inboundGovernorStep + :: ConnectionManager muxMode socket peerAddr handle handleError m + -> StrictTVar m (State muxMode initiatorCtx peerAddr versionData m a b) + -> m () + inboundGovernorStep connectionManager stateVar = do time <- getMonotonicTime inactivityVar <- registerDelay inactionTimeout + events <- atomically do + state <- readTVar stateVar + runFirstToFinish $ + -- we deliberately read the info channel queue after + -- the relevant item in each firsttofinish to limit + -- contention + FirstToFinish do + -- mark connections as mature + case maturedPeers time (freshDuplexPeers state) of + (as, _) | Map.null as + -> retry + (as, fresh) -> + (MaturedDuplexPeers as fresh :) <$> InfoChannel.readMessages infoChannel + <> FirstToFinish do + firstCommit <- runFirstToFinish $ + Map.foldMapWithKey firstPeerCommitRemote (connections state) + -- it is important we read the channel here, and join it after + -- the firstCommit. Registering responder starts are atomic wrt + -- handling an expired peer in the tracer. If the CM drops the + -- expired connection (CommitRemote below), the tracer must not + -- register a promotion activity. + (firstCommit :) <$> InfoChannel.readMessages infoChannel + <> FirstToFinish do + muxEvents <- InfoChannel.readMessages infoChannel + check (not . null $ muxEvents) >> pure muxEvents + <> FirstToFinish do + -- spin the inbound governor loop; it will re-run with new + -- time, which allows to make some peers mature. + LazySTM.readTVar inactivityVar >>= check >> pure [InactivityTimeout] + + forM_ events \event -> do + state <- readTVarIO stateVar - event - <- atomically $ runFirstToFinish $ - FirstToFinish ( - -- mark connections as mature - case maturedPeers time (freshDuplexPeers state) of - (as, _) | Map.null as - -> retry - (as, fresh) -> pure $ MaturedDuplexPeers as fresh - ) - <> Map.foldMapWithKey - ( firstMuxToFinish - <> firstPeerDemotedToCold - <> firstPeerCommitRemote - <> firstMiniProtocolToFinish connectionDataFlow - <> firstPeerPromotedToWarm - <> firstPeerPromotedToHot - <> firstPeerDemotedToWarm - - :: EventSignal muxMode initiatorCtx peerAddr versionData m a b - ) - (connections state) - <> FirstToFinish ( - NewConnection <$> InfoChannel.readMessage infoChannel - ) - <> FirstToFinish ( - -- spin the inbound governor loop; it will re-run with new - -- time, which allows to make some peers mature. - LazySTM.readTVar inactivityVar >>= check >> pure InactivityTimeout - ) (mbConnId, state') <- case event of NewConnection -- new connection has been announced by either accept loop or @@ -777,6 +816,129 @@ mkRemoteTransitionTrace connId fromState toState = } +-- | A channel which instantiates to 'NewConnectionInfo' and +-- 'Handle'. +-- +-- * /Producer:/ connection manger for duplex outbound connections. +-- * /Consumer:/ inbound governor. +-- +type InboundGovernorInfoChannel (muxMode :: Mux.Mode) initiatorCtx peerAddr versionData bytes m a b = + InformationChannel (Event (muxMode :: Mux.Mode) (Handle muxMode initiatorCtx (ResponderContext peerAddr) versionData bytes m a b) initiatorCtx peerAddr versionData m a b) m + + +-- | Announcement message for a new connection. +-- +data NewConnectionInfo peerAddr handle + + -- | Announce a new connection. /Inbound protocol governor/ will start + -- responder protocols using 'StartOnDemand' strategy and monitor remote + -- transitions: @PromotedToWarm^{Duplex}_{Remote}@ and + -- @DemotedToCold^{dataFlow}_{Remote}@. + = NewConnectionInfo + !Provenance + !(ConnectionId peerAddr) + !DataFlow + !handle + +instance Show peerAddr + => Show (NewConnectionInfo peerAddr handle) where + show (NewConnectionInfo provenance connId dataFlow _) = + concat [ "NewConnectionInfo " + , show provenance + , " " + , show connId + , " " + , show dataFlow + ] + + +-- | Edge triggered events to which the /inbound protocol governor/ reacts. +-- +data Event (muxMode :: Mux.Mode) handle initiatorCtx peerAddr versionData m a b + -- | A request to start mini-protocol bundle, either from the server or from + -- connection manager after a duplex connection was negotiated. + -- + = NewConnection !(NewConnectionInfo peerAddr handle) + + -- | A multiplexer exited. + -- + | MuxFinished !(ConnectionId peerAddr) (STM m (Maybe SomeException)) + + -- | A mini-protocol terminated either cleanly or abruptly. + -- + | MiniProtocolTerminated !(Terminated muxMode initiatorCtx peerAddr m a b) + + -- | Transition from 'RemoteEstablished' to 'RemoteIdle'. + -- + | WaitIdleRemote !(ConnectionId peerAddr) + + -- | A remote @warm → hot@ transition. It is scheduled as soon as all hot + -- mini-protocols are running. + -- + | RemotePromotedToHot !(ConnectionId peerAddr) + + -- | A @hot → warm@ transition. It is scheduled as soon as any hot + -- mini-protocol terminates. + -- + | RemoteDemotedToWarm !(ConnectionId peerAddr) + + -- | Transition from 'RemoteIdle' to 'RemoteCold'. + -- + | CommitRemote !(ConnectionId peerAddr) + + -- | Transition from 'RemoteIdle' or 'RemoteCold' to 'RemoteEstablished'. + -- + | AwakeRemote !(ConnectionId peerAddr) + + -- | Update `igsMatureDuplexPeers` and `igsFreshDuplexPeers`. + -- + | MaturedDuplexPeers !(Map peerAddr versionData) -- ^ newly matured duplex peers + !(OrdPSQ peerAddr Time versionData) -- ^ queue of fresh duplex peers + + | InactivityTimeout + + +-- STM transactions which detect 'Event's (signals) +-- + + +-- | A signal which returns an 'Event'. Signals are combined together and +-- passed used to fold the current state map. +-- +type EventSignal (muxMode :: Mux.Mode) handle initiatorCtx peerAddr versionData m a b = + ConnectionId peerAddr + -> ConnectionState muxMode initiatorCtx peerAddr versionData m a b + -> FirstToFinish (STM m) (Event muxMode handle initiatorCtx peerAddr versionData m a b) + + +-- | When a mini-protocol terminates we take 'Terminated' out of 'ConnectionState +-- and pass it to the main loop. This is just enough to decide if we need to +-- restart a mini-protocol and to do the restart. +-- +data Terminated muxMode initiatorCtx peerAddr m a b = Terminated { + tConnId :: !(ConnectionId peerAddr), + tMux :: !(Mux.Mux muxMode m), + tMiniProtocolData :: !(MiniProtocolData muxMode initiatorCtx peerAddr m a b), + tDataFlow :: !DataFlow, + tResult :: STM m (Either SomeException b) -- !(Either SomeException b) + } + + +-- | First peer for which the 'RemoteIdle' timeout expires. +-- +firstPeerCommitRemote :: (Alternative (STM m), MonadSTM m) + => EventSignal muxMode handle initiatorCtx peerAddr versionData m a b +firstPeerCommitRemote + connId ConnectionState { csRemoteState } + = case csRemoteState of + -- the connection is already in 'RemoteCold' state + RemoteCold -> mempty + RemoteEstablished -> mempty + RemoteIdle timeoutSTM -> FirstToFinish do + expired <- timeoutSTM + if expired then pure $ CommitRemote connId else retry + + data IGAssertionLocation peerAddr = InboundGovernorLoop !(Maybe (ConnectionId peerAddr)) !AbstractState deriving Show diff --git a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/Event.hs b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/Event.hs deleted file mode 100644 index 271325ed152..00000000000 --- a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/Event.hs +++ /dev/null @@ -1,401 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} - --- Internals of inbound protocol governor. This module provide 'Event' type, --- which enumerates external events and stm action which block until these --- events fire. --- -module Ouroboros.Network.InboundGovernor.Event - ( Event (..) - , EventSignal - , firstMuxToFinish - , Terminated (..) - , firstMiniProtocolToFinish - , firstPeerPromotedToWarm - , firstPeerPromotedToHot - , firstPeerDemotedToWarm - , firstPeerDemotedToCold - , firstPeerCommitRemote - , NewConnectionInfo (..) - ) where - -import Control.Applicative (Alternative) -import Control.Concurrent.Class.MonadSTM.Strict -import Control.Monad.Class.MonadThrow hiding (handle) -import Control.Monad.Class.MonadTime.SI - -import Data.ByteString.Lazy (ByteString) -import Data.Functor (($>)) -import Data.Map.Strict (Map) -import Data.Map.Strict qualified as Map -import Data.Monoid.Synchronisation -import Data.OrdPSQ (OrdPSQ) -import Data.Set qualified as Set - -import Network.Mux qualified as Mux -import Network.Mux.Types (MiniProtocolDir (..), MiniProtocolStatus (..)) - -import Ouroboros.Network.ConnectionHandler -import Ouroboros.Network.ConnectionManager.Types -import Ouroboros.Network.Context -import Ouroboros.Network.InboundGovernor.State -import Ouroboros.Network.Mux - - --- | Announcement message for a new connection. --- -data NewConnectionInfo peerAddr handle - - -- | Announce a new connection. /Inbound protocol governor/ will start - -- responder protocols using 'StartOnDemand' strategy and monitor remote - -- transitions: @PromotedToWarm^{Duplex}_{Remote}@ and - -- @DemotedToCold^{dataFlow}_{Remote}@. - = NewConnectionInfo - !Provenance - !(ConnectionId peerAddr) - !DataFlow - !handle - -instance Show peerAddr - => Show (NewConnectionInfo peerAddr handle) where - show (NewConnectionInfo provenance connId dataFlow _) = - concat [ "NewConnectionInfo " - , show provenance - , " " - , show connId - , " " - , show dataFlow - ] - --- | Edge triggered events to which the /inbound protocol governor/ reacts. --- -data Event (muxMode :: Mux.Mode) initiatorCtx peerAddr versionData m a b - -- | A request to start mini-protocol bundle, either from the server or from - -- connection manager after a duplex connection was negotiated. - -- - = NewConnection !(NewConnectionInfo peerAddr - (Handle muxMode initiatorCtx (ResponderContext peerAddr) versionData ByteString m a b)) - - -- | A multiplexer exited. - -- - | MuxFinished !(ConnectionId peerAddr) !(Maybe SomeException) - - -- | A mini-protocol terminated either cleanly or abruptly. - -- - | MiniProtocolTerminated !(Terminated muxMode initiatorCtx peerAddr m a b) - - -- | Transition from 'RemoteEstablished' to 'RemoteIdle'. - -- - | WaitIdleRemote !(ConnectionId peerAddr) - - -- | A remote @warm → hot@ transition. It is scheduled as soon as all hot - -- mini-protocols are running. - -- - | RemotePromotedToHot !(ConnectionId peerAddr) - - -- | A @hot → warm@ transition. It is scheduled as soon as any hot - -- mini-protocol terminates. - -- - | RemoteDemotedToWarm !(ConnectionId peerAddr) - - -- | Transition from 'RemoteIdle' to 'RemoteCold'. - -- - | CommitRemote !(ConnectionId peerAddr) - - -- | Transition from 'RemoteIdle' or 'RemoteCold' to 'RemoteEstablished'. - -- - | AwakeRemote !(ConnectionId peerAddr) - - -- | Update `igsMatureDuplexPeers` and `igsFreshDuplexPeers`. - -- - | MaturedDuplexPeers !(Map peerAddr versionData) -- ^ newly matured duplex peers - !(OrdPSQ peerAddr Time versionData) -- ^ queue of fresh duplex peers - - | InactivityTimeout - - --- --- STM transactions which detect 'Event's (signals) --- - - --- | A signal which returns an 'Event'. Signals are combined together and --- passed used to fold the current state map. --- -type EventSignal (muxMode :: Mux.Mode) initiatorCtx peerAddr versionData m a b = - ConnectionId peerAddr - -> ConnectionState muxMode initiatorCtx peerAddr versionData m a b - -> FirstToFinish (STM m) (Event muxMode initiatorCtx peerAddr versionData m a b) - --- | A mux stopped. If mux exited cleanly no error is attached. --- -firstMuxToFinish :: MonadSTM m - => EventSignal muxMode initiatorCtx peerAddr versionData m a b -firstMuxToFinish connId ConnectionState { csMux } = - FirstToFinish $ MuxFinished connId <$> Mux.stopped csMux - - --- | When a mini-protocol terminates we take 'Terminated' out of 'ConnectionState --- and pass it to the main loop. This is just enough to decide if we need to --- restart a mini-protocol and to do the restart. --- -data Terminated muxMode initiatorCtx peerAddr m a b = Terminated { - tConnId :: !(ConnectionId peerAddr), - tMux :: !(Mux.Mux muxMode m), - tMiniProtocolData :: !(MiniProtocolData muxMode initiatorCtx peerAddr m a b), - tDataFlow :: !DataFlow, - tResult :: !(Either SomeException b) - } - - --- | Detect when one of the mini-protocols terminated. --- --- /triggers:/ 'MiniProtocolTerminated'. --- -firstMiniProtocolToFinish :: Alternative (STM m) - => (versionData -> DataFlow) - -> EventSignal muxMode initiatorCtx peerAddr versionData m a b -firstMiniProtocolToFinish - connDataFlow - connId - ConnectionState { csMux, - csVersionData, - csMiniProtocolMap, - csCompletionMap - } - = Map.foldMapWithKey - (\miniProtocolNum completionAction -> - (\tResult -> MiniProtocolTerminated $ Terminated { - tConnId = connId, - tMux = csMux, - tMiniProtocolData = csMiniProtocolMap Map.! miniProtocolNum, - tDataFlow = connDataFlow csVersionData, - tResult - } - ) - <$> FirstToFinish completionAction - ) - csCompletionMap - - --- | Detect when one of the peers was promoted to warm, e.g. --- @PromotedToWarm^{Duplex}_{Remote}@ or --- @PromotedToWarm^{Unidirectional}_{Remote}@. --- --- /triggers:/ 'PromotedToWarm' --- --- Note: The specification only describes @PromotedToWarm^{Duplex}_{Remote}@ --- transition, but here we don't make a distinction on @Duplex@ and --- @Unidirectional@ connections. --- -firstPeerPromotedToWarm :: forall muxMode initiatorCtx peerAddr versionData m a b. - ( Alternative (STM m) - , MonadSTM m - ) - => EventSignal muxMode initiatorCtx peerAddr versionData m a b -firstPeerPromotedToWarm - connId - ConnectionState { csMux, csRemoteState } - = case csRemoteState of - -- the connection is already in 'RemoteEstablished' state. - RemoteEstablished -> mempty - - -- If the connection is in 'RemoteCold' state we do first to finish - -- synchronisation to detect incoming traffic on any of the responder - -- mini-protocols. - -- - -- This works for both duplex and unidirectional connections (e.g. p2p - -- \/ non-p2p nodes), for which protocols are started eagerly, unlike - -- for p2p nodes for which we start all mini-protocols on demand. - -- Using 'miniProtocolStatusVar' is ok for unidirectional connection, - -- as we never restart the protocols for them. They transition to - -- 'RemoteWarm' as soon the connection is accepted. This is because - -- for eagerly started mini-protocols mux puts them in 'StatusRunning' - -- as soon as mini-protocols are set in place by 'runMiniProtocol'. - RemoteCold -> - Map.foldMapWithKey - fn - (Mux.miniProtocolStateMap csMux) - - -- We skip it here; this case is done in 'firstPeerDemotedToCold'. - RemoteIdle {} -> - Map.foldMapWithKey - fn - (Mux.miniProtocolStateMap csMux) - where - fn :: (MiniProtocolNum, MiniProtocolDir) - -> STM m MiniProtocolStatus - -> FirstToFinish (STM m) (Event muxMode initiatorCtx peerAddr versionData m a b) - fn = \(_miniProtocolNum, miniProtocolDir) miniProtocolStatus -> - case miniProtocolDir of - InitiatorDir -> mempty - - ResponderDir -> - FirstToFinish $ - miniProtocolStatus >>= \case - StatusIdle -> retry - StatusStartOnDemand -> retry - StatusStartOnDemandAny -> retry - StatusRunning -> return $ AwakeRemote connId - - --- | Detect when a first warm peer is promoted to hot (any hot mini-protocols --- is running). --- -firstPeerPromotedToHot :: forall muxMode initiatorCtx peerAddr versionData m a b. - ( Alternative (STM m) - , MonadSTM m - ) - => EventSignal muxMode initiatorCtx peerAddr versionData m a b -firstPeerPromotedToHot - connId connState@ConnectionState { csRemoteState } - = case csRemoteState of - RemoteHot -> mempty - RemoteWarm -> - fmap (const $ RemotePromotedToHot connId) - $ foldMap fn - (hotMiniProtocolStateMap connState) - RemoteCold -> - fmap (const $ RemotePromotedToHot connId) - $ foldMap fn - (hotMiniProtocolStateMap connState) - RemoteIdle {} -> mempty - where - -- only hot mini-protocols; - hotMiniProtocolStateMap :: ConnectionState muxMode initiatorCtx peerAddr versionData m a b - -> Map (MiniProtocolNum, MiniProtocolDir) - (STM m MiniProtocolStatus) - hotMiniProtocolStateMap ConnectionState { csMux, csMiniProtocolMap } = - Mux.miniProtocolStateMap csMux - `Map.restrictKeys` - ( Set.map (,ResponderDir) - . Map.keysSet - . Map.filter - (\MiniProtocolData { mpdMiniProtocolTemp } -> - case mpdMiniProtocolTemp of - Hot -> True - _ -> False - ) - $ csMiniProtocolMap - ) - - fn :: STM m MiniProtocolStatus - -> FirstToFinish (STM m) () - fn miniProtocolStatus = - FirstToFinish $ - miniProtocolStatus >>= \case - StatusIdle -> retry - StatusStartOnDemand -> retry - StatusStartOnDemandAny -> retry - StatusRunning -> return () - - --- | Detect when all hot mini-protocols terminates, which triggers the --- `RemoteHot → RemoteWarm` transition. --- -firstPeerDemotedToWarm :: forall muxMode initiatorCtx peerAddr versionData m a b. - ( Alternative (STM m) - , MonadSTM m - ) - => EventSignal muxMode initiatorCtx peerAddr versionData m a b -firstPeerDemotedToWarm - connId connState@ConnectionState { csRemoteState } - = case csRemoteState of - RemoteHot -> - lastToFirstM $ - RemoteDemotedToWarm connId <$ foldMap fn (hotMiniProtocolStateMap connState) - - _ -> mempty - where - -- only hot mini-protocols; - hotMiniProtocolStateMap :: ConnectionState muxMode initiatorCtx peerAddr versionData m a b - -> Map (MiniProtocolNum, MiniProtocolDir) - (STM m MiniProtocolStatus) - hotMiniProtocolStateMap ConnectionState { csMux, csMiniProtocolMap } = - Mux.miniProtocolStateMap csMux - `Map.restrictKeys` - ( Set.map (,ResponderDir) - . Map.keysSet - . Map.filter - (\MiniProtocolData { mpdMiniProtocolTemp } -> - case mpdMiniProtocolTemp of - Hot -> True - _ -> False - ) - $ csMiniProtocolMap - ) - - fn :: STM m MiniProtocolStatus - -> LastToFinishM (STM m) () - fn miniProtocolStatus = - LastToFinishM $ - miniProtocolStatus >>= \case - StatusIdle -> return () - StatusStartOnDemand -> return () - StatusStartOnDemandAny -> return () - StatusRunning -> retry - - --- | Await for first peer demoted to cold, i.e. detect the --- @DemotedToCold^{Duplex}_{Remote}@. --- --- /triggers:/ 'DemotedToColdRemote' --- -firstPeerDemotedToCold :: ( Alternative (STM m) - , MonadSTM m - ) - => EventSignal muxMode initiatorCtx peerAddr versionData m a b -firstPeerDemotedToCold - connId - ConnectionState { - csMux, - csRemoteState - } - = case csRemoteState of - -- the connection is already in 'RemoteCold' state - RemoteCold -> mempty - - -- Responders are started using 'StartOnDemand' strategy. We detect - -- when all of the responders are in 'StatusIdle' or - -- 'StatusStartOnDemand' and subsequently put the connection in - -- 'RemoteIdle' state. - -- - -- In compat mode, when established mini-protocols terminate they will - -- not be restarted. - RemoteEstablished -> - fmap (const $ WaitIdleRemote connId) - . lastToFirstM - $ Map.foldMapWithKey - (\(_, miniProtocolDir) miniProtocolStatus -> - case miniProtocolDir of - InitiatorDir -> mempty - - ResponderDir -> - LastToFinishM $ do - miniProtocolStatus >>= \case - StatusIdle -> return () - StatusStartOnDemand -> return () - StatusStartOnDemandAny -> return () - StatusRunning -> retry - ) - (Mux.miniProtocolStateMap csMux) - - RemoteIdle {} -> mempty - - --- | First peer for which the 'RemoteIdle' timeout expires. --- -firstPeerCommitRemote :: Alternative (STM m) - => EventSignal muxMode initiatorCtx peerAddr versionData m a b -firstPeerCommitRemote - connId ConnectionState { csRemoteState } - = case csRemoteState of - -- the connection is already in 'RemoteCold' state - RemoteCold -> mempty - RemoteEstablished -> mempty - RemoteIdle timeoutSTM -> FirstToFinish (timeoutSTM $> CommitRemote connId) From 51a45b3521211a8008a71ed0cd8e5068922da643 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Fri, 11 Apr 2025 14:32:13 +0200 Subject: [PATCH 04/20] IG loop mostly whitespace Also reflects changes to 'RemoteIdle' tag --- .../src/Ouroboros/Network/InboundGovernor.hs | 655 +++++++++--------- 1 file changed, 328 insertions(+), 327 deletions(-) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs index 1fc99e7a3d3..ac5a1683d98 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs @@ -272,339 +272,340 @@ with forM_ events \event -> do state <- readTVarIO stateVar + (mbConnId, !state') <- case event of + NewConnection + -- new connection has been announced by either accept loop or + -- by connection manager (in which case the connection is in + -- 'DuplexState'). + (NewConnectionInfo + provenance + connId + dataFlow + Handle { + hMux = csMux, + hMuxBundle = muxBundle, + hVersionData = csVersionData + }) -> do + + traceWith tracer (TrNewConnection provenance connId) + let responderContext = ResponderContext { rcConnectionId = connId } + + connections <- Map.alterF + (\case + -- connection + Nothing -> do + let csMPMHot = + [ ( miniProtocolNum mpH + , MiniProtocolData mpH responderContext Hot + ) + | mpH <- projectBundle SingHot muxBundle + ] + csMPMWarm = + [ ( miniProtocolNum mpW + , MiniProtocolData mpW responderContext Warm + ) + | mpW <- projectBundle SingWarm muxBundle + ] + csMPMEstablished = + [ ( miniProtocolNum mpE + , MiniProtocolData mpE responderContext Established + ) + | mpE <- projectBundle SingEstablished muxBundle + ] + csMiniProtocolMap = + Map.fromList + (csMPMHot ++ csMPMWarm ++ csMPMEstablished) + + mCompletionMap + <- + foldM + (\acc mpd@MiniProtocolData { mpdMiniProtocol } -> + runResponder csMux mpd >>= \case + -- synchronous exceptions when starting + -- a mini-protocol are non-recoverable; we + -- close the connection and allow the server + -- to continue. + Left err -> do + traceWith tracer (TrResponderStartFailure connId (miniProtocolNum mpdMiniProtocol) err) + Mux.stop csMux + return Nothing + + Right completion -> do + let acc' = Map.insert (miniProtocolNum mpdMiniProtocol) + completion + <$> acc + -- force under lazy 'Maybe' + case acc' of + Just !_ -> return acc' + Nothing -> return acc' + ) + (Just Map.empty) + csMiniProtocolMap + + case mCompletionMap of + -- there was an error when starting one of the + -- responders, we let the server continue without this + -- connection. + Nothing -> return Nothing + + Just csCompletionMap -> do + mv <- traverse registerDelay idleTimeout + let -- initial state is 'RemoteIdle', if the remote end will not + -- start any responders this will unregister the inbound side. + csRemoteState :: RemoteState m + csRemoteState = RemoteIdle (case mv of + Nothing -> pure False + Just v -> LazySTM.readTVar v) + + connState = ConnectionState { + csMux, + csVersionData, + csMiniProtocolMap, + csCompletionMap, + csRemoteState + } + + return (Just connState) + + -- inbound governor might be notified about a connection + -- which is already tracked. In such case we preserve its + -- state. + -- + -- In particular we preserve an ongoing timeout on + -- 'RemoteIdle' state. + Just connState -> return (Just connState) + + ) + connId + (connections state) + + time' <- getMonotonicTime + -- update state and continue the recursive loop + let state' = state { + connections, + freshDuplexPeers = + case dataFlow of + Unidirectional -> freshDuplexPeers state + Duplex -> OrdPSQ.insert (remoteAddress connId) time' csVersionData + (freshDuplexPeers state) + } + return (Just connId, state') + + MuxFinished connId result -> do + + merr <- atomically result + case merr of + Nothing -> traceWith tracer (TrMuxCleanExit connId) + Just err -> traceWith tracer (TrMuxErrored connId err) + + -- the connection manager does should realise this on itself. + let state' = unregisterConnection connId state + return (Just connId, state') + + MiniProtocolTerminated + Terminated { + tConnId, + tMux, + tMiniProtocolData = mpd@MiniProtocolData { mpdMiniProtocol = miniProtocol }, + tResult + } -> do + tResult' <- atomically tResult + let num = miniProtocolNum miniProtocol + case tResult' of + Left e -> do + -- a mini-protocol errored. In this case mux will shutdown, and + -- the connection manager will tear down the socket. We can just + -- forget the connection from 'State'. + traceWith tracer $ + TrResponderErrored tConnId num e + + let state' = unregisterConnection tConnId state + return (Just tConnId, state') + + Right _ -> + runResponder tMux mpd >>= \case + Right completionAction -> do + traceWith tracer (TrResponderRestarted tConnId num) + let state' = updateMiniProtocol tConnId num completionAction state + return (Nothing, state') + + Left err -> do + -- there is no way to recover from synchronous exceptions; we + -- stop mux which allows to close resources held by + -- connection manager. + traceWith tracer (TrResponderStartFailure tConnId num err) + Mux.stop tMux + + let state' = unregisterConnection tConnId state + + return (Just tConnId, state') + + + WaitIdleRemote connId -> do + -- @ + -- DemotedToCold^{dataFlow}_{Remote} : InboundState Duplex + -- → InboundIdleState Duplex + -- @ + -- NOTE: `demotedToColdRemote` doesn't throw, hence exception handling + -- is not needed. + res <- demotedToColdRemote connectionManager connId + traceWith tracer (TrWaitIdleRemote connId res) + case res of + TerminatedConnection {} -> do + let state' = unregisterConnection connId state + return (Just connId, state') + OperationSuccess {} -> do + mv <- traverse registerDelay idleTimeout + let timeoutSTM :: STM m Bool + !timeoutSTM = case mv of + Nothing -> pure False + Just v -> LazySTM.readTVar v + + state' = updateRemoteState connId (RemoteIdle timeoutSTM) state + + return (Just connId, state') + -- It could happen that the connection got deleted by connection + -- manager due to some async exception so we need to unregister it + -- from the inbound governor state. + UnsupportedState UnknownConnectionSt -> do + let state' = unregisterConnection connId state + return (Just connId, state') + UnsupportedState {} -> do + return (Just connId, state) - (mbConnId, state') <- case event of - NewConnection - -- new connection has been announced by either accept loop or - -- by connection manager (in which case the connection is in - -- 'DuplexState'). - (NewConnectionInfo - provenance - connId - dataFlow - Handle { - hMux = csMux, - hMuxBundle = muxBundle, - hVersionData = csVersionData - }) -> do - - traceWith tracer (TrNewConnection provenance connId) - let responderContext = ResponderContext { rcConnectionId = connId } - - connections <- Map.alterF - (\case - -- connection - Nothing -> do - let csMPMHot = - [ ( miniProtocolNum mpH - , MiniProtocolData mpH responderContext Hot - ) - | mpH <- projectBundle SingHot muxBundle - ] - csMPMWarm = - [ ( miniProtocolNum mpW - , MiniProtocolData mpW responderContext Warm - ) - | mpW <- projectBundle SingWarm muxBundle - ] - csMPMEstablished = - [ ( miniProtocolNum mpE - , MiniProtocolData mpE responderContext Established - ) - | mpE <- projectBundle SingEstablished muxBundle - ] - csMiniProtocolMap = - Map.fromList - (csMPMHot ++ csMPMWarm ++ csMPMEstablished) - - mCompletionMap - <- - foldM - (\acc mpd@MiniProtocolData { mpdMiniProtocol } -> - runResponder csMux mpd >>= \case - -- synchronous exceptions when starting - -- a mini-protocol are non-recoverable; we - -- close the connection and allow the server - -- to continue. - Left err -> do - traceWith tracer (TrResponderStartFailure connId (miniProtocolNum mpdMiniProtocol) err) - Mux.stop csMux - return Nothing - - Right completion -> do - let acc' = Map.insert (miniProtocolNum mpdMiniProtocol) - completion - <$> acc - -- force under lazy 'Maybe' - case acc' of - Just !_ -> return acc' - Nothing -> return acc' - ) - (Just Map.empty) - csMiniProtocolMap - - case mCompletionMap of - -- there was an error when starting one of the - -- responders, we let the server continue without this - -- connection. - Nothing -> return Nothing - - Just csCompletionMap -> do - mv <- traverse registerDelay idleTimeout - let -- initial state is 'RemoteIdle', if the remote end will not - -- start any responders this will unregister the inbound side. - csRemoteState :: RemoteState m - csRemoteState = RemoteIdle (case mv of - Nothing -> retry - Just v -> LazySTM.readTVar v >>= check) - - connState = ConnectionState { - csMux, - csVersionData, - csMiniProtocolMap, - csCompletionMap, - csRemoteState - } - - return (Just connState) - - -- inbound governor might be notified about a connection - -- which is already tracked. In such case we preserve its - -- state. - -- - -- In particular we preserve an ongoing timeout on - -- 'RemoteIdle' state. - Just connState -> return (Just connState) - - ) - connId - (connections state) - - time' <- getMonotonicTime - -- update state and continue the recursive loop - let state' = state { - connections, - freshDuplexPeers = - case dataFlow of - Unidirectional -> freshDuplexPeers state - Duplex -> OrdPSQ.insert (remoteAddress connId) time' csVersionData - (freshDuplexPeers state) - } - return (Just connId, state') - - MuxFinished connId merr -> do - - case merr of - Nothing -> traceWith tracer (TrMuxCleanExit connId) - Just err -> traceWith tracer (TrMuxErrored connId err) - - -- the connection manager does should realise this on itself. - let state' = unregisterConnection connId state - return (Just connId, state') - - MiniProtocolTerminated - Terminated { - tConnId, - tMux, - tMiniProtocolData = mpd@MiniProtocolData { mpdMiniProtocol = miniProtocol }, - tResult - } -> - let num = miniProtocolNum miniProtocol in - case tResult of - Left e -> do - -- a mini-protocol errored. In this case mux will shutdown, and - -- the connection manager will tear down the socket. We can just - -- forget the connection from 'State'. - traceWith tracer $ - TrResponderErrored tConnId num e - - let state' = unregisterConnection tConnId state - return (Just tConnId, state') - - Right _ -> - runResponder tMux mpd >>= \case - Right completionAction -> do - traceWith tracer (TrResponderRestarted tConnId num) - let state' = updateMiniProtocol tConnId num completionAction state - return (Nothing, state') - - Left err -> do - -- there is no way to recover from synchronous exceptions; we - -- stop mux which allows to close resources held by - -- connection manager. - traceWith tracer (TrResponderStartFailure tConnId num err) - Mux.stop tMux - - let state' = unregisterConnection tConnId state - - return (Just tConnId, state') - - - WaitIdleRemote connId -> do -- @ - -- DemotedToCold^{dataFlow}_{Remote} : InboundState Duplex - -- → InboundIdleState Duplex + -- PromotedToWarm^{Duplex}_{Remote} + -- @ + -- or + -- @ + -- Awake^{dataFlow}_{Remote} -- @ - -- NOTE: `demotedToColdRemote` doesn't throw, hence exception handling - -- is not needed. - res <- demotedToColdRemote connectionManager connId - traceWith tracer (TrWaitIdleRemote connId res) - case res of - TerminatedConnection {} -> do - let state' = unregisterConnection connId state - return (Just connId, state') - OperationSuccess {} -> do - mv <- traverse registerDelay idleTimeout - let timeoutSTM :: STM m () - !timeoutSTM = case mv of - Nothing -> retry - Just v -> LazySTM.readTVar v >>= check - - let state' = updateRemoteState connId (RemoteIdle timeoutSTM) state - - return (Just connId, state') - -- It could happen that the connection got deleted by connection - -- manager due to some async exception so we need to unregister it - -- from the inbound governor state. - UnsupportedState UnknownConnectionSt -> do - let state' = unregisterConnection connId state - return (Just connId, state') - UnsupportedState {} -> do - return (Just connId, state) - - -- @ - -- PromotedToWarm^{Duplex}_{Remote} - -- @ - -- or - -- @ - -- Awake^{dataFlow}_{Remote} - -- @ - -- - -- Note: the 'AwakeRemote' is detected as soon as mux detects any - -- traffic. This means that we'll observe this transition also if the - -- first message that arrives is terminating a mini-protocol. - AwakeRemote connId -> do - -- notify the connection manager about the transition -- - -- NOTE: `promotedToWarmRemote` doesn't throw, hence exception handling - -- is not needed. - res <- promotedToWarmRemote connectionManager connId - traceWith tracer (TrPromotedToWarmRemote connId res) - - case resultInState res of - UnknownConnectionSt -> do - let state' = unregisterConnection connId state - return (Just connId, state') - _ -> do - let state' = updateRemoteState - connId - RemoteWarm - state - return (Just connId, state') - - RemotePromotedToHot connId -> do - traceWith tracer (TrPromotedToHotRemote connId) - let state' = updateRemoteState connId RemoteHot state - - return (Just connId, state') - - RemoteDemotedToWarm connId -> do - traceWith tracer (TrDemotedToWarmRemote connId) - let state' = updateRemoteState connId RemoteWarm state - - return (Just connId, state') - - CommitRemote connId -> do - -- NOTE: `releaseInboundConnection` doesn't throw, hence exception - -- handling is not needed. - res <- releaseInboundConnection connectionManager connId - traceWith tracer $ TrDemotedToColdRemote connId res - case res of - UnsupportedState {} -> do - -- 'inState' can be either: - -- @'UnknownConnection'@, - -- @'InReservedOutboundState'@, - -- @'InUnnegotiatedState', - -- @'InOutboundState' 'Unidirectional'@, - -- @'InTerminatingState'@, - -- @'InTermiantedState'@. - let state' = unregisterConnection connId state - return (Just connId, state') - - TerminatedConnection {} -> do - -- 'inState' can be either: - -- @'InTerminatingState'@, - -- @'InTermiantedState'@. - let state' = unregisterConnection connId state - return (Just connId, state') - - OperationSuccess transition -> - case transition of - -- the following two cases are when the connection was not used - -- by p2p-governor, the connection will be closed. - CommitTr -> do + -- Note: the 'AwakeRemote' is detected as soon as mux detects any + -- traffic. This means that we'll observe this transition also if the + -- first message that arrives is terminating a mini-protocol. + AwakeRemote connId -> do + -- notify the connection manager about the transition + -- + -- NOTE: `promotedToWarmRemote` doesn't throw, hence exception handling + -- is not needed. + res <- promotedToWarmRemote connectionManager connId + traceWith tracer (TrPromotedToWarmRemote connId res) + + case resultInState res of + UnknownConnectionSt -> do + let state' = unregisterConnection connId state + return (Just connId, state') + _ -> do + let state' = updateRemoteState + connId + RemoteWarm + state + return (Just connId, state') + + RemotePromotedToHot connId -> do + traceWith tracer (TrPromotedToHotRemote connId) + let state' = updateRemoteState connId RemoteHot state + + return (Just connId, state') + + RemoteDemotedToWarm connId -> do + traceWith tracer (TrDemotedToWarmRemote connId) + let state' = updateRemoteState connId RemoteWarm state + + return (Just connId, state') + + CommitRemote connId -> do + -- NOTE: `releaseInboundConnection` doesn't throw, hence exception + -- handling is not needed. + res <- releaseInboundConnection connectionManager connId + traceWith tracer $ TrDemotedToColdRemote connId res + case res of + UnsupportedState {} -> do + -- 'inState' can be either: + -- @'UnknownConnection'@, + -- @'InReservedOutboundState'@, + -- @'InUnnegotiatedState', + -- @'InOutboundState' 'Unidirectional'@, + -- @'InTerminatingState'@, + -- @'InTermiantedState'@. + let state' = unregisterConnection connId state + return (Just connId, state') + + TerminatedConnection {} -> do + -- 'inState' can be either: + -- @'InTerminatingState'@, + -- @'InTermiantedState'@. + let state' = unregisterConnection connId state + return (Just connId, state') + + OperationSuccess transition -> + case transition of + -- the following two cases are when the connection was not used + -- by p2p-governor, the connection will be closed. + CommitTr -> do + -- @ + -- Commit^{dataFlow}_{Remote} : InboundIdleState dataFlow + -- → TerminatingState + -- @ + let state' = unregisterConnection connId state + return (Just connId, state') + + -- the connection is still used by p2p-governor, carry on but put + -- it in 'RemoteCold' state. This will ensure we keep ready to + -- serve the peer. -- @ - -- Commit^{dataFlow}_{Remote} : InboundIdleState dataFlow - -- → TerminatingState + -- DemotedToCold^{Duplex}_{Remote} : DuplexState + -- → OutboundState Duplex -- @ - let state' = unregisterConnection connId state - return (Just connId, state') - - -- the connection is still used by p2p-governor, carry on but put - -- it in 'RemoteCold' state. This will ensure we keep ready to - -- serve the peer. - -- @ - -- DemotedToCold^{Duplex}_{Remote} : DuplexState - -- → OutboundState Duplex - -- @ - -- or - -- @ - -- Awake^{Duplex}^{Local} : InboundIdleState Duplex - -- → OutboundState Duplex - -- @ - -- - -- note: the latter transition is level triggered rather than - -- edge triggered. The server state is updated once protocol - -- idleness expires rather than as soon as the connection - -- manager was requested outbound connection. - KeepTr -> do - let state' = updateRemoteState connId RemoteCold state - - return (Just connId, state') - - MaturedDuplexPeers newMatureDuplexPeers freshDuplexPeers -> do - traceWith tracer $ TrMaturedConnections (Map.keysSet newMatureDuplexPeers) - (Set.fromList $ OrdPSQ.keys freshDuplexPeers) - pure (Nothing, state { matureDuplexPeers = newMatureDuplexPeers - <> matureDuplexPeers state, - freshDuplexPeers }) - - InactivityTimeout -> do - traceWith tracer $ TrInactive ((\(a,b,_) -> (a,b)) <$> OrdPSQ.toList (freshDuplexPeers state)) - pure (Nothing, state) - - mask_ $ do - atomically $ writeTVar var (mkPublicState state') - traceWith debugTracer (Debug state') - case mbConnId of - Just cid -> traceWith trTracer (mkRemoteTransitionTrace cid state state') - Nothing -> pure () - - mapTraceWithCache TrInboundGovernorCounters - tracer - (countersCache state') - (counters state') - traceWith tracer $ TrRemoteState $ - mkRemoteSt . csRemoteState - <$> connections state' - - -- Update Inbound Governor Counters cache values - let newCounters = counters state' - Cache oldCounters = countersCache state' - state'' | newCounters /= oldCounters = state' { countersCache = Cache newCounters } - | otherwise = state' - - inboundGovernorLoop var state'' + -- or + -- @ + -- Awake^{Duplex}^{Local} : InboundIdleState Duplex + -- → OutboundState Duplex + -- @ + -- + -- note: the latter transition is level triggered rather than + -- edge triggered. The server state is updated once protocol + -- idleness expires rather than as soon as the connection + -- manager was requested outbound connection. + KeepTr -> do + let state' = updateRemoteState connId RemoteCold state + + return (Just connId, state') + + MaturedDuplexPeers newMatureDuplexPeers freshDuplexPeers -> do + traceWith tracer $ TrMaturedConnections (Map.keysSet newMatureDuplexPeers) + (Set.fromList $ OrdPSQ.keys freshDuplexPeers) + pure (Nothing, state { matureDuplexPeers = newMatureDuplexPeers + <> matureDuplexPeers state, + freshDuplexPeers }) + + InactivityTimeout -> do + traceWith tracer $ TrInactive ((\(a,b,_) -> (a,b)) <$> OrdPSQ.toList (freshDuplexPeers state)) + pure (Nothing, state) + + mask_ $ do + atomically $ writeTVar stateVar state' + traceWith debugTracer (Debug state') + case mbConnId of + Just cid -> traceWith trTracer (mkRemoteTransitionTrace cid state state') + Nothing -> pure () + + mapTraceWithCache TrInboundGovernorCounters + tracer + (countersCache state') + (counters state') + traceWith tracer $ TrRemoteState $ + mkRemoteSt . csRemoteState + <$> connections state' + + -- Update Inbound Governor Counters cache values + let newCounters = counters state' + Cache oldCounters = countersCache state' + state'' | newCounters /= oldCounters = state' { countersCache = Cache newCounters } + | otherwise = state' + + atomically $ writeTVar stateVar state'' -- | The tracer embedded with the mux tracer by the connection handler -- for inbound or outbound duplex connections for efficient tracking From e83ed08b7a5d5309259a895e84f92727eef160ac Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Sun, 13 Apr 2025 13:49:31 +0200 Subject: [PATCH 05/20] Inbound governor unregister conn changes Remove unnecessary unregisterConnection call sites --- .../src/Ouroboros/Network/InboundGovernor.hs | 162 ++++++++---------- .../Network/InboundGovernor/State.hs | 7 +- 2 files changed, 77 insertions(+), 92 deletions(-) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs index ac5a1683d98..b8dcd7cd35d 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs @@ -272,7 +272,7 @@ with forM_ events \event -> do state <- readTVarIO stateVar - (mbConnId, !state') <- case event of + decision <- case event of NewConnection -- new connection has been announced by either accept loop or -- by connection manager (in which case the connection is in @@ -379,17 +379,16 @@ with connId (connections state) - time' <- getMonotonicTime -- update state and continue the recursive loop let state' = state { connections, freshDuplexPeers = case dataFlow of Unidirectional -> freshDuplexPeers state - Duplex -> OrdPSQ.insert (remoteAddress connId) time' csVersionData + Duplex -> OrdPSQ.insert (remoteAddress connId) time csVersionData (freshDuplexPeers state) } - return (Just connId, state') + return . Just $ StateWithPeerTransition state' connId MuxFinished connId result -> do @@ -399,8 +398,11 @@ with Just err -> traceWith tracer (TrMuxErrored connId err) -- the connection manager does should realise this on itself. - let state' = unregisterConnection connId state - return (Just connId, state') + -- we bypass the assertion check since MuxFinished could have been + -- placed on the queue by a racing thread before we managed + -- to remove the connection from our state at the end of this loop. + let state' = unregisterConnection True connId state + return . Just $ StateWithPeerTransition state' connId -- ^ even though it might not be true, but it's benign MiniProtocolTerminated Terminated { @@ -414,20 +416,20 @@ with case tResult' of Left e -> do -- a mini-protocol errored. In this case mux will shutdown, and - -- the connection manager will tear down the socket. We can just - -- forget the connection from 'State'. + -- the connection manager will tear down the socket. Before bailing out, + -- the IG tracer will emit BearState Dead which will unregister the connection + -- in some following iteration via MuxFinished, but for this peer it should + -- be the very next message. traceWith tracer $ TrResponderErrored tConnId num e - - let state' = unregisterConnection tConnId state - return (Just tConnId, state') + return Nothing Right _ -> runResponder tMux mpd >>= \case Right completionAction -> do traceWith tracer (TrResponderRestarted tConnId num) let state' = updateMiniProtocol tConnId num completionAction state - return (Nothing, state') + return . Just $ OnlyStateChange state' Left err -> do -- there is no way to recover from synchronous exceptions; we @@ -435,11 +437,7 @@ with -- connection manager. traceWith tracer (TrResponderStartFailure tConnId num err) Mux.stop tMux - - let state' = unregisterConnection tConnId state - - return (Just tConnId, state') - + return Nothing WaitIdleRemote connId -> do -- @ @@ -451,9 +449,6 @@ with res <- demotedToColdRemote connectionManager connId traceWith tracer (TrWaitIdleRemote connId res) case res of - TerminatedConnection {} -> do - let state' = unregisterConnection connId state - return (Just connId, state') OperationSuccess {} -> do mv <- traverse registerDelay idleTimeout let timeoutSTM :: STM m Bool @@ -463,15 +458,12 @@ with state' = updateRemoteState connId (RemoteIdle timeoutSTM) state - return (Just connId, state') - -- It could happen that the connection got deleted by connection - -- manager due to some async exception so we need to unregister it - -- from the inbound governor state. - UnsupportedState UnknownConnectionSt -> do - let state' = unregisterConnection connId state - return (Just connId, state') - UnsupportedState {} -> do - return (Just connId, state) + return . Just $ StateWithPeerTransition state' connId + -- if the connection handler failed by this time, it will have + -- written BearerState Dead to the IG tracer and we will handle this + -- in MuxFinished case on the next iteration, where it will unregister + -- the connection + _otherwise -> return Nothing -- @ -- PromotedToWarm^{Duplex}_{Remote} @@ -492,28 +484,21 @@ with res <- promotedToWarmRemote connectionManager connId traceWith tracer (TrPromotedToWarmRemote connId res) - case resultInState res of - UnknownConnectionSt -> do - let state' = unregisterConnection connId state - return (Just connId, state') - _ -> do - let state' = updateRemoteState - connId - RemoteWarm - state - return (Just connId, state') + let state' = updateRemoteState + connId + RemoteWarm + state + return . Just $ StateWithPeerTransition state' connId RemotePromotedToHot connId -> do traceWith tracer (TrPromotedToHotRemote connId) let state' = updateRemoteState connId RemoteHot state - - return (Just connId, state') + return . Just $ StateWithPeerTransition state' connId RemoteDemotedToWarm connId -> do traceWith tracer (TrDemotedToWarmRemote connId) let state' = updateRemoteState connId RemoteWarm state - - return (Just connId, state') + return . Just $ StateWithPeerTransition state' connId CommitRemote connId -> do -- NOTE: `releaseInboundConnection` doesn't throw, hence exception @@ -521,24 +506,6 @@ with res <- releaseInboundConnection connectionManager connId traceWith tracer $ TrDemotedToColdRemote connId res case res of - UnsupportedState {} -> do - -- 'inState' can be either: - -- @'UnknownConnection'@, - -- @'InReservedOutboundState'@, - -- @'InUnnegotiatedState', - -- @'InOutboundState' 'Unidirectional'@, - -- @'InTerminatingState'@, - -- @'InTermiantedState'@. - let state' = unregisterConnection connId state - return (Just connId, state') - - TerminatedConnection {} -> do - -- 'inState' can be either: - -- @'InTerminatingState'@, - -- @'InTermiantedState'@. - let state' = unregisterConnection connId state - return (Just connId, state') - OperationSuccess transition -> case transition of -- the following two cases are when the connection was not used @@ -548,8 +515,8 @@ with -- Commit^{dataFlow}_{Remote} : InboundIdleState dataFlow -- → TerminatingState -- @ - let state' = unregisterConnection connId state - return (Just connId, state') + let state' = unregisterConnection False connId state + return . Just $ StateWithPeerTransition state' connId -- the connection is still used by p2p-governor, carry on but put -- it in 'RemoteCold' state. This will ensure we keep ready to @@ -570,42 +537,56 @@ with -- manager was requested outbound connection. KeepTr -> do let state' = updateRemoteState connId RemoteCold state + return . Just $ StateWithPeerTransition state' connId - return (Just connId, state') + _otherwise -> return Nothing MaturedDuplexPeers newMatureDuplexPeers freshDuplexPeers -> do traceWith tracer $ TrMaturedConnections (Map.keysSet newMatureDuplexPeers) (Set.fromList $ OrdPSQ.keys freshDuplexPeers) - pure (Nothing, state { matureDuplexPeers = newMatureDuplexPeers - <> matureDuplexPeers state, - freshDuplexPeers }) + return . Just $ OnlyStateChange state { matureDuplexPeers = newMatureDuplexPeers + <> matureDuplexPeers state, + freshDuplexPeers } InactivityTimeout -> do traceWith tracer $ TrInactive ((\(a,b,_) -> (a,b)) <$> OrdPSQ.toList (freshDuplexPeers state)) - pure (Nothing, state) + return Nothing mask_ $ do - atomically $ writeTVar stateVar state' - traceWith debugTracer (Debug state') - case mbConnId of - Just cid -> traceWith trTracer (mkRemoteTransitionTrace cid state state') - Nothing -> pure () - - mapTraceWithCache TrInboundGovernorCounters - tracer - (countersCache state') - (counters state') - traceWith tracer $ TrRemoteState $ - mkRemoteSt . csRemoteState - <$> connections state' - - -- Update Inbound Governor Counters cache values - let newCounters = counters state' - Cache oldCounters = countersCache state' - state'' | newCounters /= oldCounters = state' { countersCache = Cache newCounters } - | otherwise = state' - - atomically $ writeTVar stateVar state'' + case decision of + Just (OnlyStateChange state') -> do + atomically $ writeTVar stateVar state' + traceWith debugTracer (Debug state') + Just (StateWithPeerTransition state' p) -> do + atomically $ writeTVar stateVar state' + traceWith debugTracer (Debug state') + traceWith trTracer (mkRemoteTransitionTrace p state state') + _otherwise -> pure () + + case decision of + _ | Just state' <- withState -> do + mapTraceWithCache TrInboundGovernorCounters + tracer + (countersCache state') + (counters state') + traceWith tracer $ TrRemoteState $ + mkRemoteSt . csRemoteState + <$> connections state' + + -- Update Inbound Governor Counters cache values + let newCounters = counters state' + Cache oldCounters = countersCache state' + state'' | newCounters /= oldCounters = state' { countersCache = Cache newCounters } + | otherwise = state' + + atomically $ writeTVar stateVar state'' + where + withState = case decision of + Just (OnlyStateChange s) -> Just s + Just (StateWithPeerTransition s _p) -> Just s + _otherwise -> Nothing + + _otherwise -> return () -- | The tracer embedded with the mux tracer by the connection handler -- for inbound or outbound duplex connections for efficient tracking @@ -972,3 +953,6 @@ data Trace peerAddr data Debug peerAddr versionData = forall muxMode initiatorCtx m a b. Debug (State muxMode initiatorCtx peerAddr versionData m a b) + +data LoopDecision state peer = OnlyStateChange !state + | StateWithPeerTransition !state !peer diff --git a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/State.hs b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/State.hs index 1cb7b6ac10d..3ec04788d51 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/State.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/State.hs @@ -206,12 +206,13 @@ data ResponderCounters = ResponderCounters { -- | Remove connection from 'State'. -- unregisterConnection :: Ord peerAddr - => ConnectionId peerAddr + => Bool + -> ConnectionId peerAddr -> State muxMode initiatorCtx peerAddr versionData m a b -> State muxMode initiatorCtx peerAddr versionData m a b -unregisterConnection connId state = +unregisterConnection bypass connId state = state { connections = - assert (connId `Map.member` connections state) $ + assert (connId `Map.member` connections state || bypass) $ Map.delete connId (connections state), matureDuplexPeers = From 7d2b7ffedba7c07d1e67bc51d4bf7d69c021f237 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Mon, 31 Mar 2025 11:28:14 +0200 Subject: [PATCH 06/20] Connection manager changes InformationChannel was moved under InboundGovernor directory Update Args and API Integrates prior commits --- .../Network/ConnectionManager/Core.hs | 98 +++++++++---------- 1 file changed, 47 insertions(+), 51 deletions(-) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs index 97228a74eb9..d1d02260c2c 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs @@ -1,15 +1,17 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE UndecidableInstances #-} - +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE UndecidableInstances #-} + +--{-# OPTIONS_GHC -fno-ignore-asserts #-} -- | The implementation of connection manager. -- -- The module should be imported qualified. @@ -58,23 +60,21 @@ import Network.Mux.Trace qualified as Mx import Network.Mux.Types qualified as Mx import Ouroboros.Network.ConnectionId -import Ouroboros.Network.ConnectionManager.InformationChannel - (InformationChannel) -import Ouroboros.Network.ConnectionManager.InformationChannel qualified as InfoChannel import Ouroboros.Network.ConnectionManager.State (ConnStateIdSupply, ConnectionManagerState, ConnectionState (..), MutableConnState (..)) import Ouroboros.Network.ConnectionManager.State qualified as State import Ouroboros.Network.ConnectionManager.Types -import Ouroboros.Network.InboundGovernor.Event (NewConnectionInfo (..)) +import Ouroboros.Network.InboundGovernor (Event (..), NewConnectionInfo (..)) +import Ouroboros.Network.InboundGovernor.InformationChannel (InformationChannel) +import Ouroboros.Network.InboundGovernor.InformationChannel qualified as InfoChannel import Ouroboros.Network.MuxMode import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..)) import Ouroboros.Network.Server.RateLimiting (AcceptedConnectionsLimit (..)) import Ouroboros.Network.Snocket - -- | Arguments for a 'ConnectionManager' which are independent of 'MuxMode'. -- -data Arguments handlerTrace socket peerAddr handle handleError versionNumber versionData m = +data Arguments handlerTrace socket peerAddr handle handleError versionNumber versionData m a b = Arguments { -- | Connection manager tracer. -- @@ -157,7 +157,9 @@ data Arguments handlerTrace socket peerAddr handle handleError versionNumber ver -- | Supply for `ConnStateId`-s. -- - connStateIdSupply :: ConnStateIdSupply m + connStateIdSupply :: ConnStateIdSupply m, + + classifyHandleError :: handleError -> HandleErrorType } @@ -360,7 +362,7 @@ data DemoteToColdLocal peerAddr handlerTrace handle handleError version m -- is responsible for the resource. -- with - :: forall (muxMode :: Mx.Mode) peerAddr socket handlerTrace handle handleError version versionData m a. + :: forall (muxMode :: Mx.Mode) peerAddr socket initiatorCtx handlerTrace handle handleError version versionData m a b x. ( Alternative (STM m) , MonadLabelledSTM m , MonadTraceSTM m @@ -378,19 +380,17 @@ with , Show peerAddr , Typeable peerAddr ) - => Arguments handlerTrace socket peerAddr handle handleError version versionData m - -> ConnectionHandler muxMode handlerTrace socket peerAddr handle handleError version versionData m - -- ^ Callback which runs in a thread dedicated for a given connection. - -> (handleError -> HandleErrorType) - -- ^ classify 'handleError's - -> InResponderMode muxMode (InformationChannel (NewConnectionInfo peerAddr handle) m) + => Arguments handlerTrace socket peerAddr handle handleError version versionData m a b + -> InResponderMode muxMode (InformationChannel (Event muxMode handle initiatorCtx peerAddr versionData m a b) m) -- ^ On outbound duplex connections we need to notify the server about -- a new connection. - -> (ConnectionManager muxMode socket peerAddr handle handleError m -> m a) + -> ConnectionHandler muxMode handlerTrace socket peerAddr handle handleError version versionData m + -- ^ ConnectionHandler which negotiates a connection and hosts the mux + -> (ConnectionManager muxMode socket peerAddr handle handleError m -> m x) -- ^ Continuation which receives the 'ConnectionManager'. It must not leak -- outside of scope of this callback. Once it returns all resources -- will be closed. - -> m a + -> m x with args@Arguments { tracer, trTracer, @@ -408,13 +408,13 @@ with args@Arguments { prunePolicy, connectionsLimits, updateVersionData, - connStateIdSupply + connStateIdSupply, + classifyHandleError } - ConnectionHandler { - connectionHandler - } - classifyHandleError inboundGovernorInfoChannel + ConnectionHandler { + connectionHandler + } k = do ((stateVar, stdGenVar) :: ( StrictTMVar m (ConnectionManagerState peerAddr handle handleError @@ -428,7 +428,7 @@ with args@Arguments { st' <- case mbst of Nothing -> pure Nothing Just st -> Just <$> traverse (inspectTVar (Proxy :: Proxy m) . toLazyTVar . connVar) st - return (TraceString (show st')) + return (TraceString ("cm-state: " <> show st')) stdGenVar <- newTVar (stdGen args) return (v, stdGenVar) @@ -1056,8 +1056,8 @@ with args@Arguments { case inboundGovernorInfoChannel of InResponderMode infoChannel -> atomically $ InfoChannel.writeMessage - infoChannel - (NewConnectionInfo provenance connId dataFlow handle) + infoChannel $ + NewConnection (NewConnectionInfo provenance connId dataFlow handle) _ -> return () return $ Connected connId dataFlow handle @@ -1075,7 +1075,7 @@ with args@Arguments { m (ConnectionManagerState peerAddr handle handleError version m) -> MutableConnState peerAddr handle handleError version m -> Maybe handleError - -> m (Connected peerAddr handle1 handleError) + -> m (Connected peerAddr handle handleError) terminateInboundWithErrorOrQuery connId connStateId connVar connThread stateVar mutableConnState handleErrorM = do transitions <- atomically $ do connState <- readTVar connVar @@ -1657,21 +1657,17 @@ with args@Arguments { -- → OutboundDupState^\tau Outbound -- @ let connState' = OutboundDupState connId connThread handle Ticking - notifyInboundGov = - case provenance' of - Inbound -> False - -- This is a connection to oneself; We don't - -- need to notify the inbound governor, as - -- it's already done by - -- `includeInboundConnectionImpl` - Outbound -> True writeTVar connVar connState' - case inboundGovernorInfoChannel of - InResponderMode infoChannel | notifyInboundGov -> - InfoChannel.writeMessage - infoChannel - (NewConnectionInfo provenance' connId dataFlow handle) - _ -> return () + case provenance' of + Outbound | InResponderMode infoChannel <- inboundGovernorInfoChannel -> + InfoChannel.writeMessage infoChannel . + NewConnection $ NewConnectionInfo provenance' connId dataFlow handle + -- This is a connection to oneself; We don't + -- need to notify the inbound governor, as + -- it's already done by + -- `includeInboundConnectionImpl` + _otherwise -> return () + return (Just $ mkTransition connState connState') -- @ From 3b6d3413495211737f49cd9e5caf00824c3bb6ba Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Mon, 31 Mar 2025 11:36:51 +0200 Subject: [PATCH 07/20] Mux changes Reordered some traces to be sequenced after some state was updated. Introduce Mux.Tracers type Contains mux tracer and separate channel tracer. The idea is that the channel tracer should not contain the inbound governor's information channel tracer which may be present in the muxTracer field for certain connections. The protocol channel send/receive trace tags are uniteresting from the IG tracer's perspective but there is a penalty for invoking it so frequently for every complete message. --- network-mux/src/Network/Mux.hs | 42 +++++++++++-------- network-mux/src/Network/Mux/Trace.hs | 17 ++++++++ .../src/Ouroboros/Network/Server/Simple.hs | 2 +- .../src/Ouroboros/Network/Socket.hs | 3 +- 4 files changed, 43 insertions(+), 21 deletions(-) diff --git a/network-mux/src/Network/Mux.hs b/network-mux/src/Network/Mux.hs index 26e7d6fd7ff..37f83a20dbc 100644 --- a/network-mux/src/Network/Mux.hs +++ b/network-mux/src/Network/Mux.hs @@ -45,6 +45,7 @@ module Network.Mux , traceBearerState , BearerState (..) , Trace (..) + , Tracers (..) , WithBearer (..) ) where @@ -212,11 +213,11 @@ run :: forall m (mode :: Mode). , MonadTimer m , MonadMask m ) - => Tracer m Trace + => Tracers m -> Mux mode m -> Bearer m -> m () -run tracer +run tracers@Tracers { muxTracer = tracer } Mux { muxMiniProtocols, muxControlCmdQueue, muxStatus @@ -238,7 +239,7 @@ run tracer -- Wait for someone to shut us down by calling muxStop or an error. -- Outstanding jobs are shut down Upon completion of withJobPool. withTimeoutSerial $ \timeout -> - monitor tracer + monitor tracers timeout jobpool egressQueue @@ -250,6 +251,7 @@ run tracer -- deadlock of mini-protocol completion action. `catch` \(SomeAsyncException e) -> do atomically $ writeTVar muxStatus (Failed $ toException e) + traceWith tracer $ TraceState Dead throwIO e where muxerJob egressQueue = @@ -272,12 +274,15 @@ miniProtocolJob , MonadThread m , MonadThrow (STM m) ) - => Tracer m Trace + => Tracers m -> EgressQueue m -> MiniProtocolState mode m -> MiniProtocolAction m -> JobPool.Job Group m JobResult -miniProtocolJob tracer egressQueue +miniProtocolJob Tracers { + muxTracer = tracer, + channelTracer } + egressQueue MiniProtocolState { miniProtocolInfo = MiniProtocolInfo { @@ -300,7 +305,7 @@ miniProtocolJob tracer egressQueue labelThisThread (case miniProtocolNum of MiniProtocolNum a -> "prtcl-" ++ show a) w <- newTVarIO BL.empty - let chan = muxChannel tracer egressQueue (Wanton w) + let chan = muxChannel channelTracer egressQueue (Wanton w) miniProtocolNum miniProtocolDirEnum miniProtocolIngressQueue (result, remainder) <- miniProtocolAction chan @@ -390,14 +395,16 @@ monitor :: forall mode m. , Alternative (STM m) , MonadThrow (STM m) ) - => Tracer m Trace + => Tracers m -> TimeoutFn m -> JobPool.JobPool Group m JobResult -> EgressQueue m -> StrictTQueue m (ControlCmd mode m) -> StrictTVar m Status -> m () -monitor tracer timeout jobpool egressQueue cmdQueue muxStatus = +monitor tracers@Tracers { + muxTracer = tracer } + timeout jobpool egressQueue cmdQueue muxStatus = go (MonitorCtx Map.empty Map.empty) where go :: MonitorCtx m mode -> m () @@ -433,9 +440,9 @@ monitor tracer timeout jobpool egressQueue cmdQueue muxStatus = go monitorCtx EventJobResult (MiniProtocolException pnum pmode e) -> do - traceWith tracer (TraceState Dead) - traceWith tracer (TraceExceptionExit pnum pmode e) atomically $ writeTVar muxStatus $ Failed e + traceWith tracer (TraceExceptionExit pnum pmode e) + traceWith tracer (TraceState Dead) throwIO e -- These two cover internal and protocol errors. The muxer exception is @@ -447,11 +454,10 @@ monitor tracer timeout jobpool egressQueue cmdQueue muxStatus = -- the source of the failure, e.g. specific mini-protocol. If we're -- propagating exceptions, we don't need to log them. EventJobResult (MuxerException e) -> do - traceWith tracer (TraceState Dead) atomically $ writeTVar muxStatus $ Failed e + traceWith tracer (TraceState Dead) throwIO e EventJobResult (DemuxerException e) -> do - traceWith tracer (TraceState Dead) r <- atomically $ do size <- JobPool.readGroupSize jobpool MiniProtocolJob case size of @@ -460,6 +466,7 @@ monitor tracer timeout jobpool egressQueue cmdQueue muxStatus = >> return True _ -> writeTVar muxStatus (Failed e) >> return False + traceWith tracer (TraceState Dead) unless r (throwIO e) EventControlCmd (CmdStartProtocolThread @@ -478,14 +485,14 @@ monitor tracer timeout jobpool egressQueue cmdQueue muxStatus = Nothing -> JobPool.forkJob jobpool $ miniProtocolJob - tracer + tracers egressQueue ptclState ptclAction Just cap -> JobPool.forkJobOn cap jobpool $ miniProtocolJob - tracer + tracers egressQueue ptclState ptclAction @@ -585,14 +592,14 @@ monitor tracer timeout jobpool egressQueue cmdQueue muxStatus = Nothing -> JobPool.forkJob jobpool $ miniProtocolJob - tracer + tracers egressQueue ptclState ptclAction Just cap -> JobPool.forkJobOn cap jobpool $ miniProtocolJob - tracer + tracers egressQueue ptclState ptclAction @@ -654,7 +661,7 @@ muxChannel -> IngressQueue m -> ByteChannel m muxChannel tracer egressQueue want@(Wanton w) mc md q = - Channel { send, recv} + Channel { send, recv } where -- Limit for the message buffer between send and mux thread. perMiniProtocolBufferSize :: Int64 @@ -797,4 +804,3 @@ runMiniProtocol Mux { muxMiniProtocols, muxControlCmdQueue , muxStatus} <|> return (Left $ toException (Shutdown Nothing st)) Failed e -> readTMVar completionVar <|> return (Left $ toException (Shutdown (Just e) st)) - diff --git a/network-mux/src/Network/Mux/Trace.hs b/network-mux/src/Network/Mux/Trace.hs index 7aefacef454..ad59fcbfe1d 100644 --- a/network-mux/src/Network/Mux/Trace.hs +++ b/network-mux/src/Network/Mux/Trace.hs @@ -10,6 +10,7 @@ module Network.Mux.Trace ( Error (..) , handleIOException , Trace (..) + , Tracers (..) , BearerState (..) , WithBearer (..) , TraceLabelPeer (..) @@ -22,6 +23,7 @@ import Text.Printf import Control.Exception hiding (throwIO) import Control.Monad.Class.MonadThrow import Control.Monad.Class.MonadTime.SI +import Control.Tracer (Tracer) import Data.Bifunctor (Bifunctor (..)) import Data.Word import GHC.Generics (Generic (..)) @@ -208,3 +210,18 @@ instance Show Trace where show (TraceTCPInfo _ len) = printf "TCPInfo len %d" len #endif +-- | Bundle of tracers passed to mux +-- Consult the 'Trace' type to determine which +-- tags are required/expected to be served by these tracers. +-- In principle, the channelTracer can be == muxTracer +-- but performance likely degrades in typical conditions +-- unnecessarily. +-- +data Tracers m = Tracers { + channelTracer :: Tracer m Trace, + -- ^ a low level tracer for events emitted by a bearer. It emits events as frequently + -- as receiving individual `SDU`s from the network. + muxTracer :: Tracer m Trace + -- ^ mux events which are emitted less frequently. It emits events which allow one + -- to observe the current state of a mini-protocol. + } diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Server/Simple.hs b/ouroboros-network-framework/src/Ouroboros/Network/Server/Simple.hs index bbdbadd3ee1..a59988fe70d 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Server/Simple.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Server/Simple.hs @@ -85,7 +85,7 @@ with sn makeBearer configureSock addr handshakeArgs versions k = Right HandshakeQueryResult {} -> error "handshake query is not supported" Right (HandshakeNegotiationResult (SomeResponderApplication app) vNumber vData) -> do mux <- Mx.new (toMiniProtocolInfos (runForkPolicy noBindForkPolicy (remoteAddress connId)) app) - withAsync (Mx.run nullTracer mux bearer) $ \aid -> do + withAsync (Mx.run (Mx.Tracers nullTracer nullTracer) mux bearer) $ \aid -> do void $ simpleMuxCallback connId vNumber vData app mux aid errorHandler = \e -> throwIO e diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Socket.hs b/ouroboros-network-framework/src/Ouroboros/Network/Socket.hs index f9dcc241474..e4b322cbf9d 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Socket.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Socket.hs @@ -409,7 +409,7 @@ connectToNodeWithMux' Mx.withReadBufferIO (\buffer -> do bearer <- Mx.getBearer makeBearer sduTimeout muxTracer sd buffer mux <- Mx.new (toMiniProtocolInfos (runForkPolicy noBindForkPolicy remoteAddress) app) - withAsync (Mx.run muxTracer mux bearer) $ \aid -> + withAsync (Mx.run (Mx.Tracers muxTracer muxTracer) mux bearer) $ \aid -> k connectionId versionNumber agreedOptions app mux aid ) @@ -502,4 +502,3 @@ data SomeResponderApplication addr bytes m b where Mx.HasResponder muxMode ~ True => (OuroborosApplicationWithMinimalCtx muxMode addr bytes m a b) -> SomeResponderApplication addr bytes m b - From 2b688c959e0daab1162228fb088d5ed5453da8c1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Mon, 31 Mar 2025 11:35:47 +0200 Subject: [PATCH 08/20] Connection handler changes Attach the IG tracer to Mux tracer before calling Mx.run The tracer is attached to the inbound handler and to the outbound handler only when a duplex mode was negotiated. Apply unmask only when calling Mx.run to guarantee in case of receiving an async exception that the promise of handshake negotiation result is delivered to the CM which is blocked waiting for it. --- .../Ouroboros/Network/ConnectionHandler.hs | 172 +++++++++++------- 1 file changed, 107 insertions(+), 65 deletions(-) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionHandler.hs b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionHandler.hs index 93c07319336..c7a36351862 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionHandler.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionHandler.hs @@ -1,12 +1,14 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeOperators #-} -- | Implementation of 'ConnectionHandler' @@ -31,6 +33,7 @@ module Ouroboros.Network.ConnectionHandler , HandleWithMinimalCtx , HandleError (..) , classifyHandleError + , MkMuxConnectionHandler (..) , MuxConnectionHandler , makeConnectionHandler , MuxConnectionManager @@ -51,17 +54,20 @@ import Control.Tracer (Tracer, contramap, traceWith) import Data.ByteString.Lazy (ByteString) import Data.Map (Map) +import Data.Maybe.Strict import Data.Text (Text) import Data.Typeable (Typeable) import Network.Mux (Mux) import Network.Mux qualified as Mx +import Network.Mux.Trace import Ouroboros.Network.ConnectionId (ConnectionId (..)) import Ouroboros.Network.ConnectionManager.Types import Ouroboros.Network.Context (ExpandedInitiatorContext, MinimalInitiatorContext, ResponderContext) import Ouroboros.Network.ControlMessage (ControlMessage (..)) +import Ouroboros.Network.InboundGovernor.State import Ouroboros.Network.Mux import Ouroboros.Network.MuxMode import Ouroboros.Network.Protocol.Handshake @@ -115,6 +121,22 @@ data Handle (muxMode :: Mx.Mode) initiatorCtx responderCtx versionData bytes m a hVersionData :: !versionData } +data MkMuxConnectionHandler (muxMode :: Mx.Mode) socket initiatorCtx responderCtx + peerAddr versionNumber versionData bytes m a b where + MuxInitiatorConnectionHandler :: MkMuxConnectionHandler + Mx.InitiatorMode socket initiatorCtx responderCtx + peerAddr versionNumber versionData bytes m a b + MuxResponderConnectionHandler :: ( StrictTVar m (StrictMaybe ResponderCounters) + -> Tracer m (WithBearer (ConnectionId peerAddr) Trace)) + -> MkMuxConnectionHandler + Mx.ResponderMode socket initiatorCtx responderCtx + peerAddr versionNumber versionData bytes m a b + MuxInitiatorResponderConnectionHandler + :: (versionData -> DataFlow) + -> ( StrictTVar m (StrictMaybe ResponderCounters) + -> Tracer m (WithBearer (ConnectionId peerAddr) Trace)) + -> MkMuxConnectionHandler Mx.InitiatorResponderMode socket initiatorCtx responderCtx peerAddr + versionNumber versionData bytes m a b -- | 'Handle' used by `node-to-node` P2P connections. -- @@ -207,6 +229,10 @@ type ConnectionManagerWithExpandedCtx muxMode socket peerAddr versionData versio -- different `ConnectionManager`s: one for `node-to-client` and another for -- `node-to-node` connections. But this is ok, as these resources are -- independent. +-- When a server is running, the inbound governor creates a tracer which is passed here, +-- and the connection handler appends it to the muxer tracer for +-- inbound and (negotiated) outbound duplex connections. This tracer +-- efficiently informs the IG loop of miniprotocol activity. -- makeConnectionHandler :: forall initiatorCtx responderCtx peerAddr muxMode socket versionNumber versionData m a b. @@ -223,33 +249,30 @@ makeConnectionHandler , Typeable peerAddr ) => Tracer m (Mx.WithBearer (ConnectionId peerAddr) Mx.Trace) - -> SingMuxMode muxMode -> ForkPolicy peerAddr - -- ^ describe whether this is outbound or inbound connection, and bring - -- evidence that we can use mux with it. -> HandshakeArguments (ConnectionId peerAddr) versionNumber versionData m -> Versions versionNumber versionData (OuroborosBundle muxMode initiatorCtx responderCtx ByteString m a b) -> (ThreadId m, RethrowPolicy) -- ^ 'ThreadId' and rethrow policy. Rethrow policy might throw an async -- exception to that thread, when trying to terminate the process. - -> MuxConnectionHandler muxMode socket initiatorCtx responderCtx peerAddr versionNumber versionData ByteString m a b -makeConnectionHandler muxTracer singMuxMode - forkPolicy + -> MkMuxConnectionHandler muxMode socket initiatorCtx responderCtx peerAddr versionNumber versionData ByteString m a b + -> MuxConnectionHandler muxMode socket initiatorCtx responderCtx peerAddr + versionNumber versionData ByteString m a b +makeConnectionHandler muxTracer forkPolicy handshakeArguments versionedApplication (mainThreadId, rethrowPolicy) = - ConnectionHandler { - connectionHandler = - case singMuxMode of - SingInitiatorMode -> - WithInitiatorMode outboundConnectionHandler - SingResponderMode -> - WithResponderMode inboundConnectionHandler - SingInitiatorResponderMode -> - WithInitiatorResponderMode outboundConnectionHandler - inboundConnectionHandler - } + \case + MuxInitiatorConnectionHandler -> + ConnectionHandler . WithInitiatorMode + $ outboundConnectionHandler NotInResponderMode + MuxResponderConnectionHandler inboundGovernorMuxTracer -> + ConnectionHandler . WithResponderMode . inboundConnectionHandler $ inboundGovernorMuxTracer + MuxInitiatorResponderConnectionHandler connectionDataFlow inboundGovernorMuxTracer -> + ConnectionHandler $ WithInitiatorResponderMode + (outboundConnectionHandler $ InResponderMode (inboundGovernorMuxTracer, connectionDataFlow)) + (inboundConnectionHandler inboundGovernorMuxTracer) where -- install classify exception handler classifyExceptions :: forall x. @@ -276,7 +299,10 @@ makeConnectionHandler muxTracer singMuxMode outboundConnectionHandler :: HasInitiator muxMode ~ True - => ConnectionHandlerFn (ConnectionHandlerTrace versionNumber versionData) + => InResponderMode muxMode ( StrictTVar m (StrictMaybe ResponderCounters) + -> Tracer m (WithBearer (ConnectionId peerAddr) Trace) + , versionData -> DataFlow) + -> ConnectionHandlerFn (ConnectionHandlerTrace versionNumber versionData) socket peerAddr (Handle muxMode initiatorCtx responderCtx versionData ByteString m a b) @@ -284,7 +310,8 @@ makeConnectionHandler muxTracer singMuxMode versionNumber versionData m - outboundConnectionHandler versionDataFn + outboundConnectionHandler inResponderMode + versionDataFn socket PromiseWriter { writePromise } tracer @@ -319,27 +346,37 @@ makeConnectionHandler muxTracer singMuxMode atomically $ writePromise (Left (HandleHandshakeClientError err)) traceWith tracer (TrHandshakeClientError err) - Right (HandshakeNegotiationResult app versionNumber agreedOptions) -> - unmask $ do - traceWith tracer (TrHandshakeSuccess versionNumber agreedOptions) - controlMessageBundle - <- (\a b c -> TemperatureBundle (WithHot a) (WithWarm b) (WithEstablished c)) - <$> newTVarIO Continue - <*> newTVarIO Continue - <*> newTVarIO Continue - mux <- Mx.new (mkMiniProtocolInfos (runForkPolicy forkPolicy remoteAddress) app) - let !handle = Handle { - hMux = mux, - hMuxBundle = app, - hControlMessage = controlMessageBundle, - hVersionData = agreedOptions - } - atomically $ writePromise (Right $ HandshakeConnectionResult handle (versionNumber, agreedOptions)) - withBuffer (\buffer -> do - bearer <- mkMuxBearer sduTimeout socket buffer - Mx.run (Mx.WithBearer connectionId `contramap` muxTracer) - mux bearer - ) + Right (HandshakeNegotiationResult app versionNumber agreedOptions) -> do + traceWith tracer (TrHandshakeSuccess versionNumber agreedOptions) + controlMessageBundle + <- (\a b c -> TemperatureBundle (WithHot a) (WithWarm b) (WithEstablished c)) + <$> newTVarIO Continue + <*> newTVarIO Continue + <*> newTVarIO Continue + mux <- Mx.new (mkMiniProtocolInfos (runForkPolicy forkPolicy remoteAddress) app) + let !handle = Handle { + hMux = mux, + hMuxBundle = app, + hControlMessage = controlMessageBundle, + hVersionData = agreedOptions + } + atomically $ writePromise (Right $ HandshakeConnectionResult handle (versionNumber, agreedOptions)) + withBuffer \buffer -> do + bearer <- mkMuxBearer sduTimeout socket buffer + muxTracer' <- + contramap (Mx.WithBearer connectionId) <$> case inResponderMode of + InResponderMode (inboundGovernorMuxTracer, connectionDataFlow) + | Duplex <- connectionDataFlow agreedOptions -> do + countersVar <- newTVarIO . SJust $ ResponderCounters 0 0 + pure $ muxTracer <> inboundGovernorMuxTracer countersVar + _notResponder -> + -- If this is InitiatorOnly, or a server where unidirectional flow was negotiated + -- the IG will never be informed of this remote for obvious reasons. + pure muxTracer + unmask $ Mx.run Mx.Tracers { + muxTracer = muxTracer', + channelTracer = Mx.WithBearer connectionId `contramap` muxTracer } + mux bearer Right (HandshakeQueryResult vMap) -> do atomically $ writePromise (Right HandshakeConnectionQuery) @@ -348,7 +385,9 @@ makeConnectionHandler muxTracer singMuxMode inboundConnectionHandler :: HasResponder muxMode ~ True - => ConnectionHandlerFn (ConnectionHandlerTrace versionNumber versionData) + => ( StrictTVar m (StrictMaybe ResponderCounters) + -> Tracer m (WithBearer (ConnectionId peerAddr) Trace)) + -> ConnectionHandlerFn (ConnectionHandlerTrace versionNumber versionData) socket peerAddr (Handle muxMode initiatorCtx responderCtx versionData ByteString m a b) @@ -356,7 +395,8 @@ makeConnectionHandler muxTracer singMuxMode versionNumber versionData m - inboundConnectionHandler updateVersionDataFn + inboundConnectionHandler inboundGovernorMuxTracer + updateVersionDataFn socket PromiseWriter { writePromise } tracer @@ -391,28 +431,30 @@ makeConnectionHandler muxTracer singMuxMode Left !err -> do atomically $ writePromise (Left (HandleHandshakeServerError err)) traceWith tracer (TrHandshakeServerError err) - Right (HandshakeNegotiationResult app versionNumber agreedOptions) -> - unmask $ do - traceWith tracer (TrHandshakeSuccess versionNumber agreedOptions) - controlMessageBundle - <- (\a b c -> TemperatureBundle (WithHot a) (WithWarm b) (WithEstablished c)) - <$> newTVarIO Continue - <*> newTVarIO Continue - <*> newTVarIO Continue - mux <- Mx.new (mkMiniProtocolInfos (runForkPolicy forkPolicy remoteAddress) app) - - let !handle = Handle { - hMux = mux, - hMuxBundle = app, - hControlMessage = controlMessageBundle, - hVersionData = agreedOptions - } - atomically $ writePromise (Right $ HandshakeConnectionResult handle (versionNumber, agreedOptions)) - withBuffer (\buffer -> do - bearer <- mkMuxBearer sduTimeout socket buffer - Mx.run (Mx.WithBearer connectionId `contramap` muxTracer) - mux bearer - ) + Right (HandshakeNegotiationResult app versionNumber agreedOptions) -> do + traceWith tracer (TrHandshakeSuccess versionNumber agreedOptions) + controlMessageBundle + <- (\a b c -> TemperatureBundle (WithHot a) (WithWarm b) (WithEstablished c)) + <$> newTVarIO Continue + <*> newTVarIO Continue + <*> newTVarIO Continue + mux <- Mx.new (mkMiniProtocolInfos (runForkPolicy forkPolicy remoteAddress) app) + + let !handle = Handle { + hMux = mux, + hMuxBundle = app, + hControlMessage = controlMessageBundle, + hVersionData = agreedOptions + } + atomically $ writePromise (Right $ HandshakeConnectionResult handle (versionNumber, agreedOptions)) + withBuffer \buffer -> do + bearer <- mkMuxBearer sduTimeout socket buffer + countersVar <- newTVarIO . SJust $ ResponderCounters 0 0 + let traceWithBearer = contramap $ Mx.WithBearer connectionId + unmask $ Mx.run Mx.Tracers { + muxTracer = traceWithBearer (muxTracer <> inboundGovernorMuxTracer countersVar), + channelTracer = traceWithBearer muxTracer } + mux bearer Right (HandshakeQueryResult vMap) -> do atomically $ writePromise (Right HandshakeConnectionQuery) traceWith tracer $ TrHandshakeQuery vMap From efb2494d1de6ee81d7e5f5e5b26b275405259c57 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Wed, 9 Apr 2025 12:00:06 +0200 Subject: [PATCH 09/20] bugfix prop_mux_starvation test The bug was exposed when Mux.run signature was changed to accept the new MuxTracerBundle type instead of the Mux.Trace's Trace type. The latter Trace type mixes low level bearer tags with the higher level mux tags, so logically they are separate and in fact are traced by separate components. The headerTracer must go along with the bearer tracer otherwise it doesn't trace anything, but the types matched so the program was accepted. --- network-mux/src/Network/Mux/Trace.hs | 38 +++++++++++++++++++++------- network-mux/test/Test/Mux.hs | 4 +-- 2 files changed, 31 insertions(+), 11 deletions(-) diff --git a/network-mux/src/Network/Mux/Trace.hs b/network-mux/src/Network/Mux/Trace.hs index ad59fcbfe1d..130380ee79e 100644 --- a/network-mux/src/Network/Mux/Trace.hs +++ b/network-mux/src/Network/Mux/Trace.hs @@ -120,9 +120,19 @@ data BearerState = Mature -- closed. deriving (Eq, Show) +-- todo The Trace type mixes tags which are output by +-- separate components but share the type. It would make more sense +-- to break this up into separate types. Care must be +-- excercised to ensure that a particular tracer goes +-- into the component that outputs the desired tags. For instance, +-- the low level bearer tags are not output by the tracer which +-- is passed to Mux via 'Tracers'. + -- | Enumeration of Mux events that can be traced. -- data Trace = + -- low level bearer trace tags (these are not traced by the tracer + -- which is passed to Mux) TraceRecvHeaderStart | TraceRecvHeaderEnd SDUHeader | TraceRecvDeltaQObservation SDUHeader Time @@ -133,19 +143,30 @@ data Trace = | TraceSendStart SDUHeader | TraceSendEnd | TraceState BearerState - | TraceCleanExit MiniProtocolNum MiniProtocolDir - | TraceExceptionExit MiniProtocolNum MiniProtocolDir SomeException - | TraceChannelRecvStart MiniProtocolNum - | TraceChannelRecvEnd MiniProtocolNum Int - | TraceChannelSendStart MiniProtocolNum Int - | TraceChannelSendEnd MiniProtocolNum + | TraceSDUReadTimeoutException + | TraceSDUWriteTimeoutException + | TraceTCPInfo StructTCPInfo Word16 + -- low level handshake bearer tags (not traced by tracer in Mux) | TraceHandshakeStart | TraceHandshakeClientEnd DiffTime | TraceHandshakeServerEnd | forall e. Exception e => TraceHandshakeClientError e DiffTime | forall e. Exception e => TraceHandshakeServerError e - | TraceSDUReadTimeoutException - | TraceSDUWriteTimeoutException + -- mid level channel tags traced independently by each mini protocol + -- job in Mux, for each complete message, by the 'channelTracer' + -- within 'Tracers' + | TraceChannelRecvStart MiniProtocolNum + | TraceChannelRecvEnd MiniProtocolNum Int + | TraceChannelSendStart MiniProtocolNum Int + | TraceChannelSendEnd MiniProtocolNum + -- high level Mux tags traced by the main Mux/Connection handler + -- thread forked by CM. These may be monitored by the inbound + -- governor information channel tracer. These should be traced + -- by muxTracer of 'Tracers' and their ordering + -- is significant at call sites or bad things will happen. + -- You have been warned. + | TraceCleanExit MiniProtocolNum MiniProtocolDir + | TraceExceptionExit MiniProtocolNum MiniProtocolDir SomeException | TraceStartEagerly MiniProtocolNum MiniProtocolDir | TraceStartOnDemand MiniProtocolNum MiniProtocolDir | TraceStartOnDemandAny MiniProtocolNum MiniProtocolDir @@ -153,7 +174,6 @@ data Trace = | TraceTerminating MiniProtocolNum MiniProtocolDir | TraceStopping | TraceStopped - | TraceTCPInfo StructTCPInfo Word16 instance Show Trace where show TraceRecvHeaderStart = printf "Bearer Receive Header Start" diff --git a/network-mux/test/Test/Mux.hs b/network-mux/test/Test/Mux.hs index 8a93c815c42..3cd5189a5db 100644 --- a/network-mux/test/Test/Mux.hs +++ b/network-mux/test/Test/Mux.hs @@ -1022,7 +1022,7 @@ prop_mux_starvation (Uneven response0 response1) = clientBearer <- getBearer makeQueueChannelBearer (-1) - clientTracer + (clientTracer' <> headerTracer) QueueChannel { writeQueue = client_w, readQueue = client_r } Nothing serverBearer <- getBearer makeQueueChannelBearer @@ -1072,7 +1072,7 @@ prop_mux_starvation (Uneven response0 response1) = Mx.StartOnDemand server_long clientMux <- Mx.new [clientApp2, clientApp3] - clientMux_aid <- async $ Mx.run (clientTracer <> headerTracer) clientMux clientBearer + clientMux_aid <- async $ Mx.run clientTracer clientMux clientBearer clientRes2 <- Mx.runMiniProtocol clientMux (miniProtocolNum clientApp2) (miniProtocolDir clientApp2) Mx.StartEagerly client_short clientRes3 <- Mx.runMiniProtocol clientMux (miniProtocolNum clientApp3) (miniProtocolDir clientApp3) From f0360ba35c3aa74ceaba7c8c5ef5172d5be12207 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Mon, 31 Mar 2025 11:39:17 +0200 Subject: [PATCH 10/20] Server changes Integrates prior commits --- .../src/Ouroboros/Network/Server.hs | 124 +++++++----------- 1 file changed, 50 insertions(+), 74 deletions(-) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Server.hs b/ouroboros-network-framework/src/Ouroboros/Network/Server.hs index 81fa7e128ba..dfa9d9da02a 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Server.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Server.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} @@ -37,9 +38,10 @@ import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadThrow hiding (handle) import Control.Monad.Class.MonadTime.SI import Control.Monad.Class.MonadTimer.SI +import Control.Monad.Fix (MonadFix) + import Control.Tracer (Tracer, contramap, traceWith) -import Data.ByteString.Lazy (ByteString) import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NonEmpty import Data.Maybe (isNothing) @@ -49,13 +51,8 @@ import GHC.IO.Exception import Foreign.C.Error #endif -import Network.Mux qualified as Mx -import Ouroboros.Network.ConnectionHandler import Ouroboros.Network.ConnectionId (ConnectionId (..)) -import Ouroboros.Network.ConnectionManager.InformationChannel - (InboundGovernorInfoChannel) import Ouroboros.Network.ConnectionManager.Types -import Ouroboros.Network.Context (ResponderContext) import Ouroboros.Network.InboundGovernor qualified as InboundGovernor import Ouroboros.Network.Mux import Ouroboros.Network.Server.RateLimiting @@ -69,31 +66,13 @@ import Ouroboros.Network.Snocket -- | Server static configuration. -- -data Arguments (muxMode :: Mx.Mode) socket initiatorCtx peerAddr versionData versionNumber bytes m a b = +data Arguments muxMode socket peerAddr initiatorCtx responderCtx handle handlerTrace handleError versionNumber versionData bytes m a b x = Arguments { sockets :: NonEmpty socket, snocket :: Snocket m socket peerAddr, tracer :: Tracer m (Trace peerAddr), - trTracer :: Tracer m (InboundGovernor.RemoteTransitionTrace peerAddr), - inboundGovernorTracer :: Tracer m (InboundGovernor.Trace peerAddr), - debugInboundGovernor :: Tracer m (InboundGovernor.Debug peerAddr versionData), connectionLimits :: AcceptedConnectionsLimit, - connectionManager :: MuxConnectionManager muxMode socket initiatorCtx (ResponderContext peerAddr) - peerAddr versionData versionNumber bytes m a b, - - -- | Time for which all protocols need to be idle to trigger - -- 'DemotedToCold' transition. - -- - inboundIdleTimeout :: Maybe DiffTime, - - connectionDataFlow :: versionData -> DataFlow, - - -- | Server control var is passed as an argument; this allows to use the - -- server to run and manage responders which needs to be started on - -- inbound connections. - -- - inboundInfoChannel :: InboundGovernorInfoChannel muxMode initiatorCtx peerAddr versionData - bytes m a b + inboundGovernorArgs :: InboundGovernor.Arguments muxMode handlerTrace socket peerAddr initiatorCtx responderCtx handle handleError versionNumber versionData bytes m a b x } -- | Server pauses accepting connections after an 'CONNABORTED' error. @@ -116,7 +95,7 @@ server_CONNABORTED_DELAY = 0.5 -- The first one is used in data diffusion for /Node-To-Node protocol/, while the -- other is useful for running a server for the /Node-To-Client protocol/. -- -with :: forall muxMode socket initiatorCtx peerAddr versionData versionNumber m a b x. +with :: forall muxMode socket peerAddr initiatorCtx responderCtx handle handlerTrace handleError versionNumber versionData bytes m a b x. ( Alternative (STM m) , MonadAsync m , MonadDelay m @@ -130,10 +109,18 @@ with :: forall muxMode socket initiatorCtx peerAddr versionData versionNumber m , HasResponder muxMode ~ True , Ord peerAddr , Show peerAddr + , MonadTraceSTM m + , MonadFork m + , MonadFix m ) - => Arguments muxMode socket initiatorCtx peerAddr versionData versionNumber ByteString m a b + => Arguments muxMode socket peerAddr initiatorCtx responderCtx handle handlerTrace + handleError versionNumber versionData bytes m a b x -- ^ record which holds all server arguments - -> (Async m Void -> m (InboundGovernor.PublicState peerAddr versionData) -> m x) + -> ( Async m Void + -> m (InboundGovernor.PublicState peerAddr versionData) + -> ConnectionManager + muxMode socket peerAddr handle handleError m + -> m x) -- ^ a callback which receives a handle to inbound governor thread and can -- read `PublicState`. -- @@ -143,56 +130,44 @@ with :: forall muxMode socket initiatorCtx peerAddr versionData versionNumber m with Arguments { sockets = socks, snocket, - trTracer, - tracer = tracer, - inboundGovernorTracer = inboundGovernorTracer, - debugInboundGovernor, + tracer, connectionLimits = limits@AcceptedConnectionsLimit { acceptedConnectionsHardLimit = hardLimit }, - inboundIdleTimeout, - connectionManager, - connectionDataFlow, - inboundInfoChannel + inboundGovernorArgs } - k = do + k + = do let sockets = NonEmpty.toList socks localAddresses <- traverse (getLocalAddr snocket) sockets - traceWith tracer (TrServerStarted localAddresses) - InboundGovernor.with - InboundGovernor.Arguments { - InboundGovernor.transitionTracer = trTracer, - InboundGovernor.tracer = inboundGovernorTracer, - InboundGovernor.debugTracer = debugInboundGovernor, - InboundGovernor.connectionDataFlow = connectionDataFlow, - InboundGovernor.infoChannel = inboundInfoChannel, - InboundGovernor.idleTimeout = inboundIdleTimeout, - InboundGovernor.connectionManager = connectionManager - } $ \inboundGovernorThread readPublicInboundState -> - withAsync (do - labelThisThread "Server2 (ouroboros-network-framework)" - k inboundGovernorThread readPublicInboundState) $ \actionThread -> do - let acceptLoops :: [m Void] - acceptLoops = - [ (do - labelThisThread ("accept " ++ show localAddress) - accept snocket socket >>= acceptLoop localAddress) - `finally` close snocket socket - | (localAddress, socket) <- localAddresses `zip` sockets - ] - -- race all `acceptLoops` with `actionThread` and - -- `inboundGovernorThread` - let waiter = fn <$> (do - labelThisThread "racing-action-inbound-governor" - actionThread `waitEither` inboundGovernorThread) + InboundGovernor.with inboundGovernorArgs + \inboundGovernorThread readPublicInboundState connectionManager -> + withAsync do + labelThisThread "Server2 (ouroboros-network-framework)" + k inboundGovernorThread readPublicInboundState connectionManager + \actionThread -> do + traceWith tracer (TrServerStarted localAddresses) + let acceptLoops :: [m Void] + acceptLoops = + [ (do + labelThisThread ("accept " ++ show localAddress) + accept snocket socket >>= acceptLoop localAddress connectionManager) + `finally` close snocket socket + | (localAddress, socket) <- localAddresses `zip` sockets + ] + -- race all `acceptLoops` with `actionThread` and + -- `inboundGovernorThread` + let waiter = fn <$> (do + labelThisThread "racing-action-inbound-governor" + actionThread `waitEither` inboundGovernorThread) - (fn <$> waiter `race` (labelThisThread "racing-accept-loops" >> raceAll acceptLoops)) - `finally` - traceWith tracer TrServerStopped - `catch` - \(e :: SomeException) -> do - when (isNothing $ fromException @SomeAsyncException e) $ - traceWith tracer (TrServerError e) - throwIO e + (fn <$> waiter `race` (labelThisThread "racing-accept-loops" >> raceAll acceptLoops)) + `finally` + traceWith tracer TrServerStopped + `catch` + \(e :: SomeException) -> do + when (isNothing $ fromException @SomeAsyncException e) $ + traceWith tracer (TrServerError e) + throwIO e where fn :: Either x Void -> x fn (Left x) = x @@ -206,9 +181,10 @@ with Arguments { go as (x:xs) = withAsync x (\a -> go (a:as) xs) acceptLoop :: peerAddr + -> ConnectionManager muxMode socket peerAddr handle handleError m -> Accept m socket peerAddr -> m Void - acceptLoop localAddress acceptOne0 = mask $ \unmask -> do + acceptLoop localAddress connectionManager acceptOne0 = mask $ \unmask -> do labelThisThread ("accept-loop-" ++ show localAddress) go unmask acceptOne0 where From 032d47f22646c5746eec7f650e8a72f502af0ffd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Mon, 31 Mar 2025 11:40:47 +0200 Subject: [PATCH 11/20] Diffusion changes integrates prior commits --- .../src/Ouroboros/Network/Diffusion.hs | 247 +++++++++--------- .../src/Ouroboros/Network/Diffusion/Types.hs | 42 ++- 2 files changed, 145 insertions(+), 144 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion.hs index f327011fe3c..029c637bd3a 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DisambiguateRecordFields #-} @@ -48,13 +49,12 @@ import System.Random (StdGen, newStdGen, split) import Network.DNS (Resolver) import Network.Mux qualified as Mx import Network.Mux.Bearer (withReadBufferIO) +import Network.Mux.Types import Network.Socket (Socket) import Network.Socket qualified as Socket import Ouroboros.Network.ConnectionHandler import Ouroboros.Network.ConnectionManager.Core qualified as CM -import Ouroboros.Network.ConnectionManager.InformationChannel - (newInformationChannel) import Ouroboros.Network.ConnectionManager.State qualified as CM import Ouroboros.Network.ConnectionManager.Types import Ouroboros.Network.Context (ExpandedInitiatorContext) @@ -64,6 +64,8 @@ import Ouroboros.Network.Diffusion.Types import Ouroboros.Network.Diffusion.Utils import Ouroboros.Network.ExitPolicy import Ouroboros.Network.InboundGovernor qualified as IG +import Ouroboros.Network.InboundGovernor.InformationChannel (InformationChannel, + newInformationChannel) import Ouroboros.Network.IOManager import Ouroboros.Network.Mux hiding (MiniProtocol (..)) import Ouroboros.Network.MuxMode @@ -316,12 +318,11 @@ runM Interfaces let localConnectionLimits = AcceptedConnectionsLimit maxBound maxBound 0 - localConnectionHandler :: NodeToClientConnectionHandler - ntcFd ntcAddr ntcVersion ntcVersionData m - localConnectionHandler = + mkLocalConnectionHandler :: MkNodeToClientConnectionHandler + ntcFd ntcAddr ntcVersion ntcVersionData m + mkLocalConnectionHandler responderMuxChannelTracer = makeConnectionHandler dtLocalMuxTracer - SingResponderMode dcLocalMuxForkPolicy daNtcHandshakeArguments ( ( \ (OuroborosApplication apps) @@ -331,12 +332,20 @@ runM Interfaces (WithEstablished []) ) <$> daLocalResponderApplication ) (mainThreadId, rethrowPolicy <> daLocalRethrowPolicy) - - localConnectionManagerArguments - :: NodeToClientConnectionManagerArguments - ntcFd ntcAddr ntcVersion ntcVersionData m - localConnectionManagerArguments = - CM.Arguments { + (MuxResponderConnectionHandler responderMuxChannelTracer) + + localWithConnectionManager + :: InformationChannel + (IG.Event 'ResponderMode handle initiatorCtx ntcAddr versionData m c b) m + -> ConnectionHandler 'ResponderMode (ConnectionHandlerTrace ntcVersion ntcVersionData) + ntcFd ntcAddr handle (HandleError muxMode versionNumber) version + versionData m + -> ( ConnectionManager 'ResponderMode ntcFd ntcAddr handle + (HandleError muxMode versionNumber) m + -> m x) + -> m x + localWithConnectionManager responderInfoChannel connectionHandler k = + CM.with CM.Arguments { CM.tracer = dtLocalConnectionManagerTracer, CM.trTracer = nullTracer, -- TODO: issue #3320 CM.muxTracer = dtLocalMuxTracer, @@ -354,36 +363,33 @@ runM Interfaces CM.stdGen = cmLocalStdGen, CM.connectionsLimits = localConnectionLimits, CM.updateVersionData = \a _ -> a, - CM.connStateIdSupply = diConnStateIdSupply + CM.connStateIdSupply = diConnStateIdSupply, + CM.classifyHandleError } - - CM.with - localConnectionManagerArguments - localConnectionHandler - classifyHandleError - (InResponderMode localInbInfoChannel) - $ \localConnectionManager-> do - -- - -- run node-to-client server - -- - traceWith tracer . RunLocalServer - =<< Snocket.getLocalAddr diNtcSnocket localSocket - - Server.with - Server.Arguments { - Server.sockets = localSocket :| [], - Server.snocket = diNtcSnocket, - Server.tracer = dtLocalServerTracer, - Server.trTracer = nullTracer, -- TODO: issue #3320 - Server.debugInboundGovernor = nullTracer, - Server.inboundGovernorTracer = dtLocalInboundGovernorTracer, - Server.inboundIdleTimeout = Nothing, - Server.connectionLimits = localConnectionLimits, - Server.connectionManager = localConnectionManager, - Server.connectionDataFlow = ntcDataFlow, - Server.inboundInfoChannel = localInbInfoChannel - } - (\inboundGovernorThread _ -> Async.wait inboundGovernorThread) + (InResponderMode responderInfoChannel) + connectionHandler + k + + traceWith tracer . RunLocalServer =<< Snocket.getLocalAddr diNtcSnocket localSocket + Server.with + Server.Arguments { + Server.sockets = localSocket :| [], + Server.snocket = diNtcSnocket, + Server.tracer = dtLocalServerTracer, + Server.connectionLimits = localConnectionLimits, + inboundGovernorArgs = + IG.Arguments { + tracer = dtLocalInboundGovernorTracer, + transitionTracer = nullTracer, + debugTracer = nullTracer, + connectionDataFlow = ntcDataFlow, + idleTimeout = Nothing, + withConnectionManager = localWithConnectionManager localInbInfoChannel, + mkConnectionHandler = mkLocalConnectionHandler, + infoChannel = localInbInfoChannel + } + } + (\inboundGovernorThread _ _ -> Async.wait inboundGovernorThread) -- | mkRemoteThread - create remote connection manager @@ -452,12 +458,12 @@ runM Interfaces -- let connectionManagerArguments' - :: forall handle handleError. + :: forall muxMode handle b. PrunePolicy ntnAddr -> StdGen -> CM.Arguments (ConnectionHandlerTrace ntnVersion ntnVersionData) - ntnFd ntnAddr handle handleError ntnVersion ntnVersionData m + ntnFd ntnAddr handle (HandleError muxMode ntnVersion) ntnVersion ntnVersionData m a b connectionManagerArguments' prunePolicy stdGen = CM.Arguments { CM.tracer = dtConnectionManagerTracer, @@ -479,21 +485,22 @@ runM Interfaces CM.timeWaitTimeout = dcTimeWaitTimeout, CM.outboundIdleTimeout = dcProtocolIdleTimeout, CM.updateVersionData = daUpdateVersionData, - CM.connStateIdSupply = diConnStateIdSupply + CM.connStateIdSupply = diConnStateIdSupply, + CM.classifyHandleError } let makeConnectionHandler' - :: forall muxMode socket initiatorCtx responderCtx b c. - SingMuxMode muxMode - -> Versions ntnVersion ntnVersionData + :: forall muxMode initiatorCtx responderCtx b c. + Versions ntnVersion ntnVersionData (OuroborosBundle muxMode initiatorCtx responderCtx ByteString m b c) - -> MuxConnectionHandler - muxMode socket initiatorCtx responderCtx ntnAddr + -> MkMuxConnectionHandler + muxMode ntnFd initiatorCtx responderCtx ntnAddr ntnVersion ntnVersionData ByteString m b c - makeConnectionHandler' muxMode versions = + -> MuxConnectionHandler muxMode ntnFd initiatorCtx responderCtx ntnAddr + ntnVersion ntnVersionData ByteString m b c + makeConnectionHandler' versions = makeConnectionHandler dtMuxTracer - muxMode dcMuxForkPolicy daNtnHandshakeArguments versions @@ -502,28 +509,26 @@ runM Interfaces -- | Capture the two variations (InitiatorMode,InitiatorResponderMode) of -- withConnectionManager: - withConnectionManagerInitiatorOnlyMode = + withConnectionManagerInitiatorOnlyMode k = CM.with (connectionManagerArguments' simplePrunePolicy cmStdGen1) -- Server is not running, it will not be able to -- advise which connections to prune. It's also not -- expected that the governor targets will be larger -- than limits imposed by 'cmConnectionsLimits'. - (makeConnectionHandler' - SingInitiatorMode - daApplicationInitiatorMode) - classifyHandleError NotInResponderMode + (makeConnectionHandler' daApplicationInitiatorMode + MuxInitiatorConnectionHandler) + k withConnectionManagerInitiatorAndResponderMode - inbndInfoChannel = + responderInfoChannel connectionHandler k = CM.with - (connectionManagerArguments' Diffusion.Policies.prunePolicy cmStdGen2) - (makeConnectionHandler' - SingInitiatorResponderMode - daApplicationInitiatorResponderMode) - classifyHandleError - (InResponderMode inbndInfoChannel) + (connectionManagerArguments' Diffusion.Policies.prunePolicy + cmStdGen2) + (InResponderMode responderInfoChannel) + connectionHandler + k -- -- peer state actions @@ -704,21 +709,29 @@ runM Interfaces f -- run node-to-node server - withServer sockets connectionManager inboundInfoChannel = - Server.with - Server.Arguments { - Server.sockets = sockets, - Server.snocket = diNtnSnocket, - Server.tracer = dtServerTracer, - Server.trTracer = dtInboundGovernorTransitionTracer, - Server.debugInboundGovernor = nullTracer, - Server.inboundGovernorTracer = dtInboundGovernorTracer, - Server.connectionLimits = dcAcceptedConnectionsLimit, - Server.connectionManager = connectionManager, - Server.connectionDataFlow = daNtnDataFlow, - Server.inboundIdleTimeout = Just dcProtocolIdleTimeout, - Server.inboundInfoChannel = inboundInfoChannel - } + withServer sockets inboundInfoChannel = + Server.with + Server.Arguments { + Server.sockets = sockets, + Server.snocket = diNtnSnocket, + Server.tracer = dtServerTracer, + Server.connectionLimits + = dcAcceptedConnectionsLimit, + inboundGovernorArgs = + IG.Arguments { + tracer = dtInboundGovernorTracer, + transitionTracer = dtInboundGovernorTransitionTracer, + debugTracer = nullTracer, + connectionDataFlow = daNtnDataFlow, + idleTimeout = Just dcProtocolIdleTimeout, + withConnectionManager = + withConnectionManagerInitiatorAndResponderMode inboundInfoChannel, + mkConnectionHandler = + makeConnectionHandler' daApplicationInitiatorResponderMode + . MuxInitiatorResponderConnectionHandler daNtnDataFlow, + infoChannel = inboundInfoChannel + } + } -- -- Part (b): capturing the major control-flow of runM: @@ -727,7 +740,7 @@ runM Interfaces -- InitiatorOnly mode, run peer selection only: InitiatorOnlyDiffusionMode -> - withConnectionManagerInitiatorOnlyMode $ \connectionManager-> do + withConnectionManagerInitiatorOnlyMode $ \connectionManager -> do debugStateVar <- newTVarIO $ Governor.emptyPeerSelectionState fuzzRng daEmptyExtraState mempty daInstallSigUSR1Handler connectionManager debugStateVar withPeerStateActions' connectionManager $ \peerStateActions-> @@ -748,45 +761,43 @@ runM Interfaces -- InitiatorAndResponder mode, run peer selection and the server: InitiatorAndResponderDiffusionMode -> do - inboundInfoChannel <- newInformationChannel - withConnectionManagerInitiatorAndResponderMode - inboundInfoChannel $ \connectionManager -> - -- - -- node-to-node sockets - -- - withSockets' $ \sockets addresses -> do - -- - -- node-to-node server - -- - withServer sockets connectionManager inboundInfoChannel $ - \inboundGovernorThread readInboundState -> do - debugStateVar <- newTVarIO $ Governor.emptyPeerSelectionState fuzzRng daEmptyExtraState mempty - daInstallSigUSR1Handler connectionManager debugStateVar - withPeerStateActions' connectionManager $ - \peerStateActions -> - withPeerSelectionActions' - (mkInboundPeersMap <$> readInboundState) - peerStateActions $ - \(ledgerPeersThread, localRootPeersProvider) peerSelectionActions -> - Async.withAsync - (do - labelThisThread "Peer selection governor" - peerSelectionGovernor' dtDebugPeerSelectionInitiatorResponderTracer debugStateVar peerSelectionActions) $ - \governorThread -> do - -- begin, unique to InitiatorAndResponder mode: - traceWith tracer (RunServer addresses) - -- end, unique to ... - Async.withAsync (do - labelThisThread "Peer churn governor" - peerChurnGovernor') $ - \churnGovernorThread -> - -- wait for any thread to fail: - snd <$> Async.waitAny [ ledgerPeersThread - , localRootPeersProvider - , governorThread - , churnGovernorThread - , inboundGovernorThread - ] + inboundInfoChannel <- newInformationChannel + -- + -- node-to-node sockets + -- + withSockets' \sockets addresses -> do + -- + -- node-to-node server + -- + -- begin, unique to InitiatorAndResponder mode: + traceWith tracer (RunServer addresses) + -- end, unique to ... + withServer sockets inboundInfoChannel + \inboundGovernorThread readInboundState connectionManager -> do + debugStateVar <- newTVarIO $ Governor.emptyPeerSelectionState fuzzRng daEmptyExtraState mempty + daInstallSigUSR1Handler connectionManager debugStateVar + withPeerStateActions' connectionManager $ + \peerStateActions -> + withPeerSelectionActions' + (mkInboundPeersMap <$> readInboundState) + peerStateActions $ + \(ledgerPeersThread, localRootPeersProvider) peerSelectionActions -> + Async.withAsync + (do + labelThisThread "Peer selection governor" + peerSelectionGovernor' dtDebugPeerSelectionInitiatorResponderTracer debugStateVar peerSelectionActions) $ + \governorThread -> do + Async.withAsync (do + labelThisThread "Peer churn governor" + peerChurnGovernor') $ + \churnGovernorThread -> + -- wait for any thread to fail: + snd <$> Async.waitAny [ ledgerPeersThread + , localRootPeersProvider + , governorThread + , churnGovernorThread + , inboundGovernorThread + ] -- | Main entry point for data diffusion service. It allows to: -- diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion/Types.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion/Types.hs index c52abbe49fc..9cd552c3c8d 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion/Types.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion/Types.hs @@ -21,8 +21,7 @@ module Ouroboros.Network.Diffusion.Types -- * NodeToClient type aliases , NodeToClientHandle , NodeToClientHandleError - , NodeToClientConnectionHandler - , NodeToClientConnectionManagerArguments + , MkNodeToClientConnectionHandler -- * NodeToNode type aliases , NodeToNodeHandle , NodeToNodeConnectionManager @@ -41,12 +40,14 @@ import Control.Tracer (Tracer, nullTracer) import Data.ByteString.Lazy (ByteString) import Data.List.NonEmpty (NonEmpty) import Data.Map (Map) +import Data.Maybe.Strict import Data.Set (Set) import Data.Typeable (Typeable) import Data.Void (Void) import System.Random (StdGen) import Network.Mux qualified as Mx +import Network.Mux.Trace qualified as Mux import Network.Mux.Types (ReadBuffer) import Network.Socket qualified as Socket @@ -565,31 +566,20 @@ type NodeToClientHandle ntcAddr versionData m = type NodeToClientHandleError ntcVersion = HandleError Mx.ResponderMode ntcVersion -type NodeToClientConnectionHandler +type MkNodeToClientConnectionHandler ntcFd ntcAddr ntcVersion ntcVersionData m = - ConnectionHandler - Mx.ResponderMode - (ConnectionHandlerTrace ntcVersion ntcVersionData) - ntcFd - ntcAddr - (NodeToClientHandle ntcAddr ntcVersionData m) - (NodeToClientHandleError ntcVersion) - ntcVersion - ntcVersionData - m - -type NodeToClientConnectionManagerArguments - ntcFd ntcAddr ntcVersion ntcVersionData m = - CM.Arguments - (ConnectionHandlerTrace ntcVersion ntcVersionData) - ntcFd - ntcAddr - (NodeToClientHandle ntcAddr ntcVersionData m) - (NodeToClientHandleError ntcVersion) - ntcVersion - ntcVersionData - m - + ( StrictTVar m (StrictMaybe IG.ResponderCounters) + -> Tracer m (Mux.WithBearer (ConnectionId ntcAddr) Mux.Trace)) + -> ConnectionHandler + Mx.ResponderMode + (ConnectionHandlerTrace ntcVersion ntcVersionData) + ntcFd + ntcAddr + (NodeToClientHandle ntcAddr ntcVersionData m) + (NodeToClientHandleError ntcVersion) + ntcVersion + ntcVersionData + m -- -- Node-To-Node type aliases From 2f8b843c3146192fbc5228df0ae15b4edd83f36d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Mon, 31 Mar 2025 11:44:36 +0200 Subject: [PATCH 12/20] Refactor tests/demos to comply with new interfaces No other significant changes besides cosmetics. --- network-mux/demo/mux-demo.hs | 7 +- network-mux/test/Test/Mux.hs | 83 +++-- .../demo/connection-manager.hs | 138 ++++---- .../io-tests/Test/Ouroboros/Network/Socket.hs | 2 +- .../Ouroboros/Network/ConnectionManager.hs | 56 ++-- .../Test/Ouroboros/Network/Server/Sim.hs | 18 +- .../Test/Ouroboros/Network/Socket.hs | 2 +- .../Test/Simulation/Network/Snocket.hs | 8 +- .../Network/ConnectionManager/Experiments.hs | 300 +++++++++--------- .../src/Test/Ouroboros/Network/Utils.hs | 15 + .../io-tests/Test/Ouroboros/Network/Pipe.hs | 4 +- .../testlib/Test/Ouroboros/Network/Mux.hs | 4 +- 12 files changed, 348 insertions(+), 289 deletions(-) diff --git a/network-mux/demo/mux-demo.hs b/network-mux/demo/mux-demo.hs index aefde5e8432..e905beb4f26 100644 --- a/network-mux/demo/mux-demo.hs +++ b/network-mux/demo/mux-demo.hs @@ -68,6 +68,8 @@ putStrLn_ = BSC.putStrLn . BSC.pack debugTracer :: Show a => Tracer IO a debugTracer = showTracing (Tracer putStrLn_) +nullTracers :: (Applicative m) => Tracers m +nullTracers = Tracers nullTracer nullTracer -- -- Protocols -- @@ -133,7 +135,7 @@ serverWorker bearer = do putStrLn $ "Result: " ++ show result Mx.stop mux - Mx.run nullTracer mux bearer + Mx.run nullTracers mux bearer where ptcls :: [MiniProtocolInfo ResponderMode] ptcls = [ MiniProtocolInfo { @@ -193,7 +195,7 @@ clientWorker bearer n msg = do putStrLn $ "Result: " ++ show result Mx.stop mux - Mx.run nullTracer mux bearer + Mx.run nullTracers mux bearer where ptcls :: [MiniProtocolInfo Mx.InitiatorMode] ptcls = [ MiniProtocolInfo { @@ -208,4 +210,3 @@ echoClient :: Int -> Int -> ByteString -> ReqRespClient ByteString ByteString IO Int echoClient !n 0 _ = SendMsgDone (pure n) echoClient !n m rawmsg = SendMsgReq rawmsg (pure . echoClient (n+1) (m-1)) - diff --git a/network-mux/test/Test/Mux.hs b/network-mux/test/Test/Mux.hs index 3cd5189a5db..603cedcc33e 100644 --- a/network-mux/test/Test/Mux.hs +++ b/network-mux/test/Test/Mux.hs @@ -127,6 +127,9 @@ activeTracer = nullTracer _sayTracer :: MonadSay m => Tracer m String _sayTracer = Tracer say +nullTracers :: (Applicative m) => Mx.Tracers m +nullTracers = Mx.Tracers nullTracer nullTracer + -- -- Generators -- @@ -350,15 +353,17 @@ prop_mux_snd_recv (DummyRun messages) = ioProperty $ do clientBearer = queueChannelAsBearer sduLen - clientTracer + clientTracer' QueueChannel { writeQueue = client_w, readQueue = client_r } serverBearer = queueChannelAsBearer sduLen - serverTracer + serverTracer' QueueChannel { writeQueue = server_w, readQueue = server_r } - clientTracer = contramap (Mx.WithBearer "client") activeTracer - serverTracer = contramap (Mx.WithBearer "server") activeTracer + clientTracer' = contramap (Mx.WithBearer "client") activeTracer + serverTracer' = contramap (Mx.WithBearer "server") activeTracer + clientTracer = Mx.Tracers clientTracer' clientTracer' + serverTracer = Mx.Tracers serverTracer' serverTracer' clientApp = MiniProtocolInfo { miniProtocolNum = Mx.MiniProtocolNum 2, @@ -418,17 +423,19 @@ prop_mux_snd_recv_bi (DummyRun messages) (DummyCapability clientCap) (DummyCapab let server_w = client_r server_r = client_w - clientTracer = contramap (Mx.WithBearer "client") activeTracer - serverTracer = contramap (Mx.WithBearer "server") activeTracer + clientTracer' = contramap (Mx.WithBearer "client") activeTracer + serverTracer' = contramap (Mx.WithBearer "server") activeTracer + clientTracer = Mx.Tracers clientTracer' clientTracer' + serverTracer = Mx.Tracers serverTracer' serverTracer' clientBearer <- getBearer makeQueueChannelBearer (-1) - clientTracer + clientTracer' QueueChannel { writeQueue = client_w, readQueue = client_r } Nothing serverBearer <- getBearer makeQueueChannelBearer (-1) - serverTracer + serverTracer' QueueChannel { writeQueue = server_w, readQueue = server_r } Nothing @@ -529,18 +536,20 @@ prop_mux_snd_recv_compat messages = ioProperty $ do let server_w = client_r server_r = client_w - clientTracer = contramap (Mx.WithBearer "client") activeTracer - serverTracer = contramap (Mx.WithBearer "server") activeTracer + clientTracer' = contramap (Mx.WithBearer "client") activeTracer + serverTracer' = contramap (Mx.WithBearer "server") activeTracer + clientTracer = Mx.Tracers clientTracer' clientTracer' + serverTracer = Mx.Tracers serverTracer' serverTracer' clientBearer <- getBearer makeQueueChannelBearer (-1) - clientTracer + clientTracer' QueueChannel { writeQueue = client_w, readQueue = client_r } Nothing serverBearer <- getBearer makeQueueChannelBearer (-1) - serverTracer + serverTracer' QueueChannel { writeQueue = server_w, readQueue = server_r } Nothing (verify, client_mp, server_mp) <- setupMiniReqRspCompat @@ -743,8 +752,10 @@ runMuxApplication :: DummyCapability -> Mx.Bearer IO -> IO Bool runMuxApplication (DummyCapability rspCap) initApps initBearer respApps respBearer = do - let clientTracer = contramap (Mx.WithBearer "client") activeTracer - serverTracer = contramap (Mx.WithBearer "server") activeTracer + let clientTracer' = contramap (Mx.WithBearer "client") activeTracer + serverTracer' = contramap (Mx.WithBearer "server") activeTracer + clientTracer = Mx.Tracers clientTracer' clientTracer' + serverTracer = Mx.Tracers serverTracer' serverTracer' protNum = [1..] respApps' = zip protNum respApps initApps' = zip protNum initApps @@ -1016,8 +1027,11 @@ prop_mux_starvation (Uneven response0 response1) = let server_w = client_r server_r = client_w - clientTracer = contramap (Mx.WithBearer "client") activeTracer - serverTracer = contramap (Mx.WithBearer "server") activeTracer + clientTracer' = contramap (Mx.WithBearer "client") activeTracer + serverTracer' = contramap (Mx.WithBearer "server") activeTracer + clientTracer = Mx.Tracers clientTracer' clientTracer' + serverTracer = Mx.Tracers serverTracer' serverTracer' + clientBearer <- getBearer makeQueueChannelBearer @@ -1027,7 +1041,7 @@ prop_mux_starvation (Uneven response0 response1) = Nothing serverBearer <- getBearer makeQueueChannelBearer (-1) - serverTracer + serverTracer' QueueChannel { writeQueue = server_w, readQueue = server_r } Nothing (client_short, server_short) <- @@ -1261,11 +1275,12 @@ prop_demux_sdu a = do server_w <- atomically $ newTBQueue 10 server_r <- atomically $ newTBQueue 10 - let serverTracer = contramap (Mx.WithBearer "server") activeTracer + let serverTracer' = contramap (Mx.WithBearer "server") activeTracer + serverTracer = Mx.Tracers serverTracer' serverTracer' serverBearer <- getBearer makeQueueChannelBearer (-1) - serverTracer + serverTracer' QueueChannel { writeQueue = server_w, readQueue = server_r } @@ -1576,7 +1591,7 @@ prop_mux_restart_m (DummyRestartingInitiatorApps apps) = do let minis = map (appToInfo Mx.InitiatorDirectionOnly . fst) apps mux <- Mx.new minis - mux_aid <- async $ Mx.run nullTracer mux bearer + mux_aid <- async $ Mx.run nullTracers mux bearer getRes <- sequence [ Mx.runMiniProtocol mux (daNum $ fst app) @@ -1625,7 +1640,7 @@ prop_mux_restart_m (DummyRestartingResponderApps rapps) = do minis = map (appToInfo Mx.ResponderDirectionOnly) apps mux <- Mx.new minis - mux_aid <- async $ Mx.run nullTracer mux bearer + mux_aid <- async $ Mx.run nullTracers mux bearer getRes <- sequence [ Mx.runMiniProtocol mux (daNum $ fst app) @@ -1677,7 +1692,7 @@ prop_mux_restart_m (DummyRestartingInitiatorResponderApps rapps) = do respMinis = map (appToInfo Mx.ResponderDirection) apps mux <- Mx.new $ initMinis ++ respMinis - mux_aid <- async $ Mx.run nullTracer mux bearer + mux_aid <- async $ Mx.run nullTracers mux bearer getInitRes <- sequence [ Mx.runMiniProtocol mux (daNum $ fst app) @@ -1762,7 +1777,7 @@ prop_mux_start_m bearer _ checkRes (DummyInitiatorApps apps) runTime _ = do minRunTime = minimum $ runTime : (map daRunTime $ filter (\app -> daAction app == DummyAppFail) apps) mux <- Mx.new minis - mux_aid <- async $ Mx.run nullTracer mux bearer + mux_aid <- async $ Mx.run nullTracers mux bearer killer <- async $ (threadDelay runTime) >> Mx.stop mux getRes <- sequence [ Mx.runMiniProtocol mux @@ -1786,7 +1801,7 @@ prop_mux_start_m bearer trigger checkRes (DummyResponderApps apps) runTime anySt ) $ filter (\app -> daAction app == DummyAppFail) apps) mux <- Mx.new minis - mux_aid <- async $ Mx.run verboseTracer mux bearer + mux_aid <- async $ Mx.run muxVerboseTracer mux bearer getRes <- sequence [ Mx.runMiniProtocol mux (daNum app) @@ -1816,7 +1831,7 @@ prop_mux_start_m bearer _trigger _checkRes (DummyResponderAppsKillMux apps) runT let minis = map (appToInfo Mx.ResponderDirectionOnly) apps mux <- Mx.new minis - mux_aid <- async $ Mx.run verboseTracer mux bearer + mux_aid <- async $ Mx.run muxVerboseTracer mux bearer getRes <- sequence [ Mx.runMiniProtocol mux (daNum app) @@ -1839,7 +1854,7 @@ prop_mux_start_m bearer trigger checkRes (DummyInitiatorResponderApps apps) runT minRunTime = minimum $ runTime : (map (\a -> daRunTime a) $ filter (\app -> daAction app == DummyAppFail) apps) mux <- Mx.new $ initMinis ++ respMinis - mux_aid <- async $ Mx.run verboseTracer mux bearer + mux_aid <- async $ Mx.run muxVerboseTracer mux bearer getInitRes <- sequence [ Mx.runMiniProtocol mux (daNum app) @@ -1917,6 +1932,14 @@ verboseTracer :: forall a m. => Tracer m a verboseTracer = threadAndTimeTracer $ showTracing $ Tracer say +muxVerboseTracer :: forall m. + ( MonadAsync m + , MonadMonotonicTime m + , MonadSay m + ) + => Mx.Tracers m +muxVerboseTracer = Mx.Tracers verboseTracer verboseTracer + threadAndTimeTracer :: forall a m. ( MonadAsync m , MonadMonotonicTime m @@ -1998,6 +2021,10 @@ close_experiment _iotest #endif fault tracer muxTracer clientCtx serverCtx reqs0 fn acc0 = do + let clientMuxTracer' = (Client,) `contramap` muxTracer + serverMuxTracer' = (Server,) `contramap` muxTracer + clientMuxTracer = Mx.Tracers clientMuxTracer' clientMuxTracer' + serverMuxTracer = Mx.Tracers serverMuxTracer' serverMuxTracer' withAsync -- run client thread (bracket (Mx.new [ MiniProtocolInfo { @@ -2009,7 +2036,7 @@ close_experiment ]) Mx.stop $ \mux -> withNetworkCtx clientCtx $ \clientBearer -> - withAsync (Mx.run ((Client,) `contramap` muxTracer) mux clientBearer) $ \_muxAsync -> + withAsync (Mx.run clientMuxTracer mux clientBearer) $ \_muxAsync -> Mx.runMiniProtocol mux miniProtocolNum Mx.InitiatorDirectionOnly Mx.StartEagerly @@ -2028,7 +2055,7 @@ close_experiment ]) Mx.stop $ \mux -> withNetworkCtx serverCtx $ \serverBearer -> - withAsync (Mx.run ((Server,) `contramap` muxTracer) mux serverBearer) $ \_muxAsync -> do + withAsync (Mx.run serverMuxTracer mux serverBearer) $ \_muxAsync -> do Mx.runMiniProtocol mux miniProtocolNum Mx.ResponderDirectionOnly Mx.StartOnDemand diff --git a/ouroboros-network-framework/demo/connection-manager.hs b/ouroboros-network-framework/demo/connection-manager.hs index 12727ffa25a..0754dbfe1a1 100644 --- a/ouroboros-network-framework/demo/connection-manager.hs +++ b/ouroboros-network-framework/demo/connection-manager.hs @@ -1,16 +1,17 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} -- just to use 'debugTracer' {-# OPTIONS_GHC -Wno-redundant-constraints #-} @@ -40,6 +41,7 @@ import Data.Functor (($>)) import Data.Hashable (Hashable) import Data.List.NonEmpty (NonEmpty (..)) import Data.Typeable (Typeable) +import Data.Void import Network.Mux qualified as Mux import Network.Mux.Bearer qualified as Mux @@ -59,11 +61,12 @@ import Network.TypedProtocol.ReqResp.Type (ReqResp) import Ouroboros.Network.ConnectionHandler import Ouroboros.Network.ConnectionManager.Core qualified as CM -import Ouroboros.Network.ConnectionManager.InformationChannel - (newInformationChannel) import Ouroboros.Network.ConnectionManager.State qualified as CM import Ouroboros.Network.ConnectionManager.Types import Ouroboros.Network.Context +import Ouroboros.Network.InboundGovernor qualified as InboundGovernor +import Ouroboros.Network.InboundGovernor.InformationChannel + (newInformationChannel) import Ouroboros.Network.IOManager import Ouroboros.Network.Mux import Ouroboros.Network.MuxMode @@ -205,6 +208,7 @@ withBidirectionalConnectionManager Mux.InitiatorResponderMode socket peerAddr UnversionedProtocolData UnversionedProtocol ByteString m () () -> peerAddr + -> Async m Void -> m a) -> m a withBidirectionalConnectionManager snocket makeBearer socket @@ -229,36 +233,8 @@ withBidirectionalConnectionManager snocket makeBearer socket establishedRequestsVar <- LazySTM.newTVarIO establishedInitiatorRequests let muxTracer = ("mux",) `contramap` nullTracer -- mux tracer - CM.with - CM.Arguments { - -- ConnectionManagerTrace - CM.tracer = ("cm",) `contramap` debugTracer, - CM.trTracer = ("cm-state",) `contramap` debugTracer, - -- MuxTracer - CM.muxTracer = muxTracer, - CM.ipv4Address = localAddress, - CM.ipv6Address = Nothing, - CM.addressType = \_ -> Just IPv4Address, - CM.snocket = snocket, - CM.makeBearer = makeBearer, - CM.withBuffer = \f -> f Nothing, - CM.configureSocket = \_ _ -> return (), - CM.timeWaitTimeout = timeWaitTimeout, - CM.outboundIdleTimeout = protocolIdleTimeout, - CM.connectionDataFlow = \_ -> Duplex, - CM.prunePolicy = simplePrunePolicy, - CM.stdGen = stdGen, - CM.connectionsLimits = AcceptedConnectionsLimit { - acceptedConnectionsHardLimit = maxBound, - acceptedConnectionsSoftLimit = maxBound, - acceptedConnectionsDelay = 0 - }, - CM.updateVersionData = \a _ -> a, - CM.connStateIdSupply - } - (makeConnectionHandler + mkConnectionHandler = makeConnectionHandler muxTracer - SingInitiatorResponderMode noBindForkPolicy HandshakeArguments { -- TraceSendRecv @@ -274,26 +250,60 @@ withBidirectionalConnectionManager snocket makeBearer socket warmRequestsVar establishedRequestsVar)) (mainThreadId, debugMuxErrorRethrowPolicy - <> debugIOErrorRethrowPolicy)) - (\_ -> HandshakeFailure) - (InResponderMode inbgovInfoChannel) - $ \connectionManager -> do - serverAddr <- Snocket.getLocalAddr snocket socket - Server.with - Server.Arguments { - Server.sockets = socket :| [], - Server.snocket = snocket, - Server.tracer = ("server",) `contramap` debugTracer, -- ServerTrace - Server.trTracer = nullTracer, - Server.inboundGovernorTracer = ("inbound-governor",) `contramap` debugTracer, - Server.debugInboundGovernor = nullTracer, - Server.connectionLimits = AcceptedConnectionsLimit maxBound maxBound 0, - Server.connectionManager = connectionManager, - Server.connectionDataFlow = \_ -> Duplex, - Server.inboundIdleTimeout = Just protocolIdleTimeout, - Server.inboundInfoChannel = inbgovInfoChannel + <> debugIOErrorRethrowPolicy) + + withConnectionManager connectionHandler k' = + CM.with + CM.Arguments { + -- ConnectionManagerTrace + tracer = ("cm",) `contramap` debugTracer, + trTracer = ("cm-state",) `contramap` debugTracer, + -- MuxTracer + muxTracer = muxTracer, + ipv4Address = localAddress, + ipv6Address = Nothing, + addressType = \_ -> Just IPv4Address, + snocket = snocket, + makeBearer = makeBearer, + CM.withBuffer = \f -> f Nothing, + configureSocket = \_ _ -> return (), + timeWaitTimeout = timeWaitTimeout, + outboundIdleTimeout = protocolIdleTimeout, + connectionDataFlow = \_ -> Duplex, + prunePolicy = simplePrunePolicy, + stdGen = stdGen, + connectionsLimits = AcceptedConnectionsLimit { + acceptedConnectionsHardLimit = maxBound, + acceptedConnectionsSoftLimit = maxBound, + acceptedConnectionsDelay = 0 + }, + updateVersionData = \a _ -> a, + connStateIdSupply, + classifyHandleError = (\_ -> HandshakeFailure) } - (\_ _ -> k connectionManager serverAddr) + (InResponderMode inbgovInfoChannel) + connectionHandler + k' + + serverAddr <- Snocket.getLocalAddr snocket socket + Server.with + Server.Arguments { + sockets = socket :| [], + snocket = snocket, + tracer = ("server",) `contramap` debugTracer, -- ServerTrace + connectionLimits = AcceptedConnectionsLimit maxBound maxBound 0, + inboundGovernorArgs = + InboundGovernor.Arguments { + transitionTracer = nullTracer, + tracer = ("inbound-governor",) `contramap` debugTracer, + debugTracer = nullTracer, + connectionDataFlow = \_ -> Duplex, + infoChannel = inbgovInfoChannel, + idleTimeout = Just protocolIdleTimeout, + withConnectionManager, + mkConnectionHandler = mkConnectionHandler . MuxInitiatorResponderConnectionHandler (\_ -> Duplex) } + } + (\inbGovAsync _ connManager-> k connManager serverAddr inbGovAsync) where serverApplication :: LazySTM.TVar m [[Int]] -> LazySTM.TVar m [[Int]] @@ -478,7 +488,7 @@ bidirectionalExperiment snocket makeBearer socket0 connStateIdSupply protocolIdleTimeout timeWaitTimeout (Just localAddr) stdGen clientAndServerData $ - \connectionManager _serverAddr -> forever' $ do + \connectionManager _serverAddr _inbGovAsync -> forever' $ do -- runInitiatorProtocols returns a list of results per each protocol -- in each bucket (warm \/ hot \/ established); but we run only one -- mini-protocol. We can use `concat` to flatten the results. diff --git a/ouroboros-network-framework/io-tests/Test/Ouroboros/Network/Socket.hs b/ouroboros-network-framework/io-tests/Test/Ouroboros/Network/Socket.hs index d6eb888c236..97301ab39bf 100644 --- a/ouroboros-network-framework/io-tests/Test/Ouroboros/Network/Socket.hs +++ b/ouroboros-network-framework/io-tests/Test/Ouroboros/Network/Socket.hs @@ -367,7 +367,7 @@ prop_socket_recv_error f rerr = [(Mx.ResponderDirectionOnly, void . runMiniProtocolCb initiator respCtx)] ] - withAsync (Mx.run nullTracer mux bearer) $ \aid -> do + withAsync (Mx.run (Mx.Tracers nullTracer nullTracer) mux bearer) $ \aid -> do _ <- atomically $ runFirstToFinish $ foldMap FirstToFinish resOps Mx.stop mux wait aid diff --git a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/ConnectionManager.hs b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/ConnectionManager.hs index 38b557b2aaa..ededf90f7c8 100644 --- a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/ConnectionManager.hs +++ b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/ConnectionManager.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -70,9 +71,9 @@ import Ouroboros.Network.Snocket (Accept (..), Accepted (..), import Test.Ouroboros.Network.ConnectionManager.Utils (verifyAbstractTransition) -import Ouroboros.Network.ConnectionManager.InformationChannel +import Ouroboros.Network.InboundGovernor.InformationChannel (newInformationChannel) -import Ouroboros.Network.ConnectionManager.InformationChannel qualified as InfoChannel +import Ouroboros.Network.InboundGovernor.InformationChannel qualified as InfoChannel @@ -762,32 +763,31 @@ prop_valid_transitions (Fixed rnd) (SkewedBool bindToLocalAddress) scheduleMap = let connectionHandler = mkConnectionHandler snocket result <- CM.with CM.Arguments { - CM.tracer, - CM.trTracer, - CM.muxTracer = nullTracer, - CM.ipv4Address = myAddress, - CM.ipv6Address = Nothing, - CM.addressType = \_ -> Just IPv4Address, - CM.snocket = snocket, - CM.makeBearer = makeFDBearer, - CM.withBuffer = \f -> f Nothing, - CM.configureSocket = \_ _ -> return (), - CM.connectionDataFlow = id, - CM.prunePolicy = simplePrunePolicy, - CM.stdGen = Random.mkStdGen rnd, - CM.connectionsLimits = AcceptedConnectionsLimit { - acceptedConnectionsHardLimit = maxBound, - acceptedConnectionsSoftLimit = maxBound, - acceptedConnectionsDelay = 0 - }, - CM.timeWaitTimeout = testTimeWaitTimeout, - CM.outboundIdleTimeout = testOutboundIdleTimeout, - CM.updateVersionData = \a _ -> a, - CM.connStateIdSupply - } - connectionHandler - (\_ -> HandshakeFailure) - (InResponderMode inbgovInfoChannel) + tracer, + trTracer, + muxTracer = nullTracer, + ipv4Address = myAddress, + ipv6Address = Nothing, + addressType = \_ -> Just IPv4Address, + snocket = snocket, + makeBearer = makeFDBearer, + withBuffer = \f -> f Nothing, + configureSocket = \_ _ -> return (), + connectionDataFlow = id, + prunePolicy = simplePrunePolicy, + stdGen = Random.mkStdGen rnd, + connectionsLimits = AcceptedConnectionsLimit { + acceptedConnectionsHardLimit = maxBound, + acceptedConnectionsSoftLimit = maxBound, + acceptedConnectionsDelay = 0 + }, + timeWaitTimeout = testTimeWaitTimeout, + outboundIdleTimeout = testOutboundIdleTimeout, + updateVersionData = \a _ -> a, + connStateIdSupply, + classifyHandleError = \_ -> HandshakeFailure } + (InResponderMode inbgovInfoChannel) + connectionHandler $ \(connectionManager :: ConnectionManager Mx.InitiatorResponderMode (FD (IOSim s)) Addr (Handle m) Void (IOSim s)) -> do diff --git a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs index 8d6dabaa02d..21bfb9adebb 100644 --- a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs +++ b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs @@ -106,7 +106,7 @@ import Test.Ouroboros.Network.InboundGovernor.Utils validRemoteTransitionMap, verifyRemoteTransition, verifyRemoteTransitionOrder) import Test.Ouroboros.Network.Orphans () -import Test.Ouroboros.Network.Utils (WithName (..), WithTime (..), +import Test.Ouroboros.Network.Utils (WithName (..), WithTime (..), debugTracerG, genDelayWithPrecision, nightlyTest, sayTracer, tracerWithTime) import Test.Simulation.Network.Snocket hiding (tests) @@ -635,6 +635,7 @@ multinodeExperiment (CM.Trace peerAddr (ConnectionHandlerTrace UnversionedProtocol DataFlowProtocolData))) + -> Tracer m (WithName (Name peerAddr) (Mux.WithBearer (ConnectionId peerAddr) Mux.Trace)) -> StdGen -> Snocket m socket peerAddr -> Mux.MakeBearer m socket @@ -647,7 +648,7 @@ multinodeExperiment -> MultiNodeScript req peerAddr -> m () multinodeExperiment inboundTrTracer trTracer inboundTracer debugTracer cmTracer - stdGen0 snocket makeBearer addrFamily serverAddr accInit + muxTracer stdGen0 snocket makeBearer addrFamily serverAddr accInit dataFlow0 acceptedConnLimit (MultiNodeScript script _) = withJobPool $ \jobpool -> do @@ -783,7 +784,7 @@ multinodeExperiment inboundTrTracer trTracer inboundTracer debugTracer cmTracer Job ( withBidirectionalConnectionManager name simTimeouts inboundTrTracer trTracer cmTracer - inboundTracer debugTracer + inboundTracer muxTracer debugTracer stdGen snocket makeBearer connStateIdSupply (\_ -> pure ()) fd (Just localAddr) serverAcc @@ -1429,6 +1430,7 @@ prop_connection_manager_counters (Fixed rnd) serverAcc (ArbDataFlow dataFlow) ( sayTracer <> Tracer traceM <> networkStateTracer getState) + debugTracerG (mkStdGen rnd) snocket makeFDBearer @@ -1485,6 +1487,7 @@ prop_timeouts_enforced (Fixed rnd) serverAcc (ArbDataFlow dataFlow) dynamicTracer nullTracer dynamicTracer + debugTracerG -- | Property wrapping `multinodeExperiment`. -- @@ -2196,7 +2199,7 @@ prop_server_accept_error (Fixed rnd) (AbsIOError ioerr) = withBidirectionalConnectionManager "node-0" simTimeouts nullTracer nullTracer nullTracer nullTracer - nullTracer + nullTracer nullTracer (mkStdGen rnd) snock makeFDBearer @@ -2260,6 +2263,8 @@ multiNodeSimTracer :: ( Alternative (STM m), Monad m, MonadFix m (WithName (Name SimAddr) (IG.Trace SimAddr)) -> Tracer m (WithName (Name SimAddr) (IG.Debug SimAddr DataFlowProtocolData)) + -> Tracer m + (WithName (Name SimAddr) (Mux.WithBearer (ConnectionId SimAddr) Mux.Trace)) -> Tracer m (WithName (Name SimAddr) @@ -2271,7 +2276,7 @@ multiNodeSimTracer :: ( Alternative (STM m), Monad m, MonadFix m multiNodeSimTracer stdGen serverAcc dataFlow defaultBearerInfo acceptedConnLimit events attenuationMap remoteTrTracer abstractTrTracer - inboundGovTracer debugTracer connMgrTracer = do + inboundGovTracer debugTracer muxTracer connMgrTracer = do let attenuationMap' = (fmap toBearerInfo <$>) . Map.mapKeys ( normaliseId @@ -2289,6 +2294,7 @@ multiNodeSimTracer stdGen serverAcc dataFlow defaultBearerInfo inboundGovTracer debugTracer connMgrTracer + muxTracer stdGen snocket makeFDBearer @@ -2323,7 +2329,7 @@ multiNodeSim stdGen serverAcc dataFlow defaultBearerInfo acceptedConnLimit events attenuationMap = do multiNodeSimTracer stdGen serverAcc dataFlow defaultBearerInfo acceptedConnLimit events attenuationMap dynamicTracer dynamicTracer dynamicTracer - (Tracer traceM) dynamicTracer + (Tracer traceM) dynamicTracer debugTracerG -- | Connection terminated while negotiating it. diff --git a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Socket.hs b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Socket.hs index 2472c829b9b..2dbeecb0135 100644 --- a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Socket.hs +++ b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Socket.hs @@ -372,7 +372,7 @@ prop_socket_recv_error f rerr = [(Mx.ResponderDirectionOnly, void . runMiniProtocolCb initiator respCtx)] ] - withAsync (Mx.run nullTracer mux bearer) $ \aid -> do + withAsync (Mx.run (Mx.Tracers nullTracer nullTracer) mux bearer) $ \aid -> do _ <- atomically $ runFirstToFinish $ foldMap FirstToFinish resOps Mx.stop mux wait aid diff --git a/ouroboros-network-framework/sim-tests/Test/Simulation/Network/Snocket.hs b/ouroboros-network-framework/sim-tests/Test/Simulation/Network/Snocket.hs index 0e5795366b1..9ca04b2f91c 100644 --- a/ouroboros-network-framework/sim-tests/Test/Simulation/Network/Snocket.hs +++ b/ouroboros-network-framework/sim-tests/Test/Simulation/Network/Snocket.hs @@ -287,9 +287,11 @@ clientServerSimulation payloads = serverPeer) withAsync (do labelThisThread "server-mux" - Mx.run (("server", connId,) + let serverTracer = + (("server", connId,) `contramap` traceTime (Tracer (say . show))) + Mx.run (Mx.Tracers serverTracer serverTracer) mux bearer) $ \_muxThread -> do res <- atomically resSTM @@ -332,9 +334,11 @@ clientServerSimulation payloads = -- kill mux as soon as the client returns withAsync (do labelThisThread "client-mux" - Mx.run (("client", connId,) + let clientTracer = + (("client", connId,) `contramap` traceTime (Tracer (say . show))) + Mx.run (Mx.Tracers clientTracer clientTracer) mux bearer) $ \_ -> do res <- atomically resSTM diff --git a/ouroboros-network-framework/testlib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs b/ouroboros-network-framework/testlib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs index c1fc4a26977..dde99502369 100644 --- a/ouroboros-network-framework/testlib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs +++ b/ouroboros-network-framework/testlib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs @@ -1,16 +1,18 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} -- for 'debugTracer' {-# OPTIONS_GHC -Wno-redundant-constraints #-} @@ -82,6 +84,8 @@ import Ouroboros.Network.Context import Ouroboros.Network.ControlMessage import Ouroboros.Network.Driver.Limits import Ouroboros.Network.InboundGovernor qualified as InboundGovernor +import Ouroboros.Network.InboundGovernor.InformationChannel + (newInformationChannel) import Ouroboros.Network.Mux import Ouroboros.Network.MuxMode import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..)) @@ -103,9 +107,6 @@ import Test.Ouroboros.Network.ConnectionManager.Timeouts import Test.Ouroboros.Network.Orphans () import Test.Ouroboros.Network.Utils (WithName (..)) -import Ouroboros.Network.ConnectionManager.InformationChannel - (newInformationChannel) - -- -- Server tests @@ -276,55 +277,58 @@ withInitiatorOnlyConnectionManager -> m a withInitiatorOnlyConnectionManager name timeouts trTracer tracer stdGen snocket makeBearer connStateIdSupply localAddr nextRequests handshakeTimeLimits acceptedConnLimit k = do - mainThreadId <- myThreadId - let muxTracer = (name,) `contramap` nullTracer -- mux tracer - CM.with - CM.Arguments { - -- ConnectionManagerTrace - CM.tracer = WithName name - `contramap` tracer, - CM.trTracer = (WithName name . fmap CM.abstractState) - `contramap` trTracer, - -- MuxTracer - CM.muxTracer = muxTracer, - CM.ipv4Address = localAddr, - CM.ipv6Address = Nothing, - CM.addressType = \_ -> Just IPv4Address, - CM.snocket = snocket, - CM.makeBearer = makeBearer, - CM.withBuffer = \f -> f Nothing, - CM.configureSocket = \_ _ -> return (), - CM.connectionDataFlow = \(DataFlowProtocolData df _) -> df, - CM.prunePolicy = simplePrunePolicy, - CM.stdGen, - CM.connectionsLimits = acceptedConnLimit, - CM.timeWaitTimeout = tTimeWaitTimeout timeouts, - CM.outboundIdleTimeout = tOutboundIdleTimeout timeouts, - CM.updateVersionData = \a _ -> a, - CM.connStateIdSupply - } - (makeConnectionHandler - muxTracer - SingInitiatorMode - noBindForkPolicy - HandshakeArguments { - -- TraceSendRecv - haHandshakeTracer = (name,) `contramap` nullTracer, - haHandshakeCodec = unversionedHandshakeCodec, - haVersionDataCodec = cborTermVersionDataCodec dataFlowProtocolDataCodec, - haAcceptVersion = acceptableVersion, - haQueryVersion = queryVersion, - haTimeLimits = handshakeTimeLimits - } - (dataFlowProtocol Unidirectional clientApplication) - (mainThreadId, debugMuxErrorRethrowPolicy - <> debugMuxRuntimeErrorRethrowPolicy - <> debugIOErrorRethrowPolicy - <> assertRethrowPolicy)) - (\_ -> HandshakeFailure) - NotInResponderMode - (\cm -> - k cm `catch` \(e :: SomeException) -> throwIO e) + mainThreadId <- myThreadId + let muxTracer = (name,) `contramap` nullTracer -- mux tracer + mkConnectionHandler = + makeConnectionHandler + muxTracer + noBindForkPolicy + HandshakeArguments { + -- TraceSendRecv + haHandshakeTracer = WithName name `contramap` nullTracer, + haHandshakeCodec = unversionedHandshakeCodec, + haVersionDataCodec = cborTermVersionDataCodec dataFlowProtocolDataCodec, + haAcceptVersion = acceptableVersion, + haQueryVersion = queryVersion, + haTimeLimits = handshakeTimeLimits + } + (dataFlowProtocol Unidirectional clientApplication) + (mainThreadId, debugMuxErrorRethrowPolicy + <> debugMuxRuntimeErrorRethrowPolicy + <> debugIOErrorRethrowPolicy + <> assertRethrowPolicy) + MuxInitiatorConnectionHandler + + + CM.with CM.Arguments { + -- ConnectionManagerTrace + tracer = WithName name + `contramap` tracer, + trTracer = (WithName name . fmap CM.abstractState) + `contramap` trTracer, + -- This is actually the low level bearer tracer + muxTracer = nullTracer, + ipv4Address = localAddr, + ipv6Address = Nothing, + addressType = \_ -> Just IPv4Address, + snocket, + makeBearer, + withBuffer = \f -> f Nothing, + configureSocket = \_ _ -> return (), + connectionDataFlow = \(DataFlowProtocolData df _) -> df, + timeWaitTimeout = tTimeWaitTimeout timeouts, + outboundIdleTimeout = tOutboundIdleTimeout timeouts, + prunePolicy = simplePrunePolicy, + stdGen, + connectionsLimits = acceptedConnLimit, + updateVersionData = \a _ -> a, + connStateIdSupply, + classifyHandleError = \_ -> HandshakeFailure + } + NotInResponderMode + mkConnectionHandler + \cm -> + k cm `catch` \(e :: SomeException) -> throwIO e where clientApplication :: TemperatureBundle [MiniProtocol Mx.InitiatorMode @@ -432,6 +436,7 @@ withBidirectionalConnectionManager peerAddr (ConnectionHandlerTrace UnversionedProtocol DataFlowProtocolData))) -> Tracer m (WithName name (InboundGovernor.Trace peerAddr)) + -> Tracer m (WithName name (Mx.WithBearer (ConnectionId peerAddr) Mx.Trace)) -> Tracer m (WithName name (InboundGovernor.Debug peerAddr DataFlowProtocolData)) -> StdGen -> Snocket m socket peerAddr @@ -459,7 +464,7 @@ withBidirectionalConnectionManager -> m a withBidirectionalConnectionManager name timeouts inboundTrTracer trTracer - tracer inboundTracer debugTracer + tracer inboundTracer muxTracer debugTracer stdGen snocket makeBearer connStateIdSupply confSock socket @@ -469,82 +474,86 @@ withBidirectionalConnectionManager name timeouts acceptedConnLimit k = do mainThreadId <- myThreadId inbgovInfoChannel <- newInformationChannel - let muxTracer = WithName name `contramap` nullTracer -- mux tracer - - CM.with - CM.Arguments { - -- ConnectionManagerTrace - CM.tracer = WithName name - `contramap` tracer, - CM.trTracer = (WithName name . fmap CM.abstractState) - `contramap` trTracer, - -- MuxTracer - CM.muxTracer = muxTracer, - CM.ipv4Address = localAddress, - CM.ipv6Address = Nothing, - CM.addressType = \_ -> Just IPv4Address, - CM.snocket = snocket, - CM.makeBearer = makeBearer, - CM.withBuffer = \f -> f Nothing, - CM.configureSocket = \sock _ -> confSock sock, - CM.timeWaitTimeout = tTimeWaitTimeout timeouts, - CM.outboundIdleTimeout = tOutboundIdleTimeout timeouts, - CM.connectionDataFlow = \(DataFlowProtocolData df _) -> df, - CM.prunePolicy = simplePrunePolicy, - CM.stdGen, - CM.connectionsLimits = acceptedConnLimit, - CM.updateVersionData = \versionData diffusionMode -> + let mkConnectionHandler = + makeConnectionHandler + (WithName name `contramap` muxTracer) + noBindForkPolicy + HandshakeArguments { + -- TraceSendRecv + haHandshakeTracer = WithName name `contramap` nullTracer, + haHandshakeCodec = unversionedHandshakeCodec, + haVersionDataCodec = cborTermVersionDataCodec dataFlowProtocolDataCodec, + haAcceptVersion = acceptableVersion, + haQueryVersion = queryVersion, + haTimeLimits = handshakeTimeLimits + } + (dataFlowProtocol Duplex serverApplication) + (mainThreadId, debugMuxErrorRethrowPolicy + <> debugMuxRuntimeErrorRethrowPolicy + <> debugIOErrorRethrowPolicy + <> assertRethrowPolicy) + + withConnectionManager connectionHandler k' = + CM.with CM.Arguments { + -- ConnectionManagerTrace + tracer = WithName name + `contramap` tracer, + trTracer = (WithName name . fmap CM.abstractState) + `contramap` trTracer, + -- low level bearer tracer + muxTracer = WithName name `contramap` nullTracer, --muxTracer, + ipv4Address = localAddress, + ipv6Address = Nothing, + addressType = \_ -> Just IPv4Address, + snocket, + makeBearer, + withBuffer = \f -> f Nothing, + configureSocket = \sock _ -> confSock sock, + connectionDataFlow = \(DataFlowProtocolData df _) -> df, + timeWaitTimeout = tTimeWaitTimeout timeouts, + outboundIdleTimeout = tOutboundIdleTimeout timeouts, + -- CM.connectionDataFlow = \(DataFlowProtocolData df _) -> df, + prunePolicy = simplePrunePolicy, + stdGen, + connectionsLimits = acceptedConnLimit, + updateVersionData = \versionData diffusionMode -> versionData { getProtocolDataFlow = case diffusionMode of InitiatorOnlyDiffusionMode -> Unidirectional InitiatorAndResponderDiffusionMode -> Duplex }, - CM.connStateIdSupply - } - (makeConnectionHandler - muxTracer - SingInitiatorResponderMode - noBindForkPolicy - HandshakeArguments { - -- TraceSendRecv - haHandshakeTracer = WithName name `contramap` nullTracer, - haHandshakeCodec = unversionedHandshakeCodec, - haVersionDataCodec = cborTermVersionDataCodec dataFlowProtocolDataCodec, - haAcceptVersion = acceptableVersion, - haQueryVersion = queryVersion, - haTimeLimits = handshakeTimeLimits + connStateIdSupply, + classifyHandleError = (\_ -> HandshakeFailure) } - (dataFlowProtocol Duplex serverApplication) - (mainThreadId, debugMuxErrorRethrowPolicy - <> debugMuxRuntimeErrorRethrowPolicy - <> debugIOErrorRethrowPolicy - <> assertRethrowPolicy)) - (\_ -> HandshakeFailure) - (InResponderMode inbgovInfoChannel) - $ \connectionManager -> - do - serverAddr <- Snocket.getLocalAddr snocket socket - Server.with - Server.Arguments { - Server.sockets = socket :| [], - Server.snocket = snocket, - Server.trTracer = - WithName name `contramap` inboundTrTracer, - Server.tracer = - WithName name `contramap` nullTracer, -- ServerTrace - Server.debugInboundGovernor = - WithName name `contramap` debugTracer, - Server.inboundGovernorTracer = - WithName name `contramap` inboundTracer, -- InboundGovernorTrace - Server.connectionLimits = acceptedConnLimit, - Server.connectionManager = connectionManager, - Server.connectionDataFlow = \(DataFlowProtocolData df _) -> df, - Server.inboundIdleTimeout = Just (tProtocolIdleTimeout timeouts), - Server.inboundInfoChannel = inbgovInfoChannel - } - (\inboundGovernorAsync _ -> k connectionManager serverAddr inboundGovernorAsync) - `catch` \(e :: SomeException) -> do - throwIO e + (InResponderMode inbgovInfoChannel) + connectionHandler + k' + + serverAddr <- Snocket.getLocalAddr snocket socket + handle (\(e :: SomeException) -> throwIO e) $ + Server.with + Server.Arguments { + sockets = socket :| [], + snocket = snocket, + tracer = + WithName name `contramap` nullTracer, -- ServerTrace + connectionLimits = acceptedConnLimit, + inboundGovernorArgs = + InboundGovernor.Arguments { + transitionTracer = + WithName name `contramap` inboundTrTracer, + tracer = + WithName name `contramap` inboundTracer, -- InboundGovernorTrace + debugTracer = + WithName name `contramap` debugTracer, + connectionDataFlow = \(DataFlowProtocolData df _) -> df, + infoChannel = inbgovInfoChannel, + idleTimeout = Just (tProtocolIdleTimeout timeouts), + withConnectionManager, + mkConnectionHandler = mkConnectionHandler . MuxInitiatorResponderConnectionHandler (\(DataFlowProtocolData df _) -> df) + } + } + (\inboundGovernorAsync _ connectionManager -> k connectionManager serverAddr inboundGovernorAsync) where serverApplication :: TemperatureBundle [MiniProtocol Mx.InitiatorResponderMode @@ -743,7 +752,7 @@ unidirectionalExperiment stdGen timeouts snocket makeBearer confSock socket clie $ \connectionManager -> withBidirectionalConnectionManager "server" timeouts nullTracer nullTracer nullTracer - nullTracer nullTracer + nullTracer nullTracer nullTracer stdGen'' snocket makeBearer connStateIdSupply confSock socket Nothing @@ -827,7 +836,7 @@ bidirectionalExperiment nextRequests0 <- oneshotNextRequests clientAndServerData0 nextRequests1 <- oneshotNextRequests clientAndServerData1 withBidirectionalConnectionManager "node-0" timeouts - nullTracer nullTracer nullTracer nullTracer + nullTracer nullTracer nullTracer nullTracer nullTracer nullTracer stdGen' snocket makeBearer connStateIdSupply confSock socket0 (Just localAddr0) @@ -837,7 +846,7 @@ bidirectionalExperiment maxAcceptedConnectionsLimit (\connectionManager0 _serverAddr0 _serverAsync0 -> do withBidirectionalConnectionManager "node-1" timeouts - nullTracer nullTracer nullTracer nullTracer + nullTracer nullTracer nullTracer nullTracer nullTracer nullTracer stdGen'' snocket makeBearer connStateIdSupply confSock socket1 (Just localAddr1) @@ -931,19 +940,6 @@ bidirectionalExperiment -- Utils -- - --- | Redefine this tracer to get valuable tracing information from various --- components: --- --- * connection-manager --- * inbound governor --- * server --- --- debugTracer :: (MonadSay m, MonadTime m, Show a) => Tracer m a --- debugTracer = Tracer (\msg -> (,msg) <$> getCurrentTime >>= say . show) - -- <> Tracer Debug.traceShowM - - withLock :: ( MonadSTM m , MonadThrow m ) diff --git a/ouroboros-network-testing/src/Test/Ouroboros/Network/Utils.hs b/ouroboros-network-testing/src/Test/Ouroboros/Network/Utils.hs index 119b3def13e..3d4196b8e70 100644 --- a/ouroboros-network-testing/src/Test/Ouroboros/Network/Utils.hs +++ b/ouroboros-network-testing/src/Test/Ouroboros/Network/Utils.hs @@ -4,6 +4,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} module Test.Ouroboros.Network.Utils ( -- * Arbitrary Delays @@ -30,6 +31,7 @@ module Test.Ouroboros.Network.Utils , splitWithNameTrace -- * Tracers , debugTracer + , debugTracerG , sayTracer -- * Tasty Utils , nightlyTest @@ -40,6 +42,7 @@ module Test.Ouroboros.Network.Utils import Control.Monad.Class.MonadSay import Control.Monad.Class.MonadTime.SI +import Control.Monad.IOSim (IOSim, traceM) import Control.Tracer (Contravariant (contramap), Tracer (..), contramapM) import Data.Bitraversable (bimapAccumR) @@ -51,6 +54,7 @@ import Data.Maybe (fromJust, isJust) import Data.Ratio import Data.Set (Set) import Data.Set qualified as Set +import Data.Typeable (Typeable) import Text.Pretty.Simple (pPrint) import Debug.Trace (traceShowM) @@ -227,6 +231,17 @@ debugTracer = Tracer traceShowM sayTracer :: ( Show a, MonadSay m) => Tracer m a sayTracer = Tracer (say . show) +-- | Redefine this tracer to get valuable tracing information from various +-- components: +-- +-- * connection-manager +-- * inbound governor +-- * server +-- +debugTracerG :: (Show a, Typeable a) => Tracer (IOSim s) a +debugTracerG = Tracer (\msg -> getCurrentTime >>= say . show . (,msg)) + <> Tracer traceM + -- <> Tracer Debug.traceShowM -- -- Nightly tests diff --git a/ouroboros-network/io-tests/Test/Ouroboros/Network/Pipe.hs b/ouroboros-network/io-tests/Test/Ouroboros/Network/Pipe.hs index f69a4fc09ae..33be92b7ca0 100644 --- a/ouroboros-network/io-tests/Test/Ouroboros/Network/Pipe.hs +++ b/ouroboros-network/io-tests/Test/Ouroboros/Network/Pipe.hs @@ -217,7 +217,7 @@ demo chain0 updates = do InitiatorProtocolOnly initiator -> [(Mx.InitiatorDirectionOnly, void . runMiniProtocolCb initiator initCtx)] ] - withAsync (Mx.run nullTracer clientMux clientBearer) $ \aid -> do + withAsync (Mx.run (Mx.Tracers nullTracer nullTracer) clientMux clientBearer) $ \aid -> do _ <- atomically $ runFirstToFinish $ foldMap FirstToFinish resOps Mx.stop clientMux wait aid @@ -242,7 +242,7 @@ demo chain0 updates = do ResponderProtocolOnly responder -> [(Mx.ResponderDirectionOnly, void . runMiniProtocolCb responder respCtx)] ] - withAsync (Mx.run nullTracer serverMux serverBearer) $ \aid -> do + withAsync (Mx.run (Mx.Tracers nullTracer nullTracer) serverMux serverBearer) $ \aid -> do _ <- atomically $ runFirstToFinish $ foldMap FirstToFinish resOps Mx.stop serverMux wait aid diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/Mux.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/Mux.hs index 002b11bf003..3a60899fc1b 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Mux.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Mux.hs @@ -186,7 +186,7 @@ demo chain0 updates delay = do InitiatorProtocolOnly initiator -> [(Mx.InitiatorDirectionOnly, void . runMiniProtocolCb initiator initCtx)] ] - withAsync (Mx.run nullTracer clientMux clientBearer) $ \aid -> do + withAsync (Mx.run (Mx.Tracers nullTracer nullTracer) clientMux clientBearer) $ \aid -> do _ <- atomically $ runFirstToFinish $ foldMap FirstToFinish resOps Mx.stop clientMux wait aid @@ -211,7 +211,7 @@ demo chain0 updates delay = do ResponderProtocolOnly responder -> [(Mx.ResponderDirectionOnly, void . runMiniProtocolCb responder respCtx)] ] - withAsync (Mx.run nullTracer serverMux serverBearer) $ \aid -> do + withAsync (Mx.run (Mx.Tracers nullTracer nullTracer) serverMux serverBearer) $ \aid -> do _ <- atomically $ runFirstToFinish $ foldMap FirstToFinish resOps Mx.stop serverMux wait aid From a376a331d32ea5eb09b4f5c671a3d8f674701b83 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Wed, 2 Apr 2025 21:50:22 +0200 Subject: [PATCH 13/20] multinodeExperiment minor improvements --- .../Test/Ouroboros/Network/Server/Sim.hs | 29 ++++++++++++------- 1 file changed, 19 insertions(+), 10 deletions(-) diff --git a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs index 21bfb9adebb..f9a03edf142 100644 --- a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs +++ b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs @@ -747,7 +747,7 @@ multinodeExperiment inboundTrTracer trTracer inboundTracer debugTracer cmTracer forkJob jobpool $ Job ( withInitiatorOnlyConnectionManager - name simTimeouts nullTracer nullTracer stdGen + name simTimeouts nullTracer cmTracer stdGen snocket makeBearer connStateIdSupply (Just localAddr) (mkNextRequests connVar) timeLimitsHandshake acceptedConnLimit @@ -1123,6 +1123,8 @@ prop_connection_manager_no_invalid_traces (Fixed rnd) serverAcc (ArbDataFlow dat , ppScript (MultiNodeScript events attenuationMap) , "========== ConnectionManager Events ==========" , Trace.ppTrace show show connectionManagerEvents + , "====== Say Events ======" + , intercalate "\n" $ selectTraceEventsSay' trace ]) . bifoldMap ( \ case @@ -1901,30 +1903,34 @@ prop_connection_manager_pruning (Fixed rnd) serverAcc -> Maybe (Either (WithName (Name SimAddr) (AbstractTransitionTrace SimAddr)) (WithName (Name SimAddr) (CM.Trace SimAddr (ConnectionHandlerTrace UnversionedProtocol DataFlowProtocolData)))) - fn _ (EventLog dyn) = Left <$> fromDynamic dyn - <|> Right <$> fromDynamic dyn + fn _ (EventLog dyn) = fromDynamic dyn fn _ _ = Nothing in tabulate "ConnectionEvents" (map showConnectionEvents events) - -- . counterexample (ppScript (MultiNodeScript events attenuationMap)) + . counterexample (ppScript (MultiNodeScript events attenuationMap)) + . counterexample (concat + [ "\n\n====== Say Events ======\n" + , intercalate "\n" $ selectTraceEventsSay' trace + , "\n" + ]) . mkPropertyPruning . bifoldMap ( \ case MainReturn {} -> mempty - v -> mempty { tpProperty = counterexample (show v) False } + v -> mempty { tpProperty = counterexample ("\ncounterexample: " <> show v) False } ) ( \ case Left trs -> TestProperty { tpProperty = (counterexample $! - ( "\nconnection:\n" + ( "\ncounterexample\nconnection:\n" ++ intercalate "\n" (map ppTransition trs)) ) . foldMap ( \ tr -> All . (counterexample $! - ( "\nUnexpected transition: " + ( "\ncounterexample\nUnexpected transition: " ++ show tr) ) . verifyAbstractTransition @@ -1940,8 +1946,11 @@ prop_connection_manager_pruning (Fixed rnd) serverAcc tpActivityTypes = [classifyActivityType trs], tpTransitions = trs } - Right b -> - mempty { tpNumberOfPrunings = classifyPruning b } + Right b + | CM.TrUnexpectedlyFalseAssertion assertionLoc <- b -> + mempty { tpProperty = counterexample ("\ncounterexample: " <> show assertionLoc) False } + | otherwise -> + mempty { tpNumberOfPrunings = classifyPruning b } ) . fmap (first (map ttTransition)) . groupConnsEither id abstractStateIsFinalTransition @@ -2329,7 +2338,7 @@ multiNodeSim stdGen serverAcc dataFlow defaultBearerInfo acceptedConnLimit events attenuationMap = do multiNodeSimTracer stdGen serverAcc dataFlow defaultBearerInfo acceptedConnLimit events attenuationMap dynamicTracer dynamicTracer dynamicTracer - (Tracer traceM) dynamicTracer debugTracerG + (Tracer traceM) dynamicTracer dynamicTracer --debugTracerG -- | Connection terminated while negotiating it. From 0091090852e078d889aa95fb5f9ac54cec935e4c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Mon, 31 Mar 2025 11:46:37 +0200 Subject: [PATCH 14/20] Fix testnet attenuation shrinker bug This addresses the shrinker hang when attempting to shrink 'AbsBearerInfo' in some cases. --- .../src/Test/Ouroboros/Network/Utils.hs | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/ouroboros-network-testing/src/Test/Ouroboros/Network/Utils.hs b/ouroboros-network-testing/src/Test/Ouroboros/Network/Utils.hs index 3d4196b8e70..15eafabaf27 100644 --- a/ouroboros-network-testing/src/Test/Ouroboros/Network/Utils.hs +++ b/ouroboros-network-testing/src/Test/Ouroboros/Network/Utils.hs @@ -40,6 +40,8 @@ module Test.Ouroboros.Network.Utils , renderRanges ) where +import GHC.Real + import Control.Monad.Class.MonadSay import Control.Monad.Class.MonadTime.SI import Control.Monad.IOSim (IOSim, traceM) @@ -51,7 +53,6 @@ import Data.List.Trace (Trace) import Data.List.Trace qualified as Trace import Data.Map qualified as Map import Data.Maybe (fromJust, isJust) -import Data.Ratio import Data.Set (Set) import Data.Set qualified as Set import Data.Typeable (Typeable) @@ -65,7 +66,7 @@ import Test.Tasty.ExpectedFailure (ignoreTest) newtype Delay = Delay { getDelay :: DiffTime } deriving Show - deriving newtype (Eq, Ord, Num) + deriving newtype (Eq, Ord, Num, Fractional, Real) genDelayWithPrecision :: Integer -> Gen DiffTime @@ -80,18 +81,20 @@ genDelayWithPrecision precision = -- instance Arbitrary Delay where arbitrary = Delay <$> genDelayWithPrecision 10 - shrink (Delay delay) | delay >= 0.1 = [ Delay (delay - 0.1) ] - | otherwise = [] + shrink delay | delay > 0.1 = + takeWhile (>= 0.1) . map fromRational . shrink . toRational $ delay + shrink _delay = [] newtype SmallDelay = SmallDelay { getSmallDelay :: DiffTime } deriving Show - deriving newtype (Eq, Ord, Num) + deriving newtype (Eq, Ord, Num, Fractional, Real) instance Arbitrary SmallDelay where arbitrary = resize 5 $ SmallDelay . getDelay <$> suchThat arbitrary (\(Delay d ) -> d < 5) - shrink (SmallDelay delay) | delay >= 0.1 = [ SmallDelay (delay - 0.1) ] - | otherwise = [] + shrink delay | delay > 0.1 = + takeWhile (>= 0.1) . map fromRational . shrink . toRational $ delay + shrink _delay = [] -- | Pick a subset of a set, using a 50:50 chance for each set element. -- From 669da9fac1eb985a2249f171991b92ab8aef9994 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Mon, 31 Mar 2025 11:48:59 +0200 Subject: [PATCH 15/20] Make testnet simulation failure traces more comprehensible --- .../src/Test/Ouroboros/Network/Utils.hs | 10 ++++++++-- .../Ouroboros/Network/Diffusion/Testnet/Cardano.hs | 5 ++++- 2 files changed, 12 insertions(+), 3 deletions(-) diff --git a/ouroboros-network-testing/src/Test/Ouroboros/Network/Utils.hs b/ouroboros-network-testing/src/Test/Ouroboros/Network/Utils.hs index 15eafabaf27..4ead5bca415 100644 --- a/ouroboros-network-testing/src/Test/Ouroboros/Network/Utils.hs +++ b/ouroboros-network-testing/src/Test/Ouroboros/Network/Utils.hs @@ -174,13 +174,19 @@ data WithName name event = WithName { wnName :: name, wnEvent :: event } - deriving (Show, Functor) + deriving (Functor) + +instance (Show name, Show event) => Show (WithName name event) where + show (WithName name ev) = "#" <> show name <> " %" <> show ev data WithTime event = WithTime { wtTime :: Time, wtEvent :: event } - deriving (Show, Functor) + deriving (Functor) + +instance Show event => Show (WithTime event) where + show (WithTime t ev) = "@" <> show t <> " " <> show ev tracerWithName :: name -> Tracer m (WithName name a) -> Tracer m a tracerWithName name = contramap (WithName name) diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs index e6098797a86..d6ae4a42fe6 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs @@ -28,6 +28,7 @@ import Data.Bifunctor (first) import Data.Dynamic (fromDynamic) import Data.Foldable (fold) import Data.IP qualified as IP +import Data.List (intercalate) import Data.List qualified as List import Data.List.Trace qualified as Trace import Data.Map (Map) @@ -302,7 +303,9 @@ testWithIOSim f traceNumber bi ds = iosimTracer trace = runSimTrace sim in labelDiffusionScript ds - $ counterexample (Trace.ppTrace show (ppSimEvent 0 0 0) $ Trace.take traceNumber trace) + $ counterexample (intercalate "\n" $ + selectTraceEventsSay' $ Trace.take traceNumber trace) + --counterexample (Trace.ppTrace show (ppSimEvent 0 0 0) $ Trace.take traceNumber trace) $ f trace traceNumber From 3ed1cf221c33c17fe63a6c3ea19b791da8319f81 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Mon, 31 Mar 2025 11:50:22 +0200 Subject: [PATCH 16/20] Shrinker improvements for testnet and framework experiments Fixes termination bug in testnet command shrinking by pruning duplicate commands. Added Skip command to diffusion testnet script. This is only generated for failed test cases by the shrinker. Sometimes we can generate a simpler command script by dropping a specific command, or a whole series of commands, and extend the delays (in effect, 'unshrinking' the delay of when the command is applied) of the remaining ones For eg. JoinNetwork 0 : Reconfigure 5 : Reconfigure 10 : Reconfigure 15 : Kill 2 Can be simplied to JoinNetwork 0 : Kill 32 when the intermediate reconfigures are skipped - the shrinker changes them to Skip and the candidate is passed here. It is important that the overall test duration is not shrunk at this stage, since a failed test might depend on some minimal run duration. If the property still fails, then the original commands are not contributing factors, but what is important is that the node has to run at least that long for the test case to fail. With such a simplified command script, the execution duration can be shrunk in the following shrinker iterations. Some commands may be just noise, and all they do is cause unnecessary work slowing down the shrinker as it attempts to shrink them individually. This only increases the search space without any benefit in the end. The skips are removed from the fixed up script, just the effect of their duration is applied to the following first non-skip command. If a specific command is in fact significant for the property to fail, for eg. the test passes if Reconfigure is changed to Skip, the shrinker will backtrack and keep that command and continue with shrinking the rest. The bottom line is that the minimal example and running time are both improved, significantly as observed in practice. For o-n-framework experiments shrinker, we shrink AcceptedConnectionLimits fields one by one, instead of simultaneously all at once, for a better minimal result. --- .../Test/Ouroboros/Network/Server/Sim.hs | 25 +++--- .../Diffusion/Testnet/Cardano/Simulation.hs | 81 +++++++++++-------- 2 files changed, 60 insertions(+), 46 deletions(-) diff --git a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs index f9a03edf142..5a4bde965f6 100644 --- a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs +++ b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs @@ -226,7 +226,7 @@ data ConnectionEvent req peerAddr -- ^ Close an outbound connection. | ShutdownClientServer DiffTime peerAddr -- ^ Shuts down a client/server (simulates power loss) - deriving (Show, Functor) + deriving (Eq, Show, Functor) -- | A sequence of connection events that make up a test scenario for `prop_multinode_Sim`. data MultiNodeScript req peerAddr = MultiNodeScript @@ -458,7 +458,7 @@ maxAcceptedConnectionsLimit = AcceptedConnectionsLimit maxBound maxBound 0 -- -- transitions. -- -instance Arbitrary req => +instance (Eq req, Arbitrary req) => Arbitrary (MultiNodePruningScript req) where arbitrary = do Positive len <- scale ((* 2) . (`div` 3)) arbitrary @@ -532,17 +532,20 @@ instance Arbitrary req => -- we could miss which change actually introduces the failure, and be lift -- with a larger counter example. shrink (MultiNodePruningScript - (AcceptedConnectionsLimit hardLimit softLimit delay) + acl@(AcceptedConnectionsLimit hardLimit softLimit delay) events attenuationMap) = - MultiNodePruningScript - <$> (AcceptedConnectionsLimit - <$> shrink hardLimit - <*> shrink softLimit - <*> pure delay) - <*> (makeValid - <$> shrinkList shrinkEvent events) - <*> shrink attenuationMap + let acls = AcceptedConnectionsLimit + <$> shrink hardLimit + <*> shrink softLimit + <*> pure delay in + [MultiNodePruningScript acl' events attenuationMap + | acl' <- acls] <> + [MultiNodePruningScript acl events' attenuationMap + | events' <- makeValid <$> shrinkList shrinkEvent events + , events' /= events] <> + [MultiNodePruningScript acl events attenuationMap' + | attenuationMap' <- shrink attenuationMap] where makeValid = go (ScriptState [] [] [] [] []) where diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano/Simulation.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano/Simulation.hs index 48a488d0674..4623d74ef2e 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano/Simulation.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano/Simulation.hs @@ -253,6 +253,7 @@ data Command = JoinNetwork DiffTime , WarmValency , Map RelayAccessPoint (LocalRootConfig PeerTrustable) )] + | Skip DiffTime deriving Eq instance Show Command where @@ -264,6 +265,9 @@ instance Show Command where . showsPrec d delay . showString " " . showsPrec d localRoots + showsPrec d (Skip delay) = showString "Skip" + . showsPrec d delay + . showString " " genCommands :: [( HotValency , WarmValency @@ -293,17 +297,20 @@ genCommands localRoots = sized $ \size -> do fixupCommands :: [Command] -> [Command] fixupCommands [] = [] -fixupCommands (jn@(JoinNetwork _):t) = jn : go jn t +fixupCommands (jn@(JoinNetwork _):t) = jn : go jn 0 t where - go :: Command -> [Command] -> [Command] - go _ [] = [] - go prev (cmd:cmds) = + go :: Command -> DiffTime -> [Command] -> [Command] + go _ _ [] = [] + go prev accDelay (cmd:cmds) = case (prev, cmd) of - (JoinNetwork _ , JoinNetwork _ ) -> go prev cmds - (Kill _ , Kill _ ) -> go prev cmds - (Kill _ , Reconfigure _ _ ) -> go prev cmds - (Reconfigure _ _ , JoinNetwork _ ) -> go prev cmds - _ -> cmd : go cmd cmds + (JoinNetwork _ , JoinNetwork _ ) -> go prev accDelay cmds + (Kill _ , Kill _ ) -> go prev accDelay cmds + (Kill _ , Reconfigure _ _ ) -> go prev accDelay cmds + (Reconfigure _ _ , JoinNetwork _ ) -> go prev accDelay cmds + (_ , Skip d ) -> go prev (d + accDelay) cmds + (_ , JoinNetwork d ) -> JoinNetwork (d + accDelay) : go cmd 0 cmds + (_ , Kill d ) -> Kill (d + accDelay) : go cmd 0 cmds + (_ , Reconfigure d c ) -> Reconfigure (d + accDelay) c : go cmd 0 cmds fixupCommands (_:t) = fixupCommands t -- | Simulation arguments. @@ -773,44 +780,48 @@ instance Arbitrary DiffusionScript where <$> frequency [ (1, arbitrary >>= genNonHotDiffusionScript) , (1, arbitrary >>= genHotDiffusionScript)] -- TODO: shrink dns map - -- TODO: we should write more careful shrinking than recursively shrinking - -- `DiffusionScript`! - shrink (DiffusionScript sargs dnsScript cmds0) = shrinkCmds cmds0 ++ shrinkDns + shrink (DiffusionScript sargs dnsScript0 players0) = + [DiffusionScript sargs dnsScript0 players + | players <- shrinkPlayers players0 + ] <> + [DiffusionScript sargs dnsScript players0 + | dnsScript <- + mapMaybe + -- make sure `fixupDomainMapScript` didn't return something that's + -- equal to the original `script` + ((\dnsScript' -> if dnsScript0 == dnsScript' then Nothing else Just dnsScript') + . fixupDomainMapScript (getLast dnsScript0)) + $ shrinkScriptWith (liftShrink2 shrinkMap_ shrink) dnsScript0 + ] where - shrinkDns = - [DiffusionScript sargs script cmds0 - | script <- - mapMaybe - -- make sure `fixupDomainMapScript` didn't return something that's - -- equal to the original `script` - ((\dnsScript' -> if dnsScript == dnsScript' then Nothing else Just dnsScript') - . fixupDomainMapScript (getLast dnsScript)) - $ shrinkScriptWith (shrinkTuple shrinkMap_ shrink) dnsScript - ] - getLast (Script ne) = fst $ NonEmpty.last ne shrinkMap_ :: Ord a => Map a b -> [Map a b] shrinkMap_ = map Map.fromList . shrinkList (const []) . Map.toList - shrinkTuple :: (a -> [a]) -> (b -> [b]) -> (a, b) -> [(a, b)] - shrinkTuple f g (a, b) = [(a', b) | a' <- f a] - ++ [(a, b') | b' <- g b] + -- the easiest failure to analyze is the one with the least number of nodes participating. + -- Currently we use up to three nodes, but in case we increase the number in the future + -- this will be even more useful. + shrinkPlayers = + filter ((> 1) . length) . shrinkList shrinkPlayer - shrinkCmds [] = [] - shrinkCmds ((nargs, cmds):rest) = - let shrunkCmdss = fixupCommands <$> shrinkList shrinkCommand cmds - rest' = shrinkCmds rest - in [DiffusionScript sargs dnsScript ((nargs, shrunkCmds):rest) - | shrunkCmds <- shrunkCmdss] ++ rest' + shrinkPlayer (nargs, cmds) = + map (nargs,) . filter (/= cmds) $ fixupCommands <$> shrinkList shrinkCommand cmds where shrinkDelay = map fromRational . shrink . toRational + -- A failing network with the least nodes active at a particular time is the simplest to analyze, + -- if for no other reason other than for having the least amount of traces for us to read. + -- A dead node is its simplest configuration as that can't contribute to its failure, + -- So we shrink to that first to see at least if a failure occurs somewhere else still. + -- Otherwise we know that this node has to be running for sure while the exchange is happening. shrinkCommand :: Command -> [Command] shrinkCommand (JoinNetwork d) = JoinNetwork <$> shrinkDelay d - shrinkCommand (Kill d) = Kill <$> shrinkDelay d - shrinkCommand (Reconfigure d lrp) = Reconfigure <$> shrinkDelay d - <*> pure lrp + shrinkCommand (Kill d) = Kill <$> shrinkDelay d + shrinkCommand (Reconfigure d lrp) = Skip d + : (Reconfigure <$> shrinkDelay d + <*> pure lrp) + shrinkCommand (Skip _d) = [] -- | Multinode Hot Diffusion Simulator Script From e9dfd55dc402d2a7eb81531a4d2c9a64c3694175 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Mon, 31 Mar 2025 11:56:38 +0200 Subject: [PATCH 17/20] Tracing UX improvement This annotes each trace with a nice (node-x), where x is a number [1..max-node in simulation]. This facilitates grepping a trace for just the node that failed a test. In the mkTracers binding, one can either turn on all component tracers for general testing, and in case of failure of a test where only a subset of components are really needed, one can selectively toggle just the interesting sayTracers to further cut down the noise. --- .../Diffusion/Testnet/Cardano/Simulation.hs | 107 ++++++++++-------- 1 file changed, 62 insertions(+), 45 deletions(-) diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano/Simulation.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano/Simulation.hs index 4623d74ef2e..9076e2271c1 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano/Simulation.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano/Simulation.hs @@ -893,6 +893,7 @@ data DiffusionSimulationTrace | TrRunning | TrErrored SomeException | TrTerminated + | TrSay String deriving Show -- Warning: be careful with writing properties that rely @@ -933,7 +934,7 @@ iosimTracer :: forall s a. , Typeable a ) => Tracer (IOSim s) (WithTime (WithName NtNAddr a)) -iosimTracer = Tracer traceM <> sayTracer +iosimTracer = Tracer traceM -- <> sayTracer -- | Run an arbitrary topology diffusionSimulation @@ -972,8 +973,10 @@ diffusionSimulation $ \ntcSnocket _ -> do dnsMapVar <- fromLazyTVar <$> playTimedScript nullTracer dnsMapScript withAsyncAll - (map ((\(args, commands) -> runCommand Nothing ntnSnocket ntcSnocket dnsMapVar simArgs args connStateIdSupply commands)) - nodeArgs) + (zipWith + (\(args, commands) i -> runCommand ntnSnocket ntcSnocket dnsMapVar simArgs args connStateIdSupply i Nothing commands) + nodeArgs + [1..]) $ \nodes -> do (_, x) <- waitAny nodes return x @@ -1000,6 +1003,7 @@ diffusionSimulation -> SimArgs -- ^ Simulation arguments needed in order to run a simulation -> NodeArgs -- ^ Simulation arguments needed in order to run a single node -> CM.ConnStateIdSupply m + -> Int -> [Command] -- ^ List of commands/actions to perform for a single node -> m Void runCommand Nothing ntnSnocket ntcSnocket dnsMapVar sArgs nArgs connStateIdSupply [] = do @@ -1039,6 +1043,7 @@ diffusionSimulation _ <- atomically $ writeTVar lrpVar newLrp runCommand (Just (async_, lrpVar)) ntnSnocket ntcSnocket dMapVarMap sArgs nArgs connStateIdSupply cs + traceWith (diffSimTracer naAddr) . TrSay $ "node-" <> show i runNode :: SimArgs -> NodeArgs @@ -1050,6 +1055,7 @@ diffusionSimulation , Map RelayAccessPoint (LocalRootConfig PeerTrustable) )] -> StrictTVar m MockDNSMap + -> Int -> m Void runNode SimArgs { saSlot = bgaSlotDuration @@ -1074,7 +1080,7 @@ diffusionSimulation ntcSnocket connStateIdSupply lrpVar - dMapVar = do + dMapVar i = do chainSyncExitVar <- newTVarIO chainSyncExitOnBlockNo ledgerPeersVar <- initScript' ledgerPeers onlyOutboundConnectionsStateVar <- newTVarIO UntrustedState @@ -1222,7 +1228,7 @@ diffusionSimulation , Node.aExtraChurnArgs = cardanoChurnArgs } - tracers = mkTracers addr + tracers = mkTracers addr i requestPublicRootPeers' = requestPublicRootPeers (Diffusion.dtTracePublicRootPeersTracer tracers) @@ -1293,61 +1299,72 @@ diffusionSimulation diffSimTracer ntnAddr = contramap DiffusionSimulationTrace . tracerWithName ntnAddr . tracerWithTime - $ nodeTracer + $ nodeTracer <> sayTracer mkTracers :: NtNAddr + -> Int -> Diffusion.Tracers NtNAddr NtNVersion NtNVersionData NtCAddr NtCVersion NtCVersionData SomeException Cardano.ExtraState Cardano.ExtraState PeerTrustable (Cardano.ExtraPeers NtNAddr) (Cardano.ExtraPeerSelectionSetsWithSizes NtNAddr) m - mkTracers ntnAddr = + mkTracers ntnAddr i = + let sayTracer' = Tracer \msg -> say $ "(node-" <> show i <> ")" <> show msg + -- toggle and uncomment interesting sayTracer' below + nodeTracer' = if True then nodeTracer <> sayTracer' else nodeTracer in + Diffusion.nullTracers { - Diffusion.dtTraceLocalRootPeersTracer = contramap - DiffusionLocalRootPeerTrace + -- Diffusion.dtMuxTracer = contramap + -- DiffusionMuxTrace + -- . tracerWithName ntnAddr + -- . tracerWithTime + -- $ nodeTracer' -- <> sayTracer', + Diff.dtTraceLocalRootPeersTracer = contramap + DiffusionLocalRootPeerTrace . tracerWithName ntnAddr . tracerWithTime - $ nodeTracer + $ nodeTracer' -- <> sayTracer' , Diffusion.dtTracePublicRootPeersTracer = contramap - DiffusionPublicRootPeerTrace + DiffusionPublicRootPeerTrace . tracerWithName ntnAddr . tracerWithTime - $ nodeTracer + $ nodeTracer' -- <> sayTracer' , Diffusion.dtTraceLedgerPeersTracer = contramap - DiffusionLedgerPeersTrace + DiffusionLedgerPeersTrace . tracerWithName ntnAddr . tracerWithTime - $ nodeTracer + $ nodeTracer' -- <> sayTracer' , Diffusion.dtTracePeerSelectionTracer = contramap - DiffusionPeerSelectionTrace + DiffusionPeerSelectionTrace . tracerWithName ntnAddr . tracerWithTime - $ nodeTracer + $ nodeTracer' -- <> sayTracer' , Diffusion.dtDebugPeerSelectionInitiatorTracer = contramap - DiffusionDebugPeerSelectionTrace + DiffusionDebugPeerSelectionTrace . tracerWithName ntnAddr . tracerWithTime - $ nodeTracer + $ nodeTracer' -- <> sayTracer' , Diffusion.dtDebugPeerSelectionInitiatorResponderTracer - = contramap DiffusionDebugPeerSelectionTrace - . tracerWithName ntnAddr - . tracerWithTime - $ nodeTracer + = contramap + DiffusionDebugPeerSelectionTrace + . tracerWithName ntnAddr + . tracerWithTime + $ nodeTracer' -- <> sayTracer' , Diffusion.dtTracePeerSelectionCounters = nullTracer , Diffusion.dtTraceChurnCounters = nullTracer , Diffusion.dtPeerSelectionActionsTracer = contramap - DiffusionPeerSelectionActionsTrace + DiffusionPeerSelectionActionsTrace . tracerWithName ntnAddr . tracerWithTime - $ nodeTracer + $ nodeTracer' -- <> sayTracer' , Diffusion.dtConnectionManagerTracer = contramap - DiffusionConnectionManagerTrace + DiffusionConnectionManagerTrace . tracerWithName ntnAddr . tracerWithTime - $ nodeTracer + $ nodeTracer' -- <> sayTracer' , Diffusion.dtConnectionManagerTransitionTracer = contramap DiffusionConnectionManagerTransitionTrace @@ -1356,30 +1373,30 @@ diffusionSimulation -- note: we have two ways getting transition trace: -- * through `traceTVar` installed in `newMutableConnState` -- * the `dtConnectionManagerTransitionTracer` - $ nodeTracer - , Diffusion.dtServerTracer = contramap - DiffusionServerTrace - . tracerWithName ntnAddr - . tracerWithTime - $ nodeTracer - , Diffusion.dtInboundGovernorTracer = contramap - DiffusionInboundGovernorTrace - . tracerWithName ntnAddr - . tracerWithTime - $ nodeTracer + $ nodeTracer' -- <> sayTracer' + , Diffusion.dtServerTracer = contramap + DiffusionServerTrace + . tracerWithName ntnAddr + . tracerWithTime + $ nodeTracer' -- <> sayTracer' + , Diffusion.dtInboundGovernorTracer = contramap + DiffusionInboundGovernorTrace + . tracerWithName ntnAddr + . tracerWithTime + $ nodeTracer' -- <> sayTracer' , Diffusion.dtInboundGovernorTransitionTracer = contramap DiffusionInboundGovernorTransitionTrace . tracerWithName ntnAddr . tracerWithTime - $ nodeTracer - , Diffusion.dtLocalConnectionManagerTracer = nullTracer - , Diffusion.dtLocalServerTracer = nullTracer - , Diffusion.dtLocalInboundGovernorTracer = nullTracer - , Diffusion.dtDnsTracer = contramap DiffusionDNSTrace - . tracerWithName ntnAddr - . tracerWithTime - $ nodeTracer + $ nodeTracer' -- <> sayTracer' + , Diffusion.dtLocalConnectionManagerTracer = nullTracer + , Diffusion.dtLocalServerTracer = nullTracer + , Diffusion.dtLocalInboundGovernorTracer = nullTracer + , Diffusion.dtDnsTracer = contramap DiffusionDNSTrace + . tracerWithName ntnAddr + . tracerWithTime + $ nodeTracer' -- <> sayTracer' } From 4f4380ee557f71d5d196a26f6ba9c8d87bf64ca9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Mon, 31 Mar 2025 11:58:39 +0200 Subject: [PATCH 18/20] Simulation module changes Comprehensibility improvements Integrates prior changes --- .../Diffusion/Testnet/Cardano/Simulation.hs | 112 ++++++++++-------- 1 file changed, 62 insertions(+), 50 deletions(-) diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano/Simulation.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano/Simulation.hs index 9076e2271c1..9eec2ca537d 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano/Simulation.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano/Simulation.hs @@ -70,6 +70,7 @@ import Network.DNS qualified as DNS import System.Random (StdGen, mkStdGen) import System.Random qualified as Random +import Network.Mux qualified as Mux import Network.TypedProtocol.Core import Network.TypedProtocol.PingPong.Type qualified as PingPong @@ -99,6 +100,7 @@ import Ouroboros.Network.Block (BlockNo) import Ouroboros.Network.BlockFetch (FetchMode (..), PraosFetchMode (..), TraceFetchClientState, TraceLabelPeer (..)) import Ouroboros.Network.ConnectionHandler (ConnectionHandlerTrace) +import Ouroboros.Network.ConnectionId import Ouroboros.Network.ConnectionManager.Core qualified as CM import Ouroboros.Network.ConnectionManager.State qualified as CM import Ouroboros.Network.ConnectionManager.Types (AbstractTransitionTrace) @@ -381,9 +383,12 @@ genNodeArgs relays minConnected localRootPeers self = flip suchThat hasUpstream -- Generating an InitiatorResponderMode node is 3 times more likely since we -- want our tests to cover more this case. - diffusionMode <- frequency [ (1, pure InitiatorOnlyDiffusionMode) - , (3, pure InitiatorAndResponderDiffusionMode) - ] + -- diffusionMode <- frequency [ (1, pure InitiatorOnlyDiffusionMode) + -- , (3, pure InitiatorAndResponderDiffusionMode) + -- ] + -- TODO: 'cm & ig enforce timeouts' fails in 'InitiatorOnlyDiffusionMode' + -- so we pin it to this + let diffusionMode = InitiatorAndResponderDiffusionMode -- These values approximately correspond to false positive -- thresholds for streaks of empty slots with 99% probability, @@ -924,6 +929,7 @@ data DiffusionTestTrace = | DiffusionChurnModeTrace TracerChurnMode | DiffusionDebugTrace String | DiffusionDNSTrace DNSTrace + | DiffusionMuxTrace (Mux.WithBearer (ConnectionId NtNAddr) Mux.Trace) deriving (Show) @@ -987,14 +993,7 @@ diffusionSimulation -- | Runs a single node according to a list of commands. runCommand - :: Maybe ( Async m Void - , StrictTVar m [( HotValency - , WarmValency - , Map RelayAccessPoint (LocalRootConfig PeerTrustable) - )]) - -- ^ If the node is running and corresponding local root configuration - -- TVar. - -> Snocket m (FD m NtNAddr) NtNAddr + :: Snocket m (FD m NtNAddr) NtNAddr -- ^ Node to node Snocket -> Snocket m (FD m NtCAddr) NtCAddr -- ^ Node to client Snocket @@ -1004,46 +1003,59 @@ diffusionSimulation -> NodeArgs -- ^ Simulation arguments needed in order to run a single node -> CM.ConnStateIdSupply m -> Int + -> Maybe ( Async m Void + , StrictTVar m [( HotValency + , WarmValency + , Map RelayAccessPoint (LocalRootConfig PeerTrustable) + )]) + -- ^ If the node is running and corresponding local root configuration + -- TVar. -> [Command] -- ^ List of commands/actions to perform for a single node -> m Void - runCommand Nothing ntnSnocket ntcSnocket dnsMapVar sArgs nArgs connStateIdSupply [] = do - threadDelay 3600 - traceWith (diffSimTracer (naAddr nArgs)) TrRunning - runCommand Nothing ntnSnocket ntcSnocket dnsMapVar sArgs nArgs connStateIdSupply [] - runCommand (Just (_, _)) ntnSnocket ntcSnocket dMapVarMap sArgs nArgs connStateIdSupply [] = do - -- We shouldn't block this thread waiting - -- on the async since this will lead to a deadlock - -- as thread returns 'Void'. - threadDelay 3600 - traceWith (diffSimTracer (naAddr nArgs)) TrRunning - runCommand Nothing ntnSnocket ntcSnocket dMapVarMap sArgs nArgs connStateIdSupply [] - runCommand Nothing ntnSnocket ntcSnocket dnsMapVar sArgs nArgs connStateIdSupply - (JoinNetwork delay :cs) = do - threadDelay delay - traceWith (diffSimTracer (naAddr nArgs)) TrJoiningNetwork - lrpVar <- newTVarIO $ naLocalRootPeers nArgs - withAsync (runNode sArgs nArgs ntnSnocket ntcSnocket connStateIdSupply lrpVar dnsMapVar) $ \nodeAsync -> - runCommand (Just (nodeAsync, lrpVar)) ntnSnocket ntcSnocket dnsMapVar sArgs nArgs connStateIdSupply cs - runCommand _ _ _ _ _ _ _ (JoinNetwork _:_) = - error "runCommand: Impossible happened" - runCommand (Just (async_, _)) ntnSnocket ntcSnocket dMapVarMap sArgs nArgs connStateIdSupply - (Kill delay:cs) = do - threadDelay delay - traceWith (diffSimTracer (naAddr nArgs)) TrKillingNode - cancel async_ - runCommand Nothing ntnSnocket ntcSnocket dMapVarMap sArgs nArgs connStateIdSupply cs - runCommand _ _ _ _ _ _ _ (Kill _:_) = do - error "runCommand: Impossible happened" - runCommand Nothing _ _ _ _ _ _ (Reconfigure _ _:_) = - error "runCommand: Impossible happened" - runCommand (Just (async_, lrpVar)) ntnSnocket ntcSnocket dMapVarMap sArgs nArgs connStateIdSupply - (Reconfigure delay newLrp:cs) = do - threadDelay delay - traceWith (diffSimTracer (naAddr nArgs)) TrReconfiguringNode - _ <- atomically $ writeTVar lrpVar newLrp - runCommand (Just (async_, lrpVar)) ntnSnocket ntcSnocket dMapVarMap sArgs nArgs connStateIdSupply - cs + runCommand ntnSocket ntcSocket dnsMapVar sArgs nArgs@NodeArgs { naAddr } + connStateIdSupply i hostAndLRP cmds = do traceWith (diffSimTracer naAddr) . TrSay $ "node-" <> show i + runCommand' hostAndLRP cmds + where + runCommand' Nothing [] = do + threadDelay 3600 + traceWith (diffSimTracer naAddr) TrRunning + runCommand' Nothing [] + runCommand' (Just (_, _)) [] = do + -- We shouldn't block this thread waiting + -- on the async since this will lead to a deadlock + -- as thread returns 'Void'. + threadDelay 3600 + traceWith (diffSimTracer naAddr) TrRunning + runCommand' Nothing [] + runCommand' Nothing + (JoinNetwork delay :cs) = do + threadDelay delay + traceWith (diffSimTracer naAddr) TrJoiningNetwork + lrpVar <- newTVarIO $ naLocalRootPeers nArgs + withAsync (runNode sArgs nArgs ntnSocket ntcSocket connStateIdSupply lrpVar dnsMapVar i) $ \nodeAsync -> + runCommand' (Just (nodeAsync, lrpVar)) cs + runCommand' _ (JoinNetwork _:_) = + error "runCommand: Impossible happened" + runCommand' (Just (async_, _)) + (Kill delay:cs) = do + threadDelay delay + traceWith (diffSimTracer naAddr) TrKillingNode + cancel async_ + runCommand' Nothing cs + runCommand' _ (Kill _:_) = do + error "runCommand: Impossible happened" + runCommand' Nothing (Reconfigure _ _:_) = + error "runCommand: Impossible happened" + runCommand' (Just (async_, lrpVar)) + (Reconfigure delay newLrp:cs) = do + threadDelay delay + traceWith (diffSimTracer naAddr) TrReconfiguringNode + _ <- atomically $ writeTVar lrpVar newLrp + runCommand' (Just (async_, lrpVar)) + cs + runCommand' _ (Skip _ : _) = + error "runCommand: Impossible happened" runNode :: SimArgs -> NodeArgs @@ -1075,6 +1087,7 @@ diffusionSimulation , naChainSyncExitOnBlockNo = chainSyncExitOnBlockNo , naChainSyncEarlyExit = chainSyncEarlyExit , naPeerSharing = peerSharing + , naDiffusionMode = diffusionMode } ntnSnocket ntcSnocket @@ -1091,7 +1104,6 @@ diffusionSimulation (bgaRng, rng) = Random.split $ mkStdGen seed acceptedConnectionsLimit = AcceptedConnectionsLimit maxBound maxBound 0 - diffusionMode = InitiatorAndResponderDiffusionMode readLocalRootPeers = readTVar lrpVar readPublicRootPeers = return publicRoots readUseLedgerPeers = return (UseLedgerPeers (After 0)) @@ -1321,7 +1333,7 @@ diffusionSimulation -- . tracerWithName ntnAddr -- . tracerWithTime -- $ nodeTracer' -- <> sayTracer', - Diff.dtTraceLocalRootPeersTracer = contramap + Diffusion.dtTraceLocalRootPeersTracer = contramap DiffusionLocalRootPeerTrace . tracerWithName ntnAddr . tracerWithTime From c9e803664a3a5396e33450e9a1e258ad3c9d6f10 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Mon, 31 Mar 2025 13:28:52 +0200 Subject: [PATCH 19/20] update spec --- docs/network-spec/connection-manager.tex | 24 +++++++++++++----------- 1 file changed, 13 insertions(+), 11 deletions(-) diff --git a/docs/network-spec/connection-manager.tex b/docs/network-spec/connection-manager.tex index ab5c8c25b3e..9b8c7b30161 100644 --- a/docs/network-spec/connection-manager.tex +++ b/docs/network-spec/connection-manager.tex @@ -2100,15 +2100,18 @@ \subsubsection{\RemoteIdle} connection is used (\warm{} or \hot{}) or not (\cold{}) by the outbound side. \subsubsection{\RemoteWarm} -A connection enters \RemoteWarm{} state once any of the mini-protocols starts -to operate. Once all hot mini-protocols start, the state will transition to -\RemoteHot{}. Note that this is slightly different than the notion of a \warm{} -peer, for which all \established{} and \warm{} mini-protocols are active, but -\hot{} ones are idle. +A connection dwells in \RemoteWarm{} if there are strictly only any warm or established +responder protocols running. Note also that an established protocol is one that may run +in both hot and warm states, but cannot be the only type running to maintain hot state +once all proper hot protocols have terminated. In other words, the connection must be +demoted in that case. \subsubsection{\RemoteHot} -A connection enters \RemoteHot{} transition once all hot protocols started, if -any of them terminates the connection will be put in \RemoteWarm{}. +A connection enters \RemoteHot{} state once any hot responder protocol has started. +In particular, if a hot responder is the first to start, the state cycles through \RemoteWarm{} +first. Once all hot responders terminate, the connection will be put in \RemoteWarm{} regardless +of whether there are any warm or established responders left. In the latter case, if there aren't any +other protocols running, the connection will then follow up with further demotion to \RemoteIdle{}. \subsection{Transitions} @@ -2166,11 +2169,10 @@ \subsubsection{\MuxTerminated} termination of the connection, as it can detect this by itself. \subsubsection{\PromotedToHotRemote} -The inbound governor detects when all \hot{} mini-protocols started. In such +The inbound governor detects when any \hot{} mini-protocols have started. In such case a \RemoteWarm{} connection is put in \RemoteHot{} state. \subsubsection{\DemotedToWarmRemote} -Dually to \PromotedToHotRemote{} state transition, as soon as any of the \hot{} -mini-protocols terminates, the connection will transition to \RemoteWarm{} +Dually to \PromotedToHotRemote{} state transition, as soon as all of the \hot{} +mini-protocols terminate, the connection will transition to \RemoteWarm{} state. - From bc25515642c580f9699024828084c057d43569cb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Mon, 31 Mar 2025 13:29:40 +0200 Subject: [PATCH 20/20] changelog update --- network-mux/CHANGELOG.md | 16 +++++++++------- ouroboros-network-framework/CHANGELOG.md | 10 ++++++++++ 2 files changed, 19 insertions(+), 7 deletions(-) diff --git a/network-mux/CHANGELOG.md b/network-mux/CHANGELOG.md index f6fcdea84ba..a0a6df8bc6c 100644 --- a/network-mux/CHANGELOG.md +++ b/network-mux/CHANGELOG.md @@ -3,15 +3,11 @@ ## next release ### Breaking changes -* Bearer writeMany function for vector IO -* An optional read buffer for Bearer -* Polling of the egress queue + +* run, miniProtocolJob, monitor now accept Tracers record + instead of `Tracer m Trace` type. ### Non-breaking changes -* Define msHeaderLength instead of using '8' -* Benchmark for Socket Bearer -* Use ByteString.Builder for the ingress queues -* Signal the kernal that we require at least the full SDU's worth of data ## 0.8.0.1 -- 2025-06-02 @@ -27,6 +23,8 @@ * `MakeBearer` accepts optional `ReadBuffer` * added fields `egressInterval`, `writeMany`, `batchSize` to `Bearer` + * writeMany provides vector IO, egressInterval supports polling of egress queue + for tuning latency vs. network efficiency * `socketAsBearer` additionally takes `ReadBuffer`, egress interval `DiffTime` for egress polling, and batchSize * changed `IngressQueue` type synonym @@ -35,6 +33,10 @@ ### Non-breaking changes * added `makeSocketBearer'`, `ReadBuffer`, `withReadBufferIO` +* Define msHeaderLength instead of using '8' +* Benchmark for Socket Bearer +* Use ByteString.Builder for the ingress queues +* Signal the kernal that we require at least the full SDU's worth of data ## 0.7.0.0 -- 2025-02-25 diff --git a/ouroboros-network-framework/CHANGELOG.md b/ouroboros-network-framework/CHANGELOG.md index 883767fc11d..2dbd025ad38 100644 --- a/ouroboros-network-framework/CHANGELOG.md +++ b/ouroboros-network-framework/CHANGELOG.md @@ -4,6 +4,16 @@ ### Breaking changes +* IG performance related improvements changing to interfaces of + * IG `with` and `Arguments` + * CM `with` and `Arguments` + * Server `with` and `Arguments` + * Deleted `InboundGovernor.Event` module and moved to InboundGovernor: + * `NewConnectionInfo`, `Event`, `EventSignal`, `Terminated`, `firstPeerCommitRemote` + * signature of `makeConnectionHandler` + * moved `InboundGovernorInfoChannel` to IG from InformationChannel + and changed its type to contain `Event`'s. + ### Non-breaking changes * Added `terminatingConns` to `ConnectionManagerCounters`