diff --git a/cabal.project b/cabal.project index 58aba0149aa..c008f67db1c 100644 --- a/cabal.project +++ b/cabal.project @@ -15,7 +15,7 @@ repository cardano-haskell-packages -- repeat the index-state for hackage to work around haskell.nix parsing limitation index-state: -- Bump this if you need newer packages from Hackage - , hackage.haskell.org 2024-10-24T05:58:23Z + , hackage.haskell.org 2024-12-10T16:20:07Z -- Bump this if you need newer packages from CHaP , cardano-haskell-packages 2024-09-26T15:16:07Z diff --git a/flake.lock b/flake.lock index 8e5e13f27db..c08d26d06ad 100644 --- a/flake.lock +++ b/flake.lock @@ -210,11 +210,11 @@ "hackageNix": { "flake": false, "locked": { - "lastModified": 1730075386, - "narHash": "sha256-/qBjmdtXZUmsxUupidlsc0+raA8fWUkPfW7Cty/U5WM=", + "lastModified": 1733877006, + "narHash": "sha256-rNpSFS/ziUQBPgo6iAbKgU00yRpeCngv215TW0D+kCo=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "bafe1b0b9060228750b70a3f11b615135ab7abea", + "rev": "583f569545854160b6bc5606374bf5006a9f6929", "type": "github" }, "original": { diff --git a/nix/ouroboros-network.nix b/nix/ouroboros-network.nix index 58bec7c0e80..d69c51cd4b4 100644 --- a/nix/ouroboros-network.nix +++ b/nix/ouroboros-network.nix @@ -90,7 +90,7 @@ let preCheck = lib.mkForce (if buildSystem == "x86_64-linux" - then "export GHCRTS=-M200M" + then "export GHCRTS=-M300M" else ""); doCheck = !pkgs.stdenv.hostPlatform.isWindows; diff --git a/ouroboros-network-framework/demo/connection-manager.hs b/ouroboros-network-framework/demo/connection-manager.hs index f05892a373e..0205ccc908f 100644 --- a/ouroboros-network-framework/demo/connection-manager.hs +++ b/ouroboros-network-framework/demo/connection-manager.hs @@ -65,6 +65,7 @@ import Ouroboros.Network.Context import Ouroboros.Network.IOManager import Ouroboros.Network.Mux import Ouroboros.Network.MuxMode +import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..)) import Ouroboros.Network.Protocol.Handshake import Ouroboros.Network.Protocol.Handshake.Codec (timeLimitsHandshake) import Ouroboros.Network.Protocol.Handshake.Unversioned @@ -242,7 +243,8 @@ withBidirectionalConnectionManager snocket makeBearer socket acceptedConnectionsHardLimit = maxBound, acceptedConnectionsSoftLimit = maxBound, acceptedConnectionsDelay = 0 - } + }, + CM.updateVersionData = \a _ -> a } (makeConnectionHandler muxTracer @@ -541,9 +543,9 @@ bidirectionalExperiment Mux.InitiatorResponderMode UnversionedProtocol)) connect n cm | n <= 1 = - acquireOutboundConnection cm remoteAddr + acquireOutboundConnection cm InitiatorAndResponderDiffusionMode remoteAddr connect n cm = - acquireOutboundConnection cm remoteAddr + acquireOutboundConnection cm InitiatorAndResponderDiffusionMode remoteAddr `catch` \(_ :: IOException) -> threadDelay 1 >> connect (pred n) cm `catch` \(_ :: Mux.Error) -> threadDelay 1 diff --git a/ouroboros-network-framework/ouroboros-network-framework.cabal b/ouroboros-network-framework/ouroboros-network-framework.cabal index 580e3acfbbb..3fe5620c7e0 100644 --- a/ouroboros-network-framework/ouroboros-network-framework.cabal +++ b/ouroboros-network-framework/ouroboros-network-framework.cabal @@ -195,6 +195,7 @@ test-suite sim-tests monoidal-synchronisation, network, network-mux, + ouroboros-network-api, ouroboros-network-framework, ouroboros-network-framework:testlib, ouroboros-network-testing, 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 0e6c9e49ed5..81568e79985 100644 --- a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/ConnectionManager.hs +++ b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/ConnectionManager.hs @@ -59,9 +59,11 @@ import Test.Tasty.QuickCheck (testProperty) import Ouroboros.Network.ConnectionId (ConnectionId (..)) import Ouroboros.Network.ConnectionManager.Core qualified as CM +import Ouroboros.Network.ConnectionManager.State qualified as CM import Ouroboros.Network.ConnectionManager.Test.Utils (verifyAbstractTransition) import Ouroboros.Network.ConnectionManager.Types import Ouroboros.Network.MuxMode +import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..)) import Ouroboros.Network.Server.RateLimiting import Ouroboros.Network.Snocket (Accept (..), Accepted (..), AddressFamily (TestFamily), Snocket (..), TestAddress (..)) @@ -597,7 +599,7 @@ mkConnectionHandler :: forall m handlerTrace. -> ConnectionHandler Mx.InitiatorResponderMode handlerTrace (FD m) Addr (Handle m) - Void (Version, VersionData) + Void Version VersionData m mkConnectionHandler snocket = ConnectionHandler $ @@ -605,8 +607,8 @@ mkConnectionHandler snocket = handler handler where - handler :: ConnectionHandlerFn handlerTrace (FD m) Addr (Handle m) Void (Version, VersionData) m - handler fd promise _ ConnectionId { remoteAddress } _ = + handler :: ConnectionHandlerFn handlerTrace (FD m) Addr (Handle m) Void Version VersionData m + handler _ fd promise _ ConnectionId { remoteAddress } _ = MaskedAction $ \unmask -> do threadId <- myThreadId let addr = getTestAddress remoteAddress @@ -648,8 +650,8 @@ mkConnectionHandler snocket = type TestConnectionState m = CM.ConnectionState Addr (Handle m) Void Version m type TestConnectionManagerTrace = CM.Trace Addr () -type TestTransitionTrace m = TransitionTrace Addr (TestConnectionState m) -type TestAbstractTransitionTrace = AbstractTransitionTrace Addr +type TestTransitionTrace m = TransitionTrace CM.ConnStateId (TestConnectionState m) +type TestAbstractTransitionTrace = AbstractTransitionTrace CM.ConnStateId newtype SkewedBool = SkewedBool Bool deriving Show @@ -772,7 +774,8 @@ prop_valid_transitions (Fixed rnd) (SkewedBool bindToLocalAddress) scheduleMap = acceptedConnectionsDelay = 0 }, CM.timeWaitTimeout = testTimeWaitTimeout, - CM.outboundIdleTimeout = testOutboundIdleTimeout + CM.outboundIdleTimeout = testOutboundIdleTimeout, + CM.updateVersionData = \a _ -> a } connectionHandler (\_ -> HandshakeFailure) @@ -781,11 +784,7 @@ prop_valid_transitions (Fixed rnd) (SkewedBool bindToLocalAddress) scheduleMap = :: ConnectionManager Mx.InitiatorResponderMode (FD (IOSim s)) Addr (Handle m) Void (IOSim s)) -> do fd <- open snocket TestFamily - case myAddress of - Just localAddr -> - bind snocket fd localAddr - Nothing -> - pure () + traverse_ (bind snocket fd) myAddress let go :: HasCallStack => [Async (IOSim s) ()] @@ -811,7 +810,7 @@ prop_valid_transitions (Fixed rnd) (SkewedBool bindToLocalAddress) scheduleMap = -- handshake negotiation. timeout (1 + 5 + testTimeWaitTimeout) (acquireOutboundConnection - connectionManager addr)) + connectionManager InitiatorAndResponderDiffusionMode addr)) `catches` [ Handler $ \(e :: IOException) -> return (Left (toException e)) , Handler $ \(e :: SomeConnectionManagerError) -> 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 bbb968f1b03..5dbe7c759ff 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 @@ -74,12 +74,14 @@ import Network.Mux qualified as Mux import Ouroboros.Network.ConnectionHandler import Ouroboros.Network.ConnectionId import Ouroboros.Network.ConnectionManager.Core qualified as CM +import Ouroboros.Network.ConnectionManager.State qualified as CM import Ouroboros.Network.ConnectionManager.Types import Ouroboros.Network.InboundGovernor qualified as IG import Ouroboros.Network.InboundGovernor.State (ConnectionState (..)) import Ouroboros.Network.InboundGovernor.State qualified as IG import Ouroboros.Network.Mux import Ouroboros.Network.MuxMode +import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..)) import Ouroboros.Network.Protocol.Handshake.Codec (noTimeLimitsHandshake, timeLimitsHandshake) import Ouroboros.Network.Protocol.Handshake.Unversioned @@ -626,7 +628,7 @@ multinodeExperiment => Tracer m (WithName (Name peerAddr) (RemoteTransitionTrace peerAddr)) -> Tracer m (WithName (Name peerAddr) - (AbstractTransitionTrace peerAddr)) + (AbstractTransitionTrace CM.ConnStateId)) -> Tracer m (WithName (Name peerAddr) (IG.Trace peerAddr)) -> Tracer m (WithName (Name peerAddr) @@ -869,7 +871,7 @@ multinodeExperiment inboundTrTracer trTracer inboundTracer debugTracer cmTracer case fromException e of Just SomeAsyncException {} -> Nothing _ -> Just e) - $ acquireOutboundConnection cm remoteAddr + $ acquireOutboundConnection cm InitiatorAndResponderDiffusionMode remoteAddr case connHandle of Left _ -> go connMap @@ -2241,7 +2243,7 @@ multiNodeSimTracer :: ( Alternative (STM m), Monad m, MonadFix m -> Tracer m (WithName (Name SimAddr) (RemoteTransitionTrace SimAddr)) -> Tracer m - (WithName (Name SimAddr) (AbstractTransitionTrace SimAddr)) + (WithName (Name SimAddr) (AbstractTransitionTrace CM.ConnStateId)) -> Tracer m (WithName (Name SimAddr) (IG.Trace SimAddr)) -> Tracer m diff --git a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionHandler.hs b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionHandler.hs index e2969ab874a..650b4299043 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionHandler.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionHandler.hs @@ -65,6 +65,7 @@ import Ouroboros.Network.ControlMessage (ControlMessage (..)) import Ouroboros.Network.Mux import Ouroboros.Network.MuxMode import Ouroboros.Network.Protocol.Handshake +import Ouroboros.Network.Protocol.Handshake.Version qualified as Handshake import Ouroboros.Network.RethrowPolicy -- | We place an upper limit of `30s` on the time we wait on receiving an SDU. @@ -179,7 +180,8 @@ type MuxConnectionHandler muxMode socket initiatorCtx responderCtx peerAddr vers peerAddr (Handle muxMode initiatorCtx responderCtx versionData bytes m a b) (HandleError muxMode versionNumber) - (versionNumber, versionData) + versionNumber + versionData m -- | Type alias for 'ConnectionManager' using 'Handle'. @@ -276,9 +278,11 @@ makeConnectionHandler muxTracer singMuxMode peerAddr (Handle muxMode initiatorCtx responderCtx versionData ByteString m a b) (HandleError muxMode versionNumber) - (versionNumber, versionData) + versionNumber + versionData m - outboundConnectionHandler socket + outboundConnectionHandler versionDataFn + socket PromiseWriter { writePromise } tracer connectionId@ConnectionId { localAddress @@ -299,7 +303,7 @@ makeConnectionHandler muxTracer singMuxMode unmask (runHandshakeClient handshakeBearer connectionId handshakeArguments - versionedApplication) + (Handshake.updateVersionData versionDataFn versionedApplication)) -- 'runHandshakeClient' only deals with protocol limit errors or -- handshake negotiation failures, but not with 'IOException's or -- 'MuxError's. @@ -343,9 +347,11 @@ makeConnectionHandler muxTracer singMuxMode peerAddr (Handle muxMode initiatorCtx responderCtx versionData ByteString m a b) (HandleError muxMode versionNumber) - (versionNumber, versionData) + versionNumber + versionData m - inboundConnectionHandler socket + inboundConnectionHandler updateVersionDataFn + socket PromiseWriter { writePromise } tracer connectionId@ConnectionId { localAddress @@ -366,7 +372,7 @@ makeConnectionHandler muxTracer singMuxMode unmask (runHandshakeServer handshakeBearer connectionId handshakeArguments - versionedApplication) + (Handshake.updateVersionData updateVersionDataFn versionedApplication)) -- 'runHandshakeServer' only deals with protocol limit errors or -- handshake negotiation failures, but not with 'IOException's or -- 'MuxError's. diff --git a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/ConnMap.hs b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/ConnMap.hs index 22c4e79ea33..9aaa5ff6101 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/ConnMap.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/ConnMap.hs @@ -17,7 +17,7 @@ module Ouroboros.Network.ConnectionManager.ConnMap , lookup , lookupByRemoteAddr , updateLocalAddr - , traverseMaybeWithKey + , traverseMaybe ) where import Prelude hiding (lookup) @@ -248,22 +248,17 @@ updateLocalAddr ConnectionId { remoteAddress, localAddress } (ConnMap m) = m -traverseMaybeWithKey +traverseMaybe :: Applicative f - => (Either peerAddr (ConnectionId peerAddr) -> a -> f (Maybe b)) + => (a -> f (Maybe b)) -> ConnMap peerAddr a -> f [b] -traverseMaybeWithKey fn = +traverseMaybe fn = fmap (concat . Map.elems) . Map.traverseMaybeWithKey - (\remoteAddress st -> + (\_ st -> fmap (Just . Map.elems) - . Map.traverseMaybeWithKey - (\case - UnknownLocalAddr -> fn (Left remoteAddress) - LocalAddr localAddress -> fn (Right ConnectionId { remoteAddress, - localAddress }) - ) + . Map.traverseMaybeWithKey (\_ -> fn) $ st ) . getConnMap diff --git a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs index 8b461a6e7f0..35b07e7ad2e 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs @@ -3,7 +3,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -61,12 +60,13 @@ import Ouroboros.Network.ConnectionId import Ouroboros.Network.ConnectionManager.InformationChannel (InformationChannel) import Ouroboros.Network.ConnectionManager.InformationChannel qualified as InfoChannel -import Ouroboros.Network.ConnectionManager.State (ConnectionManagerState, - ConnectionState (..), FreshIdSupply, MutableConnState (..)) +import Ouroboros.Network.ConnectionManager.State (ConnStateIdSupply, + ConnectionManagerState, ConnectionState (..), MutableConnState (..)) import Ouroboros.Network.ConnectionManager.State qualified as State import Ouroboros.Network.ConnectionManager.Types import Ouroboros.Network.InboundGovernor.Event (NewConnectionInfo (..)) import Ouroboros.Network.MuxMode +import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..)) import Ouroboros.Network.Server.RateLimiting (AcceptedConnectionsLimit (..)) import Ouroboros.Network.Snocket @@ -83,7 +83,7 @@ data Arguments handlerTrace socket peerAddr handle handleError versionNumber ver -- -- TODO: do we need this tracer? In some tests we relay on `traceTVar` in -- `newNetworkMutableState` instead. - trTracer :: Tracer m (TransitionTrace peerAddr + trTracer :: Tracer m (TransitionTrace State.ConnStateId (ConnectionState peerAddr handle handleError versionNumber m)), -- | Mux trace. @@ -147,7 +147,9 @@ data Arguments handlerTrace socket peerAddr handle handleError versionNumber ver -- stdGen :: StdGen, - connectionsLimits :: AcceptedConnectionsLimit + connectionsLimits :: AcceptedConnectionsLimit, + + updateVersionData :: versionData -> DiffusionMode -> versionData } @@ -289,9 +291,10 @@ data DemoteToColdLocal peerAddr handlerTrace handle handleError version m (StrictTVar m (ConnectionState peerAddr handle handleError version m)) - !(Transition (ConnectionState - peerAddr handle - handleError version m)) + !(TransitionTrace State.ConnStateId + (ConnectionState + peerAddr handle + handleError version m)) -- | Any @DemoteToCold@ transition which does not terminate the connection, i.e. -- @ @@ -301,9 +304,10 @@ data DemoteToColdLocal peerAddr handlerTrace handle handleError version m -- or the case where the connection is already in 'TerminatingState' or -- 'TerminatedState'. -- - | DemoteToColdLocalNoop !(Maybe (Transition (ConnectionState - peerAddr handle - handleError version m))) + | DemoteToColdLocalNoop !(Maybe (TransitionTrace State.ConnStateId + (ConnectionState + peerAddr handle + handleError version m))) !AbstractState -- | Duplex connection was demoted, prune connections. @@ -315,9 +319,10 @@ data DemoteToColdLocal peerAddr handlerTrace handle handleError version m (ConnectionState peerAddr handle handleError version m) - (Transition (ConnectionState - peerAddr handle - handleError version m)) + (TransitionTrace State.ConnStateId + (ConnectionState + peerAddr handle + handleError version m)) ) -- ^ Left case is for when the connection which @@ -365,7 +370,7 @@ with , Typeable peerAddr ) => Arguments handlerTrace socket peerAddr handle handleError version versionData m - -> ConnectionHandler muxMode handlerTrace socket peerAddr handle handleError (version, versionData) m + -> ConnectionHandler muxMode handlerTrace socket peerAddr handle handleError version versionData m -- ^ Callback which runs in a thread dedicated for a given connection. -> (handleError -> HandleErrorType) -- ^ classify 'handleError's @@ -391,7 +396,8 @@ with args@Arguments { outboundIdleTimeout, connectionDataFlow, prunePolicy, - connectionsLimits + connectionsLimits, + updateVersionData } ConnectionHandler { connectionHandler @@ -399,8 +405,8 @@ with args@Arguments { classifyHandleError inboundGovernorInfoChannel k = do - ((freshIdSupply, stateVar, stdGenVar) - :: ( FreshIdSupply m + ((connStateIdSupply, stateVar, stdGenVar) + :: ( ConnStateIdSupply m , StrictTMVar m (ConnectionManagerState peerAddr handle handleError version m) , StrictTVar m StdGen @@ -414,9 +420,9 @@ with args@Arguments { Just st -> Just <$> traverse (inspectTVar (Proxy :: Proxy m) . toLazyTVar . connVar) st return (TraceString (show st')) - freshIdSupply <- State.newFreshIdSupply (Proxy :: Proxy m) + connStateIdSupply <- State.newConnStateIdSupply (Proxy :: Proxy m) stdGenVar <- newTVar (stdGen args) - return (freshIdSupply, v, stdGenVar) + return (connStateIdSupply, v, stdGenVar) let readState :: STM m (State.ConnMap peerAddr AbstractState) @@ -453,7 +459,7 @@ with args@Arguments { WithInitiatorMode OutboundConnectionManager { ocmAcquireConnection = - acquireOutboundConnectionImpl freshIdSupply stateVar + acquireOutboundConnectionImpl connStateIdSupply stateVar stdGenVar outboundHandler, ocmReleaseConnection = releaseOutboundConnectionImpl stateVar stdGenVar @@ -468,7 +474,7 @@ with args@Arguments { WithResponderMode InboundConnectionManager { icmIncludeConnection = - includeInboundConnectionImpl freshIdSupply stateVar + includeInboundConnectionImpl connStateIdSupply stateVar inboundHandler, icmReleaseConnection = releaseInboundConnectionImpl stateVar, @@ -489,14 +495,14 @@ with args@Arguments { WithInitiatorResponderMode OutboundConnectionManager { ocmAcquireConnection = - acquireOutboundConnectionImpl freshIdSupply stateVar + acquireOutboundConnectionImpl connStateIdSupply stateVar stdGenVar outboundHandler, ocmReleaseConnection = releaseOutboundConnectionImpl stateVar stdGenVar } InboundConnectionManager { icmIncludeConnection = - includeInboundConnectionImpl freshIdSupply stateVar + includeInboundConnectionImpl connStateIdSupply stateVar inboundHandler, icmReleaseConnection = releaseInboundConnectionImpl stateVar, @@ -522,9 +528,8 @@ with args@Arguments { -- Spawning one thread for each connection cleanup avoids spending time -- waiting for locks and cleanup logic that could delay closing the -- connections and making us not respecting certain timeouts. - asyncs <- State.traverseMaybeWithKey - (\peerAddrOrConnId MutableConnState { connVar } -> do - let remoteAddr = either id remoteAddress peerAddrOrConnId + asyncs <- State.traverseMaybe + (\MutableConnState { connStateId, connVar } -> do -- cleanup handler for that thread will close socket associated -- with the thread. We put each connection in 'TerminatedState' to -- try that none of the connection threads will enter @@ -539,12 +544,12 @@ with args@Arguments { connState <- readTVar connVar let connState' = TerminatedState Nothing trT = - TransitionTrace remoteAddr (mkTransition connState connState') + TransitionTrace connStateId (mkTransition connState connState') absConnState = State.abstractState (Known connState) shouldTraceTerminated = absConnState /= TerminatedSt shouldTraceUnknown = absConnState == ReservedOutboundSt trU = TransitionTrace - remoteAddr + connStateId (Transition { fromState = Known connState' , toState = Unknown }) @@ -597,22 +602,23 @@ with args@Arguments { -- TODO: We could probably elegantly eliminate 'PromiseWriter', now that we use -- MonadFix. forkConnectionHandler - :: StrictTMVar m (ConnectionManagerState peerAddr handle handleError version m) + :: (versionData -> versionData) + -> StrictTMVar m (ConnectionManagerState peerAddr handle handleError version m) -> MutableConnState peerAddr handle handleError version m -> socket -> ConnectionId peerAddr -> PromiseWriter m (Either handleError (HandshakeConnectionResult handle (version, versionData))) - -> ConnectionHandlerFn handlerTrace socket peerAddr handle handleError (version, versionData) m + -> ConnectionHandlerFn handlerTrace socket peerAddr handle handleError version versionData m -> m (Async m ()) - forkConnectionHandler stateVar - mutableConnState@MutableConnState { connVar } + forkConnectionHandler updateVersionDataFn stateVar + mutableConnState@MutableConnState { connStateId, connVar } socket - connId@ConnectionId { remoteAddress = peerAddr } + connId writer handler = mask $ \unmask -> async $ do runWithUnmask - (handler socket writer + (handler updateVersionDataFn socket writer (TrConnectionHandler connId `contramap` tracer) connId (\bearerTimeout -> @@ -639,7 +645,7 @@ with args@Arguments { connState <- readTVar connVar let connState' = TerminatedState Nothing transition = mkTransition connState connState' - transitionTrace = TransitionTrace peerAddr transition + transitionTrace = TransitionTrace connStateId transition case connState of ReservedOutboundState -> do writeTVar connVar connState' @@ -687,7 +693,7 @@ with args@Arguments { Nothing -> do let transition = TransitionTrace - peerAddr + connStateId Transition { fromState = Known (TerminatedState Nothing) , toState = Unknown @@ -770,7 +776,7 @@ with args@Arguments { -- overwriting. else return [ ] - traverse_ (traceWith trTracer . TransitionTrace peerAddr) trs + traverse_ (traceWith trTracer . TransitionTrace connStateId) trs traceCounters stateVar -- Pruning is done in two stages: @@ -840,9 +846,9 @@ with args@Arguments { includeInboundConnectionImpl :: HasCallStack - => FreshIdSupply m + => ConnStateIdSupply m -> StrictTMVar m (ConnectionManagerState peerAddr handle handleError version m) - -> ConnectionHandlerFn handlerTrace socket peerAddr handle handleError (version, versionData) m + -> ConnectionHandlerFn handlerTrace socket peerAddr handle handleError version versionData m -> Word32 -- ^ inbound connections hard limit -- TODO: This is needed because the accept loop can not guarantee that @@ -855,7 +861,7 @@ with args@Arguments { -> ConnectionId peerAddr -- ^ connection id used as an identifier of the resource -> m (Connected peerAddr handle handleError) - includeInboundConnectionImpl freshIdSupply + includeInboundConnectionImpl connStateIdSupply stateVar handler hardLimit @@ -901,7 +907,7 @@ with args@Arguments { case v0 of Nothing -> do -- 'Accepted' - v <- State.newMutableConnState (remoteAddress connId) freshIdSupply connState' + v <- State.newMutableConnState (remoteAddress connId) connStateIdSupply connState' labelTVar (connVar v) ("conn-state-" ++ show connId) return (v, Nothing) Just v -> do @@ -929,18 +935,18 @@ with args@Arguments { InboundState {} -> writeTVar (connVar v) connState' $> assert False v - TerminatingState {} -> State.newMutableConnState (remoteAddress connId) freshIdSupply connState' - TerminatedState {} -> State.newMutableConnState (remoteAddress connId) freshIdSupply connState' + TerminatingState {} -> State.newMutableConnState (remoteAddress connId) connStateIdSupply connState' + TerminatedState {} -> State.newMutableConnState (remoteAddress connId) connStateIdSupply connState' labelTVar (connVar v') ("conn-state-" ++ show connId) return (v', Just connState0') connThread' <- forkConnectionHandler - stateVar mutableConnVar' socket connId writer handler + id stateVar mutableConnVar' socket connId writer handler return (connThread', mutableConnVar', connState0', connState') - traceWith trTracer (TransitionTrace (remoteAddress connId) + traceWith trTracer (TransitionTrace (connStateId connVar) Transition { fromState = maybe Unknown Known connState0 , toState = Known connState }) @@ -956,17 +962,17 @@ with args@Arguments { Nothing -> return (Disconnected connId Nothing) - Just (mutableConnState@MutableConnState { connVar } + Just (mutableConnState@MutableConnState { connVar, connStateId } , connThread, reader) -> do traceCounters stateVar res <- atomically $ readPromise reader case res of Left handleError -> do - terminateInboundWithErrorOrQuery connId connVar connThread stateVar mutableConnState $ Just handleError + terminateInboundWithErrorOrQuery connId connStateId connVar connThread stateVar mutableConnState $ Just handleError Right HandshakeConnectionQuery -> do - terminateInboundWithErrorOrQuery connId connVar connThread stateVar mutableConnState Nothing + terminateInboundWithErrorOrQuery connId connStateId connVar connThread stateVar mutableConnState Nothing Right (HandshakeConnectionResult handle (_version, versionData)) -> do let dataFlow = connectionDataFlow versionData @@ -1026,7 +1032,7 @@ with args@Arguments { TerminatedState {} -> return (False, Nothing, Inbound) - traverse_ (traceWith trTracer . TransitionTrace (remoteAddress connId)) mbTransition + traverse_ (traceWith trTracer . TransitionTrace connStateId) mbTransition traceCounters stateVar -- Note that we don't set a timeout thread here which would @@ -1058,6 +1064,7 @@ with args@Arguments { terminateInboundWithErrorOrQuery :: ConnectionId peerAddr + -> State.ConnStateId -> StrictTVar m (ConnectionState peerAddr handle handleError version m) -> Async m () -> StrictTMVar @@ -1065,7 +1072,7 @@ with args@Arguments { -> MutableConnState peerAddr handle handleError version m -> Maybe handleError -> m (Connected peerAddr handle1 handleError) - terminateInboundWithErrorOrQuery connId connVar connThread stateVar mutableConnState handleErrorM = do + terminateInboundWithErrorOrQuery connId connStateId connVar connThread stateVar mutableConnState handleErrorM = do transitions <- atomically $ do connState <- readTVar connVar @@ -1140,7 +1147,7 @@ with args@Arguments { -- overwriting. else return [ ] - traverse_ (traceWith trTracer . TransitionTrace (remoteAddress connId)) transitions + traverse_ (traceWith trTracer . TransitionTrace connStateId) transitions traceCounters stateVar return (Disconnected connId handleErrorM) @@ -1154,7 +1161,7 @@ with args@Arguments { -> m (OperationResult DemotedToColdRemoteTr) releaseInboundConnectionImpl stateVar connId = mask_ $ do traceWith tracer (TrReleaseConnection Inbound connId) - (mbThread, mbTransition, result, mbAssertion) <- atomically $ do + (mbThread, mbTransitionTrace, result, mbAssertion) <- atomically $ do state <- readTMVar stateVar case State.lookup connId state of Nothing -> do @@ -1166,7 +1173,7 @@ with args@Arguments { , OperationSuccess CommitTr , Nothing ) - Just MutableConnState { connVar } -> do + Just MutableConnState { connVar, connStateId } -> do connState <- readTVar connVar let st = State.abstractState (Known connState) case connState of @@ -1195,7 +1202,7 @@ with args@Arguments { let connState' = OutboundDupState connId connThread handle Expired writeTVar connVar connState' return ( Nothing - , Just (mkTransition connState connState') + , Just (TransitionTrace connStateId (mkTransition connState connState')) , OperationSuccess KeepTr , Nothing ) @@ -1239,7 +1246,7 @@ with args@Arguments { let connState' = TerminatingState connId connThread Nothing writeTVar connVar connState' return ( Just connThread - , Just (mkTransition connState connState') + , Just (TransitionTrace connStateId (mkTransition connState connState')) , OperationSuccess CommitTr , Nothing ) @@ -1250,7 +1257,7 @@ with args@Arguments { let connState' = TerminatingState connId connThread Nothing writeTVar connVar connState' return ( Just connThread - , Just (mkTransition connState connState') + , Just (TransitionTrace connStateId (mkTransition connState connState')) , UnsupportedState st , Just (TrUnexpectedlyFalseAssertion (ReleaseInboundConnection (Just connId) @@ -1264,7 +1271,7 @@ with args@Arguments { let connState' = OutboundDupState connId connThread handle Ticking writeTVar connVar connState' return ( Nothing - , Just (mkTransition connState connState') + , Just (TransitionTrace connStateId (mkTransition connState connState')) , UnsupportedState st , Just (TrUnexpectedlyFalseAssertion (ReleaseInboundConnection (Just connId) @@ -1291,7 +1298,7 @@ with args@Arguments { , Nothing ) - traverse_ (traceWith trTracer . TransitionTrace (remoteAddress connId)) mbTransition + traverse_ (traceWith trTracer) mbTransitionTrace traceCounters stateVar -- 'throwTo' avoids blocking until 'timeWaitTimeout' expires. @@ -1307,21 +1314,22 @@ with args@Arguments { acquireOutboundConnectionImpl :: HasCallStack - => FreshIdSupply m + => ConnStateIdSupply m -> StrictTMVar m (ConnectionManagerState peerAddr handle handleError version m) -> StrictTVar m StdGen - -> ConnectionHandlerFn handlerTrace socket peerAddr handle handleError (version, versionData) m + -> ConnectionHandlerFn handlerTrace socket peerAddr handle handleError version versionData m + -> DiffusionMode -> peerAddr -> m (Connected peerAddr handle handleError) - acquireOutboundConnectionImpl freshIdSupply stateVar stdGenVar handler peerAddr = do + acquireOutboundConnectionImpl connStateIdSupply stateVar stdGenVar handler diffusionMode peerAddr = do let provenance = Outbound traceWith tracer (TrIncludeConnection provenance peerAddr) - (trace, mutableConnState@MutableConnState { connVar } + (trace, mutableConnState@MutableConnState { connVar, connStateId } , eHandleWedge) <- atomically $ do state <- readTMVar stateVar stdGen <- stateTVar stdGenVar split case State.lookupByRemoteAddr stdGen peerAddr state of - Just mutableConnState@MutableConnState { connVar } -> do + Just mutableConnState@MutableConnState { connVar, connStateId } -> do connState <- readTVar connVar let st = State.abstractState (Known connState) case connState of @@ -1384,7 +1392,7 @@ with args@Arguments { let connState' = OutboundDupState connId connThread handle Ticking writeTVar connVar connState' return ( Just (Left (TransitionTrace - peerAddr + connStateId (mkTransition connState connState'))) , mutableConnState , Right (Here (Connected connId dataFlow handle)) @@ -1407,7 +1415,7 @@ with args@Arguments { let connState' = DuplexState connId connThread handle writeTVar connVar connState' return ( Just (Left (TransitionTrace - peerAddr + connStateId (mkTransition connState connState'))) , mutableConnState , Right (Here (Connected connId dataFlow handle)) @@ -1433,16 +1441,17 @@ with args@Arguments { Nothing -> do let connState' = ReservedOutboundState - (mutableConnState :: MutableConnState peerAddr handle handleError - version m) - <- State.newMutableConnState peerAddr freshIdSupply connState' + (mutableConnState@MutableConnState { connVar, connStateId } + :: MutableConnState peerAddr handle handleError + version m) + <- State.newMutableConnState peerAddr connStateIdSupply connState' -- TODO: label `connVar` using 'ConnectionId' - labelTVar (connVar mutableConnState) ("conn-state-" ++ show peerAddr) + labelTVar connVar ("conn-state-" ++ show peerAddr) writeTMVar stateVar (State.insertUnknownLocalAddr peerAddr mutableConnState state) return ( Just (Left (TransitionTrace - peerAddr + connStateId Transition { fromState = Unknown, toState = Known connState' @@ -1500,7 +1509,7 @@ with args@Arguments { ] ) - traverse_ (traceWith trTracer . TransitionTrace peerAddr) trs + traverse_ (traceWith trTracer . TransitionTrace connStateId) trs traceCounters stateVar ) $ \socket -> do @@ -1510,16 +1519,22 @@ with args@Arguments { Just IPv4Address -> ipv4Address Just IPv6Address -> ipv6Address configureSocket socket addr + -- only bind to the ip address if: + -- * the diffusion is given `ipv4/6` addresses; + -- * `diffusionMode` for this connection is + -- `InitiatorAndResponderMode`. case addressType peerAddr of - Nothing -> pure () - Just IPv4Address -> + Just IPv4Address | InitiatorAndResponderDiffusionMode + <- diffusionMode -> traverse_ (bind snocket socket) ipv4Address - Just IPv6Address -> + Just IPv6Address | InitiatorAndResponderDiffusionMode + <- diffusionMode -> traverse_ (bind snocket socket) ipv6Address + _ -> pure () - traceWith tracer (TrConnect addr peerAddr) + traceWith tracer (TrConnect addr peerAddr diffusionMode) connect snocket socket peerAddr `catch` \e -> do traceWith tracer (TrConnectError addr peerAddr e) @@ -1553,7 +1568,7 @@ with args@Arguments { connThread <- forkConnectionHandler - stateVar mutableConnState socket connId writer handler + (`updateVersionData` diffusionMode) stateVar mutableConnState socket connId writer handler return (connId, connThread) (trans, mbAssertion) <- atomically $ do @@ -1598,7 +1613,7 @@ with args@Arguments { ) ) - traverse_ (traceWith trTracer . TransitionTrace peerAddr) trans + traverse_ (traceWith trTracer . TransitionTrace connStateId) trans traverse_ (traceWith tracer >=> evaluate . assert True) mbAssertion traceCounters stateVar @@ -1606,10 +1621,10 @@ with args@Arguments { res <- atomically (readPromise reader) case res of Left handleError -> do - terminateOutboundWithErrorOrQuery connId connVar connThread peerAddr stateVar mutableConnState $ Just handleError + terminateOutboundWithErrorOrQuery connId connStateId connVar connThread stateVar mutableConnState $ Just handleError Right HandshakeConnectionQuery -> do - terminateOutboundWithErrorOrQuery connId connVar connThread peerAddr stateVar mutableConnState Nothing + terminateOutboundWithErrorOrQuery connId connStateId connVar connThread stateVar mutableConnState Nothing Right (HandshakeConnectionResult handle (_version, versionData)) -> do let dataFlow = connectionDataFlow versionData @@ -1680,7 +1695,7 @@ with args@Arguments { _ -> let st = State.abstractState (Known connState) in throwSTM (withCallStack (ForbiddenOperation peerAddr st)) - traverse_ (traceWith trTracer . TransitionTrace peerAddr) + traverse_ (traceWith trTracer . TransitionTrace connStateId) mbTransition traceCounters stateVar return $ case mbTransition of @@ -1726,7 +1741,7 @@ with args@Arguments { let connState' = OutboundDupState connId connThread handle Ticking writeTVar connVar connState' return ( Left (TransitionTrace - peerAddr + connStateId (mkTransition connState connState')) , Connected connId dataFlow handle ) @@ -1751,7 +1766,7 @@ with args@Arguments { let connState' = DuplexState connId connThread handle writeTVar connVar connState' return ( Left (TransitionTrace - peerAddr + connStateId (mkTransition connState connState')) , Connected connId dataFlow handle ) @@ -1785,14 +1800,14 @@ with args@Arguments { terminateOutboundWithErrorOrQuery :: ConnectionId peerAddr + -> State.ConnStateId -> StrictTVar m (ConnectionState peerAddr handle handleError version m) -> Async m () - -> peerAddr -> StrictTMVar m (ConnectionManagerState peerAddr handle handleError version m) -> MutableConnState peerAddr handle handleError version m -> Maybe handleError -> m (Connected peerAddr handle handleError) - terminateOutboundWithErrorOrQuery connId connVar connThread peerAddr stateVar mutableConnState handleErrorM = do + terminateOutboundWithErrorOrQuery connId connStateId connVar connThread stateVar mutableConnState handleErrorM = do transitions <- atomically $ do connState <- readTVar connVar @@ -1858,7 +1873,7 @@ with args@Arguments { else return [ ] - traverse_ (traceWith trTracer . TransitionTrace peerAddr) transitions + traverse_ (traceWith trTracer . TransitionTrace connStateId) transitions traceCounters stateVar return (Disconnected connId handleErrorM) @@ -1881,7 +1896,7 @@ with args@Arguments { Nothing -> pure ( DemoteToColdLocalNoop Nothing UnknownConnectionSt , Nothing) - Just MutableConnState { connVar } -> do + Just MutableConnState { connVar, connStateId } -> do connState <- readTVar connVar let st = State.abstractState (Known connState) case connState of @@ -1915,7 +1930,7 @@ with args@Arguments { Unidirectional writeTVar connVar connState' return ( DemotedToColdLocal connId connThread connVar - (mkTransition connState connState') + (TransitionTrace connStateId $ mkTransition connState connState') , Nothing ) @@ -1929,13 +1944,13 @@ with args@Arguments { Duplex writeTVar connVar connState' return ( DemotedToColdLocal connId connThread connVar - (mkTransition connState connState') + (TransitionTrace connStateId $ mkTransition connState connState') , Nothing ) OutboundDupState _connId connThread handle Ticking -> do let connState' = InboundIdleState connId connThread handle Duplex - tr = mkTransition connState connState' + tr = TransitionTrace connStateId $ mkTransition connState connState' numberOfConns <- countIncomingConnections state @@ -2005,7 +2020,7 @@ with args@Arguments { -- @ -- let connState' = InboundState connId connThread handle Duplex - tr = mkTransition connState connState' + tr = TransitionTrace connStateId $ mkTransition connState connState' -- @ -- DemotedToCold^{Duplex}_{Local} : DuplexState @@ -2033,8 +2048,9 @@ with args@Arguments { pure () case transition of - DemotedToColdLocal _connId connThread connVar tr -> do - traceWith trTracer (TransitionTrace (remoteAddress connId) tr) + DemotedToColdLocal _connId connThread connVar + tr@TransitionTrace { ttPeerAddr = connStateId } -> do + traceWith trTracer tr traceCounters stateVar timeoutVar <- registerDelay outboundIdleTimeout r <- atomically $ runFirstToFinish $ @@ -2053,7 +2069,7 @@ with args@Arguments { Right connState -> do let connState' = TerminatingState connId connThread Nothing atomically $ writeTVar connVar connState' - traceWith trTracer (TransitionTrace (remoteAddress connId) + traceWith trTracer (TransitionTrace connStateId (mkTransition connState connState')) traceCounters stateVar -- We rely on the `finally` handler of connection thread to: @@ -2072,17 +2088,17 @@ with args@Arguments { return (UnsupportedState (State.abstractState $ Known connState)) PruneConnections prune eTr -> do - traverse_ (traceWith trTracer . TransitionTrace (remoteAddress connId)) eTr + traverse_ (traceWith trTracer) eTr runPruneAction prune traceCounters stateVar - return (OperationSuccess (State.abstractState (either Known fromState eTr))) + return (OperationSuccess (State.abstractState (either Known (fromState . ttTransition) eTr))) DemoteToColdLocalError trace st -> do traceWith tracer trace return (UnsupportedState st) DemoteToColdLocalNoop tr a -> do - traverse_ (traceWith trTracer . TransitionTrace (remoteAddress connId)) tr + traverse_ (traceWith trTracer) tr traceCounters stateVar return (OperationSuccess a) @@ -2104,7 +2120,7 @@ with args@Arguments { , Nothing , Nothing ) - Just MutableConnState { connVar } -> do + Just MutableConnState { connVar, connStateId } -> do connState <- readTVar connVar let st = State.abstractState (Known connState) case connState of @@ -2171,14 +2187,14 @@ with args@Arguments { $ writeTVar connVar connState' return - ( OperationSuccess tr + ( OperationSuccess (TransitionTrace connStateId tr) , Just prune , Nothing ) else do writeTVar connVar connState' - return ( OperationSuccess tr + return ( OperationSuccess (TransitionTrace connStateId tr) , Nothing , Nothing ) @@ -2209,14 +2225,14 @@ with args@Arguments { $ writeTVar connVar connState' return - ( OperationSuccess (mkTransition connState (TerminatedState Nothing)) + ( OperationSuccess (TransitionTrace connStateId $ mkTransition connState (TerminatedState Nothing)) , Just prune , Nothing ) else do writeTVar connVar connState' - return ( OperationSuccess tr + return ( OperationSuccess (TransitionTrace connStateId tr) , Nothing , Nothing ) @@ -2232,12 +2248,12 @@ with args@Arguments { -- @ let connState' = InboundState connId connThread handle dataFlow writeTVar connVar connState' - return ( OperationSuccess (mkTransition connState connState') + return ( OperationSuccess (TransitionTrace connStateId $ mkTransition connState connState') , Nothing , Nothing ) InboundState _connId _ _ _ -> - return ( OperationSuccess (mkTransition connState connState) + return ( OperationSuccess (TransitionTrace connStateId $ mkTransition connState connState) , Nothing -- already in 'InboundState'? , Just (TrUnexpectedlyFalseAssertion @@ -2247,7 +2263,7 @@ with args@Arguments { ) ) DuplexState {} -> - return ( OperationSuccess (mkTransition connState connState) + return ( OperationSuccess (TransitionTrace connStateId $ mkTransition connState connState) , Nothing , Nothing ) @@ -2270,16 +2286,16 @@ with args@Arguments { -- trace transition case (result, pruneTr) of (OperationSuccess tr, Nothing) -> do - traceWith trTracer (TransitionTrace (remoteAddress connId) tr) + traceWith trTracer tr traceCounters stateVar (OperationSuccess tr, Just prune) -> do - traceWith trTracer (TransitionTrace (remoteAddress connId) tr) + traceWith trTracer tr runPruneAction prune traceCounters stateVar _ -> return () - return (State.abstractState . fromState <$> result) + return (State.abstractState . fromState . ttTransition <$> result) demotedToColdRemoteImpl @@ -2293,7 +2309,7 @@ with args@Arguments { Nothing -> return ( UnsupportedState UnknownConnectionSt , Nothing ) - Just MutableConnState { connVar } -> do + Just MutableConnState { connVar, connStateId } -> do connState <- readTVar connVar let st = State.abstractState (Known connState) case connState of @@ -2322,17 +2338,17 @@ with args@Arguments { ) ) OutboundDupState _connId _connThread _handle _expired -> - return ( OperationSuccess (mkTransition connState connState) + return ( OperationSuccess (TransitionTrace connStateId $ mkTransition connState connState) , Nothing ) -- one can only enter 'OutboundIdleState' if remote state is -- already cold. OutboundIdleState _connId _connThread _handle _dataFlow -> - return ( OperationSuccess (mkTransition connState connState) + return ( OperationSuccess (TransitionTrace connStateId $ mkTransition connState connState) , Nothing ) InboundIdleState _connId _connThread _handle _dataFlow -> - return ( OperationSuccess (mkTransition connState connState) + return ( OperationSuccess (TransitionTrace connStateId $ mkTransition connState connState) , Nothing ) @@ -2344,7 +2360,7 @@ with args@Arguments { InboundState _connId connThread handle dataFlow -> do let connState' = InboundIdleState connId connThread handle dataFlow writeTVar connVar connState' - return ( OperationSuccess (mkTransition connState connState') + return ( OperationSuccess (TransitionTrace connStateId $ mkTransition connState connState') , Nothing ) @@ -2356,7 +2372,7 @@ with args@Arguments { DuplexState _connId connThread handle -> do let connState' = OutboundDupState connId connThread handle Ticking writeTVar connVar connState' - return ( OperationSuccess (mkTransition connState connState') + return ( OperationSuccess (TransitionTrace connStateId $ mkTransition connState connState') , Nothing ) @@ -2377,11 +2393,11 @@ with args@Arguments { -- trace transition case result of OperationSuccess tr -> - traceWith trTracer (TransitionTrace (remoteAddress connId) tr) + traceWith trTracer tr _ -> return () traceCounters stateVar - return (State.abstractState . fromState <$> result) + return (State.abstractState . fromState . ttTransition <$> result) -- @@ -2447,6 +2463,7 @@ data Trace peerAddr handlerTrace | TrReleaseConnection Provenance (ConnectionId peerAddr) | TrConnect (Maybe peerAddr) -- ^ local address peerAddr -- ^ remote address + DiffusionMode | TrConnectError (Maybe peerAddr) -- ^ local address peerAddr -- ^ remote address SomeException diff --git a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/State.hs b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/State.hs index 10031f58752..7025ceac537 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/State.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/State.hs @@ -1,9 +1,11 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} -- Undecidable instances are need for 'Show' instance of 'ConnectionState'. -{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE QuantifiedConstraints #-} module Ouroboros.Network.ConnectionManager.State ( -- * ConnectionManagerState API @@ -14,8 +16,10 @@ module Ouroboros.Network.ConnectionManager.State , readAbstractStateMap -- * MutableConnState , MutableConnState (..) - , FreshIdSupply - , newFreshIdSupply + , ConnStateIdSupply + , ConnStateId (..) + , ConnectionTransitionTrace + , newConnStateIdSupply , newMutableConnState -- * ConnectionState , ConnectionState (..) @@ -57,6 +61,14 @@ readAbstractStateMap -> STM m (ConnMap peerAddr AbstractState) readAbstractStateMap = traverse (fmap (abstractState . Known) . readTVar . connVar) +-- | A unique identifier of a connection. +-- +-- It's used even when we don't yet know `ConnectionId`. +-- +newtype ConnStateId = ConnStateId Int + deriving stock (Eq, Ord, Show) + deriving newtype Enum + -- | 'MutableConnState', which supplies a unique identifier. -- -- TODO: We can get away without id, by tracking connections in @@ -65,7 +77,7 @@ readAbstractStateMap = traverse (fmap (abstractState . Known) . readTVar . connV data MutableConnState peerAddr handle handleError version m = MutableConnState { -- | A unique identifier -- - connStateId :: !Int + connStateId :: !ConnStateId , -- | Mutable state -- @@ -82,21 +94,25 @@ instance Eq (MutableConnState peerAddr handle handleError version m) where -- -- We use a fresh ids for 'MutableConnState'. -- -newtype FreshIdSupply m = FreshIdSupply { getFreshId :: STM m Int } +newtype ConnStateIdSupply m = ConnStateIdSupply { getConnStateId :: STM m ConnStateId } -- | Create a 'FreshIdSupply' inside an 'STM' monad. -- -newFreshIdSupply :: forall m. MonadSTM m - => Proxy m -> STM m (FreshIdSupply m) -newFreshIdSupply _ = do - (v :: StrictTVar m Int) <- newTVar 0 - let getFreshId :: STM m Int - getFreshId = do +newConnStateIdSupply :: forall m. MonadSTM m + => Proxy m + -> STM m (ConnStateIdSupply m) +newConnStateIdSupply _ = do + (v :: StrictTVar m ConnStateId) <- newTVar (ConnStateId 0) + let getConnStateId :: STM m ConnStateId + getConnStateId = do c <- readTVar v writeTVar v (succ c) return c - return $ FreshIdSupply { getFreshId } + return $ ConnStateIdSupply { getConnStateId } + + +type ConnectionTransitionTrace peerAddr = WithName peerAddr (AbstractTransitionTrace ConnStateId) newMutableConnState :: forall peerAddr handle handleError version m. @@ -104,13 +120,13 @@ newMutableConnState :: forall peerAddr handle handleError version m. , Typeable peerAddr ) => peerAddr - -> FreshIdSupply m + -> ConnStateIdSupply m -> ConnectionState peerAddr handle handleError version m -> STM m (MutableConnState peerAddr handle handleError version m) newMutableConnState peerAddr freshIdSupply connState = do - connStateId <- getFreshId freshIdSupply + connStateId <- getConnStateId freshIdSupply connVar <- newTVar connState -- This tracing is a no op in IO. -- @@ -132,21 +148,20 @@ newMutableConnState peerAddr freshIdSupply connState = do let prevAbs = abstractState (Known prev) , prevAbs /= currAbs -> pure $ TraceDynamic - $ WithName connStateId - $ TransitionTrace peerAddr - $ mkAbsTransition prevAbs - currAbs + ( WithName peerAddr + (TransitionTrace connStateId $ mkAbsTransition prevAbs currAbs) + :: ConnectionTransitionTrace peerAddr) Nothing -> pure $ TraceDynamic - $ WithName connStateId - $ TransitionTrace peerAddr + ( WithName peerAddr + $ TransitionTrace connStateId $ mkAbsTransition TerminatedSt currAbs + :: ConnectionTransitionTrace peerAddr) _ -> pure DontTrace ) return $ MutableConnState { connStateId, connVar } - abstractState :: MaybeUnknown (ConnectionState muxMode peerAddr m a b) -> AbstractState abstractState = \case diff --git a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Types.hs b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Types.hs index 0e51c54129a..a11a6bb6a85 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Types.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Types.hs @@ -180,6 +180,7 @@ import Network.Mux.Types qualified as Mux import Ouroboros.Network.ConnectionId (ConnectionId (..)) import Ouroboros.Network.ConnectionManager.ConnMap (ConnMap) import Ouroboros.Network.MuxMode +import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..)) -- | Connection manager supports `IPv4` and `IPv6` addresses. @@ -349,9 +350,10 @@ newtype MaskedAction m a = MaskedAction { -- Note: 'PromiseWriter' could be replaced with an stm action which is -- accessing the 'TVar' which holds state of the connection. -- -type ConnectionHandlerFn handlerTrace socket peerAddr handle handleError version m - = socket - -> PromiseWriter m (Either handleError (HandshakeConnectionResult handle version)) +type ConnectionHandlerFn handlerTrace socket peerAddr handle handleError versionNumber versionData m + = (versionData -> versionData) + -> socket + -> PromiseWriter m (Either handleError (HandshakeConnectionResult handle (versionNumber, versionData))) -> Tracer m handlerTrace -> ConnectionId peerAddr -> (DiffTime -> socket -> m (Mux.Bearer m)) @@ -370,13 +372,13 @@ data HandshakeConnectionResult handle version -- There's one 'ConnectionHandlerFn' per provenance, possibly limited by -- @muxMode@. -- -newtype ConnectionHandler muxMode handlerTrace socket peerAddr handle handleError version m = +newtype ConnectionHandler muxMode handlerTrace socket peerAddr handle handleError versionNumber versionData m = ConnectionHandler { -- | Connection handler. -- connectionHandler :: WithMuxTuple muxMode - (ConnectionHandlerFn handlerTrace socket peerAddr handle handleError version m) + (ConnectionHandlerFn handlerTrace socket peerAddr handle handleError versionNumber versionData m) } @@ -495,7 +497,7 @@ data Connected peerAddr handle handleError = type AcquireOutboundConnection peerAddr handle handleError m - = peerAddr -> m (Connected peerAddr handle handleError) + = DiffusionMode -> peerAddr -> m (Connected peerAddr handle handleError) type IncludeInboundConnection socket peerAddr handle handleError m = Word32 -- ^ inbound connections hard limit. @@ -888,8 +890,8 @@ mkAbsTransition from to = Transition { fromState = from , toState = to } -data TransitionTrace' peerAddr state = TransitionTrace - { ttPeerAddr :: peerAddr -- TODO: use ConnectionId +data TransitionTrace' id state = TransitionTrace + { ttPeerAddr :: id -- ^ an id of a connection, not necessarily an address, e.g. `State.ConnStateId` , ttTransition :: Transition' state } deriving Functor diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Protocol/Handshake/Version.hs b/ouroboros-network-framework/src/Ouroboros/Network/Protocol/Handshake/Version.hs index d25d1288cd3..d6836a623c1 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Protocol/Handshake/Version.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Protocol/Handshake/Version.hs @@ -3,13 +3,12 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} module Ouroboros.Network.Protocol.Handshake.Version ( Versions (..) + , updateVersionData , Version (..) , VersionMismatch (..) -- * Simple or no versioning @@ -54,6 +53,12 @@ newtype Versions vNum vData r = Versions } deriving Semigroup +updateVersionData :: (vData -> vData) -> Versions vNum vData r -> Versions vNum vData r +updateVersionData fn = + Versions + . Map.map (\v -> v { versionData = fn (versionData v) }) + . getVersions + instance Functor (Versions vNum extra) where fmap f (Versions vs) = Versions $ Map.map (fmap f) vs 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 aa962773b63..5e6bd3a05c8 100644 --- a/ouroboros-network-framework/testlib/Ouroboros/Network/ConnectionManager/Test/Experiments.hs +++ b/ouroboros-network-framework/testlib/Ouroboros/Network/ConnectionManager/Test/Experiments.hs @@ -74,6 +74,7 @@ import Network.TypedProtocol.ReqResp.Type as ReqResp import Ouroboros.Network.ConnectionHandler import Ouroboros.Network.ConnectionId import Ouroboros.Network.ConnectionManager.Core qualified as CM +import Ouroboros.Network.ConnectionManager.State qualified as CM import Ouroboros.Network.ConnectionManager.Types import Ouroboros.Network.Context import Ouroboros.Network.ControlMessage @@ -81,6 +82,7 @@ import Ouroboros.Network.Driver.Limits import Ouroboros.Network.InboundGovernor qualified as InboundGovernor import Ouroboros.Network.Mux import Ouroboros.Network.MuxMode +import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..)) import Ouroboros.Network.Protocol.Handshake import Ouroboros.Network.Protocol.Handshake.Codec (cborTermVersionDataCodec, noTimeLimitsHandshake, timeLimitsHandshake) @@ -249,7 +251,7 @@ withInitiatorOnlyConnectionManager => name -- ^ identifier (for logging) -> Timeouts - -> Tracer m (WithName name (AbstractTransitionTrace peerAddr)) + -> Tracer m (WithName name (AbstractTransitionTrace CM.ConnStateId)) -> Tracer m (WithName name (CM.Trace peerAddr @@ -294,7 +296,8 @@ withInitiatorOnlyConnectionManager name timeouts trTracer tracer stdGen snocket CM.stdGen, CM.connectionsLimits = acceptedConnLimit, CM.timeWaitTimeout = tTimeWaitTimeout timeouts, - CM.outboundIdleTimeout = tOutboundIdleTimeout timeouts + CM.outboundIdleTimeout = tOutboundIdleTimeout timeouts, + CM.updateVersionData = \a _ -> a } (makeConnectionHandler muxTracer @@ -417,7 +420,7 @@ withBidirectionalConnectionManager -> Timeouts -- ^ identifier (for logging) -> Tracer m (WithName name (RemoteTransitionTrace peerAddr)) - -> Tracer m (WithName name (AbstractTransitionTrace peerAddr)) + -> Tracer m (WithName name (AbstractTransitionTrace CM.ConnStateId)) -> Tracer m (WithName name (CM.Trace peerAddr @@ -481,7 +484,13 @@ withBidirectionalConnectionManager name timeouts CM.connectionDataFlow = \(DataFlowProtocolData df _) -> df, CM.prunePolicy = simplePrunePolicy, CM.stdGen, - CM.connectionsLimits = acceptedConnLimit + CM.connectionsLimits = acceptedConnLimit, + CM.updateVersionData = \versionData diffusionMode -> + versionData { getProtocolDataFlow = + case diffusionMode of + InitiatorOnlyDiffusionMode -> Unidirectional + InitiatorAndResponderDiffusionMode -> Duplex + } } (makeConnectionHandler muxTracer @@ -589,7 +598,7 @@ withBidirectionalConnectionManager name timeouts reqRespSizeLimits :: forall req resp. ProtocolSizeLimits (ReqResp req resp) - ByteString + ByteString reqRespSizeLimits = ProtocolSizeLimits { sizeLimitForState , dataSize = fromIntegral . LBS.length @@ -735,7 +744,7 @@ unidirectionalExperiment stdGen timeouts snocket makeBearer confSock socket clie replicateM (numberOfRounds clientAndServerData) (bracket - (acquireOutboundConnection connectionManager serverAddr) + (acquireOutboundConnection connectionManager InitiatorOnlyDiffusionMode serverAddr) (\case Connected connId _ _ -> releaseOutboundConnection connectionManager connId Disconnected {} -> error "unidirectionalExperiment: impossible happened") @@ -836,6 +845,7 @@ bidirectionalExperiment (withLock useLock lock (acquireOutboundConnection connectionManager0 + InitiatorAndResponderDiffusionMode localAddr1)) (\case Connected connId _ _ -> @@ -861,6 +871,7 @@ bidirectionalExperiment (withLock useLock lock (acquireOutboundConnection connectionManager1 + InitiatorAndResponderDiffusionMode localAddr0)) (\case Connected connId _ _ -> diff --git a/ouroboros-network-framework/testlib/Ouroboros/Network/ConnectionManager/Test/Timeouts.hs b/ouroboros-network-framework/testlib/Ouroboros/Network/ConnectionManager/Test/Timeouts.hs index d4ae0325a2c..bf9ded00a94 100644 --- a/ouroboros-network-framework/testlib/Ouroboros/Network/ConnectionManager/Test/Timeouts.hs +++ b/ouroboros-network-framework/testlib/Ouroboros/Network/ConnectionManager/Test/Timeouts.hs @@ -1,7 +1,29 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -module Ouroboros.Network.ConnectionManager.Test.Timeouts where +module Ouroboros.Network.ConnectionManager.Test.Timeouts + ( verifyAllTimeouts + , SimAddr + , SimAddr_ + , TestAddr (..) + , TestProperty (..) + , ArbDataFlow (..) + , Timeouts (..) + , ioTimeouts + , simTimeouts + , mkProperty + , mkPropertyPruning + , groupConns + , groupConnsEither + , classifyNegotiatedDataFlow + , classifyActivityType + , classifyEffectiveDataFlow + , classifyTermination + , classifyPrunings + , classifyPruning + , within_ + , ppTransition + ) where import Control.Monad.Class.MonadTime.SI (DiffTime, Time, diffTime) import Control.Monad.IOSim @@ -69,7 +91,7 @@ verifyTimeouts state inDiffusion [] = ("This state didn't timeout:\n" ++ show state ) - $ (inDiffusion || isNothing state) + $ inDiffusion || isNothing state -- If we already seen a \tau transition state verifyTimeouts st@(Just (state, t')) inDiffusion ((t, TransitionTrace _ tt@(Transition _ to)):xs) = diff --git a/ouroboros-network-framework/testlib/Ouroboros/Network/ConnectionManager/Test/Utils.hs b/ouroboros-network-framework/testlib/Ouroboros/Network/ConnectionManager/Test/Utils.hs index 710bc03472e..643969144b9 100644 --- a/ouroboros-network-framework/testlib/Ouroboros/Network/ConnectionManager/Test/Utils.hs +++ b/ouroboros-network-framework/testlib/Ouroboros/Network/ConnectionManager/Test/Utils.hs @@ -303,11 +303,11 @@ connectionManagerTraceMap -> String connectionManagerTraceMap (TrIncludeConnection p _) = "TrIncludeConnection " ++ show p -connectionManagerTraceMap (TrReleaseConnection p _) = +connectionManagerTraceMap (TrReleaseConnection p _) = "TrUnregisterConnection " ++ show p -connectionManagerTraceMap (TrConnect _ _) = +connectionManagerTraceMap TrConnect {} = "TrConnect" -connectionManagerTraceMap (TrConnectError _ _ _) = +connectionManagerTraceMap (TrConnectError _ _ _) = "TrConnectError" connectionManagerTraceMap (TrTerminatingConnection p _) = "TrTerminatingConnection " ++ show p diff --git a/ouroboros-network/CHANGELOG.md b/ouroboros-network/CHANGELOG.md index 32b85b19594..baa3154e46e 100644 --- a/ouroboros-network/CHANGELOG.md +++ b/ouroboros-network/CHANGELOG.md @@ -8,6 +8,8 @@ * Removed deprecated `ReconnectDelay` type alias. * Addapted to `network-mux` changes in https://github.com/IntersectMBO/ouroboros-network/pull/4999 * 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. ### Non-Breaking changes diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index 19883ea2b52..073588689e9 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -210,7 +210,7 @@ library sim-tests-lib dns, hashable, io-classes, - io-sim, + io-sim ^>=1.5.1, iproute, monoidal-synchronisation, mtl, diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerSelection.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerSelection.hs index 72727798661..caa4d881ab1 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerSelection.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerSelection.hs @@ -59,6 +59,7 @@ import Network.Socket (SockAddr) import Ouroboros.Network.ConsensusMode import Ouroboros.Network.ExitPolicy (RepromoteDelay (..)) +import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..)) import Ouroboros.Network.PeerSelection.Bootstrap (UseBootstrapPeers (..), requiresBootstrapPeers) import Ouroboros.Network.PeerSelection.Governor hiding (PeerSelectionState (..), @@ -77,7 +78,7 @@ import Ouroboros.Network.PeerSelection.RootPeersDNS.PublicRootPeers import Ouroboros.Network.PeerSelection.State.EstablishedPeers qualified as EstablishedPeers import Ouroboros.Network.PeerSelection.State.KnownPeers qualified as KnownPeers import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency (..), - LocalRootPeers (..), WarmValency (..)) + LocalRootConfig (..), LocalRootPeers (..), WarmValency (..)) import Ouroboros.Network.PeerSelection.State.LocalRootPeers qualified as LocalRootPeers import Ouroboros.Network.Point import Ouroboros.Network.Protocol.PeerSharing.Type (PeerSharingResult (..)) @@ -3464,8 +3465,9 @@ prop_governor_only_bootstrap_peers_in_clean_state env = . selectEnvEvents $ events where - isTrustable (_, IsTrustable) = True - isTrustable _ = False + isTrustable LocalRootConfig { peerTrustable = IsTrustable } + = True + isTrustable _ = False govHasOnlyBootstrapPeers :: Signal Bool govHasOnlyBootstrapPeers = @@ -3874,8 +3876,8 @@ prop_issue_3550 = prop_governor_target_established_below defaultMaxTime $ (PeerAddr 29,[],GovernorScripts {peerShareScript = Script (Nothing :| []), peerSharingScript = Script (PeerSharingDisabled :| []), connectionScript = Script ((ToWarm,NoDelay) :| [(ToCold,NoDelay),(Noop,NoDelay)])}) ], localRootPeers = LocalRootPeers.fromGroups - [ (1, 1, Map.fromList [(PeerAddr 16,(DoAdvertisePeer, IsNotTrustable))]) - , (1, 1, Map.fromList [(PeerAddr 4,(DoAdvertisePeer, IsNotTrustable))]) + [ (1, 1, Map.fromList [(PeerAddr 16, LocalRootConfig DoAdvertisePeer IsNotTrustable InitiatorAndResponderDiffusionMode)]) + , (1, 1, Map.fromList [(PeerAddr 4, LocalRootConfig DoAdvertisePeer IsNotTrustable InitiatorAndResponderDiffusionMode)]) ], publicRootPeers = PublicRootPeers.fromPublicRootPeers (Map.fromList [ (PeerAddr 14, DoNotAdvertisePeer) @@ -3922,7 +3924,7 @@ prop_issue_3515 = prop_governor_nolivelock $ peerSharingScript = Script (PeerSharingDisabled :| []), connectionScript = Script ((ToCold,NoDelay) :| [(Noop,NoDelay)]) })], - localRootPeers = LocalRootPeers.fromGroups [(1,1,Map.fromList [(PeerAddr 10,(DoAdvertisePeer, IsNotTrustable))])], + localRootPeers = LocalRootPeers.fromGroups [(1,1,Map.fromList [(PeerAddr 10, LocalRootConfig DoAdvertisePeer IsNotTrustable InitiatorAndResponderDiffusionMode)])], publicRootPeers = PublicRootPeers.empty, targets = Script . NonEmpty.fromList $ targets'', pickKnownPeersForPeerShare = Script (PickFirst :| []), @@ -3963,7 +3965,7 @@ prop_issue_3494 = prop_governor_nofail $ peerSharingScript = Script (PeerSharingDisabled :| []), connectionScript = Script ((ToCold,NoDelay) :| [(Noop,NoDelay)]) })], - localRootPeers = LocalRootPeers.fromGroups [(1,1,Map.fromList [(PeerAddr 64, (DoAdvertisePeer, IsNotTrustable))])], + localRootPeers = LocalRootPeers.fromGroups [(1,1,Map.fromList [(PeerAddr 64, LocalRootConfig DoAdvertisePeer IsNotTrustable InitiatorAndResponderDiffusionMode)])], publicRootPeers = PublicRootPeers.empty, targets = Script . NonEmpty.fromList $ targets'', pickKnownPeersForPeerShare = Script (PickFirst :| []), @@ -4012,8 +4014,8 @@ prop_issue_3233 = prop_governor_nolivelock $ (PeerAddr 15,[],GovernorScripts {peerShareScript = Script (Just ([],PeerShareTimeSlow) :| []), peerSharingScript = Script (PeerSharingDisabled :| []), connectionScript = Script ((Noop,NoDelay) :| [])}) ], localRootPeers = LocalRootPeers.fromGroups - [ (1, 1, Map.fromList [(PeerAddr 15, (DoAdvertisePeer, IsNotTrustable))]) - , (1, 1, Map.fromList [(PeerAddr 13, (DoAdvertisePeer, IsNotTrustable))]) + [ (1, 1, Map.fromList [(PeerAddr 15, LocalRootConfig DoAdvertisePeer IsNotTrustable InitiatorAndResponderDiffusionMode)]) + , (1, 1, Map.fromList [(PeerAddr 13, LocalRootConfig DoAdvertisePeer IsNotTrustable InitiatorAndResponderDiffusionMode)]) ], publicRootPeers = PublicRootPeers.fromPublicRootPeers (Map.fromList [(PeerAddr 4, DoNotAdvertisePeer)]), diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerSelection/Instances.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerSelection/Instances.hs index e2f83b90331..4aa2f959aaf 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerSelection/Instances.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerSelection/Instances.hs @@ -17,17 +17,17 @@ module Test.Ouroboros.Network.PeerSelection.Instances , prop_shrink_PeerSelectionTargets ) where +import Data.Hashable +import Data.IP qualified as IP import Data.Text.Encoding (encodeUtf8) import Data.Word (Word32, Word64) import Cardano.Slotting.Slot (SlotNo (..)) -import Ouroboros.Network.PeerSelection.Governor - -import Data.Hashable -import Data.IP qualified as IP import Ouroboros.Network.ConsensusMode +import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..)) import Ouroboros.Network.PeerSelection.Bootstrap (UseBootstrapPeers (..)) +import Ouroboros.Network.PeerSelection.Governor import Ouroboros.Network.PeerSelection.LedgerPeers.Type (AfterSlot (..), UseLedgerPeers (..)) import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..)) @@ -35,6 +35,8 @@ import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) import Ouroboros.Network.PeerSelection.PeerTrustable (PeerTrustable (..)) import Ouroboros.Network.PeerSelection.RelayAccessPoint (DomainAccessPoint (..), RelayAccessPoint (..)) +import Ouroboros.Network.PeerSelection.State.LocalRootPeers + (LocalRootConfig (..)) import Ouroboros.Network.Testing.Utils (ShrinkCarefully, prop_shrink_nonequal, prop_shrink_valid) import Test.QuickCheck @@ -188,3 +190,20 @@ prop_shrink_PeerSelectionTargets x = prop_shrink_valid sanePeerSelectionTargets x .&&. prop_shrink_nonequal x + +instance Arbitrary LocalRootConfig where + arbitrary = LocalRootConfig <$> arbitrary <*> arbitrary <*> elements [InitiatorAndResponderDiffusionMode, InitiatorOnlyDiffusionMode] + shrink a@LocalRootConfig { peerAdvertise, peerTrustable, diffusionMode } = + [ a { peerTrustable = peerTrustable' } + | peerTrustable' <- shrink peerTrustable + ] + ++ + [ a { peerAdvertise = peerAdvertise' } + | peerAdvertise' <- shrink peerAdvertise + ] + ++ + [ a { diffusionMode = diffusionMode' } + | diffusionMode' <- case diffusionMode of + InitiatorOnlyDiffusionMode -> [] + InitiatorAndResponderDiffusionMode -> [InitiatorOnlyDiffusionMode] + ] diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerSelection/LocalRootPeers.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerSelection/LocalRootPeers.hs index be5bea345eb..e9451b7d986 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerSelection/LocalRootPeers.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerSelection/LocalRootPeers.hs @@ -17,19 +17,16 @@ import Data.Map.Strict qualified as Map import Data.Set (Set) import Data.Set qualified as Set +import Ouroboros.Network.PeerSelection.Governor import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency (..), - LocalRootPeers (..), WarmValency (..)) + LocalRootConfig (..), LocalRootPeers (..), WarmValency (..)) import Ouroboros.Network.PeerSelection.State.LocalRootPeers qualified as LocalRootPeers -import Ouroboros.Network.PeerSelection.Governor - import Ouroboros.Network.Testing.Utils (ShrinkCarefully, prop_shrink_nonequal, prop_shrink_valid, renderRanges) import Test.Ouroboros.Network.PeerSelection.Instances -import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise) -import Ouroboros.Network.PeerSelection.PeerTrustable (PeerTrustable) import Test.QuickCheck import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) @@ -153,7 +150,7 @@ prop_shrink_LocalRootPeers x = prop_shrink_valid LocalRootPeers.invariant x .&&. prop_shrink_nonequal x -prop_fromGroups :: [(HotValency, WarmValency, Map PeerAddr (PeerAdvertise, PeerTrustable))] -> Bool +prop_fromGroups :: [(HotValency, WarmValency, Map PeerAddr LocalRootConfig)] -> Bool prop_fromGroups = LocalRootPeers.invariant . LocalRootPeers.fromGroups prop_fromToGroups :: LocalRootPeers PeerAddr -> Bool diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerSelection/MockEnvironment.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerSelection/MockEnvironment.hs index 5433bf2668b..77525938f93 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerSelection/MockEnvironment.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerSelection/MockEnvironment.hs @@ -60,6 +60,7 @@ import Control.Monad.IOSim import Control.Tracer (Tracer (..), contramap, traceWith) import Ouroboros.Network.ExitPolicy +import Ouroboros.Network.NodeToNode.Version (DiffusionMode) import Ouroboros.Network.PeerSelection.Governor hiding (PeerSelectionState (..)) import Ouroboros.Network.PeerSelection.Governor qualified as Governor import Ouroboros.Network.PeerSelection.State.LocalRootPeers qualified as LocalRootPeers @@ -515,8 +516,8 @@ mockPeerSelectionActions' tracer traceWith tracer (TraceEnvPeerShareResult addr peeraddrs) return (PeerSharingResult peeraddrs) - establishPeerConnection :: IsBigLedgerPeer -> PeerAddr -> m (PeerConn m) - establishPeerConnection _ peeraddr = do + establishPeerConnection :: IsBigLedgerPeer -> DiffusionMode -> PeerAddr -> m (PeerConn m) + establishPeerConnection _ _ peeraddr = do --TODO: add support for variable delays and synchronous failure traceWith tracer (TraceEnvEstablishConn peeraddr) threadDelay 1 diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerSelection/RootPeersDNS.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerSelection/RootPeersDNS.hs index d12bb2001f0..68b092bb625 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerSelection/RootPeersDNS.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerSelection/RootPeersDNS.hs @@ -57,6 +57,7 @@ import Control.Tracer (Tracer (Tracer), contramap, nullTracer, traceWith) import Control.Concurrent.Class.MonadSTM qualified as LazySTM import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty (..)) +import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..)) import Ouroboros.Network.PeerSelection.LedgerPeers import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..)) import Ouroboros.Network.PeerSelection.PeerTrustable (PeerTrustable (..)) @@ -65,7 +66,7 @@ import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSSemaphore import Ouroboros.Network.PeerSelection.RootPeersDNS.LocalRootPeers import Ouroboros.Network.PeerSelection.RootPeersDNS.PublicRootPeers import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency (..), - WarmValency (..)) + LocalRootConfig (..), WarmValency (..)) import Ouroboros.Network.Testing.Data.Script (Script (Script), initScript', scriptHead, singletonScript, stepScript') import Test.Ouroboros.Network.PeerSelection.Instances () @@ -104,7 +105,7 @@ tests = data MockRoots = MockRoots { mockLocalRootPeers :: [( HotValency , WarmValency - , Map RelayAccessPoint (PeerAdvertise, PeerTrustable))] + , Map RelayAccessPoint LocalRootConfig)] , mockLocalRootPeersDNSMap :: Script (Map Domain [(IP, TTL)]) , mockPublicRootPeers :: Map RelayAccessPoint PeerAdvertise , mockPublicRootPeersDNSMap :: Script (Map Domain [(IP, TTL)]) @@ -238,10 +239,10 @@ simpleMockRoots = MockRoots localRootPeers dnsMap Map.empty (singletonScript Map [ ( 2, 2 , Map.fromList [ ( RelayAccessAddress (read "192.0.2.1") (read "3333") - , (DoAdvertisePeer, IsNotTrustable) + , LocalRootConfig DoAdvertisePeer IsNotTrustable InitiatorAndResponderDiffusionMode ) , ( RelayAccessDomain "test.domain" (read "4444") - , (DoNotAdvertisePeer, IsNotTrustable) + , LocalRootConfig DoNotAdvertisePeer IsNotTrustable InitiatorAndResponderDiffusionMode ) ] ) @@ -463,7 +464,7 @@ mockResolveLedgerPeers tracer (MockRoots _ _ publicRootPeers dnsMapScript) -- data TestTraceEvent = RootPeerDNSLocal (TraceLocalRootPeers SockAddr Failure) - | LocalRootPeersResults [(HotValency, WarmValency, Map SockAddr (PeerAdvertise, PeerTrustable))] + | LocalRootPeersResults [(HotValency, WarmValency, Map SockAddr LocalRootConfig)] | RootPeerDNSPublic TracePublicRootPeers deriving (Show, Typeable) @@ -499,13 +500,13 @@ selectLocalRootPeersEvents :: [(Time, TestTraceEvent)] selectLocalRootPeersEvents trace = [ (t, e) | (t, RootPeerDNSLocal e) <- trace ] selectLocalRootPeersResults :: [(Time, TestTraceEvent)] - -> [(Time, [(HotValency, WarmValency, Map SockAddr (PeerAdvertise, PeerTrustable))])] + -> [(Time, [(HotValency, WarmValency, Map SockAddr LocalRootConfig)])] selectLocalRootPeersResults trace = [ (t, r) | (t, LocalRootPeersResults r) <- trace ] selectLocalRootGroupsEvents :: [(Time, TraceLocalRootPeers SockAddr Failure)] -> [(Time, [( HotValency , WarmValency - , Map SockAddr (PeerAdvertise, PeerTrustable))])] + , Map SockAddr LocalRootConfig)])] selectLocalRootGroupsEvents trace = [ (t, e) | (t, TraceLocalRootGroups e) <- trace ] selectLocalRootResultEvents :: [(Time, TraceLocalRootPeers SockAddr Failure)] @@ -555,13 +556,13 @@ prop_local_preservesIPs mockRoots@(MockRoots localRoots _ _ _) where checkAll :: [(Time, [( HotValency , WarmValency - , Map SockAddr (PeerAdvertise, PeerTrustable))])] + , Map SockAddr LocalRootConfig)])] -> Property checkAll [] = property True checkAll (x:t) = let thrd (_, _, c) = c -- get local root ip addresses - localRootAddresses :: [(a, b, Map RelayAccessPoint (PeerAdvertise, PeerTrustable))] + localRootAddresses :: [(a, b, Map RelayAccessPoint LocalRootConfig)] -> Set SockAddr localRootAddresses lrp = Set.fromList @@ -573,7 +574,7 @@ prop_local_preservesIPs mockRoots@(MockRoots localRoots _ _ _) -- get ip addresses out of LocalRootGroup trace events localGroupEventsAddresses :: (a, [( HotValency , WarmValency - , Map SockAddr (PeerAdvertise, PeerTrustable))]) + , Map SockAddr LocalRootConfig)]) -> Set SockAddr localGroupEventsAddresses (_, s) = Set.fromList 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 37796ec5d8f..4f2de336c7c 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet.hs @@ -46,9 +46,10 @@ import Network.DNS.Types qualified as DNS import Ouroboros.Network.BlockFetch (PraosFetchMode (..), TraceFetchClientState (..)) -import Ouroboros.Network.ConnectionHandler (ConnectionHandlerTrace) +import Ouroboros.Network.ConnectionHandler (ConnectionHandlerTrace (..)) import Ouroboros.Network.ConnectionId import Ouroboros.Network.ConnectionManager.Core qualified as CM +import Ouroboros.Network.ConnectionManager.State qualified as CM import Ouroboros.Network.ConnectionManager.Test.Timeouts (TestProperty (..), classifyActivityType, classifyEffectiveDataFlow, classifyNegotiatedDataFlow, classifyPrunings, classifyTermination, @@ -84,7 +85,7 @@ import Ouroboros.Network.PeerSelection.RootPeersDNS.LocalRootPeers import Ouroboros.Network.PeerSelection.State.EstablishedPeers qualified as EstablishedPeers import Ouroboros.Network.PeerSelection.State.KnownPeers qualified as KnownPeers import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency (..), - WarmValency (..)) + LocalRootConfig (..), WarmValency (..)) import Ouroboros.Network.PeerSelection.State.LocalRootPeers qualified as LocalRootPeers import Ouroboros.Network.PeerSelection.Types import Ouroboros.Network.PeerSharing (PeerSharingResult (..)) @@ -223,6 +224,12 @@ tests = (testWithIOSim prop_only_bootstrap_peers_in_fallback_state 125000) , testProperty "no non trustable peers before caught up state" (testWithIOSim prop_no_non_trustable_peers_before_caught_up_state 125000) + , testGroup "local root diffusion mode" + [ testProperty "InitiatorOnly" + (unit_local_root_diffusion_mode InitiatorOnlyDiffusionMode) + , testProperty "InitiatorAndResponder" + (unit_local_root_diffusion_mode InitiatorAndResponderDiffusionMode) + ] , testGroup "Peer Sharing" [ testProperty "share a peer" unit_peer_sharing @@ -376,16 +383,9 @@ prop_connection_manager_transitions_coverage defaultBearerInfo diffScript = diffScript iosimTracer - events :: [AbstractTransitionTrace NtNAddr] - events = mapMaybe (\case DiffusionConnectionManagerTransitionTrace st -> - Just st - _ -> Nothing - ) - . Trace.toList - . fmap (\(WithTime _ (WithName _ b)) -> b) - . withTimeNameTraceEvents - @DiffusionTestTrace - @NtNAddr + events :: [AbstractTransitionTrace CM.ConnStateId] + events = fmap (\((WithName _ b)) -> b) + . selectTraceEventsDynamic' @_ @(CM.ConnectionTransitionTrace NtNAddr) . Trace.take 125000 $ runSimTrace sim @@ -731,8 +731,8 @@ unit_4177 = prop_inbound_governor_transitions_coverage absNoAttenuation script (Script (UseBootstrapPeers [RelayAccessDomain "bootstrap" 00000] :| [])) (TestAddress (IPAddr (read "0:7:0:7::") 65533)) PeerSharingDisabled - [ (1,1,Map.fromList [(RelayAccessDomain "test2" 65535,(DoNotAdvertisePeer, IsNotTrustable)) - , (RelayAccessAddress "0:6:0:3:0:6:0:5" 65530,(DoNotAdvertisePeer, IsNotTrustable))]) + [ (1,1,Map.fromList [(RelayAccessDomain "test2" 65535,LocalRootConfig DoNotAdvertisePeer IsNotTrustable InitiatorAndResponderDiffusionMode) + , (RelayAccessAddress "0:6:0:3:0:6:0:5" 65530,LocalRootConfig DoNotAdvertisePeer IsNotTrustable InitiatorAndResponderDiffusionMode)]) ] (Script (LedgerPools [] :| [])) ConsensusModePeerTargets { @@ -751,11 +751,11 @@ unit_4177 = prop_inbound_governor_transitions_coverage absNoAttenuation script False (Script (FetchModeDeadline :| [])) , [JoinNetwork 1.742857142857 - ,Reconfigure 6.33333333333 [(1,1,Map.fromList [(RelayAccessDomain "test2" 65535,(DoAdvertisePeer, IsNotTrustable))]), - (1,1,Map.fromList [(RelayAccessAddress "0:6:0:3:0:6:0:5" 65530,(DoAdvertisePeer, IsNotTrustable)) + ,Reconfigure 6.33333333333 [(1,1,Map.fromList [(RelayAccessDomain "test2" 65535,LocalRootConfig DoAdvertisePeer IsNotTrustable InitiatorAndResponderDiffusionMode)]), + (1,1,Map.fromList [(RelayAccessAddress "0:6:0:3:0:6:0:5" 65530,LocalRootConfig DoAdvertisePeer IsNotTrustable InitiatorAndResponderDiffusionMode) ])] - ,Reconfigure 23.88888888888 [(1,1,Map.empty),(1,1,Map.fromList [(RelayAccessAddress "0:6:0:3:0:6:0:5" 65530,(DoAdvertisePeer, IsNotTrustable))])] - ,Reconfigure 4.870967741935 [(1,1,Map.fromList [(RelayAccessDomain "test2" 65535,(DoAdvertisePeer, IsNotTrustable))])] + ,Reconfigure 23.88888888888 [(1,1,Map.empty),(1,1,Map.fromList [(RelayAccessAddress "0:6:0:3:0:6:0:5" 65530,LocalRootConfig DoAdvertisePeer IsNotTrustable InitiatorAndResponderDiffusionMode)])] + ,Reconfigure 4.870967741935 [(1,1,Map.fromList [(RelayAccessDomain "test2" 65535,LocalRootConfig DoAdvertisePeer IsNotTrustable InitiatorAndResponderDiffusionMode)])] ] ) , ( NodeArgs 1 InitiatorAndResponderDiffusionMode (Just 135) @@ -1336,8 +1336,8 @@ unit_4191 = testWithIOSim prop_diffusion_dns_can_recover 125000 absInfo script (Script (UseBootstrapPeers [RelayAccessDomain "bootstrap" 00000] :| [])) (TestAddress (IPAddr (read "0.0.1.236") 65527)) PeerSharingDisabled - [ (2,2,Map.fromList [ (RelayAccessDomain "test2" 15,(DoNotAdvertisePeer, IsNotTrustable)) - , (RelayAccessDomain "test3" 4,(DoAdvertisePeer, IsNotTrustable))]) + [ (2,2,Map.fromList [ (RelayAccessDomain "test2" 15,LocalRootConfig DoNotAdvertisePeer IsNotTrustable InitiatorAndResponderDiffusionMode) + , (RelayAccessDomain "test3" 4,LocalRootConfig DoAdvertisePeer IsNotTrustable InitiatorAndResponderDiffusionMode)]) ] (Script (LedgerPools [] :| [])) ConsensusModePeerTargets { @@ -1384,10 +1384,10 @@ unit_4191 = testWithIOSim prop_diffusion_dns_can_recover 125000 absInfo script , [ JoinNetwork 6.710144927536 , Kill 7.454545454545 , JoinNetwork 10.763157894736 - , Reconfigure 0.415384615384 [(1,1,Map.empty) + , Reconfigure 0.415384615384 [(1,1,Map.fromList []) , (1,1,Map.empty)] - , Reconfigure 15.550561797752 [(1,1,Map.empty) - , (1,1,Map.fromList [(RelayAccessDomain "test2" 15,(DoAdvertisePeer, IsNotTrustable))])] + , Reconfigure 15.550561797752 [(1,1,Map.fromList []) + , (1,1,Map.fromList [(RelayAccessDomain "test2" 15,LocalRootConfig DoAdvertisePeer IsNotTrustable InitiatorAndResponderDiffusionMode)])] , Reconfigure 82.85714285714 [] ]) ] @@ -1471,7 +1471,7 @@ prop_connect_failure (AbsIOError ioerr) = naBootstrapPeers = Script (DontUseBootstrapPeers :| []), naAddr = TestAddress (IPAddr nodeIP nodePort), naPeerSharing = PeerSharingDisabled, - naLocalRootPeers = [(1,1,Map.fromList [(RelayAccessAddress relayIP relayPort,(DoNotAdvertisePeer, IsNotTrustable))])], + naLocalRootPeers = [(1,1,Map.fromList [(RelayAccessAddress relayIP relayPort,LocalRootConfig DoNotAdvertisePeer IsNotTrustable InitiatorAndResponderDiffusionMode)])], naLedgerPeers = Script (LedgerPools [] :| []), naPeerTargets = ConsensusModePeerTargets { deadlineTargets = PeerSelectionTargets { @@ -1603,7 +1603,7 @@ prop_accept_failure (AbsIOError ioerr) = naBootstrapPeers = Script (DontUseBootstrapPeers :| []), naAddr = TestAddress (IPAddr nodeIP nodePort), naPeerSharing = PeerSharingDisabled, - naLocalRootPeers = [(1,1,Map.fromList [(RelayAccessAddress relayIP relayPort,(DoNotAdvertisePeer, IsNotTrustable))])], + naLocalRootPeers = [(1,1,Map.fromList [(RelayAccessAddress relayIP relayPort,LocalRootConfig DoNotAdvertisePeer IsNotTrustable InitiatorAndResponderDiffusionMode)])], naLedgerPeers = Script (LedgerPools [] :| []), naPeerTargets = ConsensusModePeerTargets { deadlineTargets = PeerSelectionTargets { @@ -2550,21 +2550,21 @@ async_demotion_network_script = ] ) , ( common { naAddr = addr2, - naLocalRootPeers = [(1,1, Map.fromList [(ra_addr1, (DoNotAdvertisePeer, IsNotTrustable))])] } + naLocalRootPeers = [(1,1, Map.fromList [(ra_addr1, LocalRootConfig DoNotAdvertisePeer IsNotTrustable InitiatorAndResponderDiffusionMode)])] } , [JoinNetwork 0, Kill 5, JoinNetwork 20] ) , ( common { naAddr = addr3, - naLocalRootPeers = [(1,1, Map.fromList [(ra_addr1, (DoNotAdvertisePeer, IsNotTrustable))])] } + naLocalRootPeers = [(1,1, Map.fromList [(ra_addr1, LocalRootConfig DoNotAdvertisePeer IsNotTrustable InitiatorAndResponderDiffusionMode)])] } , [JoinNetwork 0] ) ] where addr1 = TestAddress (IPAddr (read "10.0.0.1") 3000) ra_addr1 = RelayAccessAddress (read "10.0.0.1") 3000 - localRoots1 = [(2,2, Map.fromList [(ra_addr2, (DoNotAdvertisePeer, IsNotTrustable)) - ,(ra_addr3, (DoNotAdvertisePeer, IsNotTrustable))])] - localRoots1' = [(2,2, Map.fromList [(ra_addr2, (DoAdvertisePeer, IsNotTrustable)) - ,(ra_addr3, (DoAdvertisePeer, IsNotTrustable))])] + localRoots1 = [(2,2, Map.fromList [(ra_addr2, LocalRootConfig DoNotAdvertisePeer IsNotTrustable InitiatorAndResponderDiffusionMode) + ,(ra_addr3, LocalRootConfig DoNotAdvertisePeer IsNotTrustable InitiatorAndResponderDiffusionMode)])] + localRoots1' = [(2,2, Map.fromList [(ra_addr2, LocalRootConfig DoAdvertisePeer IsNotTrustable InitiatorAndResponderDiffusionMode) + ,(ra_addr3, LocalRootConfig DoAdvertisePeer IsNotTrustable InitiatorAndResponderDiffusionMode)])] addr2 = TestAddress (IPAddr (read "10.0.0.2") 3000) ra_addr2 = RelayAccessAddress (read "10.0.0.2") 3000 @@ -2937,7 +2937,7 @@ prop_diffusion_cm_valid_transitions ioSimTrace traceNumber = where verify_cm_valid_transitions :: Trace () DiffusionTestTrace -> Property verify_cm_valid_transitions events = - let abstractTransitionEvents :: Trace () (AbstractTransitionTrace NtNAddr) + let abstractTransitionEvents :: Trace () (AbstractTransitionTrace CM.ConnStateId) abstractTransitionEvents = selectDiffusionConnectionManagerTransitionEvents events @@ -3084,7 +3084,7 @@ prop_diffusion_cm_valid_transition_order ioSimTrace traceNumber = where verify_cm_valid_transition_order :: Trace () (WithName NtNAddr (WithTime DiffusionTestTrace)) -> Property verify_cm_valid_transition_order events = - let abstractTransitionEvents :: Trace () (WithName NtNAddr (WithTime (AbstractTransitionTrace NtNAddr))) + let abstractTransitionEvents :: Trace () (WithName NtNAddr (WithTime (AbstractTransitionTrace CM.ConnStateId))) abstractTransitionEvents = selectDiffusionConnectionManagerTransitionEvents' events @@ -3130,7 +3130,7 @@ prop_unit_4258 = (Script (UseBootstrapPeers [RelayAccessDomain "bootstrap" 00000] :| [])) (TestAddress (IPAddr (read "0.0.0.4") 9)) PeerSharingDisabled - [(1,1,Map.fromList [(RelayAccessAddress "0.0.0.8" 65531,(DoNotAdvertisePeer, IsNotTrustable))])] + [(1,1,Map.fromList [(RelayAccessAddress "0.0.0.8" 65531,LocalRootConfig DoNotAdvertisePeer IsNotTrustable InitiatorAndResponderDiffusionMode)])] (Script (LedgerPools [] :| [])) ConsensusModePeerTargets { deadlineTargets = nullPeerSelectionTargets { @@ -3165,7 +3165,7 @@ prop_unit_4258 = (Script (UseBootstrapPeers [RelayAccessDomain "bootstrap" 00000] :| [])) (TestAddress (IPAddr (read "0.0.0.8") 65531)) PeerSharingDisabled - [(1,1,Map.fromList [(RelayAccessAddress "0.0.0.4" 9,(DoNotAdvertisePeer, IsNotTrustable))])] + [(1,1,Map.fromList [(RelayAccessAddress "0.0.0.4" 9,LocalRootConfig DoNotAdvertisePeer IsNotTrustable InitiatorAndResponderDiffusionMode)])] (Script (LedgerPools [] :| [])) ConsensusModePeerTargets { deadlineTargets = nullPeerSelectionTargets { @@ -3196,7 +3196,7 @@ prop_unit_4258 = False (Script (FetchModeDeadline :| [])) , [ JoinNetwork 3.384615384615, - Reconfigure 3.583333333333 [(1,1,Map.fromList [(RelayAccessAddress "0.0.0.4" 9,(DoNotAdvertisePeer, IsNotTrustable))])], + Reconfigure 3.583333333333 [(1,1,Map.fromList [(RelayAccessAddress "0.0.0.4" 9,LocalRootConfig DoNotAdvertisePeer IsNotTrustable InitiatorAndResponderDiffusionMode)])], Kill 15.55555555555, JoinNetwork 30.53333333333, Kill 71.11111111111 @@ -3238,8 +3238,8 @@ prop_unit_reconnect = (Script (DontUseBootstrapPeers :| [])) (TestAddress (IPAddr (read "0.0.0.0") 0)) PeerSharingDisabled - [ (2,2,Map.fromList [ (RelayAccessAddress "0.0.0.1" 0,(DoNotAdvertisePeer, IsNotTrustable)) - , (RelayAccessAddress "0.0.0.2" 0,(DoNotAdvertisePeer, IsNotTrustable)) + [ (2,2,Map.fromList [ (RelayAccessAddress "0.0.0.1" 0,LocalRootConfig DoNotAdvertisePeer IsNotTrustable InitiatorAndResponderDiffusionMode) + , (RelayAccessAddress "0.0.0.2" 0,LocalRootConfig DoNotAdvertisePeer IsNotTrustable InitiatorAndResponderDiffusionMode) ]) ] (Script (LedgerPools [] :| [])) @@ -3270,7 +3270,7 @@ prop_unit_reconnect = (Script (DontUseBootstrapPeers :| [])) (TestAddress (IPAddr (read "0.0.0.1") 0)) PeerSharingDisabled - [(1,1,Map.fromList [(RelayAccessAddress "0.0.0.0" 0,(DoNotAdvertisePeer, IsNotTrustable))])] + [(1,1,Map.fromList [(RelayAccessAddress "0.0.0.0" 0,LocalRootConfig DoNotAdvertisePeer IsNotTrustable InitiatorAndResponderDiffusionMode)])] (Script (LedgerPools [] :| [])) ConsensusModePeerTargets { deadlineTargets = PeerSelectionTargets { @@ -3298,10 +3298,10 @@ prop_unit_reconnect = diffScript iosimTracer - events :: [Events DiffusionTestTrace] + events :: [Events (WithName NtNAddr DiffusionTestTrace)] events = Trace.toList . fmap ( Signal.eventsFromList - . fmap (\(WithName _ (WithTime t b)) -> (t, b)) + . fmap (\(WithName addr (WithTime t b)) -> (t, WithName addr b)) ) . splitWithNameTrace . fmap (\(WithTime t (WithName name b)) -> WithName name (WithTime t b)) @@ -3316,26 +3316,27 @@ prop_unit_reconnect = <$> events where - verify_consistency :: Events DiffusionTestTrace -> Property + verify_consistency :: Events (WithName NtNAddr DiffusionTestTrace) -> Property verify_consistency events = let govEstablishedPeersSig :: Signal (Set NtNAddr) govEstablishedPeersSig = selectDiffusionPeerSelectionState' (EstablishedPeers.toSet . Governor.establishedPeers) - events + (wnEvent <$> events) - govConnectionManagerTransitionsSig :: [E (AbstractTransitionTrace NtNAddr)] + govConnectionManagerTransitionsSig :: [E (WithName NtNAddr (AbstractTransitionTrace CM.ConnStateId))] govConnectionManagerTransitionsSig = - Signal.eventsToListWithId + Signal.eventsToListWithId $ Signal.selectEvents (\case - DiffusionConnectionManagerTransitionTrace tr -> Just tr - _ -> Nothing + WithName addr (DiffusionConnectionManagerTransitionTrace tr) + -> Just (WithName addr tr) + _ -> Nothing ) events in conjoin - $ map (\(E ts a) -> case a of - TransitionTrace addr (Transition _ TerminatedSt) -> + $ map (\(E ts (WithName addr a)) -> case a of + TransitionTrace _ (Transition _ TerminatedSt) -> eventually ts (Set.notMember addr) govEstablishedPeersSig _ -> True -- TODO: Do the opposite ) @@ -3705,7 +3706,7 @@ unit_peer_sharing = (mainnetSimArgs 3) (singletonScript (mempty, ShortDelay)) [ ( (defaultNodeArgs GenesisMode) { naAddr = ip_0, - naLocalRootPeers = [(1, 1, Map.fromList [(ra_1, (DoNotAdvertisePeer, IsNotTrustable))])], + naLocalRootPeers = [(1, 1, Map.fromList [(ra_1, LocalRootConfig DoNotAdvertisePeer IsNotTrustable InitiatorAndResponderDiffusionMode)])], naPeerTargets = targets 1 } , [JoinNetwork 0] @@ -3717,7 +3718,7 @@ unit_peer_sharing = , [JoinNetwork 0] ) , ( (defaultNodeArgs GenesisMode) { naAddr = ip_2, - naLocalRootPeers = [(1, 1, Map.fromList [(ra_1, (DoNotAdvertisePeer, IsNotTrustable))])], + naLocalRootPeers = [(1, 1, Map.fromList [(ra_1, LocalRootConfig DoNotAdvertisePeer IsNotTrustable InitiatorAndResponderDiffusionMode)])], naPeerTargets = targets 2 } , [JoinNetwork 0] @@ -4043,7 +4044,7 @@ prop_diffusion_timeouts_enforced ioSimTrace traceNumber = where verify_timeouts :: Trace () (Time, DiffusionTestTrace) -> Property verify_timeouts events = - let transitionSignal :: Trace (SimResult ()) [(Time, AbstractTransitionTrace NtNAddr)] + let transitionSignal :: Trace (SimResult ()) [(Time, AbstractTransitionTrace CM.ConnStateId)] transitionSignal = Trace.fromList (MainReturn (Time 0) (Labelled (ThreadId []) (Just "main")) () []) . Trace.toList . groupConns snd abstractStateIsFinalTransition @@ -4054,6 +4055,116 @@ prop_diffusion_timeouts_enforced ioSimTrace traceNumber = $ verifyAllTimeouts True transitionSignal +newtype ArbDiffusionMode = ArbDiffusionMode { getDiffusionMode :: DiffusionMode } + deriving (Eq, Show) + +-- | Verify that local root can negotiate the right diffusion mode. +-- +unit_local_root_diffusion_mode :: DiffusionMode + -> Property +unit_local_root_diffusion_mode diffusionMode = + -- this is a unit test + withMaxSuccess 1 $ + let sim = diffusionSimulation (toBearerInfo absNoAttenuation) script iosimTracer + + -- list of negotiated version data + events :: [NtNVersionData] + events = + mapMaybe (\case + DiffusionConnectionManagerTrace (CM.TrConnectionHandler ConnectionId { remoteAddress } (TrHandshakeSuccess _ versionData)) + | remoteAddress == addr' + -> Just versionData + _ -> Nothing + ) + . fmap wnEvent + . filter (\WithName { wnName } -> wnName == addr) + . fmap wtEvent + . Trace.toList + . withTimeNameTraceEvents + @DiffusionTestTrace + @NtNAddr + . Trace.take 125000 + $ runSimTrace sim + in property $ foldMap (\versionData -> All $ ntnDiffusionMode versionData === diffusionMode) events + where + addr, addr' :: NtNAddr + addr = TestAddress (IPAddr (read "127.0.0.2") 1000) + addr' = TestAddress (IPAddr (read "127.0.0.1") 1000) + + script = + 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 diffusionMode) + ]) + ], + 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] + ) + ] + -- Utils -- @@ -4171,7 +4282,7 @@ selectTimedDiffusionPeerSelectionActionsEvents = selectDiffusionConnectionManagerTransitionEvents :: Trace () DiffusionTestTrace - -> Trace () (AbstractTransitionTrace NtNAddr) + -> Trace () (AbstractTransitionTrace CM.ConnStateId) selectDiffusionConnectionManagerTransitionEvents = Trace.fromList () . mapMaybe @@ -4181,7 +4292,7 @@ selectDiffusionConnectionManagerTransitionEvents = selectDiffusionConnectionManagerTransitionEvents' :: Trace () (WithName NtNAddr (WithTime DiffusionTestTrace)) - -> Trace () (WithName NtNAddr (WithTime (AbstractTransitionTrace NtNAddr))) + -> Trace () (WithName NtNAddr (WithTime (AbstractTransitionTrace CM.ConnStateId))) selectDiffusionConnectionManagerTransitionEvents' = Trace.fromList () . mapMaybe @@ -4193,7 +4304,7 @@ selectDiffusionConnectionManagerTransitionEvents' = selectDiffusionConnectionManagerTransitionEventsTime :: Trace () (Time, DiffusionTestTrace) - -> Trace () (Time, AbstractTransitionTrace NtNAddr) + -> Trace () (Time, AbstractTransitionTrace CM.ConnStateId) selectDiffusionConnectionManagerTransitionEventsTime = Trace.fromList () . mapMaybe 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 6fe51a1b288..f97eee2e9e6 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 @@ -73,6 +73,7 @@ import Network.TypedProtocol.PingPong.Type qualified as PingPong import Ouroboros.Network.ConnectionHandler (ConnectionHandlerTrace) import Ouroboros.Network.ConnectionManager.Core qualified as CM +import Ouroboros.Network.ConnectionManager.State qualified as CM import Ouroboros.Network.ConnectionManager.Types (AbstractTransitionTrace) import Ouroboros.Network.ConsensusMode import Ouroboros.Network.Diffusion.P2P qualified as Diff.P2P @@ -129,7 +130,6 @@ import Ouroboros.Network.PeerSelection.LocalRootPeers (OutboundConnectionsState (..)) import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..)) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing) -import Ouroboros.Network.PeerSelection.PeerTrustable (PeerTrustable) import Ouroboros.Network.PeerSelection.RelayAccessPoint (DomainAccessPoint (..), PortNumber, RelayAccessPoint (..)) import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions (DNSLookupType) @@ -138,7 +138,7 @@ import Ouroboros.Network.PeerSelection.RootPeersDNS.LocalRootPeers import Ouroboros.Network.PeerSelection.RootPeersDNS.PublicRootPeers (TracePublicRootPeers) import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency (..), - WarmValency (..)) + LocalRootConfig, WarmValency (..)) import Ouroboros.Network.Protocol.PeerSharing.Codec (byteLimitsPeerSharing, timeLimitsPeerSharing) import Test.Ouroboros.Network.LedgerPeers (LedgerPools (..), genLedgerPoolsFrom) @@ -206,8 +206,7 @@ data NodeArgs = -- ^ 'Arguments' 'aOwnPeerSharing' value , naLocalRootPeers :: [( HotValency , WarmValency - , Map RelayAccessPoint ( PeerAdvertise - , PeerTrustable) + , Map RelayAccessPoint LocalRootConfig )] , naLedgerPeers :: Script LedgerPools -- ^ 'Arguments' 'LocalRootPeers' values @@ -251,8 +250,7 @@ data Command = JoinNetwork DiffTime | Reconfigure DiffTime [( HotValency , WarmValency - , Map RelayAccessPoint ( PeerAdvertise - , PeerTrustable) + , Map RelayAccessPoint LocalRootConfig )] deriving Eq @@ -268,7 +266,7 @@ instance Show Command where genCommands :: [( HotValency , WarmValency - , Map RelayAccessPoint (PeerAdvertise, PeerTrustable) + , Map RelayAccessPoint LocalRootConfig )] -> Gen [Command] genCommands localRoots = sized $ \size -> do @@ -282,7 +280,7 @@ genCommands localRoots = sized $ \size -> do where subLocalRootPeers :: Gen [( HotValency , WarmValency - , Map RelayAccessPoint (PeerAdvertise, PeerTrustable) + , Map RelayAccessPoint LocalRootConfig )] subLocalRootPeers = do subLRP <- sublistOf localRoots @@ -362,7 +360,7 @@ instance Arbitrary SmallPeerSelectionTargets where -- Simulation genNodeArgs :: [RelayAccessInfo] -> Int - -> [(HotValency, WarmValency, Map RelayAccessPoint (PeerAdvertise, PeerTrustable))] + -> [(HotValency, WarmValency, Map RelayAccessPoint LocalRootConfig)] -> RelayAccessInfo -> Gen NodeArgs genNodeArgs relays minConnected localRootPeers relay = flip suchThat hasUpstream $ do @@ -681,7 +679,7 @@ genDiffusionScript :: ([RelayAccessInfo] -> RelayAccessInfo -> Gen [( HotValency , WarmValency - , Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]) + , Map RelayAccessPoint LocalRootConfig)]) -> RelayAccessInfosWithDNS -> Gen (SimArgs, DomainMapScript, [(NodeArgs, [Command])]) genDiffusionScript genLocalRootPeers @@ -724,7 +722,7 @@ genNonHotDiffusionScript = genDiffusionScript genLocalRootPeers -> RelayAccessInfo -> Gen [( HotValency , WarmValency - , Map RelayAccessPoint (PeerAdvertise, PeerTrustable) + , Map RelayAccessPoint LocalRootConfig )] genLocalRootPeers relays _relay = flip suchThat hasUpstream $ do nrGroups <- chooseInt (1, 3) @@ -757,7 +755,7 @@ genNonHotDiffusionScript = genDiffusionScript genLocalRootPeers hasUpstream :: [( HotValency , WarmValency - , Map RelayAccessPoint (PeerAdvertise, PeerTrustable) + , Map RelayAccessPoint LocalRootConfig )] -> Bool hasUpstream localRootPeers = @@ -784,7 +782,7 @@ genHotDiffusionScript = genDiffusionScript genLocalRootPeers -> RelayAccessInfo -> Gen [( HotValency , WarmValency - , Map RelayAccessPoint (PeerAdvertise, PeerTrustable) + , Map RelayAccessPoint LocalRootConfig )] genLocalRootPeers relays _relay = flip suchThat hasUpstream $ do let size = length relays @@ -804,7 +802,7 @@ genHotDiffusionScript = genDiffusionScript genLocalRootPeers hasUpstream :: [( HotValency , WarmValency - , Map RelayAccessPoint (PeerAdvertise, PeerTrustable) + , Map RelayAccessPoint LocalRootConfig )] -> Bool hasUpstream localRootPeers = @@ -924,7 +922,7 @@ data DiffusionTestTrace = (ConnectionHandlerTrace NtNVersion NtNVersionData)) | DiffusionDiffusionSimulationTrace DiffusionSimulationTrace | DiffusionConnectionManagerTransitionTrace - (AbstractTransitionTrace NtNAddr) + (AbstractTransitionTrace CM.ConnStateId) | DiffusionInboundGovernorTransitionTrace (IG.RemoteTransitionTrace NtNAddr) | DiffusionInboundGovernorTrace (IG.Trace NtNAddr) @@ -994,7 +992,7 @@ diffusionSimulation :: Maybe ( Async m Void , StrictTVar m [( HotValency , WarmValency - , Map RelayAccessPoint (PeerAdvertise, PeerTrustable) + , Map RelayAccessPoint LocalRootConfig )]) -- ^ If the node is running and corresponding local root configuration -- TVar. @@ -1052,7 +1050,7 @@ diffusionSimulation -> Snocket m (FD m NtCAddr) NtCAddr -> StrictTVar m [( HotValency , WarmValency - , Map RelayAccessPoint (PeerAdvertise, PeerTrustable) + , Map RelayAccessPoint LocalRootConfig )] -> StrictTVar m (Map Domain [(IP, TTL)]) -> m Void @@ -1292,11 +1290,7 @@ diffusionSimulation . tracerWithName ntnAddr . tracerWithTime $ nodeTracer - , Diff.P2P.dtConnectionManagerTransitionTracer = contramap - DiffusionConnectionManagerTransitionTrace - . tracerWithName ntnAddr - . tracerWithTime - $ nodeTracer + , Diff.P2P.dtConnectionManagerTransitionTracer = nullTracer , 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 feaa243cd4f..5f6158c07de 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 @@ -100,12 +100,11 @@ import Ouroboros.Network.PeerSelection.LedgerPeers.Type import Ouroboros.Network.PeerSelection.LocalRootPeers (OutboundConnectionsState) import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..)) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) -import Ouroboros.Network.PeerSelection.PeerTrustable (PeerTrustable) import Ouroboros.Network.PeerSelection.RelayAccessPoint (DomainAccessPoint, RelayAccessPoint) import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions (DNSLookupType) import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency, - WarmValency) + LocalRootConfig, WarmValency) import Test.Ouroboros.Network.PeerSelection.RootPeersDNS (DNSLookupDelay, DNSTimeout, mockDNSActions) import Test.Ouroboros.Network.Testnet.Node.ChainDB (addBlock, getBlockPointSet) @@ -145,8 +144,7 @@ data Arguments m = Arguments , aPeerTargets :: ConsensusModePeerTargets , aReadLocalRootPeers :: STM m [( HotValency , WarmValency - , Map RelayAccessPoint ( PeerAdvertise - , PeerTrustable))] + , Map RelayAccessPoint LocalRootConfig)] , aReadPublicRootPeers :: STM m (Map RelayAccessPoint PeerAdvertise) , aReadUseBootstrapPeers :: Script UseBootstrapPeers , aConsensusMode :: ConsensusMode @@ -246,6 +244,8 @@ run blockGeneratorArgs limits ni na tracersExtra tracerBlockFetch = (iDomainMap ni) dnsTimeoutScriptVar dnsLookupDelayScriptVar) + , Diff.P2P.diUpdateVersionData = \versionData diffusionMode -> + versionData { ntnDiffusionMode = diffusionMode } } 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 0519effd62b..99e1d2e31bc 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs @@ -81,6 +81,7 @@ import Ouroboros.Network.Socket (configureSocket, configureSystemdSocket) import Ouroboros.Network.ConnectionHandler import Ouroboros.Network.ConnectionManager.Core qualified as CM +import Ouroboros.Network.ConnectionManager.State qualified as CM import Ouroboros.Network.ConnectionManager.InformationChannel (newInformationChannel) import Ouroboros.Network.ConnectionManager.Types @@ -188,7 +189,7 @@ data TracersExtra ntnAddr ntnVersion ntnVersionData ntnVersionData)) , dtConnectionManagerTransitionTracer - :: Tracer m (AbstractTransitionTrace ntnAddr) + :: Tracer m (AbstractTransitionTrace CM.ConnStateId) , dtServerTracer :: Tracer m (Server.Trace ntnAddr) @@ -390,7 +391,8 @@ type NodeToClientConnectionHandler ntcAddr (NodeToClientHandle ntcAddr ntcVersionData m) (NodeToClientHandleError ntcVersion) - (ntcVersion, ntcVersionData) + ntcVersion + ntcVersionData m type NodeToClientConnectionManagerArguments @@ -541,7 +543,11 @@ data Interfaces ntnFd ntnAddr ntnVersion ntnVersionData -- | diffusion dns actions -- diDnsActions - :: DNSLookupType -> DNSActions resolver resolverError m + :: DNSLookupType -> DNSActions resolver resolverError m, + + -- | Update `ntnVersionData` for initiator-only local roots. + diUpdateVersionData + :: ntnVersionData -> DiffusionMode -> ntnVersionData } runM @@ -618,6 +624,7 @@ runM Interfaces , diRng , diInstallSigUSR1Handler , diDnsActions + , diUpdateVersionData } Tracers { dtMuxTracer @@ -813,7 +820,8 @@ runM Interfaces CM.connectionDataFlow = ntcDataFlow, CM.prunePolicy = Diffusion.Policies.prunePolicy, CM.stdGen = cmLocalStdGen, - CM.connectionsLimits = localConnectionLimits + CM.connectionsLimits = localConnectionLimits, + CM.updateVersionData = \a _ -> a } CM.with @@ -942,7 +950,8 @@ runM Interfaces CM.stdGen, CM.connectionsLimits = daAcceptedConnectionsLimit, CM.timeWaitTimeout = daTimeWaitTimeout, - CM.outboundIdleTimeout = daProtocolIdleTimeout + CM.outboundIdleTimeout = daProtocolIdleTimeout, + CM.updateVersionData = diUpdateVersionData } let peerSelectionPolicy = Diffusion.Policies.simplePeerSelectionPolicy @@ -1319,7 +1328,8 @@ run tracers tracersExtra args argsExtra apps appsExtra = do diRng, diInstallSigUSR1Handler, - diDnsActions = ioDNSActions + diDnsActions = ioDNSActions, + diUpdateVersionData = \versionData diffusionMode -> versionData { diffusionMode } } tracers tracersExtra args argsExtra apps appsExtra diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/EstablishedPeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/EstablishedPeers.hs index 7d72d67697f..1c07b934c6a 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/EstablishedPeers.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/EstablishedPeers.hs @@ -21,6 +21,7 @@ import Control.Monad.Class.MonadSTM import Control.Monad.Class.MonadTime.SI import System.Random (randomR) +import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..)) import Ouroboros.Network.PeerSelection.Bootstrap (requiresBootstrapPeers) import Ouroboros.Network.PeerSelection.Governor.Types import Ouroboros.Network.PeerSelection.LedgerPeers.Type (IsBigLedgerPeer (..)) @@ -129,8 +130,11 @@ belowTargetLocal actions inProgressPromoteCold = inProgressPromoteCold <> selectedToPromote }, - decisionJobs = [ jobPromoteColdPeer actions policy peer IsNotBigLedgerPeer - | peer <- Set.toList selectedToPromote ] + decisionJobs = [ jobPromoteColdPeer actions policy peer IsNotBigLedgerPeer diffusionMode + | peer <- Set.toList selectedToPromote + , let diffusionMode = LocalRootPeers.diffusionMode + $ LocalRootPeers.toMap localRootPeers Map.! peer + ] } -- If we could promote except that there are no peers currently available @@ -217,7 +221,7 @@ belowTargetOther actions inProgressPromoteCold = inProgressPromoteCold <> selectedToPromote }, - decisionJobs = [ jobPromoteColdPeer actions policy peer IsNotBigLedgerPeer + decisionJobs = [ jobPromoteColdPeer actions policy peer IsNotBigLedgerPeer InitiatorAndResponderDiffusionMode | peer <- Set.toList selectedToPromote ] } @@ -305,7 +309,7 @@ belowTargetBigLedgerPeers actions inProgressPromoteCold = inProgressPromoteCold <> selectedToPromote }, - decisionJobs = [ jobPromoteColdPeer actions policy peer IsBigLedgerPeer + decisionJobs = [ jobPromoteColdPeer actions policy peer IsBigLedgerPeer InitiatorAndResponderDiffusionMode | peer <- Set.toList selectedToPromote ] } @@ -343,13 +347,14 @@ jobPromoteColdPeer :: forall peeraddr peerconn m. -> PeerSelectionPolicy peeraddr m -> peeraddr -> IsBigLedgerPeer + -> DiffusionMode -> Job () m (Completion m peeraddr peerconn) jobPromoteColdPeer PeerSelectionActions { peerStateActions = PeerStateActions {establishPeerConnection}, peerConnToPeerSharing } PeerSelectionPolicy { policyPeerShareActivationDelay } - peeraddr isBigLedgerPeer = + peeraddr isBigLedgerPeer diffusionMode = Job job handler () "promoteColdPeer" where handler :: SomeException -> m (Completion m peeraddr peerconn) @@ -408,7 +413,7 @@ jobPromoteColdPeer PeerSelectionActions { job = do --TODO: decide if we should do timeouts here or if we should make that -- the responsibility of establishPeerConnection - peerconn <- establishPeerConnection isBigLedgerPeer peeraddr + peerconn <- establishPeerConnection isBigLedgerPeer diffusionMode peeraddr let !peerSharing = peerConnToPeerSharing peerconn return $ Completion $ \st@PeerSelectionState { diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/KnownPeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/KnownPeers.hs index 2f8b3846ab9..564b9b79971 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/KnownPeers.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/KnownPeers.hs @@ -117,6 +117,8 @@ belowTarget actions@PeerSelectionActions { peerSharing } selectedMap availablePeers ], + -- NOTE: We set `DoAdvertisePeer` for all peers coming from the + -- inbound side. `AdvertisePeer` is only a local configuration option. decisionState = st { knownPeers = KnownPeers.setSuccessfulConnectionFlag selected $ KnownPeers.insert (Map.map (\ps -> (Just ps, Just DoAdvertisePeer)) selectedMap) diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Monitor.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Monitor.hs index 2d28adf3adc..f213f9487c8 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Monitor.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Monitor.hs @@ -51,6 +51,8 @@ import Ouroboros.Network.PeerSelection.PeerTrustable (PeerTrustable (..)) import Ouroboros.Network.PeerSelection.PublicRootPeers qualified as PublicRootPeers import Ouroboros.Network.PeerSelection.State.EstablishedPeers qualified as EstablishedPeers import Ouroboros.Network.PeerSelection.State.KnownPeers qualified as KnownPeers +import Ouroboros.Network.PeerSelection.State.LocalRootPeers + (LocalRootConfig (..)) import Ouroboros.Network.PeerSelection.State.LocalRootPeers qualified as LocalRootPeers import Ouroboros.Network.PeerSelection.Types @@ -411,12 +413,16 @@ localRoots actions@PeerSelectionActions{ readLocalRootPeers --TODO: trace when the clamping kicks in, and warn operators - let added = LocalRootPeers.toMap localRootPeers' Map.\\ + let added, removed :: Map peeraddr LocalRootConfig + added = LocalRootPeers.toMap localRootPeers' Map.\\ LocalRootPeers.toMap localRootPeers removed = LocalRootPeers.toMap localRootPeers Map.\\ LocalRootPeers.toMap localRootPeers' -- LocalRoots are not ledger! - addedInfoMap = Map.map (\(pa, _) -> (Nothing, Just pa)) added + addedInfoMap = Map.map + (\LocalRootConfig { peerAdvertise } -> + (Nothing, Just peerAdvertise)) + added removedSet = Map.keysSet removed knownPeers' = KnownPeers.insert addedInfoMap knownPeers -- We do not immediately remove old ones from the @@ -728,8 +734,9 @@ waitForSystemToQuiesce st@PeerSelectionState{ , not hasOnlyBootstrapPeers -- Are the local root peers all trustable? , all (\case - (_, IsTrustable) -> True - _ -> False + LocalRootConfig { peerTrustable = IsTrustable } + -> True + _ -> False ) (LocalRootPeers.toMap localRootPeers) -- Are the known peers all trustable or all in progress to be demoted? diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs index d03d4c710db..15a03b3a846 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs @@ -144,6 +144,7 @@ import System.Random (StdGen) import Control.Concurrent.Class.MonadSTM.Strict import Ouroboros.Network.ConsensusMode import Ouroboros.Network.ExitPolicy +import Ouroboros.Network.NodeToNode.Version (DiffusionMode) import Ouroboros.Network.PeerSelection.Bootstrap (UseBootstrapPeers (..)) import Ouroboros.Network.PeerSelection.LedgerPeers.Type import Ouroboros.Network.PeerSelection.LocalRootPeers (OutboundConnectionsState) @@ -446,6 +447,7 @@ data PeerStateActions peeraddr peerconn m = PeerStateActions { -- mini-protocol callbacks. -- establishPeerConnection :: IsBigLedgerPeer + -> DiffusionMode -> peeraddr -> m peerconn, -- | Activate a connection: warm to hot promotion. diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerSelectionActions.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerSelectionActions.hs index dce49594e8a..7aa5b6e4131 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerSelectionActions.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerSelectionActions.hs @@ -41,7 +41,6 @@ import Ouroboros.Network.PeerSelection.LedgerPeers hiding (getLedgerPeers) import Ouroboros.Network.PeerSelection.LocalRootPeers (OutboundConnectionsState) import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..)) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing) -import Ouroboros.Network.PeerSelection.PeerTrustable (PeerTrustable) import Ouroboros.Network.PeerSelection.PublicRootPeers (PublicRootPeers) import Ouroboros.Network.PeerSelection.PublicRootPeers qualified as PublicRootPeers import Ouroboros.Network.PeerSelection.RootPeersDNS @@ -61,7 +60,7 @@ data PeerSelectionActionsArgs peeraddr peerconn exception m = PeerSelectionActio -- ^ peer selection governor know, established and active targets getLedgerStateCtx :: LedgerPeersConsensusInterface m, -- ^ Is consensus close to current slot? - psReadLocalRootPeers :: STM m [(HotValency, WarmValency, Map RelayAccessPoint (PeerAdvertise, PeerTrustable))], + psReadLocalRootPeers :: STM m [(HotValency, WarmValency, Map RelayAccessPoint LocalRootConfig)], psReadPublicRootPeers :: STM m (Map RelayAccessPoint PeerAdvertise), psReadUseBootstrapPeers :: STM m UseBootstrapPeers, psPeerSharing :: PeerSharing, diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerStateActions.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerStateActions.hs index fec2e79be89..b8584ed70ef 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerStateActions.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerStateActions.hs @@ -55,6 +55,7 @@ import Ouroboros.Network.Context import Ouroboros.Network.ControlMessage (ControlMessage (..)) import Ouroboros.Network.ExitPolicy import Ouroboros.Network.Mux +import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..)) import Ouroboros.Network.PeerSelection.Governor (PeerStateActions (..)) import Ouroboros.Network.Protocol.Handshake (HandshakeException) import Ouroboros.Network.RethrowPolicy @@ -724,16 +725,20 @@ withPeerStateActions PeerStateActionsArguments { establishPeerConnection :: JobPool () m (Maybe SomeException) -> IsBigLedgerPeer + -> DiffusionMode -> peerAddr -> m (PeerConnectionHandle muxMode responderCtx peerAddr versionData ByteString m a b) - establishPeerConnection jobPool isBigLedgerPeer remotePeerAddr = + establishPeerConnection jobPool isBigLedgerPeer diffusionMode remotePeerAddr = -- Protect consistency of the peer state with 'bracketOnError' if -- opening a connection fails. bracketOnError (newTVarIO PeerCold) (\peerStateVar -> atomically $ writeTVar peerStateVar PeerCold) $ \peerStateVar -> do - res <- try $ acquireOutboundConnection spsConnectionManager remotePeerAddr + res <- try $ acquireOutboundConnection + spsConnectionManager + diffusionMode + remotePeerAddr case res of Left e -> do traceWith spsTracer (AcquireConnectionError e) diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/LocalRootPeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/LocalRootPeers.hs index cc6c155125c..053828ce561 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/LocalRootPeers.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/LocalRootPeers.hs @@ -30,14 +30,12 @@ import Network.DNS qualified as DNS import Network.Socket qualified as Socket import Data.Bifunctor (second) -import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise) -import Ouroboros.Network.PeerSelection.PeerTrustable (PeerTrustable) import Ouroboros.Network.PeerSelection.RelayAccessPoint import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSSemaphore (DNSSemaphore, newDNSLocalRootSemaphore, withDNSSemaphore) import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency, - WarmValency) + LocalRootConfig, WarmValency) import Ouroboros.Network.PeerSelection.State.LocalRootPeers qualified as LocalRootPeers data TraceLocalRootPeers peerAddr exception = @@ -75,11 +73,11 @@ localRootPeersProvider -> DNSActions resolver exception m -> STM m [( HotValency , WarmValency - , Map RelayAccessPoint (PeerAdvertise, PeerTrustable))] + , Map RelayAccessPoint LocalRootConfig)] -- ^ input -> StrictTVar m [( HotValency , WarmValency - , Map peerAddr (PeerAdvertise, PeerTrustable))] + , Map peerAddr LocalRootConfig)] -- ^ output 'TVar' -> m Void localRootPeersProvider tracer @@ -101,7 +99,7 @@ localRootPeersProvider tracer -- if either these threads fail or detects the local configuration changed. -- loop :: DNSSemaphore m - -> [(HotValency, WarmValency, Map RelayAccessPoint (PeerAdvertise, PeerTrustable))] + -> [(HotValency, WarmValency, Map RelayAccessPoint LocalRootConfig)] -> m Void loop dnsSemaphore domainsGroups = do traceWith tracer (TraceLocalRootDomains domainsGroups) @@ -260,10 +258,10 @@ localRootPeersProvider tracer getLocalRootPeersGroups :: Map DomainAccessPoint [peerAddr] -> [( HotValency , WarmValency - , Map RelayAccessPoint (PeerAdvertise, PeerTrustable))] + , Map RelayAccessPoint LocalRootConfig)] -> [( HotValency , WarmValency - , Map peerAddr (PeerAdvertise, PeerTrustable))] + , Map peerAddr LocalRootConfig)] getLocalRootPeersGroups dnsMap = -- The idea is to traverse the static configuration. Enter each local -- group and check if any of the RelayAccessPoint has a Domain Name. diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/State/KnownPeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/State/KnownPeers.hs index 5a869c9a7a8..537a439f3ca 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/State/KnownPeers.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/State/KnownPeers.hs @@ -43,15 +43,16 @@ module Ouroboros.Network.PeerSelection.State.KnownPeers import Data.List qualified as List import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map +import Data.Maybe.Strict import Data.OrdPSQ (OrdPSQ) import Data.OrdPSQ qualified as PSQ import Data.Set (Set) import Data.Set qualified as Set +import Control.Applicative ((<|>)) import Control.Exception (assert) import Control.Monad.Class.MonadTime.SI -import Data.Maybe (fromMaybe) import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..)) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) @@ -114,7 +115,7 @@ data KnownPeerInfo = KnownPeerInfo { -- -- It is used by the Peer Sharing logic to decide if we should share/ask -- about/to this peer's address to others. - knownPeerSharing :: !PeerSharing, + knownPeerSharing :: !(StrictMaybe PeerSharing), -- | Indicates current local Peer Willingness information. -- @@ -123,7 +124,7 @@ data KnownPeerInfo = KnownPeerInfo { -- -- It is used by the Peer Sharing logic to decide if we should share -- about this peer's address to others. - knownPeerAdvertise :: !PeerAdvertise, + knownPeerAdvertise :: !(StrictMaybe PeerAdvertise), -- | Indicates if the node managed to connect to the peer at some point -- in time. @@ -165,14 +166,17 @@ alterKnownPeerInfo (peerSharing, peerAdvertise) peerLookupResult = KnownPeerInfo { knownPeerFailCount = 0 , knownPeerTepid = False - , knownPeerSharing = fromMaybe PeerSharingDisabled peerSharing - , knownPeerAdvertise = fromMaybe DoNotAdvertisePeer peerAdvertise + , knownPeerSharing = maybeToStrictMaybe peerSharing + , knownPeerAdvertise = maybeToStrictMaybe peerAdvertise , knownSuccessfulConnection = False } Just kpi -> Just $ + -- pick first known value kpi { - knownPeerSharing = fromMaybe (knownPeerSharing kpi) peerSharing - , knownPeerAdvertise = fromMaybe (knownPeerAdvertise kpi) peerAdvertise + knownPeerSharing = maybeToStrictMaybe peerSharing + <|> knownPeerSharing kpi + , knownPeerAdvertise = maybeToStrictMaybe peerAdvertise + <|> knownPeerAdvertise kpi } ------------------------------- @@ -437,7 +441,7 @@ canPeerShareRequest :: Ord peeraddr => peeraddr -> KnownPeers peeraddr -> Bool canPeerShareRequest pa KnownPeers { allPeers } = case Map.lookup pa allPeers of Just KnownPeerInfo - { knownPeerSharing = PeerSharingEnabled + { knownPeerSharing = SJust PeerSharingEnabled } -> True _ -> False @@ -448,7 +452,7 @@ canSharePeers :: Ord peeraddr => peeraddr -> KnownPeers peeraddr -> Bool canSharePeers pa KnownPeers { allPeers } = case Map.lookup pa allPeers of Just KnownPeerInfo - { knownPeerAdvertise = DoAdvertisePeer + { knownPeerAdvertise = SJust DoAdvertisePeer , knownSuccessfulConnection = True , knownPeerFailCount = 0 } -> True @@ -473,7 +477,7 @@ getPeerSharingResponsePeers knownPeers = Map.keysSet $ Map.filter (\case KnownPeerInfo - { knownPeerAdvertise = DoAdvertisePeer + { knownPeerAdvertise = SJust DoAdvertisePeer , knownSuccessfulConnection = True , knownPeerFailCount = 0 } -> True diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/State/LocalRootPeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/State/LocalRootPeers.hs index d8ea701c984..6dc3a699155 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/State/LocalRootPeers.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/State/LocalRootPeers.hs @@ -1,12 +1,11 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE NamedFieldPuns #-} module Ouroboros.Network.PeerSelection.State.LocalRootPeers ( -- * Types LocalRootPeers (..) + , LocalRootConfig (..) , HotValency (..) , WarmValency (..) , Config @@ -38,6 +37,7 @@ import Data.Map.Strict qualified as Map import Data.Set (Set) import Data.Set qualified as Set +import Ouroboros.Network.NodeToNode.Version (DiffusionMode) import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise) import Ouroboros.Network.PeerSelection.PeerTrustable (PeerTrustable (..)) @@ -46,13 +46,20 @@ import Ouroboros.Network.PeerSelection.PeerTrustable (PeerTrustable (..)) -- Local root peer set representation -- +data LocalRootConfig = LocalRootConfig { + peerAdvertise :: !PeerAdvertise, + peerTrustable :: !PeerTrustable, + diffusionMode :: !DiffusionMode + } + deriving (Show, Eq) + data LocalRootPeers peeraddr = LocalRootPeers -- We use two partial & overlapping representations: -- The collection of all the peers, with the associated PeerAdvertise -- and PeerTrustable values - (Map peeraddr (PeerAdvertise, PeerTrustable)) + (Map peeraddr LocalRootConfig) -- The groups, but without the associated PeerAdvertise and -- PeerTrustable values @@ -76,7 +83,7 @@ newtype WarmValency = WarmValency { getWarmValency :: Int } -- | Data available from topology file. -- type Config peeraddr = - [(HotValency, WarmValency, Map peeraddr ( PeerAdvertise, PeerTrustable))] + [(HotValency, WarmValency, Map peeraddr LocalRootConfig)] -- It is an abstract type, so the derived Show is unhelpful, e.g. for replaying @@ -123,7 +130,7 @@ hotTarget (LocalRootPeers _ gs) = sum [ h | (h, _, _) <- gs ] warmTarget :: LocalRootPeers peeraddr -> WarmValency warmTarget (LocalRootPeers _ gs) = sum [ w | (_, w, _) <- gs ] -toMap :: LocalRootPeers peeraddr -> Map peeraddr (PeerAdvertise, PeerTrustable) +toMap :: LocalRootPeers peeraddr -> Map peeraddr LocalRootConfig toMap (LocalRootPeers m _) = m keysSet :: LocalRootPeers peeraddr -> Set peeraddr @@ -143,7 +150,7 @@ toGroupSets (LocalRootPeers _ gs) = gs -- trace a warning about dodgy config. -- fromGroups :: Ord peeraddr - => [(HotValency, WarmValency, Map peeraddr (PeerAdvertise, PeerTrustable))] + => [(HotValency, WarmValency, Map peeraddr LocalRootConfig)] -> LocalRootPeers peeraddr fromGroups = (\gs -> let m' = Map.unions [ g | (_, _, g) <- gs ] @@ -170,7 +177,7 @@ fromGroups = -- toGroups :: Ord peeraddr => LocalRootPeers peeraddr - -> [(HotValency, WarmValency, Map peeraddr (PeerAdvertise, PeerTrustable))] + -> [(HotValency, WarmValency, Map peeraddr LocalRootConfig)] toGroups (LocalRootPeers m gs) = [ (h, w, Map.fromSet (m Map.!) g) | (h, w, g) <- gs ] @@ -229,7 +236,7 @@ clampToTrustable :: Ord peeraddr => LocalRootPeers peeraddr -> LocalRootPeers peeraddr clampToTrustable (LocalRootPeers m gs) = - let trustedMap = Map.filter (\(_, pt) -> case pt of + let trustedMap = Map.filter (\LocalRootConfig { peerTrustable } -> case peerTrustable of IsTrustable -> True IsNotTrustable -> False ) @@ -238,7 +245,7 @@ clampToTrustable (LocalRootPeers m gs) = where trustedGroups [] = [] trustedGroups ((h, w, g):gss) = - let trusted = Map.filter (\(_, pt) -> case pt of + let trusted = Map.filter (\LocalRootConfig { peerTrustable } -> case peerTrustable of IsTrustable -> True IsNotTrustable -> False ) @@ -257,14 +264,16 @@ isPeerTrustable :: Ord peeraddr -> Bool isPeerTrustable peeraddr lrp = case Map.lookup peeraddr (toMap lrp) of - Just (_, IsTrustable) -> True - _ -> False + Just LocalRootConfig { peerTrustable = IsTrustable } + -> True + _ -> False trustableKeysSet :: LocalRootPeers peeraddr -> Set peeraddr trustableKeysSet (LocalRootPeers m _) = Map.keysSet - . Map.filter (\(_, trustable) -> case trustable of - IsTrustable -> True - IsNotTrustable -> False) + . Map.filter (\LocalRootConfig { peerTrustable } -> + case peerTrustable of + IsTrustable -> True + IsNotTrustable -> False) $ m diff --git a/scripts/ci/check-stylish-ignore b/scripts/ci/check-stylish-ignore index 7f0a204497e..10f9da46dea 100644 --- a/scripts/ci/check-stylish-ignore +++ b/scripts/ci/check-stylish-ignore @@ -3,6 +3,7 @@ ouroboros-network-api/src/Ouroboros/Network/Protocol/Type.hs ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Genesis.hs ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs +ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet.hs network-mux/src/Network/Mux/TCPInfo.hs network-mux/src/Network/Mux/Bearer.hs network-mux/src/Network/Mux/Bearer/Pipe.hs