From 62263aca20c99e1405466680108261d05e93f302 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 19 Nov 2021 07:27:12 +0100 Subject: [PATCH 1/9] pruning: present only inbound connections to the pruning policy This guarantees that whatever choice the policy will make, it will make progress towards smaller number of inbound connections. --- .../Network/ConnectionManager/Core.hs | 40 +++++++++++++++---- 1 file changed, 32 insertions(+), 8 deletions(-) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs index 7a7657f148c..c1180587107 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs @@ -25,7 +25,7 @@ module Ouroboros.Network.ConnectionManager.Core ) where import Control.Exception (assert) -import Control.Monad (when) +import Control.Monad (guard, when) import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadThrow hiding (handle) @@ -395,6 +395,22 @@ getConnType (TerminatingState _connId _connThread _handleError) = Nothing getConnType TerminatedState {} = Nothing +-- | Return 'True' if a connection is inbound. This must agree with +-- 'connectionStateToCounters'. Both are used for prunning. +-- +isInboundConn :: ConnectionState peerAddr handle handleError version m -> Bool +isInboundConn ReservedOutboundState = False +isInboundConn (UnnegotiatedState pr _connId _connThread) = pr == Inbound +isInboundConn OutboundUniState {} = False +isInboundConn OutboundDupState {} = False +isInboundConn OutboundIdleState {} = False +isInboundConn InboundIdleState {} = True +isInboundConn InboundState {} = True +isInboundConn DuplexState {} = True +isInboundConn TerminatingState {} = False +isInboundConn TerminatedState {} = False + + abstractState :: MaybeUnknown (ConnectionState muxMode peerAddr m a b) -> AbstractState abstractState = \s -> case s of Unknown -> UnknownConnectionSt @@ -1855,8 +1871,10 @@ withConnectionManager ConnectionManagerArguments { -- 'TerminatingState' and 'TerminatedState'. (choiseMap :: Map peerAddr (ConnectionType, Async m ())) <- flip Map.traverseMaybeWithKey state $ \_peerAddr MutableConnState { connVar = connVar' } -> - (\cs -> -- this expression returns @Maybe (connType, connThread)@; - -- 'traverseMaybeWithKey' collects all 'Just' cases. + (\cs -> do + -- this expression returns @Maybe (connType, connThread)@; + -- 'traverseMaybeWithKey' collects all 'Just' cases. + guard (isInboundConn cs) (,) <$> getConnType cs <*> getConnThread cs) <$> readTVar connVar' @@ -1939,8 +1957,10 @@ withConnectionManager ConnectionManagerArguments { -- 'TerminatingState' and 'TerminatedState'. (choiseMap :: Map peerAddr (ConnectionType, Async m ())) <- flip Map.traverseMaybeWithKey state $ \_peerAddr MutableConnState { connVar = connVar' } -> - (\cs -> -- this expression returns @Maybe (connType, connThread)@; - -- 'traverseMaybeWithKey' collects all 'Just' cases. + (\cs -> do + -- this expression returns @Maybe (connType, connThread)@; + -- 'traverseMaybeWithKey' collects all 'Just' cases. + guard (isInboundConn cs) (,) <$> getConnType cs <*> getConnThread cs) <$> readTVar connVar' @@ -2133,8 +2153,10 @@ withConnectionManager ConnectionManagerArguments { -- 'TerminatingState' and 'TerminatedState'. (choiseMap :: Map peerAddr (ConnectionType, Async m ())) <- flip Map.traverseMaybeWithKey state $ \_peerAddr MutableConnState { connVar = connVar' } -> - (\cs -> -- this expression returns @Maybe (connType, connThread)@; + (\cs -> do + -- this expression returns @Maybe (connType, connThread)@; -- 'traverseMaybeWithKey' collects all 'Just' cases. + guard (isInboundConn cs) (,) <$> getConnType cs <*> getConnThread cs) <$> readTVar connVar' @@ -2188,8 +2210,10 @@ withConnectionManager ConnectionManagerArguments { -- 'TerminatingState' and 'TerminatedState'. (choiseMap :: Map peerAddr (ConnectionType, Async m ())) <- flip Map.traverseMaybeWithKey state $ \_peerAddr MutableConnState { connVar = connVar' } -> - (\cs -> -- this expression returns @Maybe (connType, connThread)@; - -- 'traverseMaybeWithKey' collects all 'Just' cases. + (\cs -> do + -- this expression returns @Maybe (connType, connThread)@; + -- 'traverseMaybeWithKey' collects all 'Just' cases. + guard (isInboundConn cs) (,) <$> getConnType cs <*> getConnThread cs) <$> readTVar connVar' From 2972ee6a0f26215e0ef66dc0415875a56b3b8b6a Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 19 Nov 2021 07:42:23 +0100 Subject: [PATCH 2/9] pruning: fixed typos --- .../Network/ConnectionManager/Core.hs | 26 +++++++++---------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs index c1180587107..20af59876c3 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs @@ -1869,7 +1869,7 @@ withConnectionManager ConnectionManagerArguments { -- have 'ConnectionType' and are running (have a thread). -- This excludes connections in 'ReservedOutboundState', -- 'TerminatingState' and 'TerminatedState'. - (choiseMap :: Map peerAddr (ConnectionType, Async m ())) + (choiceMap :: Map peerAddr (ConnectionType, Async m ())) <- flip Map.traverseMaybeWithKey state $ \_peerAddr MutableConnState { connVar = connVar' } -> (\cs -> do -- this expression returns @Maybe (connType, connThread)@; @@ -1881,14 +1881,14 @@ withConnectionManager ConnectionManagerArguments { pruneSet <- cmPrunePolicy - (fst <$> choiseMap) + (fst <$> choiceMap) numberToPrune when (remoteAddress connId `Set.notMember` pruneSet) $ writeTVar connVar connState' return ( PruneConnections connId - (snd <$> choiseMap `Map.restrictKeys` pruneSet) + (snd <$> choiceMap `Map.restrictKeys` pruneSet) (Left connState) , Nothing ) @@ -1955,7 +1955,7 @@ withConnectionManager ConnectionManagerArguments { -- have 'ConnectionType' and are running (have a thread). -- This excludes connections in 'ReservedOutboundState', -- 'TerminatingState' and 'TerminatedState'. - (choiseMap :: Map peerAddr (ConnectionType, Async m ())) + (choiceMap :: Map peerAddr (ConnectionType, Async m ())) <- flip Map.traverseMaybeWithKey state $ \_peerAddr MutableConnState { connVar = connVar' } -> (\cs -> do -- this expression returns @Maybe (connType, connThread)@; @@ -1967,7 +1967,7 @@ withConnectionManager ConnectionManagerArguments { pruneSet <- cmPrunePolicy - (fst <$> choiseMap) + (fst <$> choiceMap) numberToPrune -- If this connection is in the to-prune set we do not let it @@ -1976,7 +1976,7 @@ withConnectionManager ConnectionManagerArguments { then return ( PruneConnections connId - (snd <$> choiseMap `Map.restrictKeys` pruneSet) + (snd <$> choiceMap `Map.restrictKeys` pruneSet) (Left connState) , Nothing ) @@ -1984,7 +1984,7 @@ withConnectionManager ConnectionManagerArguments { writeTVar connVar connState' return ( PruneConnections connId - (snd <$> choiseMap `Map.restrictKeys` pruneSet) + (snd <$> choiceMap `Map.restrictKeys` pruneSet) (Right tr) , Nothing ) @@ -2151,7 +2151,7 @@ withConnectionManager ConnectionManagerArguments { -- have 'ConnectionType' and are running (have a thread). -- This excludes connections in 'ReservedOutboundState', -- 'TerminatingState' and 'TerminatedState'. - (choiseMap :: Map peerAddr (ConnectionType, Async m ())) + (choiceMap :: Map peerAddr (ConnectionType, Async m ())) <- flip Map.traverseMaybeWithKey state $ \_peerAddr MutableConnState { connVar = connVar' } -> (\cs -> do -- this expression returns @Maybe (connType, connThread)@; @@ -2163,14 +2163,14 @@ withConnectionManager ConnectionManagerArguments { pruneSet <- cmPrunePolicy - (fst <$> choiseMap) + (fst <$> choiceMap) numberToPrune when (remoteAddress connId `Set.notMember` pruneSet) $ writeTVar connVar connState' return ( OperationSuccess tr - , Just ( snd <$> choiseMap `Map.restrictKeys` pruneSet + , Just ( snd <$> choiceMap `Map.restrictKeys` pruneSet , Nothing ) @@ -2208,7 +2208,7 @@ withConnectionManager ConnectionManagerArguments { -- have 'ConnectionType' and are running (have a thread). -- This excludes connections in 'ReservedOutboundState', -- 'TerminatingState' and 'TerminatedState'. - (choiseMap :: Map peerAddr (ConnectionType, Async m ())) + (choiceMap :: Map peerAddr (ConnectionType, Async m ())) <- flip Map.traverseMaybeWithKey state $ \_peerAddr MutableConnState { connVar = connVar' } -> (\cs -> do -- this expression returns @Maybe (connType, connThread)@; @@ -2220,14 +2220,14 @@ withConnectionManager ConnectionManagerArguments { pruneSet <- cmPrunePolicy - (fst <$> choiseMap) + (fst <$> choiceMap) numberToPrune when (remoteAddress connId `Set.notMember` pruneSet) $ writeTVar connVar connState' return ( OperationSuccess tr - , Just ( snd <$> choiseMap `Map.restrictKeys` pruneSet + , Just ( snd <$> choiceMap `Map.restrictKeys` pruneSet , Nothing ) , Nothing From d812b027e39b3bb679440c219891700e478fb81e Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 19 Nov 2021 07:44:12 +0100 Subject: [PATCH 3/9] pruning: include current connection in the choice map When pruning connections we have to add current connection, as it is filtered out by the guard. --- .../Network/ConnectionManager/Core.hs | 27 ++++++++++++++++--- 1 file changed, 23 insertions(+), 4 deletions(-) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs index 20af59876c3..7ed375d9e9d 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs @@ -1869,7 +1869,7 @@ withConnectionManager ConnectionManagerArguments { -- have 'ConnectionType' and are running (have a thread). -- This excludes connections in 'ReservedOutboundState', -- 'TerminatingState' and 'TerminatedState'. - (choiceMap :: Map peerAddr (ConnectionType, Async m ())) + (choiceMap' :: Map peerAddr (ConnectionType, Async m ())) <- flip Map.traverseMaybeWithKey state $ \_peerAddr MutableConnState { connVar = connVar' } -> (\cs -> do -- this expression returns @Maybe (connType, connThread)@; @@ -1878,6 +1878,11 @@ withConnectionManager ConnectionManagerArguments { (,) <$> getConnType cs <*> getConnThread cs) <$> readTVar connVar' + let choiceMap = + case getConnType connState' of + Nothing -> assert False choiceMap' + Just a -> Map.insert peerAddr (a, connThread) + choiceMap' pruneSet <- cmPrunePolicy @@ -1955,7 +1960,7 @@ withConnectionManager ConnectionManagerArguments { -- have 'ConnectionType' and are running (have a thread). -- This excludes connections in 'ReservedOutboundState', -- 'TerminatingState' and 'TerminatedState'. - (choiceMap :: Map peerAddr (ConnectionType, Async m ())) + (choiceMap' :: Map peerAddr (ConnectionType, Async m ())) <- flip Map.traverseMaybeWithKey state $ \_peerAddr MutableConnState { connVar = connVar' } -> (\cs -> do -- this expression returns @Maybe (connType, connThread)@; @@ -1964,6 +1969,11 @@ withConnectionManager ConnectionManagerArguments { (,) <$> getConnType cs <*> getConnThread cs) <$> readTVar connVar' + let choiceMap = + case getConnType connState' of + Nothing -> assert False choiceMap' + Just a -> Map.insert peerAddr (a, connThread) + choiceMap' pruneSet <- cmPrunePolicy @@ -2151,7 +2161,7 @@ withConnectionManager ConnectionManagerArguments { -- have 'ConnectionType' and are running (have a thread). -- This excludes connections in 'ReservedOutboundState', -- 'TerminatingState' and 'TerminatedState'. - (choiceMap :: Map peerAddr (ConnectionType, Async m ())) + (choiceMap' :: Map peerAddr (ConnectionType, Async m ())) <- flip Map.traverseMaybeWithKey state $ \_peerAddr MutableConnState { connVar = connVar' } -> (\cs -> do -- this expression returns @Maybe (connType, connThread)@; @@ -2160,6 +2170,11 @@ withConnectionManager ConnectionManagerArguments { (,) <$> getConnType cs <*> getConnThread cs) <$> readTVar connVar' + let choiceMap = + case getConnType connState' of + Nothing -> assert False choiceMap' + Just a -> Map.insert peerAddr (a, connThread) + choiceMap' pruneSet <- cmPrunePolicy @@ -2208,7 +2223,7 @@ withConnectionManager ConnectionManagerArguments { -- have 'ConnectionType' and are running (have a thread). -- This excludes connections in 'ReservedOutboundState', -- 'TerminatingState' and 'TerminatedState'. - (choiceMap :: Map peerAddr (ConnectionType, Async m ())) + (choiceMap' :: Map peerAddr (ConnectionType, Async m ())) <- flip Map.traverseMaybeWithKey state $ \_peerAddr MutableConnState { connVar = connVar' } -> (\cs -> do -- this expression returns @Maybe (connType, connThread)@; @@ -2217,6 +2232,10 @@ withConnectionManager ConnectionManagerArguments { (,) <$> getConnType cs <*> getConnThread cs) <$> readTVar connVar' + let choiceMap = + case getConnType connState' of + Nothing -> assert False choiceMap' + Just a -> Map.insert peerAddr (a, connThread) choiceMap' pruneSet <- cmPrunePolicy From ae79af7ab38d55ac6442d1e8409ca629facce2e9 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 19 Nov 2021 08:26:54 +0100 Subject: [PATCH 4/9] pruning: improved logging --- .../Network/ConnectionManager/Core.hs | 48 ++++++++++++++----- .../Network/ConnectionManager/Types.hs | 4 +- .../test/Test/Ouroboros/Network/Server2.hs | 4 +- 3 files changed, 41 insertions(+), 15 deletions(-) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs index 7ed375d9e9d..c5c551561bd 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs @@ -38,6 +38,7 @@ import Data.Functor (($>), void) import Data.Function (on) import Data.Maybe (maybeToList) import Data.Proxy (Proxy (..)) +import Data.Set (Set) import Data.Typeable (Typeable) import GHC.Stack (CallStack, HasCallStack, callStack) @@ -481,14 +482,17 @@ data DemoteToColdLocal peerAddr handlerTrace handle handleError version m -- | Duplex connection was demoted, prune connections. -- | PruneConnections (ConnectionId peerAddr) + (Map peerAddr (Async m ())) - -- Left case is for when pruning tries to prune - -- the connection which triggered pruning, in this - -- case we do not want to trace a new transition. - -- - -- Right case is for when the connection which - -- triggered pruning isn't pruned. In this case - -- we do want to trace a new transition. + -- ^ a subset of connections to be prunned + + Int + -- ^ number of connections to prune, just for + -- logging + + (Set peerAddr) + -- ^ prunning choice set, just for logging + !(Either (ConnectionState peerAddr handle @@ -497,6 +501,13 @@ data DemoteToColdLocal peerAddr handlerTrace handle handleError version m peerAddr handle handleError version m)) ) + -- ^ Left case is for when pruning tries to prune + -- the connection which triggered pruning, in this + -- case we do not want to trace a new transition. + -- + -- Right case is for when the connection which + -- triggered pruning isn't pruned. In this case + -- we do want to trace a new transition. -- | Demote error. | DemoteToColdLocalError (ConnectionManagerTrace peerAddr handlerTrace) @@ -1894,6 +1905,8 @@ withConnectionManager ConnectionManagerArguments { return ( PruneConnections connId (snd <$> choiceMap `Map.restrictKeys` pruneSet) + numberToPrune + (Map.keysSet choiceMap) (Left connState) , Nothing ) @@ -1987,6 +2000,8 @@ withConnectionManager ConnectionManagerArguments { return ( PruneConnections connId (snd <$> choiceMap `Map.restrictKeys` pruneSet) + numberToPrune + (Map.keysSet choiceMap) (Left connState) , Nothing ) @@ -1995,6 +2010,8 @@ withConnectionManager ConnectionManagerArguments { return ( PruneConnections connId (snd <$> choiceMap `Map.restrictKeys` pruneSet) + numberToPrune + (Map.keysSet choiceMap) (Right tr) , Nothing ) @@ -2062,10 +2079,12 @@ withConnectionManager ConnectionManagerArguments { Left connState -> return (UnsupportedState (abstractState $ Known connState)) - PruneConnections _connId pruneMap eTr -> do + PruneConnections _connId pruneMap numberToPrune choiceSet eTr -> do traverse_ (traceWith trTracer . TransitionTrace peerAddr) eTr traceCounters stateVar - traceWith tracer (TrPruneConnections (Map.keys pruneMap)) + traceWith tracer (TrPruneConnections (Map.keysSet pruneMap) + numberToPrune + choiceSet) -- previous comment applies here as well. traverse_ cancel pruneMap @@ -2186,6 +2205,8 @@ withConnectionManager ConnectionManagerArguments { return ( OperationSuccess tr , Just ( snd <$> choiceMap `Map.restrictKeys` pruneSet + , numberToPrune + , Map.keysSet choiceMap , Nothing ) @@ -2247,6 +2268,8 @@ withConnectionManager ConnectionManagerArguments { return ( OperationSuccess tr , Just ( snd <$> choiceMap `Map.restrictKeys` pruneSet + , numberToPrune + , Map.keysSet choiceMap , Nothing ) , Nothing @@ -2311,10 +2334,11 @@ withConnectionManager ConnectionManagerArguments { traceWith trTracer (TransitionTrace peerAddr tr) traceCounters stateVar - (OperationSuccess _, Just (pruneMap, mbTr)) -> do - traceWith tracer (TrPruneConnections (Map.keys pruneMap)) + (OperationSuccess _, Just (pruneMap, numberToPrune, choiceSet, mbTr)) -> do traverse_ (traceWith trTracer . TransitionTrace peerAddr) mbTr - traceCounters stateVar + traceWith tracer (TrPruneConnections (Map.keysSet pruneMap) + numberToPrune + choiceSet) -- We relay on the `finally` handler of connection thread to: -- diff --git a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Types.hs b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Types.hs index 2d93e32e68f..0f95ea3b629 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Types.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Types.hs @@ -837,7 +837,9 @@ data ConnectionManagerTrace peerAddr handlerTrace | TrConnectionFailure !(ConnectionId peerAddr) | TrConnectionNotFound !Provenance !peerAddr | TrForbiddenOperation !peerAddr !AbstractState - | TrPruneConnections ![peerAddr] + | TrPruneConnections !(Set peerAddr) -- ^ prunning set + !Int -- ^ number connections that must be prunned + !(Set peerAddr) -- ^ choice set | TrConnectionCleanup !(ConnectionId peerAddr) | TrConnectionTimeWait !(ConnectionId peerAddr) | TrConnectionTimeWaitDone !(ConnectionId peerAddr) diff --git a/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs b/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs index bd129607e8b..fe126f7538e 100644 --- a/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs +++ b/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs @@ -2842,8 +2842,8 @@ classifyPrunings = . filter ( \ tr -> case tr of x -> case x of - TrPruneConnections _ -> True - _ -> False + TrPruneConnections _ _ _ -> True + _ -> False ) -- classify negotiated data flow From ded160a72953124b7581f50e77317176c0e4f5c6 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 19 Nov 2021 09:14:27 +0100 Subject: [PATCH 5/9] pruning: set connection state to TerminatedState When pruning we can set the state to TerminatedState and then cancel the connection handler thread, which will recognise this connection to be pruned. Note that this avoids our application level WAIT_TIME interval. --- .../Network/ConnectionManager/Core.hs | 130 +++++++++++++----- .../test/Test/Ouroboros/Network/Server2.hs | 5 +- 2 files changed, 97 insertions(+), 38 deletions(-) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs index c5c551561bd..0cfc545ab1b 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs @@ -7,6 +7,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} -- Undecidable instances are need for 'Show' instance of 'ConnectionState'. {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE QuantifiedConstraints #-} @@ -25,7 +26,7 @@ module Ouroboros.Network.ConnectionManager.Core ) where import Control.Exception (assert) -import Control.Monad (guard, when) +import Control.Monad (forM_, guard, when) import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadThrow hiding (handle) @@ -483,7 +484,13 @@ data DemoteToColdLocal peerAddr handlerTrace handle handleError version m -- | PruneConnections (ConnectionId peerAddr) - (Map peerAddr (Async m ())) + (Map peerAddr ( Async m () + , StrictTVar m + (ConnectionState + peerAddr + handle handleError + version m) + )) -- ^ a subset of connections to be prunned Int @@ -1880,31 +1887,44 @@ withConnectionManager ConnectionManagerArguments { -- have 'ConnectionType' and are running (have a thread). -- This excludes connections in 'ReservedOutboundState', -- 'TerminatingState' and 'TerminatedState'. - (choiceMap' :: Map peerAddr (ConnectionType, Async m ())) + (choiceMap' :: Map peerAddr ( ConnectionType + , Async m () + , StrictTVar m + (ConnectionState + peerAddr + handle handleError + version m) + )) <- flip Map.traverseMaybeWithKey state $ \_peerAddr MutableConnState { connVar = connVar' } -> (\cs -> do -- this expression returns @Maybe (connType, connThread)@; -- 'traverseMaybeWithKey' collects all 'Just' cases. guard (isInboundConn cs) - (,) <$> getConnType cs - <*> getConnThread cs) + (,,connVar') <$> getConnType cs + <*> getConnThread cs) <$> readTVar connVar' let choiceMap = case getConnType connState' of Nothing -> assert False choiceMap' - Just a -> Map.insert peerAddr (a, connThread) + Just a -> Map.insert peerAddr (a, connThread, connVar) choiceMap' pruneSet <- cmPrunePolicy - (fst <$> choiceMap) + ((\(a, _, _) -> a) <$> choiceMap) numberToPrune when (remoteAddress connId `Set.notMember` pruneSet) $ writeTVar connVar connState' + + let pruneMap = choiceMap `Map.restrictKeys` pruneSet + forM_ pruneMap $ \(_, _, connVar') -> + + writeTVar connVar' (TerminatedState Nothing) return ( PruneConnections connId - (snd <$> choiceMap `Map.restrictKeys` pruneSet) + ((\(_, a, b) -> (a, b)) + <$> pruneMap) numberToPrune (Map.keysSet choiceMap) (Left connState) @@ -1973,33 +1993,45 @@ withConnectionManager ConnectionManagerArguments { -- have 'ConnectionType' and are running (have a thread). -- This excludes connections in 'ReservedOutboundState', -- 'TerminatingState' and 'TerminatedState'. - (choiceMap' :: Map peerAddr (ConnectionType, Async m ())) + (choiceMap' :: Map peerAddr ( ConnectionType + , Async m () + , StrictTVar m + (ConnectionState + peerAddr + handle handleError + version m) + )) <- flip Map.traverseMaybeWithKey state $ \_peerAddr MutableConnState { connVar = connVar' } -> (\cs -> do -- this expression returns @Maybe (connType, connThread)@; -- 'traverseMaybeWithKey' collects all 'Just' cases. guard (isInboundConn cs) - (,) <$> getConnType cs - <*> getConnThread cs) + (,,connVar') <$> getConnType cs + <*> getConnThread cs) <$> readTVar connVar' let choiceMap = case getConnType connState' of Nothing -> assert False choiceMap' - Just a -> Map.insert peerAddr (a, connThread) + Just a -> Map.insert peerAddr (a, connThread, connVar) choiceMap' pruneSet <- cmPrunePolicy - (fst <$> choiceMap) + ((\(a,_,_) -> a) <$> choiceMap) numberToPrune + let pruneMap = choiceMap `Map.restrictKeys` pruneSet + forM_ pruneMap $ \(_, _, connVar') -> + writeTVar connVar' (TerminatedState Nothing) + -- If this connection is in the to-prune set we do not let it -- evolve to a new state. Otherwise we do. if Set.member peerAddr pruneSet then return ( PruneConnections connId - (snd <$> choiceMap `Map.restrictKeys` pruneSet) + ((\(_, a, b) -> (a, b)) + <$> pruneMap) numberToPrune (Map.keysSet choiceMap) (Left connState) @@ -2009,7 +2041,8 @@ withConnectionManager ConnectionManagerArguments { writeTVar connVar connState' return ( PruneConnections connId - (snd <$> choiceMap `Map.restrictKeys` pruneSet) + ((\(_, a, b) -> (a, b)) + <$> pruneMap) numberToPrune (Map.keysSet choiceMap) (Right tr) @@ -2081,13 +2114,14 @@ withConnectionManager ConnectionManagerArguments { PruneConnections _connId pruneMap numberToPrune choiceSet eTr -> do traverse_ (traceWith trTracer . TransitionTrace peerAddr) eTr - traceCounters stateVar traceWith tracer (TrPruneConnections (Map.keysSet pruneMap) numberToPrune choiceSet) -- previous comment applies here as well. - traverse_ cancel pruneMap + forM_ pruneMap $ \(connThread', _) -> do + cancel connThread' + traceCounters stateVar return (OperationSuccess (abstractState (either Known fromState eTr))) DemoteToColdLocalError trace st -> do @@ -2180,31 +2214,44 @@ withConnectionManager ConnectionManagerArguments { -- have 'ConnectionType' and are running (have a thread). -- This excludes connections in 'ReservedOutboundState', -- 'TerminatingState' and 'TerminatedState'. - (choiceMap' :: Map peerAddr (ConnectionType, Async m ())) + (choiceMap' :: Map peerAddr ( ConnectionType + , Async m () + , StrictTVar m + (ConnectionState + peerAddr + handle handleError + version m) + )) <- flip Map.traverseMaybeWithKey state $ \_peerAddr MutableConnState { connVar = connVar' } -> (\cs -> do -- this expression returns @Maybe (connType, connThread)@; - -- 'traverseMaybeWithKey' collects all 'Just' cases. + -- 'traverseMaybeWithKey' collects all 'Just' cases. guard (isInboundConn cs) - (,) <$> getConnType cs - <*> getConnThread cs) + (,,connVar') <$> getConnType cs + <*> getConnThread cs) <$> readTVar connVar' let choiceMap = case getConnType connState' of Nothing -> assert False choiceMap' - Just a -> Map.insert peerAddr (a, connThread) + Just a -> Map.insert peerAddr (a, connThread, connVar) choiceMap' pruneSet <- cmPrunePolicy - (fst <$> choiceMap) + ((\(a, _, _) -> a) + <$> choiceMap) numberToPrune + let pruneMap = choiceMap `Map.restrictKeys` pruneSet + forM_ pruneMap $ \(_, _, connVar') -> + writeTVar connVar' (TerminatedState Nothing) + when (remoteAddress connId `Set.notMember` pruneSet) $ writeTVar connVar connState' + return ( OperationSuccess tr - , Just ( snd <$> choiceMap `Map.restrictKeys` pruneSet + , Just ( pruneMap , numberToPrune , Map.keysSet choiceMap , Nothing @@ -2244,30 +2291,43 @@ withConnectionManager ConnectionManagerArguments { -- have 'ConnectionType' and are running (have a thread). -- This excludes connections in 'ReservedOutboundState', -- 'TerminatingState' and 'TerminatedState'. - (choiceMap' :: Map peerAddr (ConnectionType, Async m ())) + (choiceMap' :: Map peerAddr ( ConnectionType + , Async m () + , StrictTVar m + (ConnectionState + peerAddr + handle handleError + version m) + )) <- flip Map.traverseMaybeWithKey state $ \_peerAddr MutableConnState { connVar = connVar' } -> (\cs -> do -- this expression returns @Maybe (connType, connThread)@; -- 'traverseMaybeWithKey' collects all 'Just' cases. guard (isInboundConn cs) - (,) <$> getConnType cs - <*> getConnThread cs) + (,,connVar') <$> getConnType cs + <*> getConnThread cs) <$> readTVar connVar' let choiceMap = case getConnType connState' of Nothing -> assert False choiceMap' - Just a -> Map.insert peerAddr (a, connThread) choiceMap' + Just a -> Map.insert peerAddr (a, connThread, connVar) + choiceMap' pruneSet <- cmPrunePolicy - (fst <$> choiceMap) + ((\(a, _, _) -> a) <$> choiceMap) numberToPrune + let pruneMap = choiceMap `Map.restrictKeys` pruneSet + forM_ pruneMap $ \(_, _, connVar') -> + writeTVar connVar' (TerminatedState Nothing) + when (remoteAddress connId `Set.notMember` pruneSet) $ writeTVar connVar connState' + return ( OperationSuccess tr - , Just ( snd <$> choiceMap `Map.restrictKeys` pruneSet + , Just ( pruneMap , numberToPrune , Map.keysSet choiceMap , Nothing @@ -2340,11 +2400,11 @@ withConnectionManager ConnectionManagerArguments { numberToPrune choiceSet) - -- We relay on the `finally` handler of connection thread to: - -- - -- - close the socket, - -- - set the state to 'TerminatedState' - traverse_ cancel pruneMap + -- We relay on the `finally` handler of connection thread to + -- close the socket. + forM_ pruneMap $ \ (_, connThread', _) -> cancel connThread' + + traceCounters stateVar _ -> return () return (abstractState . fromState <$> result) diff --git a/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs b/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs index fe126f7538e..82cb085e27d 100644 --- a/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs +++ b/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs @@ -127,9 +127,8 @@ tests = prop_connection_manager_pruning , testProperty "inbound_governor_pruning" prop_inbound_governor_pruning - -- The test fails at the moment. See issue #3487. - -- , testProperty "never_above_hardlimit" - -- prop_never_above_hardlimit + , testProperty "never_above_hardlimit" + prop_never_above_hardlimit , testProperty "connection_manager_valid_transitions" prop_connection_manager_valid_transitions , testProperty "connection_manager_no_invalid_traces" From e452676478bc98f992abaac2931faf4a1b74963f Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 19 Nov 2021 11:22:52 +0100 Subject: [PATCH 6/9] pruning: factor out pruning --- .../Network/ConnectionManager/Core.hs | 351 ++++++------------ 1 file changed, 110 insertions(+), 241 deletions(-) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs index 0cfc545ab1b..0cd905e5c5b 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs @@ -39,7 +39,6 @@ import Data.Functor (($>), void) import Data.Function (on) import Data.Maybe (maybeToList) import Data.Proxy (Proxy (..)) -import Data.Set (Set) import Data.Typeable (Typeable) import GHC.Stack (CallStack, HasCallStack, callStack) @@ -447,6 +446,8 @@ defaultResetTimeout :: DiffTime defaultResetTimeout = 5 +newtype PruneAction m = PruneAction { runPruneAction :: m () } + -- | Instruction used internally in @unregisterOutboundConnectionImpl@, e.g. in -- the implementation of one of the two @DemotedToCold^{dataFlow}_{Local}@ -- transitions. @@ -482,39 +483,25 @@ data DemoteToColdLocal peerAddr handlerTrace handle handleError version m -- | Duplex connection was demoted, prune connections. -- - | PruneConnections (ConnectionId peerAddr) - - (Map peerAddr ( Async m () - , StrictTVar m - (ConnectionState - peerAddr - handle handleError - version m) - )) - -- ^ a subset of connections to be prunned - - Int - -- ^ number of connections to prune, just for - -- logging - - (Set peerAddr) - -- ^ prunning choice set, just for logging - - !(Either - (ConnectionState - peerAddr handle - handleError version m) - (Transition (ConnectionState - peerAddr handle - handleError version m)) - ) - -- ^ Left case is for when pruning tries to prune - -- the connection which triggered pruning, in this - -- case we do not want to trace a new transition. - -- - -- Right case is for when the connection which - -- triggered pruning isn't pruned. In this case - -- we do want to trace a new transition. + | PruneConnections (PruneAction m) + -- ^ prune action + + !(Either + (ConnectionState + peerAddr handle + handleError version m) + (Transition (ConnectionState + peerAddr handle + handleError version m)) + ) + -- ^ Left case is for when pruning tries to prune + -- the connection which triggered pruning, in this + -- case we do not want to trace a new transition. + -- + -- Right case is for when the connection which + -- triggered pruning isn't pruned. In this case + -- we do want to trace a new transition. + -- | Demote error. | DemoteToColdLocalError (ConnectionManagerTrace peerAddr handlerTrace) @@ -891,6 +878,62 @@ withConnectionManager ConnectionManagerArguments { traverse_ (traceWith trTracer . TransitionTrace peerAddr) trs traceCounters stateVar + -- Pruning is done in two stages: + -- * an STM transaction which selects which connections to prune, and sets + -- their state to 'TerminatedState'; + -- * an io action which logs and cancells all the connection handler + -- threads. + mkPruneAction :: peerAddr + -> Int + -- ^ number of connections to prune + -> ConnectionManagerState peerAddr handle handleError version m + -> ConnectionState peerAddr handle handleError version m + -- ^ next connection state, if it will not be pruned. + -> StrictTVar m (ConnectionState peerAddr handle handleError version m) + -> Async m () + -> STM m (Bool, PruneAction m) + -- ^ return if the connection was choose to be prunned and the + -- 'PruneAction' + mkPruneAction peerAddr numberToPrune state connState' connVar connThread = do + (choiceMap' :: Map peerAddr ( ConnectionType + , Async m () + , StrictTVar m + (ConnectionState + peerAddr + handle handleError + version m) + )) + <- flip Map.traverseMaybeWithKey state $ \_peerAddr MutableConnState { connVar = connVar' } -> + (\cs -> do + -- this expression returns @Maybe (connType, connThread)@; + -- 'traverseMaybeWithKey' collects all 'Just' cases. + guard (isInboundConn cs) + (,,connVar') <$> getConnType cs + <*> getConnThread cs) + <$> readTVar connVar' + let choiceMap = + case getConnType connState' of + Nothing -> assert False choiceMap' + Just a -> Map.insert peerAddr (a, connThread, connVar) + choiceMap' + + pruneSet <- + cmPrunePolicy + ((\(a,_,_) -> a) <$> choiceMap) + numberToPrune + + let pruneMap = choiceMap `Map.restrictKeys` pruneSet + forM_ pruneMap $ \(_, _, connVar') -> + writeTVar connVar' (TerminatedState Nothing) + + return ( peerAddr `Set.member` pruneSet + , PruneAction $ do + traceWith tracer (TrPruneConnections (Map.keysSet pruneMap) + numberToPrune + (Map.keysSet choiceMap)) + forM_ pruneMap $ \(_, connThread', _) -> cancel connThread' + ) + includeInboundConnectionImpl :: HasCallStack => FreshIdSupply m @@ -1883,51 +1926,10 @@ withConnectionManager ConnectionManagerArguments { (acceptedConnectionsHardLimit cmConnectionsLimits) if numberToPrune > 0 then do - -- traverse the state and get only the connection which - -- have 'ConnectionType' and are running (have a thread). - -- This excludes connections in 'ReservedOutboundState', - -- 'TerminatingState' and 'TerminatedState'. - (choiceMap' :: Map peerAddr ( ConnectionType - , Async m () - , StrictTVar m - (ConnectionState - peerAddr - handle handleError - version m) - )) - <- flip Map.traverseMaybeWithKey state $ \_peerAddr MutableConnState { connVar = connVar' } -> - (\cs -> do - -- this expression returns @Maybe (connType, connThread)@; - -- 'traverseMaybeWithKey' collects all 'Just' cases. - guard (isInboundConn cs) - (,,connVar') <$> getConnType cs - <*> getConnThread cs) - <$> readTVar connVar' - let choiceMap = - case getConnType connState' of - Nothing -> assert False choiceMap' - Just a -> Map.insert peerAddr (a, connThread, connVar) - choiceMap' - - pruneSet <- - cmPrunePolicy - ((\(a, _, _) -> a) <$> choiceMap) - numberToPrune - - when (remoteAddress connId `Set.notMember` pruneSet) - $ writeTVar connVar connState' - - let pruneMap = choiceMap `Map.restrictKeys` pruneSet - forM_ pruneMap $ \(_, _, connVar') -> - - writeTVar connVar' (TerminatedState Nothing) + (_, prune) + <- mkPruneAction peerAddr numberToPrune state connState' connVar connThread return - ( PruneConnections connId - ((\(_, a, b) -> (a, b)) - <$> pruneMap) - numberToPrune - (Map.keysSet choiceMap) - (Left connState) + ( PruneConnections prune (Left connState) , Nothing ) @@ -1988,66 +1990,21 @@ withConnectionManager ConnectionManagerArguments { (acceptedConnectionsHardLimit cmConnectionsLimits) if numberToPrune > 0 + then do - -- traverse the state and get only the connection which - -- have 'ConnectionType' and are running (have a thread). - -- This excludes connections in 'ReservedOutboundState', - -- 'TerminatingState' and 'TerminatedState'. - (choiceMap' :: Map peerAddr ( ConnectionType - , Async m () - , StrictTVar m - (ConnectionState - peerAddr - handle handleError - version m) - )) - <- flip Map.traverseMaybeWithKey state $ \_peerAddr MutableConnState { connVar = connVar' } -> - (\cs -> do - -- this expression returns @Maybe (connType, connThread)@; - -- 'traverseMaybeWithKey' collects all 'Just' cases. - guard (isInboundConn cs) - (,,connVar') <$> getConnType cs - <*> getConnThread cs) - <$> readTVar connVar' - let choiceMap = - case getConnType connState' of - Nothing -> assert False choiceMap' - Just a -> Map.insert peerAddr (a, connThread, connVar) - choiceMap' - - pruneSet <- - cmPrunePolicy - ((\(a,_,_) -> a) <$> choiceMap) - numberToPrune - - let pruneMap = choiceMap `Map.restrictKeys` pruneSet - forM_ pruneMap $ \(_, _, connVar') -> - writeTVar connVar' (TerminatedState Nothing) - - -- If this connection is in the to-prune set we do not let it - -- evolve to a new state. Otherwise we do. - if Set.member peerAddr pruneSet - then - return - ( PruneConnections connId - ((\(_, a, b) -> (a, b)) - <$> pruneMap) - numberToPrune - (Map.keysSet choiceMap) - (Left connState) - , Nothing - ) - else do - writeTVar connVar connState' - return - ( PruneConnections connId - ((\(_, a, b) -> (a, b)) - <$> pruneMap) - numberToPrune - (Map.keysSet choiceMap) - (Right tr) - , Nothing - ) + (pruneSelf, prune) + <- mkPruneAction peerAddr numberToPrune state connState' connVar connThread + when (not pruneSelf) + $ writeTVar connVar connState' + if pruneSelf + then return ( PruneConnections prune (Left connState) + , Nothing + ) + else do + writeTVar connVar connState' + return ( PruneConnections prune (Right tr) + , Nothing + ) else do -- @ @@ -2112,15 +2069,9 @@ withConnectionManager ConnectionManagerArguments { Left connState -> return (UnsupportedState (abstractState $ Known connState)) - PruneConnections _connId pruneMap numberToPrune choiceSet eTr -> do + PruneConnections prune eTr -> do traverse_ (traceWith trTracer . TransitionTrace peerAddr) eTr - traceWith tracer (TrPruneConnections (Map.keysSet pruneMap) - numberToPrune - choiceSet) - -- previous comment applies here as well. - forM_ pruneMap $ \(connThread', _) -> do - cancel connThread' - + runPruneAction prune traceCounters stateVar return (OperationSuccess (abstractState (either Known fromState eTr))) @@ -2210,53 +2161,15 @@ withConnectionManager ConnectionManagerArguments { -- Are we above the hard limit? if numberToPrune > 0 then do - -- traverse the state and get only the connection which - -- have 'ConnectionType' and are running (have a thread). - -- This excludes connections in 'ReservedOutboundState', - -- 'TerminatingState' and 'TerminatedState'. - (choiceMap' :: Map peerAddr ( ConnectionType - , Async m () - , StrictTVar m - (ConnectionState - peerAddr - handle handleError - version m) - )) - <- flip Map.traverseMaybeWithKey state $ \_peerAddr MutableConnState { connVar = connVar' } -> - (\cs -> do - -- this expression returns @Maybe (connType, connThread)@; - -- 'traverseMaybeWithKey' collects all 'Just' cases. - guard (isInboundConn cs) - (,,connVar') <$> getConnType cs - <*> getConnThread cs) - <$> readTVar connVar' - let choiceMap = - case getConnType connState' of - Nothing -> assert False choiceMap' - Just a -> Map.insert peerAddr (a, connThread, connVar) - choiceMap' - - pruneSet <- - cmPrunePolicy - ((\(a, _, _) -> a) - <$> choiceMap) - numberToPrune - - let pruneMap = choiceMap `Map.restrictKeys` pruneSet - forM_ pruneMap $ \(_, _, connVar') -> - writeTVar connVar' (TerminatedState Nothing) - - when (remoteAddress connId `Set.notMember` pruneSet) + (pruneSelf, prune) + <- mkPruneAction peerAddr numberToPrune state connState' connVar connThread + + when (not pruneSelf) $ writeTVar connVar connState' return ( OperationSuccess tr - , Just ( pruneMap - , numberToPrune - , Map.keysSet choiceMap - , Nothing - ) - + , Just prune , Nothing ) @@ -2287,51 +2200,14 @@ withConnectionManager ConnectionManagerArguments { -- Are we above the hard limit? if numberToPrune > 0 then do - -- traverse the state and get only the connection which - -- have 'ConnectionType' and are running (have a thread). - -- This excludes connections in 'ReservedOutboundState', - -- 'TerminatingState' and 'TerminatedState'. - (choiceMap' :: Map peerAddr ( ConnectionType - , Async m () - , StrictTVar m - (ConnectionState - peerAddr - handle handleError - version m) - )) - <- flip Map.traverseMaybeWithKey state $ \_peerAddr MutableConnState { connVar = connVar' } -> - (\cs -> do - -- this expression returns @Maybe (connType, connThread)@; - -- 'traverseMaybeWithKey' collects all 'Just' cases. - guard (isInboundConn cs) - (,,connVar') <$> getConnType cs - <*> getConnThread cs) - <$> readTVar connVar' - let choiceMap = - case getConnType connState' of - Nothing -> assert False choiceMap' - Just a -> Map.insert peerAddr (a, connThread, connVar) - choiceMap' - - pruneSet <- - cmPrunePolicy - ((\(a, _, _) -> a) <$> choiceMap) - numberToPrune - - let pruneMap = choiceMap `Map.restrictKeys` pruneSet - forM_ pruneMap $ \(_, _, connVar') -> - writeTVar connVar' (TerminatedState Nothing) - - when (remoteAddress connId `Set.notMember` pruneSet) - $ writeTVar connVar connState' + (pruneSelf, prune) + <- mkPruneAction peerAddr numberToPrune state connState' connVar connThread + when (not pruneSelf) + $ writeTVar connVar connState' return - ( OperationSuccess tr - , Just ( pruneMap - , numberToPrune - , Map.keysSet choiceMap - , Nothing - ) + ( OperationSuccess (mkTransition connState (TerminatedState Nothing)) + , Just prune , Nothing ) @@ -2394,16 +2270,9 @@ withConnectionManager ConnectionManagerArguments { traceWith trTracer (TransitionTrace peerAddr tr) traceCounters stateVar - (OperationSuccess _, Just (pruneMap, numberToPrune, choiceSet, mbTr)) -> do - traverse_ (traceWith trTracer . TransitionTrace peerAddr) mbTr - traceWith tracer (TrPruneConnections (Map.keysSet pruneMap) - numberToPrune - choiceSet) - - -- We relay on the `finally` handler of connection thread to - -- close the socket. - forM_ pruneMap $ \ (_, connThread', _) -> cancel connThread' - + (OperationSuccess tr, Just prune) -> do + traceWith trTracer (TransitionTrace peerAddr tr) + runPruneAction prune traceCounters stateVar _ -> return () From 167c0bb9b63e2237f882d682da071ac4c5095da0 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 19 Nov 2021 11:36:58 +0100 Subject: [PATCH 7/9] =?UTF-8?q?pruning:=20do=20not=20prune=20in=20Duplex?= =?UTF-8?q?=20=E2=86=92=20InboundState=20transition?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit When we unregister outbound side of a Duplex connection, it does not changes the number of inbound connections, so there's not need to prune anything. --- .../Network/ConnectionManager/Core.hs | 44 +++++-------------- 1 file changed, 10 insertions(+), 34 deletions(-) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs index 0cd905e5c5b..98548658700 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs @@ -1983,40 +1983,16 @@ withConnectionManager ConnectionManagerArguments { let connState' = InboundState connId connThread handle Duplex tr = mkTransition connState connState' - numberOfConns <- countIncomingConnections state - let numberToPrune = - numberOfConns - - fromIntegral - (acceptedConnectionsHardLimit cmConnectionsLimits) - - if numberToPrune > 0 - - then do - (pruneSelf, prune) - <- mkPruneAction peerAddr numberToPrune state connState' connVar connThread - when (not pruneSelf) - $ writeTVar connVar connState' - if pruneSelf - then return ( PruneConnections prune (Left connState) - , Nothing - ) - else do - writeTVar connVar connState' - return ( PruneConnections prune (Right tr) - , Nothing - ) - - else do - -- @ - -- DemotedToCold^{Duplex}_{Local} : DuplexState - -- → InboundState Duplex - -- @ - -- does not require to perform any additional io action (we - -- already updated 'connVar'). - writeTVar connVar connState' - return ( DemoteToColdLocalNoop (Just tr) st - , Nothing - ) + -- @ + -- DemotedToCold^{Duplex}_{Local} : DuplexState + -- → InboundState Duplex + -- @ + -- does not require to perform any additional io action (we + -- already updated 'connVar'). + writeTVar connVar connState' + return ( DemoteToColdLocalNoop (Just tr) st + , Nothing + ) TerminatingState _connId _connThread _handleError -> return (DemoteToColdLocalNoop Nothing st From 1098494ae86050a52238f7db84b1f26e253d5676 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 19 Nov 2021 11:38:24 +0100 Subject: [PATCH 8/9] pruning: improved a comment --- .../src/Ouroboros/Network/ConnectionManager/Core.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs index 98548658700..f7c25ca9180 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs @@ -1919,7 +1919,9 @@ withConnectionManager ConnectionManagerArguments { -- use 'numberOfConns + 1' because we want to know if we -- actually let this connection evolve if we need to make - -- room for them by pruning. + -- room for them by pruning. This is because + -- 'countIncomingConnections' does not count 'OutboundDupState' + -- as an inbound connection, but does so for 'InboundIdleState'. let numberToPrune = numberOfConns + 1 - fromIntegral From 7ba155a65487a88b465ecb52894f0876fa182014 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 19 Nov 2021 16:51:56 +0100 Subject: [PATCH 9/9] pruning: check that TrPruneConnections traces valid data --- .../test/Test/Ouroboros/Network/Server2.hs | 20 ++++++++++++++++++- 1 file changed, 19 insertions(+), 1 deletion(-) diff --git a/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs b/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs index 82cb085e27d..8be16fa80ba 100644 --- a/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs +++ b/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs @@ -55,6 +55,7 @@ import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe, fromJust, isJust) import Data.Monoid (Sum (..)) import Data.Monoid.Synchronisation (FirstToFinish (..)) +import qualified Data.Set as Set import Data.Typeable (Typeable) import Data.Void (Void) import Foreign.C.Error @@ -2477,7 +2478,11 @@ prop_inbound_governor_pruning serverAcc -- | Property wrapping `multinodeExperiment` that has a generator optimized for triggering -- pruning, and random generated number of connections hard limit. -- --- We test that we never go above hard limit of incoming connections. +-- We test that: +-- +-- * we never go above hard limit of incoming connections; +-- * the pruning set is at least as big as expected, and that +-- the picked peers belong to the choice set. -- prop_never_above_hardlimit :: Int -> MultiNodePruningScript Int -> Property prop_never_above_hardlimit serverAcc @@ -2526,6 +2531,19 @@ prop_never_above_hardlimit serverAcc ) . property $ incomingConns cmc <= fromIntegral hardlimit + (TrPruneConnections prunnedSet numberToPrune choiceSet) -> + ( AllProperty + . counterexample (concat + [ "prunned set too small: " + , show numberToPrune + , " ≰ " + , show $ length prunnedSet + ]) + $ numberToPrune <= length prunnedSet ) + <> + ( AllProperty + . counterexample "" + $ prunnedSet `Set.isSubsetOf` choiceSet ) _ -> mempty ) $ evsCMT