diff --git a/ouroboros-network-framework/CHANGELOG.md b/ouroboros-network-framework/CHANGELOG.md index 823d534dc3..31c2f2364e 100644 --- a/ouroboros-network-framework/CHANGELOG.md +++ b/ouroboros-network-framework/CHANGELOG.md @@ -14,6 +14,8 @@ * Added `RawBearer` API (see https://github.com/IntersectMBO/ouroboros-network/pull/4395) * Connection manager is using `ConnectionId`s to identify connections, this affects its API. +* Added `connStateSupply` record field to + `Ouroboros.Network.ConnectionManager.Core.Arguments`. ### Non-breaking changes diff --git a/ouroboros-network-framework/demo/connection-manager.hs b/ouroboros-network-framework/demo/connection-manager.hs index 0205ccc908..af64c266c9 100644 --- a/ouroboros-network-framework/demo/connection-manager.hs +++ b/ouroboros-network-framework/demo/connection-manager.hs @@ -60,6 +60,7 @@ 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.IOManager @@ -187,6 +188,7 @@ withBidirectionalConnectionManager -> Mux.MakeBearer m socket -> socket -- ^ listening socket + -> CM.ConnStateIdSupply m -> DiffTime -- protocol idle timeout -> DiffTime -- wait time timeout -> Maybe peerAddr @@ -201,6 +203,7 @@ withBidirectionalConnectionManager -> m a) -> m a withBidirectionalConnectionManager snocket makeBearer socket + connStateIdSupply protocolIdleTimeout timeWaitTimeout localAddress @@ -244,7 +247,8 @@ withBidirectionalConnectionManager snocket makeBearer socket acceptedConnectionsSoftLimit = maxBound, acceptedConnectionsDelay = 0 }, - CM.updateVersionData = \a _ -> a + CM.updateVersionData = \a _ -> a, + CM.connStateIdSupply } (makeConnectionHandler muxTracer @@ -458,8 +462,9 @@ bidirectionalExperiment localAddr remoteAddr clientAndServerData = do stdGen <- Random.newStdGen + connStateIdSupply <- atomically $ CM.newConnStateIdSupply (Proxy @IO) withBidirectionalConnectionManager - snocket makeBearer socket0 + snocket makeBearer socket0 connStateIdSupply protocolIdleTimeout timeWaitTimeout (Just localAddr) stdGen clientAndServerData $ \connectionManager _serverAddr -> forever' $ do 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 81568e7998..abed13ecae 100644 --- a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/ConnectionManager.hs +++ b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/ConnectionManager.hs @@ -44,6 +44,7 @@ import Data.List (intercalate, sortOn) import Data.Map (Map) import Data.Map.Strict qualified as Map import Data.Monoid (All (..)) +import Data.Proxy (Proxy (..)) import Data.Text.Lazy qualified as Text import Data.Void (Void) import Quiet @@ -731,6 +732,7 @@ prop_valid_transitions (Fixed rnd) (SkewedBool bindToLocalAddress) scheduleMap = experiment = do labelThisThread "th-main" snocket <- mkSnocket scheduleMap + connStateIdSupply <- atomically $ CM.newConnStateIdSupply Proxy let tracer :: Tracer (IOSim s) TestConnectionManagerTrace tracer = Tracer (say . show) {-- @@ -775,7 +777,8 @@ prop_valid_transitions (Fixed rnd) (SkewedBool bindToLocalAddress) scheduleMap = }, CM.timeWaitTimeout = testTimeWaitTimeout, CM.outboundIdleTimeout = testOutboundIdleTimeout, - CM.updateVersionData = \a _ -> a + CM.updateVersionData = \a _ -> a, + CM.connStateIdSupply } connectionHandler (\_ -> HandshakeFailure) diff --git a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server2/Sim.hs b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server2/Sim.hs index 5dbe7c759f..abcd1a73a1 100644 --- a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server2/Sim.hs +++ b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server2/Sim.hs @@ -55,6 +55,7 @@ import Data.Monoid (Sum (..)) import Data.Monoid.Synchronisation (FirstToFinish (..)) import Data.OrdPSQ (OrdPSQ) import Data.OrdPSQ qualified as OrdPSQ +import Data.Proxy (Proxy (..)) import Data.Set (Set) import Data.Set qualified as Set import Data.Typeable (Typeable) @@ -654,64 +655,66 @@ multinodeExperiment inboundTrTracer trTracer inboundTracer debugTracer cmTracer (MultiNodeScript script _) = withJobPool $ \jobpool -> do stdGenVar <- newTVarIO stdGen0 - cc <- startServerConnectionHandler stdGenVar MainServer dataFlow0 [accInit] serverAddr jobpool - loop stdGenVar (Map.singleton serverAddr [accInit]) (Map.singleton serverAddr cc) script jobpool + connStateIdSupply <- atomically $ CM.newConnStateIdSupply (Proxy @m) + cc <- startServerConnectionHandler stdGenVar connStateIdSupply MainServer dataFlow0 [accInit] serverAddr jobpool + loop stdGenVar connStateIdSupply (Map.singleton serverAddr [accInit]) (Map.singleton serverAddr cc) script jobpool where loop :: StrictTVar m StdGen + -> CM.ConnStateIdSupply m -> Map.Map peerAddr acc -> Map.Map peerAddr (StrictTQueue m (ConnectionHandlerMessage peerAddr req)) -> [ConnectionEvent req peerAddr] -> JobPool () m () -> m () - loop _ _ _ [] _ = threadDelay 3600 - loop stdGenVar nodeAccs servers (event : events) jobpool = + loop _ _ _ _ [] _ = threadDelay 3600 + loop stdGenVar connStateIdSupply nodeAccs servers (event : events) jobpool = case event of StartClient delay localAddr -> do threadDelay delay - cc <- startClientConnectionHandler stdGenVar (Client localAddr) localAddr jobpool - loop stdGenVar nodeAccs (Map.insert localAddr cc servers) events jobpool + cc <- startClientConnectionHandler stdGenVar connStateIdSupply (Client localAddr) localAddr jobpool + loop stdGenVar connStateIdSupply nodeAccs (Map.insert localAddr cc servers) events jobpool StartServer delay localAddr nodeAcc -> do threadDelay delay - cc <- startServerConnectionHandler stdGenVar (Node localAddr) Duplex [nodeAcc] localAddr jobpool - loop stdGenVar (Map.insert localAddr [nodeAcc] nodeAccs) (Map.insert localAddr cc servers) events jobpool + cc <- startServerConnectionHandler stdGenVar connStateIdSupply (Node localAddr) Duplex [nodeAcc] localAddr jobpool + loop stdGenVar connStateIdSupply (Map.insert localAddr [nodeAcc] nodeAccs) (Map.insert localAddr cc servers) events jobpool InboundConnection delay nodeAddr -> do threadDelay delay sendMsg nodeAddr $ NewConnection serverAddr - loop stdGenVar nodeAccs servers events jobpool + loop stdGenVar connStateIdSupply nodeAccs servers events jobpool OutboundConnection delay nodeAddr -> do threadDelay delay sendMsg serverAddr $ NewConnection nodeAddr - loop stdGenVar nodeAccs servers events jobpool + loop stdGenVar connStateIdSupply nodeAccs servers events jobpool CloseInboundConnection delay remoteAddr -> do threadDelay delay sendMsg remoteAddr $ Disconnect serverAddr - loop stdGenVar nodeAccs servers events jobpool + loop stdGenVar connStateIdSupply nodeAccs servers events jobpool CloseOutboundConnection delay remoteAddr -> do threadDelay delay sendMsg serverAddr $ Disconnect remoteAddr - loop stdGenVar nodeAccs servers events jobpool + loop stdGenVar connStateIdSupply nodeAccs servers events jobpool InboundMiniprotocols delay nodeAddr reqs -> do threadDelay delay sendMsg nodeAddr $ RunMiniProtocols serverAddr reqs - loop stdGenVar nodeAccs servers events jobpool + loop stdGenVar connStateIdSupply nodeAccs servers events jobpool OutboundMiniprotocols delay nodeAddr reqs -> do threadDelay delay sendMsg serverAddr $ RunMiniProtocols nodeAddr reqs - loop stdGenVar nodeAccs servers events jobpool + loop stdGenVar connStateIdSupply nodeAccs servers events jobpool ShutdownClientServer delay nodeAddr -> do threadDelay delay sendMsg nodeAddr Shutdown - loop stdGenVar nodeAccs servers events jobpool + loop stdGenVar connStateIdSupply nodeAccs servers events jobpool where sendMsg :: peerAddr -> ConnectionHandlerMessage peerAddr req -> m () sendMsg addr msg = atomically $ @@ -731,11 +734,12 @@ multinodeExperiment inboundTrTracer trTracer inboundTracer debugTracer cmTracer Just qs -> readTQueue (projectBundle tok qs) startClientConnectionHandler :: StrictTVar m StdGen + -> CM.ConnStateIdSupply m -> Name peerAddr -> peerAddr -> JobPool () m () -> m (StrictTQueue m (ConnectionHandlerMessage peerAddr req)) - startClientConnectionHandler stdGenVar name localAddr jobpool = do + startClientConnectionHandler stdGenVar connStateIdSupply name localAddr jobpool = do cc <- atomically newTQueue labelTQueueIO cc $ "cc/" ++ show name connVar <- newTVarIO Map.empty @@ -746,7 +750,8 @@ multinodeExperiment inboundTrTracer trTracer inboundTracer debugTracer cmTracer $ Job ( withInitiatorOnlyConnectionManager name simTimeouts nullTracer nullTracer stdGen - snocket makeBearer (Just localAddr) (mkNextRequests connVar) + snocket makeBearer connStateIdSupply + (Just localAddr) (mkNextRequests connVar) timeLimitsHandshake acceptedConnLimit ( \ connectionManager -> connectionLoop SingInitiatorMode localAddr cc connectionManager Map.empty connVar @@ -758,13 +763,14 @@ multinodeExperiment inboundTrTracer trTracer inboundTracer debugTracer cmTracer return cc startServerConnectionHandler :: StrictTVar m StdGen + -> CM.ConnStateIdSupply m -> Name peerAddr -> DataFlow -> acc -> peerAddr -> JobPool () m () -> m (StrictTQueue m (ConnectionHandlerMessage peerAddr req)) - startServerConnectionHandler stdGenVar name dataFlow serverAcc localAddr jobpool = do + startServerConnectionHandler stdGenVar connStateIdSupply name dataFlow serverAcc localAddr jobpool = do fd <- Snocket.open snocket addrFamily Snocket.bind snocket fd localAddr Snocket.listen snocket fd @@ -782,7 +788,8 @@ multinodeExperiment inboundTrTracer trTracer inboundTracer debugTracer cmTracer inboundTrTracer trTracer cmTracer inboundTracer debugTracer stdGen - snocket makeBearer (\_ -> pure ()) fd (Just localAddr) serverAcc + snocket makeBearer connStateIdSupply + (\_ -> pure ()) fd (Just localAddr) serverAcc (mkNextRequests connVar) timeLimitsHandshake acceptedConnLimit @@ -799,7 +806,8 @@ multinodeExperiment inboundTrTracer trTracer inboundTracer debugTracer cmTracer (show name) Unidirectional -> Job ( withInitiatorOnlyConnectionManager - name simTimeouts trTracer cmTracer stdGen snocket makeBearer (Just localAddr) + name simTimeouts trTracer cmTracer stdGen snocket makeBearer + connStateIdSupply (Just localAddr) (mkNextRequests connVar) timeLimitsHandshake acceptedConnLimit @@ -2182,6 +2190,7 @@ prop_server_accept_error (Fixed rnd) (AbsIOError ioerr) = Snocket.bind snock socket0 addr Snocket.listen snock socket0 nextRequests <- oneshotNextRequests pdata + connStateIdSupply <- atomically $ CM.newConnStateIdSupply Proxy withBidirectionalConnectionManager "node-0" simTimeouts nullTracer nullTracer nullTracer nullTracer @@ -2189,6 +2198,7 @@ prop_server_accept_error (Fixed rnd) (AbsIOError ioerr) = (mkStdGen rnd) snock makeFDBearer + connStateIdSupply (\_ -> pure ()) socket0 (Just addr) [accumulatorInit pdata] diff --git a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs index 35b07e7ad2..47fd8555e4 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs @@ -149,7 +149,11 @@ data Arguments handlerTrace socket peerAddr handle handleError versionNumber ver connectionsLimits :: AcceptedConnectionsLimit, - updateVersionData :: versionData -> DiffusionMode -> versionData + updateVersionData :: versionData -> DiffusionMode -> versionData, + + -- | Supply for `ConnStateId`-s. + -- + connStateIdSupply :: ConnStateIdSupply m } @@ -397,7 +401,8 @@ with args@Arguments { connectionDataFlow, prunePolicy, connectionsLimits, - updateVersionData + updateVersionData, + connStateIdSupply } ConnectionHandler { connectionHandler @@ -405,9 +410,8 @@ with args@Arguments { classifyHandleError inboundGovernorInfoChannel k = do - ((connStateIdSupply, stateVar, stdGenVar) - :: ( ConnStateIdSupply m - , StrictTMVar m (ConnectionManagerState peerAddr handle handleError + ((stateVar, stdGenVar) + :: ( StrictTMVar m (ConnectionManagerState peerAddr handle handleError version m) , StrictTVar m StdGen )) @@ -420,9 +424,8 @@ with args@Arguments { Just st -> Just <$> traverse (inspectTVar (Proxy :: Proxy m) . toLazyTVar . connVar) st return (TraceString (show st')) - connStateIdSupply <- State.newConnStateIdSupply (Proxy :: Proxy m) stdGenVar <- newTVar (stdGen args) - return (connStateIdSupply, v, stdGenVar) + return (v, stdGenVar) let readState :: STM m (State.ConnMap peerAddr AbstractState) @@ -459,8 +462,7 @@ with args@Arguments { WithInitiatorMode OutboundConnectionManager { ocmAcquireConnection = - acquireOutboundConnectionImpl connStateIdSupply stateVar - stdGenVar outboundHandler, + acquireOutboundConnectionImpl stateVar stdGenVar outboundHandler, ocmReleaseConnection = releaseOutboundConnectionImpl stateVar stdGenVar }, @@ -474,8 +476,7 @@ with args@Arguments { WithResponderMode InboundConnectionManager { icmIncludeConnection = - includeInboundConnectionImpl connStateIdSupply stateVar - inboundHandler, + includeInboundConnectionImpl stateVar inboundHandler, icmReleaseConnection = releaseInboundConnectionImpl stateVar, icmPromotedToWarmRemote = @@ -495,15 +496,13 @@ with args@Arguments { WithInitiatorResponderMode OutboundConnectionManager { ocmAcquireConnection = - acquireOutboundConnectionImpl connStateIdSupply stateVar - stdGenVar outboundHandler, + acquireOutboundConnectionImpl stateVar stdGenVar outboundHandler, ocmReleaseConnection = releaseOutboundConnectionImpl stateVar stdGenVar } InboundConnectionManager { icmIncludeConnection = - includeInboundConnectionImpl connStateIdSupply stateVar - inboundHandler, + includeInboundConnectionImpl stateVar inboundHandler, icmReleaseConnection = releaseInboundConnectionImpl stateVar, icmPromotedToWarmRemote = @@ -846,8 +845,7 @@ with args@Arguments { includeInboundConnectionImpl :: HasCallStack - => ConnStateIdSupply m - -> StrictTMVar m (ConnectionManagerState peerAddr handle handleError version m) + => StrictTMVar m (ConnectionManagerState peerAddr handle handleError version m) -> ConnectionHandlerFn handlerTrace socket peerAddr handle handleError version versionData m -> Word32 -- ^ inbound connections hard limit @@ -861,8 +859,7 @@ with args@Arguments { -> ConnectionId peerAddr -- ^ connection id used as an identifier of the resource -> m (Connected peerAddr handle handleError) - includeInboundConnectionImpl connStateIdSupply - stateVar + includeInboundConnectionImpl stateVar handler hardLimit socket @@ -1314,14 +1311,13 @@ with args@Arguments { acquireOutboundConnectionImpl :: HasCallStack - => ConnStateIdSupply m - -> StrictTMVar m (ConnectionManagerState peerAddr handle handleError version m) + => StrictTMVar m (ConnectionManagerState peerAddr handle handleError version m) -> StrictTVar m StdGen -> ConnectionHandlerFn handlerTrace socket peerAddr handle handleError version versionData m -> DiffusionMode -> peerAddr -> m (Connected peerAddr handle handleError) - acquireOutboundConnectionImpl connStateIdSupply stateVar stdGenVar handler diffusionMode peerAddr = do + acquireOutboundConnectionImpl stateVar stdGenVar handler diffusionMode peerAddr = do let provenance = Outbound traceWith tracer (TrIncludeConnection provenance peerAddr) (trace, mutableConnState@MutableConnState { connVar, connStateId } diff --git a/ouroboros-network-framework/testlib/Ouroboros/Network/ConnectionManager/Test/Experiments.hs b/ouroboros-network-framework/testlib/Ouroboros/Network/ConnectionManager/Test/Experiments.hs index 5e6bd3a05c..af1a2aef59 100644 --- a/ouroboros-network-framework/testlib/Ouroboros/Network/ConnectionManager/Test/Experiments.hs +++ b/ouroboros-network-framework/testlib/Ouroboros/Network/ConnectionManager/Test/Experiments.hs @@ -52,6 +52,7 @@ import Data.ByteString.Lazy qualified as LBS import Data.Functor (($>), (<&>)) import Data.List (mapAccumL) import Data.List.NonEmpty (NonEmpty (..)) +import Data.Proxy (Proxy (..)) import Data.Typeable (Typeable) import Data.Void (Void) @@ -261,6 +262,7 @@ withInitiatorOnlyConnectionManager -> Mx.MakeBearer m socket -- ^ series of request possible to do with the bidirectional connection -- manager towards some peer. + -> CM.ConnStateIdSupply m -> Maybe peerAddr -> TemperatureBundle (ConnectionId peerAddr -> STM m [req]) -- ^ Functions to get the next requests for a given connection @@ -272,8 +274,8 @@ withInitiatorOnlyConnectionManager DataFlowProtocolData UnversionedProtocol ByteString m [resp] Void -> m a) -> m a -withInitiatorOnlyConnectionManager name timeouts trTracer tracer stdGen snocket makeBearer localAddr - nextRequests handshakeTimeLimits acceptedConnLimit k = do +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 @@ -297,7 +299,8 @@ withInitiatorOnlyConnectionManager name timeouts trTracer tracer stdGen snocket CM.connectionsLimits = acceptedConnLimit, CM.timeWaitTimeout = tTimeWaitTimeout timeouts, CM.outboundIdleTimeout = tOutboundIdleTimeout timeouts, - CM.updateVersionData = \a _ -> a + CM.updateVersionData = \a _ -> a, + CM.connStateIdSupply } (makeConnectionHandler muxTracer @@ -430,6 +433,7 @@ withBidirectionalConnectionManager -> StdGen -> Snocket m socket peerAddr -> Mx.MakeBearer m socket + -> CM.ConnStateIdSupply m -> (socket -> m ()) -- ^ configure socket -> socket -- ^ listening socket @@ -454,7 +458,7 @@ withBidirectionalConnectionManager name timeouts inboundTrTracer trTracer tracer inboundTracer debugTracer stdGen - snocket makeBearer + snocket makeBearer connStateIdSupply confSock socket localAddress accumulatorInit nextRequests @@ -490,7 +494,8 @@ withBidirectionalConnectionManager name timeouts case diffusionMode of InitiatorOnlyDiffusionMode -> Unidirectional InitiatorAndResponderDiffusionMode -> Duplex - } + }, + CM.connStateIdSupply } (makeConnectionHandler muxTracer @@ -724,15 +729,16 @@ unidirectionalExperiment unidirectionalExperiment stdGen timeouts snocket makeBearer confSock socket clientAndServerData = do let (stdGen', stdGen'') = split stdGen nextReqs <- oneshotNextRequests clientAndServerData + connStateIdSupply <- atomically $ CM.newConnStateIdSupply (Proxy @m) withInitiatorOnlyConnectionManager - "client" timeouts nullTracer nullTracer stdGen' snocket makeBearer Nothing nextReqs + "client" timeouts nullTracer nullTracer stdGen' snocket makeBearer connStateIdSupply Nothing nextReqs timeLimitsHandshake maxAcceptedConnectionsLimit $ \connectionManager -> withBidirectionalConnectionManager "server" timeouts nullTracer nullTracer nullTracer nullTracer nullTracer stdGen'' - snocket makeBearer + snocket makeBearer connStateIdSupply confSock socket Nothing [accumulatorInit clientAndServerData] noNextRequests @@ -809,11 +815,13 @@ bidirectionalExperiment clientAndServerData0 clientAndServerData1 = do let (stdGen', stdGen'') = split stdGen lock <- newTMVarIO () + connStateIdSupply <- atomically $ CM.newConnStateIdSupply (Proxy @m) nextRequests0 <- oneshotNextRequests clientAndServerData0 nextRequests1 <- oneshotNextRequests clientAndServerData1 withBidirectionalConnectionManager "node-0" timeouts nullTracer nullTracer nullTracer nullTracer - nullTracer stdGen' snocket makeBearer confSock + nullTracer stdGen' snocket makeBearer + connStateIdSupply confSock socket0 (Just localAddr0) [accumulatorInit clientAndServerData0] nextRequests0 @@ -822,7 +830,8 @@ bidirectionalExperiment (\connectionManager0 _serverAddr0 _serverAsync0 -> do withBidirectionalConnectionManager "node-1" timeouts nullTracer nullTracer nullTracer nullTracer - nullTracer stdGen'' snocket makeBearer confSock + nullTracer stdGen'' snocket makeBearer + connStateIdSupply confSock socket1 (Just localAddr1) [accumulatorInit clientAndServerData1] nextRequests1 diff --git a/ouroboros-network/CHANGELOG.md b/ouroboros-network/CHANGELOG.md index 5c9e0fd87f..13d944a1a1 100644 --- a/ouroboros-network/CHANGELOG.md +++ b/ouroboros-network/CHANGELOG.md @@ -10,6 +10,7 @@ * Addapted to `network-mux` changes in https://github.com/IntersectMBO/ouroboros-network/pull/4997 * Use `LocalRootConfig` instead of a tuple. * Extended `LocalRootConfig` with `diffusionMode :: DiffusionMode` field. +* Added `diConnStateSupply` record field to `Ouroboros.Network.Diffusion.P2P.Interfaces`. ### Non-Breaking changes diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet.hs index 4f2de336c7..6d4f6d72c4 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet.hs @@ -23,10 +23,11 @@ import Control.Monad.Class.MonadTime.SI (DiffTime, Time (Time), addTime, import Control.Monad.IOSim import Data.Bifoldable (bifoldMap) +import Data.Bifunctor (first) import Data.Dynamic (fromDynamic) import Data.Foldable (fold) import Data.IP qualified as IP -import Data.List as List (find, foldl', intercalate, tails) +import Data.List qualified as List import Data.List.Trace qualified as Trace import Data.Map (Map) import Data.Map qualified as Map @@ -248,9 +249,9 @@ tests = , testProperty "peer selection trace coverage" prop_peer_selection_trace_coverage , testProperty "connection manager trace coverage" - prop_connection_manager_trace_coverage + unit_connection_manager_trace_coverage , testProperty "connection manager transitions coverage" - prop_connection_manager_transitions_coverage + unit_connection_manager_transitions_coverage , testProperty "inbound governor trace coverage" prop_inbound_governor_trace_coverage , testProperty "inbound governor transitions coverage" @@ -335,20 +336,21 @@ prop_diffusion_nofail ioSimTrace traceNumber = if r then return $ property True else do - putStrLn $ intercalate "\n" $ map show trace + putStrLn $ List.intercalate "\n" $ map show trace -- the ioSimTrace is infinite, but it will terminate with `AssertionFailed` error "impossible!" -- | This test coverage of 'CM.Trace' constructors. -- -prop_connection_manager_trace_coverage :: AbsBearerInfo - -> DiffusionScript - -> Property -prop_connection_manager_trace_coverage defaultBearerInfo diffScript = - +-- TODO: to turn this test into a property test requires to generate +-- `DiffusionScript` which have at least two nodes that connect to each other. +-- +unit_connection_manager_trace_coverage :: Property +unit_connection_manager_trace_coverage = + withMaxSuccess 1 $ let sim :: forall s . IOSim s Void - sim = diffusionSimulation (toBearerInfo defaultBearerInfo) - diffScript + sim = diffusionSimulation (toBearerInfo absNoAttenuation) + script iosimTracer events :: [CM.Trace @@ -367,35 +369,218 @@ prop_connection_manager_trace_coverage defaultBearerInfo diffScript = eventsSeenNames = map connectionManagerTraceMap events - -- TODO: Add checkCoverage here in tabulate "connection manager trace" eventsSeenNames - True + $ label (showBucket 250 $ length events) + (case events of [] | any (not . List.null . snd) nodes + -> False + _ -> True) + where + addr, addr' :: NtNAddr + addr = TestAddress (IPAddr (read "127.0.0.2") 1000) + addr' = TestAddress (IPAddr (read "127.0.0.1") 1000) + + script@(DiffusionScript _ _ nodes) = + DiffusionScript + (SimArgs 1 20) + (singletonTimedScript Map.empty) + [ -- a relay node + (NodeArgs { + naSeed = 0, + naDiffusionMode = InitiatorAndResponderDiffusionMode, + naMbTime = Just 224, + naPublicRoots = Map.empty, + naConsensusMode = PraosMode, + naBootstrapPeers = (Script (DontUseBootstrapPeers :| [])), + naAddr = addr', + naPeerSharing = PeerSharingDisabled, + naLocalRootPeers = [], + naLedgerPeers = Script (LedgerPools [] :| []), + naPeerTargets = ConsensusModePeerTargets { + deadlineTargets = PeerSelectionTargets + { targetNumberOfRootPeers = 1, + targetNumberOfKnownPeers = 1, + targetNumberOfEstablishedPeers = 0, + targetNumberOfActivePeers = 0, + + targetNumberOfKnownBigLedgerPeers = 0, + targetNumberOfEstablishedBigLedgerPeers = 0, + targetNumberOfActiveBigLedgerPeers = 0 + }, + syncTargets = nullPeerSelectionTargets }, + naDNSTimeoutScript = Script (DNSTimeout {getDNSTimeout = 1} :| []), + naDNSLookupDelayScript = Script (DNSLookupDelay {getDNSLookupDelay = 0.1} :| []), + naChainSyncExitOnBlockNo = Nothing, + naChainSyncEarlyExit = False, + naFetchModeScript = Script (FetchModeDeadline :| []) + } + , [JoinNetwork 0] + ) + , -- a relay, which has the BP as a local root + (NodeArgs { + naSeed = 0, + naDiffusionMode = InitiatorAndResponderDiffusionMode, + naMbTime = Just 224, + naPublicRoots = Map.empty, + naConsensusMode = PraosMode, + naBootstrapPeers = (Script (DontUseBootstrapPeers :| [])), + naAddr = addr, + naPeerSharing = PeerSharingDisabled, + naLocalRootPeers = + [ (1,1,Map.fromList [ (RelayAccessAddress (read "127.0.0.1") 1000, + LocalRootConfig DoNotAdvertisePeer IsNotTrustable InitiatorAndResponderDiffusionMode) + ]) + ], + naLedgerPeers = Script (LedgerPools [] :| []), + naPeerTargets = ConsensusModePeerTargets { + deadlineTargets = PeerSelectionTargets + { targetNumberOfRootPeers = 6, + targetNumberOfKnownPeers = 7, + targetNumberOfEstablishedPeers = 7, + targetNumberOfActivePeers = 6, + + targetNumberOfKnownBigLedgerPeers = 0, + targetNumberOfEstablishedBigLedgerPeers = 0, + targetNumberOfActiveBigLedgerPeers = 0 + }, + syncTargets = nullPeerSelectionTargets }, + naDNSTimeoutScript = Script (DNSTimeout {getDNSTimeout = 1} :| []), + naDNSLookupDelayScript = Script (DNSLookupDelay {getDNSLookupDelay = 0.1} :| []), + naChainSyncExitOnBlockNo = Nothing, + naChainSyncEarlyExit = False, + naFetchModeScript = Script (FetchModeDeadline :| []) + } + , [JoinNetwork 0] + ) + ] -- | This tests coverage of ConnectionManager transitions. -- -prop_connection_manager_transitions_coverage :: AbsBearerInfo - -> DiffusionScript - -> Property -prop_connection_manager_transitions_coverage defaultBearerInfo diffScript = - +-- TODO: to turn this test into a property test requires to generate +-- `DiffusionScript` which have at least two nodes that connect to each other. +-- +unit_connection_manager_transitions_coverage :: Property +unit_connection_manager_transitions_coverage = + withMaxSuccess 1 $ let sim :: forall s . IOSim s Void - sim = diffusionSimulation (toBearerInfo defaultBearerInfo) - diffScript + sim = diffusionSimulation (toBearerInfo absNoAttenuation) + script iosimTracer + trace = runSimTrace sim + -- events from `traceTVar` installed in `newMutableConnState` events :: [AbstractTransitionTrace CM.ConnStateId] events = fmap (\((WithName _ b)) -> b) . selectTraceEventsDynamic' @_ @(CM.ConnectionTransitionTrace NtNAddr) . Trace.take 125000 - $ runSimTrace sim - + $ trace + + -- events from the transition tracer + events' :: [AbstractTransitionTrace CM.ConnStateId] + events' = Trace.toList + . selectDiffusionConnectionManagerTransitionEvents + . fmap (wnEvent . wtEvent) + . withTimeNameTraceEvents + @DiffusionTestTrace + @NtNAddr + . first (const ()) + . Trace.take 125000 + $ trace transitionsSeenNames = map (snd . validTransitionMap . ttTransition) events - -- TODO: Add checkCoverage here in tabulate "connection manager transitions" transitionsSeenNames - True + $ counterexample "traceTVar" + (label ("traceTVar transitions: " ++ showBucket 250 (length events)) + (case events of [] | any (not . List.null . snd) nodes + -> False + _ -> True)) + .&&. + counterexample "trace" + (label ("tracer transitions: " ++ showBucket 250 (length events')) + (case events' of [] | any (not . List.null . snd) nodes + -> False + _ -> True)) + + where + addr, addr' :: NtNAddr + addr = TestAddress (IPAddr (read "127.0.0.2") 1000) + addr' = TestAddress (IPAddr (read "127.0.0.1") 1000) + + script@(DiffusionScript _ _ nodes) = + DiffusionScript + (SimArgs 1 20) + (singletonTimedScript Map.empty) + [ -- a relay node + (NodeArgs { + naSeed = 0, + naDiffusionMode = InitiatorAndResponderDiffusionMode, + naMbTime = Just 224, + naPublicRoots = Map.empty, + naConsensusMode = PraosMode, + naBootstrapPeers = (Script (DontUseBootstrapPeers :| [])), + naAddr = addr', + naPeerSharing = PeerSharingDisabled, + naLocalRootPeers = [], + naLedgerPeers = Script (LedgerPools [] :| []), + naPeerTargets = ConsensusModePeerTargets { + deadlineTargets = PeerSelectionTargets + { targetNumberOfRootPeers = 1, + targetNumberOfKnownPeers = 1, + targetNumberOfEstablishedPeers = 0, + targetNumberOfActivePeers = 0, + + targetNumberOfKnownBigLedgerPeers = 0, + targetNumberOfEstablishedBigLedgerPeers = 0, + targetNumberOfActiveBigLedgerPeers = 0 + }, + syncTargets = nullPeerSelectionTargets }, + naDNSTimeoutScript = Script (DNSTimeout {getDNSTimeout = 1} :| []), + naDNSLookupDelayScript = Script (DNSLookupDelay {getDNSLookupDelay = 0.1} :| []), + naChainSyncExitOnBlockNo = Nothing, + naChainSyncEarlyExit = False, + naFetchModeScript = Script (FetchModeDeadline :| []) + } + , [JoinNetwork 0] + ) + , -- a relay, which has the BP as a local root + (NodeArgs { + naSeed = 0, + naDiffusionMode = InitiatorAndResponderDiffusionMode, + naMbTime = Just 224, + naPublicRoots = Map.empty, + naConsensusMode = PraosMode, + naBootstrapPeers = (Script (DontUseBootstrapPeers :| [])), + naAddr = addr, + naPeerSharing = PeerSharingDisabled, + naLocalRootPeers = + [ (1,1,Map.fromList [ (RelayAccessAddress (read "127.0.0.1") 1000, + LocalRootConfig DoNotAdvertisePeer IsNotTrustable InitiatorAndResponderDiffusionMode) + ]) + ], + naLedgerPeers = Script (LedgerPools [] :| []), + naPeerTargets = ConsensusModePeerTargets { + deadlineTargets = PeerSelectionTargets + { targetNumberOfRootPeers = 6, + targetNumberOfKnownPeers = 7, + targetNumberOfEstablishedPeers = 7, + targetNumberOfActivePeers = 6, + + targetNumberOfKnownBigLedgerPeers = 0, + targetNumberOfEstablishedBigLedgerPeers = 0, + targetNumberOfActiveBigLedgerPeers = 0 + }, + syncTargets = nullPeerSelectionTargets }, + naDNSTimeoutScript = Script (DNSTimeout {getDNSTimeout = 1} :| []), + naDNSLookupDelayScript = Script (DNSLookupDelay {getDNSLookupDelay = 0.1} :| []), + naChainSyncExitOnBlockNo = Nothing, + naChainSyncEarlyExit = False, + naFetchModeScript = Script (FetchModeDeadline :| []) + } + , [JoinNetwork 0] + ) + ] + -- | This test coverage of InboundGovernorTrace constructors. -- @@ -599,7 +784,7 @@ prop_only_bootstrap_peers_in_fallback_state ioSimTrace traceNumber = <*> govLedgerStateJudgement <*> trIsNodeAlive ) - in counterexample (intercalate "\n" $ map show $ Signal.eventsToList events) + in counterexample (List.intercalate "\n" $ map show $ Signal.eventsToList events) $ signalProperty 20 show Set.null keepNonTrustablePeersTooLong @@ -709,7 +894,7 @@ prop_no_non_trustable_peers_before_caught_up_state ioSimTrace traceNumber = <*> trIsNodeAlive ) - in counterexample (intercalate "\n" $ map show $ Signal.eventsToList events) + in counterexample (List.intercalate "\n" $ map show $ Signal.eventsToList events) $ signalProperty 20 show Set.null keepNonTrustablePeersTooLong @@ -2158,7 +2343,7 @@ prop_diffusion_target_established_local ioSimTrace traceNumber = in counterexample ("\nSignal key: (local root peers, established peers, " ++ "recent failures, is alive, opportunities, ignored too long)\n" ++ - intercalate "\n" (map show $ eventsToList events) + List.intercalate "\n" (map show $ eventsToList events) ) $ signalProperty 20 show (\(_,_,_,_,_,_, tooLong) -> Set.null tooLong) @@ -2351,7 +2536,7 @@ prop_diffusion_target_active_below ioSimTrace traceNumber = ("\nSignal key: (local, established peers, active peers, " ++ "recent failures, opportunities, is node running, ignored too long)") $ counterexample - (intercalate "\n" $ map show $ Signal.eventsToList events) $ + (List.intercalate "\n" $ map show $ Signal.eventsToList events) $ signalProperty 20 show (\(_, _, _, _, _, _, toolong) -> Set.null toolong) @@ -2515,7 +2700,7 @@ prop_diffusion_target_active_local_below ioSimTrace traceNumber = ("\nSignal key: (local, established peers, active peers, " ++ "recent failures, opportunities, ignored too long)") $ counterexample - (intercalate "\n" $ map show $ Signal.eventsToList events) $ + (List.intercalate "\n" $ map show $ Signal.eventsToList events) $ signalProperty 20 show (\(_,_,_,_,_,toolong) -> Set.null toolong) @@ -2887,7 +3072,7 @@ prop_diffusion_target_active_local_above ioSimTrace traceNumber = in counterexample ("\nSignal key: (local peers, active peers, is alive " ++ "demotion opportunities, ignored too long)") $ - counterexample (intercalate "\n" $ map show $ Signal.eventsToList events) $ + counterexample (List.intercalate "\n" $ map show $ Signal.eventsToList events) $ signalProperty 20 show (\(_,_,_,_,toolong) -> Set.null toolong) @@ -2959,7 +3144,7 @@ prop_diffusion_cm_valid_transitions ioSimTrace traceNumber = tpProperty = (counterexample $! ( "\nconnection:\n" - ++ intercalate "\n" (map ppTransition trs)) + ++ List.intercalate "\n" (map ppTransition trs)) ) . foldMap ( \ tr -> All @@ -3029,7 +3214,7 @@ prop_diffusion_cm_valid_transition_order_iosim_por ioSimTrace traceNumber = lastTime = (\(WithName _ (WithTime t _)) -> t) . last $ evsList - in counterexample (intercalate "\n" $ map show $ Trace.toList ev) + in counterexample (List.intercalate "\n" $ map show $ Trace.toList ev) $ classifySimulatedTime lastTime $ classifyNumberOfEvents (length evsList) $ verify_cm_valid_transition_order @@ -3428,17 +3613,6 @@ prop_diffusion_peer_selection_actions_no_dodgy_traces ioSimTrace traceNumber = <$> events where - showBucket :: Int -> Int -> String - showBucket size a | a < size - = show a - | otherwise - = concat [ "[" - , show (a `div` size * size) - , ", " - , show (a `div` size * size + size) - , ")" - ] - classifyNumberOfPeerStateActionEvents :: [Trace () (WithName NtNAddr (WithTime DiffusionTestTrace))] -> Property -> Property @@ -3512,11 +3686,12 @@ prop_diffusion_peer_selection_actions_no_dodgy_traces ioSimTrace traceNumber = ) .&&. ( let f :: [WithTime (PeerSelectionActionsTrace NtNAddr NtNVersion)] -> Property - f as = conjoin $ g <$> tails as + f as = conjoin $ g <$> List.tails as g :: [WithTime (PeerSelectionActionsTrace NtNAddr NtNVersion)] -> Property g as@(WithTime demotionTime (PeerStatusChanged HotToCooling{}) : as') = - case find (\case + case List.find + (\case WithTime _ (PeerStatusChanged ColdToWarm{}) -> True _ -> False) as' of @@ -3527,9 +3702,10 @@ prop_diffusion_peer_selection_actions_no_dodgy_traces ioSimTrace traceNumber = >= repromoteDelay config_REPROMOTE_DELAY ) g as@(WithTime demotionTime (PeerStatusChanged WarmToCooling{}) : as') = - case find (\case - WithTime _ (PeerStatusChanged ColdToWarm{}) -> True - _ -> False) + case List.find + (\case + WithTime _ (PeerStatusChanged ColdToWarm{}) -> True + _ -> False) as' of Nothing -> property True @@ -3648,7 +3824,7 @@ unit_peer_sharing = , show addr , " =====\n\n" ] - ++ intercalate "\n" (map show evs) + ++ List.intercalate "\n" (map show evs) ++ s) "" events) $ Map.foldMapWithKey verify events where @@ -3749,7 +3925,7 @@ prop_churn_notimeouts ioSimTrace traceNumber = $ (\evs -> let evsList :: [TracePeerSelection NtNAddr] evsList = snd <$> eventsToList (selectDiffusionPeerSelectionEvents evs) - in property $ counterexample (intercalate "\n" (show <$> eventsToList evs)) + in property $ counterexample (List.intercalate "\n" (show <$> eventsToList evs)) $ all noChurnTimeout evsList ) <$> events @@ -3799,7 +3975,7 @@ prop_churn_steps ioSimTrace traceNumber = $ (\evs -> let evsList :: [(Time, TracePeerSelection NtNAddr)] evsList = eventsToList (selectDiffusionPeerSelectionEvents evs) - in counterexample (intercalate "\n" (show <$> evsList)) + in counterexample (List.intercalate "\n" (show <$> evsList)) . churnTracePredicate . mapMaybe (\case (_, TraceChurnAction _ a _) -> Just a @@ -4381,3 +4557,16 @@ dropBigLedgerPeers -> Governor.PeerSelectionState NtNAddr peerconn -> Set NtNAddr dropBigLedgerPeers f = \st -> f st Set.\\ PublicRootPeers.getBigLedgerPeers (Governor.publicRootPeers st) + + +showBucket :: Int -> Int -> String +showBucket size a | a < size + = show a + | otherwise + = concat [ "[" + , show (a `div` size * size) + , ", " + , show (a `div` size * size + size) + , ")" + ] + diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Internal.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Internal.hs index f97eee2e9e..681b0b7847 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Internal.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Internal.hs @@ -59,6 +59,7 @@ import Data.List.NonEmpty qualified as NonEmpty import Data.Map (Map) import Data.Map qualified as Map import Data.Maybe (catMaybes, fromMaybe, maybeToList) +import Data.Proxy (Proxy (..)) import Data.Set (Set) import Data.Set qualified as Set import Data.Time.Clock (secondsToDiffTime) @@ -967,8 +968,9 @@ diffusionSimulation -> m Void diffusionSimulation defaultBearerInfo - (DiffusionScript simArgs dnsMapScript nodeArgs) - nodeTracer = + (DiffusionScript simArgs dnsMapScript args) + nodeTracer = do + connStateIdSupply <- atomically $ CM.newConnStateIdSupply Proxy -- TODO: we should use `snocket` per node, this will allow us to set up -- bearer info per node withSnocket netSimTracer defaultBearerInfo Map.empty @@ -977,8 +979,8 @@ diffusionSimulation $ \ntcSnocket _ -> do dnsMapVar <- fromLazyTVar <$> playTimedScript nullTracer dnsMapScript withAsyncAll - (map (uncurry (runCommand Nothing ntnSnocket ntcSnocket dnsMapVar simArgs)) - nodeArgs) + (map ((\(nodeArgs, commands) -> runCommand Nothing ntnSnocket ntcSnocket dnsMapVar simArgs nodeArgs connStateIdSupply commands)) + args) $ \nodes -> do (_, x) <- waitAny nodes return x @@ -1004,50 +1006,52 @@ diffusionSimulation -- ^ Map of domain map TVars to be updated in case a node changes its IP -> SimArgs -- ^ Simulation arguments needed in order to run a simulation -> NodeArgs -- ^ Simulation arguments needed in order to run a single node + -> CM.ConnStateIdSupply m -> [Command] -- ^ List of commands/actions to perform for a single node -> m Void - runCommand Nothing ntnSnocket ntcSnocket dnsMapVar sArgs nArgs [] = do + runCommand Nothing ntnSnocket ntcSnocket dnsMapVar sArgs nArgs connStateIdSupply [] = do threadDelay 3600 traceWith (diffSimTracer (naAddr nArgs)) TrRunning - runCommand Nothing ntnSnocket ntcSnocket dnsMapVar sArgs nArgs [] - runCommand (Just (_, _)) ntnSnocket ntcSnocket dMapVarMap sArgs nArgs [] = do + 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 [] - runCommand Nothing ntnSnocket ntcSnocket dnsMapVar sArgs nArgs + 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 lrpVar dnsMapVar) $ \nodeAsync -> - runCommand (Just (nodeAsync, lrpVar)) ntnSnocket ntcSnocket dnsMapVar sArgs nArgs cs - runCommand _ _ _ _ _ _ (JoinNetwork _:_) = + 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 + 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 cs - runCommand _ _ _ _ _ _ (Kill _:_) = do + runCommand Nothing ntnSnocket ntcSnocket dMapVarMap sArgs nArgs connStateIdSupply cs + runCommand _ _ _ _ _ _ _ (Kill _:_) = do error "runCommand: Impossible happened" - runCommand Nothing _ _ _ _ _ (Reconfigure _ _:_) = + runCommand Nothing _ _ _ _ _ _ (Reconfigure _ _:_) = error "runCommand: Impossible happened" - runCommand (Just (async_, lrpVar)) ntnSnocket ntcSnocket dMapVarMap sArgs nArgs + 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 + runCommand (Just (async_, lrpVar)) ntnSnocket ntcSnocket dMapVarMap sArgs nArgs connStateIdSupply cs runNode :: SimArgs -> NodeArgs -> Snocket m (FD m NtNAddr) NtNAddr -> Snocket m (FD m NtCAddr) NtCAddr + -> CM.ConnStateIdSupply m -> StrictTVar m [( HotValency , WarmValency , Map RelayAccessPoint LocalRootConfig @@ -1075,6 +1079,7 @@ diffusionSimulation } ntnSnocket ntcSnocket + connStateIdSupply lrpVar dMapVar = do chainSyncExitVar <- newTVarIO chainSyncExitOnBlockNo @@ -1166,6 +1171,7 @@ diffusionSimulation a' <- readTVar onlyOutboundConnectionsStateVar when (a /= a') $ writeTVar onlyOutboundConnectionsStateVar a + , Node.iConnStateIdSupply = connStateIdSupply } shouldChainSyncExit :: StrictTVar m (Maybe BlockNo) -> BlockHeader -> m Bool @@ -1290,7 +1296,14 @@ diffusionSimulation . tracerWithName ntnAddr . tracerWithTime $ nodeTracer - , Diff.P2P.dtConnectionManagerTransitionTracer = nullTracer + , Diff.P2P.dtConnectionManagerTransitionTracer = contramap + DiffusionConnectionManagerTransitionTrace + . tracerWithName ntnAddr + . tracerWithTime + -- note: we have two ways getting transition trace: + -- * through `traceTVar` installed in `newMutableConnState` + -- * the `dtConnectionManagerTransitionTracer` + $ nodeTracer , Diff.P2P.dtServerTracer = contramap DiffusionServerTrace . tracerWithName ntnAddr . tracerWithTime diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Node.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Node.hs index 985f964255..a23c142e3f 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Node.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Node.hs @@ -67,6 +67,7 @@ import Ouroboros.Network.Block (MaxSlotNo (..), maxSlotNoFromWithOrigin, pointSlot) import Ouroboros.Network.BlockFetch import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainSelStarvation (..)) +import Ouroboros.Network.ConnectionManager.State qualified as CM import Ouroboros.Network.ConnectionManager.Types (DataFlow (..)) import Ouroboros.Network.ConsensusMode import Ouroboros.Network.Diffusion qualified as Diff @@ -127,6 +128,7 @@ data Interfaces m = Interfaces :: LedgerPeersConsensusInterface m , iUpdateOutboundConnectionsState :: OutboundConnectionsState -> STM m () + , iConnStateIdSupply :: CM.ConnStateIdSupply m } type NtNFD m = FD m NtNAddr @@ -246,6 +248,7 @@ run blockGeneratorArgs limits ni na tracersExtra tracerBlockFetch = dnsLookupDelayScriptVar) , Diff.P2P.diUpdateVersionData = \versionData diffusionMode -> versionData { ntnDiffusionMode = diffusionMode } + , Diff.P2P.diConnStateIdSupply = iConnStateIdSupply ni } appsExtra :: Diff.P2P.ApplicationsExtra NtNAddr m () diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs index 99e1d2e31b..4accbf9e2b 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs @@ -52,6 +52,7 @@ import Data.List.NonEmpty (NonEmpty (..)) import Data.Map (Map) import Data.Map qualified as Map import Data.Maybe (catMaybes, maybeToList) +import Data.Proxy (Proxy (..)) import Data.Typeable (Typeable) import Data.Void (Void) import GHC.IO.Exception (IOException (..), IOErrorType (..)) @@ -547,7 +548,15 @@ data Interfaces ntnFd ntnAddr ntnVersion ntnVersionData -- | Update `ntnVersionData` for initiator-only local roots. diUpdateVersionData - :: ntnVersionData -> DiffusionMode -> ntnVersionData + :: ntnVersionData -> DiffusionMode -> ntnVersionData, + + -- | `ConnStateIdSupply` used by the connection-manager for this node. + -- + -- This is exposed for testing, where we use a global + -- `ConnStateIdSupply`. + -- + diConnStateIdSupply + :: CM.ConnStateIdSupply m } runM @@ -625,6 +634,7 @@ runM Interfaces , diInstallSigUSR1Handler , diDnsActions , diUpdateVersionData + , diConnStateIdSupply } Tracers { dtMuxTracer @@ -821,7 +831,8 @@ runM Interfaces CM.prunePolicy = Diffusion.Policies.prunePolicy, CM.stdGen = cmLocalStdGen, CM.connectionsLimits = localConnectionLimits, - CM.updateVersionData = \a _ -> a + CM.updateVersionData = \a _ -> a, + CM.connStateIdSupply = diConnStateIdSupply } CM.with @@ -951,7 +962,8 @@ runM Interfaces CM.connectionsLimits = daAcceptedConnectionsLimit, CM.timeWaitTimeout = daTimeWaitTimeout, CM.outboundIdleTimeout = daProtocolIdleTimeout, - CM.updateVersionData = diUpdateVersionData + CM.updateVersionData = diUpdateVersionData, + CM.connStateIdSupply = diConnStateIdSupply } let peerSelectionPolicy = Diffusion.Policies.simplePeerSelectionPolicy @@ -1307,6 +1319,7 @@ run tracers tracersExtra args argsExtra apps appsExtra = do #endif diRng <- newStdGen + diConnStateIdSupply <- atomically $ CM.newConnStateIdSupply Proxy runM Interfaces { diNtnSnocket = Snocket.socketSnocket iocp, @@ -1329,7 +1342,8 @@ run tracers tracersExtra args argsExtra apps appsExtra = do diRng, diInstallSigUSR1Handler, diDnsActions = ioDNSActions, - diUpdateVersionData = \versionData diffusionMode -> versionData { diffusionMode } + diUpdateVersionData = \versionData diffusionMode -> versionData { diffusionMode }, + diConnStateIdSupply } tracers tracersExtra args argsExtra apps appsExtra